diff --git a/src/Data/Language/Ruby.hs b/src/Data/Language/Ruby.hs new file mode 100644 index 0000000..56325ed --- /dev/null +++ b/src/Data/Language/Ruby.hs @@ -0,0 +1,137 @@ +{-# 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 diff --git a/src/Rubyhs.hs b/src/Rubyhs.hs index 070395e..c97606c 100644 --- a/src/Rubyhs.hs +++ b/src/Rubyhs.hs @@ -2,125 +2,19 @@ {-# OPTIONS_GHC -Wall #-} module Rubyhs (main) where -import Frelude -import System.Process -import System.Environment -import Data.Foldable (traverse_) -import Data.Aeson (parseJSON, Value(String), withArray, eitherDecode, encode) -import Data.Aeson.Types -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as ByteString import Control.Monad.Fail (MonadFail) -import qualified Data.Vector as Vector +import Data.Aeson (eitherDecode, encode) +import Data.ByteString.Lazy (ByteString) +import Data.Foldable (traverse_) +import Data.Language.Ruby (Block) +import Frelude +import System.Environment (getArgs) +import System.Process (readProcess) +import qualified Data.ByteString.Lazy.Char8 as ByteString main :: IO () main = getArgs >>= traverse_ run -kebabCase :: String -> String -kebabCase = camelTo2 '-' - -newtype Block = Block [Definition] - -opts :: Options -opts = defaultOptions { sumEncoding = ObjectWithSingleField, constructorTagModifier = kebabCase } - -deriving stock instance Show Block -deriving stock instance Generic Block -instance ToJSON Block where - toEncoding = genericToEncoding opts - -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 = genericToEncoding ( opts { constructorTagModifier = go }) - where - 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 = genericToEncoding opts - -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 = genericToEncoding opts - -instance FromJSON Module where - parseJSON = withArray "Module" $ \case - [String "module", name, block] -> Module <$> parseJSON name <*> parseMaybeBlock block - _ -> empty - -parseMaybeBlock :: Value -> 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 = genericToEncoding opts - -newtype Args = Args Value - -deriving stock instance Show Args -deriving stock instance Generic Args -instance ToJSON Args where - toEncoding = genericToEncoding opts - -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 - run :: FilePath -> IO () run p = do json <- runParser p