{-# LANGUAGE DuplicateRecordFields, OverloadedLists, StrictData #-}
{-# OPTIONS_GHC -Wall #-}
module Data.Language.Ruby.AST
  ( Begin(..)
  , Statement(..)
  , Def(..)
  , Module(..)
  , Send(..)
  , Const(..)
  , Block(..)
  , Casgn(..)
  , Array(..)
  , Args(..)
  , Anything(..)
  , Sym(..)
  , String(..)
  , Str(..)
  , Lvasgn(..)
  , Lvar(..)
  , Ivar(..)
  , Atom(..)
  , Defs(..)
  , Self(..)
  , Nil(..)
  , Cbase
  ) where

import Data.Aeson (parseJSON, Value(Null,Object,Number,Bool), withArray)
import Frelude hiding (String)
import qualified Frelude
import qualified Data.Aeson.Types as Aeson
import qualified Data.Vector as Vector
import Data.Coerce
import Data.Word

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

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

newtype Begin = Begin [Statement]

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

instance FromJSON Begin where
  parseJSON = withArray "Begin" $ \as -> case Vector.toList as of
    (Aeson.String "begin":xs) -> Begin <$> traverse parseJSON xs
    _ -> Begin . pure <$> parseJSON (Aeson.Array as)

-- Maybe should be 'expression'.
data Statement
  = StmtModule Module
  | StmtDef Def
  | StmtDefs Defs
  | StmtSend Send
  | StmtBlock Block
  | StmtConst Const
  | StmtCasgn Casgn
  | StmtArray Array
  | StmtSym Sym
  | StmtStr Str
  | StmtLvasgn Lvasgn
  | StmtLvar Lvar
  | StmtIvar Ivar
  | StmtSelf Self
  | StmtNil Nil
  | StmtCbase Cbase
  -- TODO Get rid of this
  | 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"
      "StmtDef"      -> "def"
      "StmtDefs"     -> "defs"
      "StmtSend"     -> "send"
      "StmtBlock"    -> "block"
      "StmtConst"    -> "const"
      "StmtCasgn"    -> "casgn"
      "StmtArray"    -> "array"
      "StmtSym"      -> "sym"
      "StmtStr"      -> "str"
      "StmtLvasgn"   -> "lvasgn"
      "StmtLvar"     -> "lvar"
      "StmtIvar"     -> "ivar"
      "StmtSelf"     -> "self"
      "StmtNil"      -> "nil"
      "StmtCbase"    -> "cbase"
      x              -> x

instance FromJSON Statement where
  parseJSON v
    =   (StmtModule   <$> parseJSON v)
    <|> (StmtDef      <$> parseJSON v)
    <|> (StmtDefs     <$> parseJSON v)
    <|> (StmtSend     <$> parseJSON v)
    <|> (StmtBlock    <$> parseJSON v)
    <|> (StmtConst    <$> parseJSON v)
    <|> (StmtCasgn    <$> parseJSON v)
    <|> (StmtArray    <$> parseJSON v)
    <|> (StmtSym      <$> parseJSON v)
    <|> (StmtStr      <$> parseJSON v)
    <|> (StmtLvasgn   <$> parseJSON v)
    <|> (StmtLvar     <$> parseJSON v)
    <|> (StmtIvar     <$> parseJSON v)
    <|> (StmtSelf     <$> parseJSON v)
    <|> (StmtNil      <$> parseJSON v)
    <|> (StmtCbase    <$> parseJSON v)
    <|> (StmtAnything <$> parseJSON v)

data Casgn = Casgn
  { context   :: Statement
  , atom      :: Atom
  , rhs       :: Statement
  }
deriving stock instance Show Casgn
deriving stock instance Ord Casgn
deriving stock instance Eq Casgn
deriving stock instance Generic Casgn
instance ToJSON Casgn where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Casgn where
  parseJSON = withArray "Module" $ \case
    [Aeson.String "casgn", context, atom, rhs]
      ->  Casgn
      <$> parseJSON context
      <*> parseJSON atom
      <*> parseJSON rhs
    _ -> empty


newtype Array = Array
  { statements :: [Statement]
  }
deriving stock instance Show Array
deriving stock instance Ord Array
deriving stock instance Eq Array
deriving stock instance Generic Array
instance ToJSON Array where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Array where
  parseJSON = withArray "Array" $ \as -> case Vector.toList as of
    Aeson.String "array":xs
      ->  Array
      <$> traverse parseJSON xs
    _ -> empty

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 Block = Block
  { send  :: Send
  , args  :: Args
  , begin :: Begin
  }

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
    [Aeson.String "block",send,args,begin]
      ->  Block
      <$> parseJSON send
      <*> parseJSON args
      <*> parseJSON begin
    _ -> empty

newtype Args = Args [Arg]

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

data Arg = Arg Atom | KWArg Atom

deriving stock instance Show Arg
deriving stock instance Ord Arg
deriving stock instance Eq Arg
deriving stock instance Generic Arg
instance ToJSON Arg where
  toEncoding = Aeson.genericToEncoding opts
    where
    opts = aesonOptions { Aeson.constructorTagModifier = go }
    go = \case
      "KWArg" -> "kwarg"
      "Arg"   -> "arg"
      x       -> x

instance FromJSON Arg where
  parseJSON = withArray "Arg" $ \as -> case Vector.toList as of
    [Aeson.String "arg"   , symbol] -> Arg   <$> parseJSON symbol
    [Aeson.String "kwarg" , symbol] -> KWArg <$> parseJSON symbol
    _ -> empty

newtype Atom = Atom Text

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

instance FromJSON Atom where
  parseJSON = \case
    Aeson.String s -> pure $ Atom s
    _ -> empty

data Const = Const
  { context :: Statement
  , atom    :: Atom
  }

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

instance FromJSON Const where
  parseJSON = withArray "Send" $ \case -- \ as -> case Vector.toList as of
    [Aeson.String "const", context, atom] -> Const <$> parseJSON context <*> parseJSON atom
    _ -> empty

data Send = Send
  { context   :: Statement
  , atom      :: Atom
  , args      :: [Statement]
  }

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
    (Aeson.String "send" : context : atom : args)
      ->  Send
      <$> parseJSON context
      <*> parseJSON atom
      <*> parseJSON (Aeson.Array $ Vector.fromList args)
    _ -> empty

data Module = Module
  { name  :: Const
  , begin :: Begin
  }

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
    [Aeson.String "module", name, begin]
      ->  Module
      <$> parseJSON name
      <*> parseMaybe begin
    [Aeson.String "class", name, _, begin]
      ->  Module
      <$> parseJSON name
      <*> parseMaybe begin
    _ -> empty

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

data Def = Def
  { atom  :: Atom
  , args  :: Args
  , begin :: Begin
  }

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

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

-- | N.B.: 'Defs' is *not* meant to be the plural form of 'Def'!
data Defs = Defs
  -- Is it really possible to put an arbitrary expression here?  The
  -- parser certainly allows it.  E.g. defining
  --
  --     def (2+2).f
  --     end
  --
  -- Raises the error "can't define singleton (TypeError)".  We'll
  -- permit it in the parser and kick the puck down the road.
  { context   :: Statement
  , atom      :: Atom
  , args      :: Args
  , begin     :: Begin
  }

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

instance FromJSON Defs where
  parseJSON = withArray "Defs" $ \case
    [Aeson.String "defs", ctxt, atom, args, begin]
      ->  Defs
      <$> parseJSON ctxt
      <*> parseJSON atom
      <*> parseJSON args
      <*> parseMaybe begin
    _ -> empty

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)
  (Aeson.Array a0, Aeson.Array a1)      -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1)
  (Aeson.String s0, Aeson.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
      Aeson.Array{}  -> 1
      Aeson.String{} -> 2
      Number{} -> 3
      Bool{}   -> 4
      Null{}   -> 5

newtype Sym = Sym Atom

deriving stock instance Show Sym
deriving newtype instance Ord Sym
deriving stock instance Eq Sym
deriving stock instance Generic Sym
instance ToJSON Sym where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Sym where
  parseJSON = withArray "Sym" $ \case
    [Aeson.String "sym", atom] -> Sym <$> parseJSON atom
    _ -> empty

newtype String = String Text

deriving stock instance Show String
deriving newtype instance Ord String
deriving stock instance Eq String
deriving stock instance Generic String
deriving newtype instance ToJSON String
deriving newtype instance FromJSON String
newtype Str = Str String

deriving stock instance Show Str
deriving newtype instance Ord Str
deriving stock instance Eq Str
deriving stock instance Generic Str
instance ToJSON Str where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Str where
  parseJSON = withArray "Str" $ \case
    [Aeson.String "str", atom] -> Str <$> parseJSON atom
    _ -> empty

data Lvasgn = Lvasgn
  { atom      :: Atom
  , statement :: Statement
  }

deriving stock instance Show Lvasgn
deriving stock instance Ord Lvasgn
deriving stock instance Eq Lvasgn
deriving stock instance Generic Lvasgn
instance ToJSON Lvasgn where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Lvasgn where
  parseJSON = withArray "Lvasgn" $ \case
    [Aeson.String "lvasgn", atom, statement] -> Lvasgn <$> parseJSON atom <*> parseJSON statement
    _ -> empty

newtype Lvar = Lvar
  { atom      :: Atom
  }

deriving stock instance Show Lvar
deriving stock instance Ord Lvar
deriving stock instance Eq Lvar
deriving stock instance Generic Lvar
instance ToJSON Lvar where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Lvar where
  parseJSON = withArray "Lvar" $ \case
    [Aeson.String "lvar", atom] -> Lvar <$> parseJSON atom
    _ -> empty

newtype Ivar = Ivar
  { atom      :: Atom
  }

deriving stock instance Show Ivar
deriving stock instance Ord Ivar
deriving stock instance Eq Ivar
deriving stock instance Generic Ivar
instance ToJSON Ivar where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Ivar where
  parseJSON = withArray "Ivar" $ \case
    [Aeson.String "ivar", atom] -> Ivar <$> parseJSON atom
    _ -> empty

data Self = Self

deriving stock instance Show Self
deriving stock instance Ord Self
deriving stock instance Eq Self
deriving stock instance Generic Self
instance ToJSON Self where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Self where
  parseJSON = withArray "Self" $ \case
    [Aeson.String "self"] -> pure Self
    _ -> empty

data Cbase = Cbase

deriving stock instance Show Cbase
deriving stock instance Ord Cbase
deriving stock instance Eq Cbase
deriving stock instance Generic Cbase
instance ToJSON Cbase where
  toEncoding = Aeson.genericToEncoding aesonOptions
instance FromJSON Cbase where
  parseJSON = withArray "Cbase" $ \case
    [Aeson.String "cbase"] -> pure Cbase
    _ -> empty

data Nil = Nil

deriving stock instance Show Nil
deriving stock instance Ord Nil
deriving stock instance Eq Nil
deriving stock instance Generic Nil
instance ToJSON Nil where
  toJSON = pure Aeson.Null
instance FromJSON Nil where
  parseJSON = \case
    Aeson.Null -> pure Nil
    _ -> empty