141 lines
3.7 KiB
Haskell
141 lines
3.7 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
|
|
{-# 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
|
|
|
|
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
|
|
block <- decodeFail @_ @Block $ ByteString.pack json
|
|
ByteString.putStrLn $ encode block
|
|
|
|
decodeFail :: MonadFail m => FromJSON a => ByteString -> m a
|
|
decodeFail s = case eitherDecode s of
|
|
Left err -> fail err
|
|
Right a -> pure a
|
|
|
|
runParser :: FilePath -> IO String
|
|
runParser p = sh "ruby-parse" ["--emit-json", "--25", p]
|
|
|
|
sh :: String -> [String] -> IO String
|
|
sh cmd args = readProcess cmd args mempty
|
|
|