rubyhs/src/Data/Language/Ruby.hs

{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
{-# OPTIONS_GHC -Wall #-}
module Data.Language.Ruby
  ( Args(..)
  , Block(..)
  , Statement(..)
  , Function(..)
  , Module(..)
  , Name(..)
  , Send(..)
  , Namespace(..)
  ) where

import Data.Aeson (parseJSON, Value(..), withArray)
import Frelude
import qualified Data.Aeson.Types as Aeson
import qualified Data.Vector as Vector
import Data.Coerce
import Data.Word

kebabCase :: String -> String
kebabCase = Aeson.camelTo2 '-'

aesonOptions :: Aeson.Options
aesonOptions = Aeson.defaultOptions
  { Aeson.sumEncoding = Aeson.ObjectWithSingleField
  , Aeson.constructorTagModifier = kebabCase
  }

newtype Block = Block [Statement]

deriving stock instance Show Block
deriving stock instance Ord Block
deriving stock instance Eq Block
deriving stock instance Generic Block
instance ToJSON Block where
  toEncoding = Aeson.genericToEncoding aesonOptions
deriving newtype instance Semigroup Block
deriving newtype instance Monoid Block

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)

-- Should be 'expression'
data Statement
  = StmtModule Module
  | StmtFunction Function
  | StmtSend Send
  | StmtRBlock RBlock
  -- TODO: We should also handle modules here.  Otherwise we cannot
  -- cover the case where a function references a module.
  | StmtConst Namespace
  | StmtAnything Anything

deriving stock instance Show Statement
deriving stock instance Ord Statement
deriving stock instance Eq Statement
deriving stock instance Generic Statement
instance ToJSON Statement where
  toEncoding = Aeson.genericToEncoding opts
    where
    opts = aesonOptions { Aeson.constructorTagModifier = go }
    go = \case
      "StmtModule"   -> "module"
      "StmtFunction" -> "function"
      "StmtSend"     -> "send"
      "StmtRBlock"   -> "block"
      "StmtConst"    -> "const"
      x             -> x

instance FromJSON Statement where
  parseJSON v
    =   (StmtModule   <$> parseJSON v)
    <|> (StmtFunction <$> parseJSON v)
    <|> (StmtSend     <$> parseJSON v)
    <|> (StmtRBlock   <$> parseJSON v)
    <|> (StmtConst    <$> parseJSON v)
    <|> (StmtAnything <$> parseJSON v)

newtype Anything = Anything Value

deriving stock instance Show Anything
instance Ord Anything where
  compare = coerce compareValue
deriving stock instance Eq Anything
deriving stock instance Generic Anything
instance ToJSON Anything where
  toEncoding = Aeson.genericToEncoding aesonOptions
deriving newtype instance FromJSON Anything

-- f do |x|
--   expr
-- end
data RBlock = RBlock
  { send  :: Send
  , args  :: Args
  , block :: Block
  }

deriving stock instance Show RBlock
deriving stock instance Ord RBlock
deriving stock instance Eq RBlock
deriving stock instance Generic RBlock
instance ToJSON RBlock where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON RBlock where
  parseJSON = withArray "RBlock" $ \as -> case Vector.toList as of
    (String "block":send:args:block:[])
      ->  RBlock
      <$> parseJSON send
      <*> parseJSON args
      <*> parseJSON block
    _ -> empty

newtype Namespace = Namespace [Name]

deriving newtype instance Semigroup Namespace
deriving newtype instance Monoid Namespace
deriving stock instance Show Namespace
deriving stock instance Ord Namespace
deriving stock instance Eq Namespace
deriving stock instance Generic Namespace
instance ToJSON Namespace where
  toEncoding = Aeson.genericToEncoding aesonOptions

instance FromJSON Namespace where
  parseJSON = \case
    Null -> pure mempty
    Array [String "const", namespace, String name] -> (<> Namespace [Name $ String name]) <$> parseJSON namespace
    _ -> empty

data Send = Send
  { args :: Args
  , namespace :: Namespace
  , name :: Name
  }

deriving stock instance Show Send
deriving stock instance Ord Send
deriving stock instance Eq 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" : namespace : name : args)
      ->  Send
      <$> parseJSON (Array $ Vector.fromList args)
      <*> parseJSON namespace
      <*> parseJSON name
    _ -> empty

data Module = Module
  { name :: Name
  , block :: Block
  }

deriving stock instance Show Module
deriving stock instance Ord Module
deriving stock instance Eq 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
      <*> parseMaybe block
    [String "class", name, _, block]
      ->  Module
      <$> parseJSON name
      <*> parseMaybe block
    _ -> empty

parseMaybe :: FromJSON m => Monoid m => Value -> Aeson.Parser m
parseMaybe = \case
  Null -> pure mempty
  x -> parseJSON x

data Function = Function
  { name :: Name
  , args :: Args
  , block :: Block
  }

deriving stock instance Show Function
deriving stock instance Ord Function
deriving stock instance Eq Function
deriving stock instance Generic Function
instance ToJSON Function where
  toEncoding = Aeson.genericToEncoding aesonOptions

newtype Args = Args Anything

deriving stock instance Show Args
instance Ord Args where
  compare = coerce compareValue
deriving stock instance Eq Args
deriving stock instance Generic Args
instance ToJSON Args where
  toEncoding = Aeson.genericToEncoding aesonOptions

instance FromJSON Args where
  parseJSON = pure . coerce

instance FromJSON Function where
  parseJSON = withArray "Function" $ \case
    [String "def", name, args, block]
      ->  Function
      <$> parseJSON name
      <*> parseJSON args
      <*> parseMaybe block
    _ -> empty

newtype Name = Name Value

deriving stock instance Show Name
instance Ord Name where
  compare = coerce compareValue
deriving stock instance Eq Name
deriving newtype instance ToJSON Name
deriving newtype instance FromJSON Name

compareValue :: Aeson.Value -> Aeson.Value -> Ordering
compareValue v0 v1 = case (v0, v1) of
  -- This case is buggy:
  (Object o0, Object o1)    -> compare (fst <$> toList o0) (fst <$> toList o1)
  (Array a0, Array a1)      -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1)
  (String s0, String s1)    -> compare s0 s1
  (Number n0, Number n1)    -> compare n0 n1
  (Bool b0, Bool b1)        -> compare b0 b1
  (Null, Null)              -> EQ
  _                         -> (compare `on` cons) v0 v1
    where
    -- Enumerate constructors.
    cons :: Aeson.Value -> Word8
    cons = \case
      Object{} -> 0
      Array{}  -> 1
      String{} -> 2
      Number{} -> 3
      Bool{}   -> 4
      Null{}   -> 5