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

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
    x -> error $ show x

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