rubyhs/src/Data/Language/Ruby.hs

{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
{-# OPTIONS_GHC -Wall #-}
module Data.Language.Ruby
  ( Args(..)
  , Block(..)
  , Definition(..)
  , Function(..)
  , Module(..)
  , Name(..)
  , Send(..)
  ) 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 [Definition]

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

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 Ord Definition
deriving stock instance Eq Definition
deriving stock instance Generic Definition
instance ToJSON Definition where
  toEncoding = Aeson.genericToEncoding opts
    where
    opts = aesonOptions { 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 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" : _ : 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 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
      <*> 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 Ord Function
deriving stock instance Eq Function
deriving stock instance Generic Function
instance ToJSON Function where
  toEncoding = Aeson.genericToEncoding aesonOptions

newtype Args = Args Value

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 . 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
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