138 lines
3.4 KiB
Haskell
138 lines
3.4 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
module Data.Language.Ruby
|
|
( Args(..)
|
|
, Block(..)
|
|
, Definition(..)
|
|
, Function(..)
|
|
, Module(..)
|
|
, Name(..)
|
|
, Send(..)
|
|
) where
|
|
|
|
import Data.Aeson (parseJSON, Value(String, Null, Array), withArray)
|
|
import Frelude
|
|
import qualified Data.Aeson.Types as Aeson
|
|
import qualified Data.Vector as Vector
|
|
|
|
kebabCase :: String -> String
|
|
kebabCase = Aeson.camelTo2 '-'
|
|
|
|
aesonOptions :: Aeson.Options
|
|
aesonOptions = Aeson.defaultOptions
|
|
{ Aeson.sumEncoding = Aeson.ObjectWithSingleField
|
|
, Aeson.constructorTagModifier = kebabCase
|
|
}
|
|
|
|
newtype Block = Block [Definition]
|
|
|
|
deriving stock instance Show Block
|
|
deriving stock instance Generic Block
|
|
instance ToJSON Block where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
instance FromJSON Block where
|
|
parseJSON = withArray "Block" $ \as -> case Vector.toList as of
|
|
(String "begin":xs) -> Block <$> traverse parseJSON xs
|
|
_ -> Block . pure <$> parseJSON (Array as)
|
|
|
|
data Definition
|
|
= DefModule Module
|
|
| DefFunction Function
|
|
| DefSend Send
|
|
|
|
deriving stock instance Show Definition
|
|
deriving stock instance Generic Definition
|
|
instance ToJSON Definition where
|
|
toEncoding = Aeson.genericToEncoding opts
|
|
where
|
|
opts = opts { Aeson.constructorTagModifier = go }
|
|
go = \case
|
|
"DefModule" -> "module"
|
|
"DefFunction" -> "function"
|
|
"DefSend" -> "send"
|
|
x -> x
|
|
|
|
instance FromJSON Definition where
|
|
parseJSON val
|
|
= (DefModule <$> parseJSON val)
|
|
<|> (DefFunction <$> parseJSON val)
|
|
<|> (DefSend <$> parseJSON val)
|
|
|
|
data Send = Send
|
|
{ args :: Args
|
|
, name :: Name
|
|
}
|
|
|
|
deriving stock instance Show Send
|
|
deriving stock instance Generic Send
|
|
instance ToJSON Send where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
instance FromJSON Send where
|
|
parseJSON = withArray "Send" $ \ as -> case Vector.toList as of
|
|
(String "send" : _ : name : args)
|
|
-> Send
|
|
<$> parseJSON (Array $ Vector.fromList args)
|
|
<*> parseJSON name
|
|
_ -> empty
|
|
|
|
data Module = Module
|
|
{ name :: Name
|
|
, block :: Block
|
|
}
|
|
|
|
deriving stock instance Show Module
|
|
deriving stock instance Generic Module
|
|
instance ToJSON Module where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
instance FromJSON Module where
|
|
parseJSON = withArray "Module" $ \case
|
|
[String "module", name, block]
|
|
-> Module
|
|
<$> parseJSON name
|
|
<*> parseMaybeBlock block
|
|
_ -> empty
|
|
|
|
parseMaybeBlock :: Value -> Aeson.Parser Block
|
|
parseMaybeBlock = \case
|
|
Null -> pure (Block mempty)
|
|
x -> parseJSON x
|
|
|
|
data Function = Function
|
|
{ name :: Name
|
|
, args :: Args
|
|
, block :: Block
|
|
}
|
|
|
|
deriving stock instance Show Function
|
|
deriving stock instance Generic Function
|
|
instance ToJSON Function where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
newtype Args = Args Value
|
|
|
|
deriving stock instance Show Args
|
|
deriving stock instance Generic Args
|
|
instance ToJSON Args where
|
|
toEncoding = Aeson.genericToEncoding aesonOptions
|
|
|
|
instance FromJSON Args where
|
|
parseJSON = pure . Args
|
|
|
|
instance FromJSON Function where
|
|
parseJSON = withArray "Function" $ \case
|
|
[String "def", name, args, block]
|
|
-> Function
|
|
<$> parseJSON name
|
|
<*> parseJSON args
|
|
<*> parseMaybeBlock block
|
|
_ -> empty
|
|
|
|
newtype Name = Name Value
|
|
|
|
deriving stock instance Show Name
|
|
deriving newtype instance ToJSON Name
|
|
deriving newtype instance FromJSON Name
|