content: {-# LANGUAGE DeriveAnyClass #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE DeriveGeneric #-}
  module Syntax where
  
  import           Data.Text (Text)
  import           Data.Hashable
  import           Data.Label
  import           Data.String
  import           Data.GraphViz.Attributes
  import           Prettyprinter hiding (list)
  import           Prettyprinter.Render.Text
  
  import           Control.Monad.State
  import           Control.DeepSeq
  import           GHC.Generics
  
  import Data.Aeson (ToJSON, FromJSON)
  -- Literals of Scheme
  
  data Literal
    = Int Int
    | Float Double
    | Rational Rational
    | Bool Bool
    | Char Char --single character and single quotation (')
    | String Text -- any amount of chars and double quotation (")
    | Symbol Text
    | Quote Literal
    -- | DottedList [Literal] Literal
    deriving (Eq,Generic,NFData)
  instance ToJSON Literal 
  instance FromJSON Literal
  
  data Op1
  -- | Check operations
    = IsNumber -- (number? z)
    | IsInteger -- (integer? z)
    | IsFloat -- (float? z)
    | IsRational -- (rational? z)
    | IsZero -- (zero? z)
    | IsPositive -- (positive? z)
    | IsNegative -- (negative? z)
    | IsOdd -- (odd? z)
    | IsEven-- (even? z)
    | IsNull -- (null? z)
    | IsCons -- (cons? z)
    | IsBoolean -- (boolean? z)
  -- | Numeric Operations
    | Abs -- (abs z)
    | Floor -- (floor z)
    | Ceiling -- (ceiling z)
    | Log -- (log z) base e
  -- | Boolean operations
    | Not -- (not z)
  -- | List operations
    | Car -- (car z)
    | Cdr -- (cdr z)
    | Caar -- (caar z)
    | Cadr -- (cadr z)
    | Cddr -- (cddr z)
    | Caddr -- (caddr z)
    | Cadddr -- (cadddr z)
  -- | String Operations
    | NumberToString -- (number->string z)
    | StringToSymbol -- (string->symbol z)
    | SymbolToString -- (symbol->string z)
  -- | Miscellaneous operations
    -- | Error -- (error z)
    | Random -- (random z)
    deriving (Eq,Generic,NFData)
  instance ToJSON Op1
  instance FromJSON Op1
  
  data Op2
  -- | Equivalence predicates
    = Eqv -- (eq? z) / (eqv? z)
  -- | Numerical operations
    | Quotient -- (quotient z1 z2)
    | Remainder -- (remainder z1 z2)
    | Modulo -- (modulo z1 z2)
  -- | String operations
    | StringRef -- (string-ref z1 z2)
    deriving (Eq,Generic,NFData)
  instance ToJSON Op2 
  instance FromJSON Op2
  
  data OpVar
  -- | Numerical operations
    = Equal -- (= z1 z2 z3 ...)
    | Smaller -- (< z1 z2 z3 ...)
    | Greater -- (> z1 z2 z3 ...)
    | SmallerEqual -- (<= z1 z2 z3 ...)
    | GreaterEqual -- (>= z1 z2 z3 ...)
    | Max -- (max z1 z2 z3 ...)
    | Min -- (max z1 z2 z3 ...)
    | Add -- (+) (+ z) (+ z1 z2 z3 ...)
    | Mul -- (*) (* z) (* z1 z2 z3 ...)
    | Sub -- (- z) (- z1 z2 z3 ...)
    | Div -- (/ z) (/ z1 z2 z3 ...)
    | Gcd -- (gcd z1 z2 z3 ...)
    | Lcm -- (lcm z1 z2 z3 ...)
    | StringAppend -- (string-append z1 z2 z3 ...)
  -- | List operations
    deriving (Eq,Generic,NFData)
  instance ToJSON OpVar
  instance FromJSON OpVar
  
  
  -- | Expressions of Scheme. Each expression has a label, with which the
  -- expression can be uniquely identified.
  data Expr
  -- | Expressions for inner representation and evaluation
    = Lit Literal Label
    | Nil Label -- (nil)
    | Cons Expr Expr Label -- (cons z1 z2)
  
    -- | List_ [Expr] Label -- (list z1 z2 z3 ...)
    | Begin [Expr] Label
    | App Expr [Expr] Label
    | Apply [Expr] Label
  -- | Scheme expressions
    | Var Text Label
    | Set Text Expr Label
    | Define Text Expr Label
    | Lam [Text] [Expr] Label
    | If Expr Expr Expr Label
    | Let [(Text, Expr)] [Expr] Label
    | LetRec [(Text, Expr)] [Expr] Label
  -- | Scheme standard procedures
    | Op1 Op1 Expr Label
    | Op2 Op2 Expr Expr Label
    | OpVar OpVar [Expr] Label
    | Error String Label
    | Breakpoint Expr -- breakpoint z
    deriving (Generic,NFData)
  
  instance ToJSON Expr 
  instance FromJSON Expr 
  
  instance Eq Expr where
    e1 == e2 = label e1 == label e2
  
  type LExpr = State Label Expr 
  
  -- Smart constructors that build labeled Scheme expressions.
  -- | Expressions for inner representation and evaluation
  lit :: Literal -> LExpr
  lit x = Lit x <$> fresh
  list :: [LExpr] -> LExpr
  list [] = Nil <$> fresh
  list (x : xs) = Cons <$> x <*> list xs <*> fresh
  -- list_ :: [State Label Expr] -> State Label Expr 
  -- list_ xs = List_ <$> (sequence xs) <*> fresh 
  cons :: LExpr -> LExpr ->LExpr
  cons e1 e2 = Cons <$> e1 <*> e2 <*> fresh
  begin :: [LExpr] -> LExpr
  begin es = Begin <$> sequence es <*> fresh
  app :: LExpr -> [LExpr] -> LExpr
  app e1 e2 = App <$> e1 <*> sequence e2 <*> fresh
  -- | Scheme expressions
  var_ :: Text -> LExpr
  var_ x = Var x <$> fresh
  set :: Text -> LExpr -> LExpr
  set t e = Set t <$> e <*> fresh
  lam :: [Text] -> [LExpr] -> LExpr
  lam xs es = Lam xs <$> sequence es <*> fresh
  if_ :: LExpr -> LExpr -> LExpr -> LExpr
  if_ e1 e2 e3 = If <$> e1 <*> e2 <*> e3 <*> fresh
  define :: Text -> LExpr -> LExpr
  define t e = Define t <$> e <*> fresh
  let_ :: [(Text, LExpr)] -> [LExpr] -> LExpr
  let_ bnds body = Let <$> sequence [(v,) <$> e | (v,e) <- bnds] <*> sequence body <*> fresh
  let_rec :: [(Text, LExpr)] -> [LExpr] -> LExpr
  let_rec bnds body = LetRec <$> sequence [(v,) <$> e | (v,e) <- bnds] <*> sequence body <*> fresh
  -- | Scheme standard procedures
  op1_ :: Op1 -> LExpr -> LExpr
  op1_ operation e1 = Op1 operation <$> e1 <*> fresh
  op2_ :: Op2 -> LExpr -> LExpr -> LExpr
  op2_ operation e1 e2 = Op2 operation <$> e1 <*> e2 <*> fresh
  opvar_ :: OpVar -> [LExpr] -> LExpr
  opvar_ operation es = OpVar operation <$> sequence es <*> fresh
  error_ :: String -> LExpr
  error_ err = Error err <$> fresh
  breakpoint :: LExpr -> LExpr
  breakpoint e = Breakpoint <$> e
  
  
  instance Show Literal where show = show . pretty
  
  instance Pretty Literal where
    pretty e0 = case e0 of
      Int x -> pretty x
      Float x -> pretty x
      Rational x -> pretty (show x)
      Bool x -> pretty x
      Char x -> squotes (pretty x)
      String x -> dquotes (pretty x)
      Symbol x -> pretty x
      Quote x -> "'" <> pretty x
      -- DottedList xs x -> showString ("DottedList ") . showList(xs) . showString (" . ") . shows (x)
  
  instance Show Op1 where show = show . pretty
  
  instance Pretty Op1 where
    pretty e0 = case e0 of
      IsNumber -> "number?"
      IsInteger -> "integer?"
      IsFloat -> "float?"
      IsRational -> "rational?"
      IsZero -> "zero?"
      IsPositive -> "positive?"
      IsNegative -> "negative?"
      IsOdd -> "odd?"
      IsEven -> "even?"
      IsBoolean -> "boolean?"
      IsNull -> "null?"
      IsCons -> "cons?"
      Abs -> "abs"
      Floor -> "floor"
      Ceiling -> "ceiling"
      Log -> "log"
      Not -> "not"
      Car -> "car"
      Cdr -> "cdr"
      Caar -> "caar"
      Cadr -> "cadr"
      Cddr -> "cddr"
      Caddr -> "caddr"
      Cadddr -> "cadddr"
      -- Error -> "error"
      Random -> "random"
      StringToSymbol -> "string->symbol"
      SymbolToString -> "symbol->string"
      NumberToString -> "number->string"
  
  instance Show Op2 where show = show . pretty
  
  instance Pretty Op2 where
    pretty e0 = case e0 of
      Eqv -> "eq?"
      Quotient -> "quotient "
      Remainder -> "remainder "
      Modulo -> "modulo "
      StringRef -> "string-ref "
  
  instance Show OpVar where show = show . pretty
  
  instance Pretty OpVar where
    pretty e0 = case e0 of
      Equal -> "="
      Smaller -> "<"
      Greater -> ">"
      SmallerEqual -> "<="
      GreaterEqual -> ">="
      Max -> "max"
      Min -> "min"
      Add -> "+"
      Mul -> "*"
      Sub -> "-"
      Div -> "/"
      Gcd -> "gcd"
      Lcm -> "lcm"
      StringAppend -> "string-append"
      -- List_ -> showString ("list")
  
  instance Show Expr where show = show . pretty
  
  instance Pretty Expr where
    pretty e = flatAlt (prettyExpr e) (parens (showTopLvl e <> "..."))
  
  prettyExpr :: Expr -> Doc ann
  prettyExpr e0 = case e0 of
    Lit x _ -> pretty x
    Nil _ -> "nil"
    Cons e1 e2 _ -> parens $ "cons" <+> prettyExpr e1 <+> prettyExpr e2
    Begin es _-> parens $ "begin" <+> prettyExprList es
    App e1 e2 _ -> parens $ prettyExpr e1 <+> prettyExprList e2
    Apply e _ -> parens $ prettyExprList e
    Var x _ -> pretty x
    Set t e _ -> parens $ "set!" <+> pretty t <+> prettyExpr e
    Define t e _ -> parens $ "define" <+> pretty t <+> prettyExpr e
    Lam xs e2 _ -> parens $ "lambda" <+> hsep (map pretty xs) <> "." <+> prettyExprList e2
    If e1 e2 e3 _ -> parens $ "if" <+> prettyExpr e1 <+> prettyExpr e2 <+> prettyExpr e3
    Let bnds body _ -> parens $ "let" <+> brackets (align (vcat [ pretty var <+> prettyExpr expr | (var,expr) <- bnds])) <+> prettyExprList body
    LetRec bnds body _ -> parens $ "letrec" <+> brackets (align (vcat [ pretty var <+> prettyExpr expr | (var,expr) <- bnds])) <+> pretty body
    Op1 op1 e _ -> parens $ pretty op1 <+> prettyExpr e
    Op2 op2 e1 e2 _ -> parens $ pretty op2 <> prettyExpr e1 <+> prettyExpr e2
    OpVar opvar es _ -> parens $ pretty opvar <+> prettyExprList es
    Error err _ -> parens $ "error " <+> dquotes (pretty err)
    Breakpoint _ -> "breakpoint"
  
  prettyExprList :: [Expr] -> Doc ann
  prettyExprList expr = hsep (map prettyExpr expr)
  
  showTopLvl :: Expr -> Doc ann
  showTopLvl e = case e of
      Lit x _ -> pretty x
      Nil _ -> "nil"
      Cons {} -> "cons"
      Begin {} -> "begin"
      App {} -> "app"
      -- Apply {} -> "apply"
      Apply e' _ -> pretty e'
      Var x _ -> pretty x
      Set t _ _ -> "set!" <+> pretty t
      Define t _ _ -> "define" <+> pretty t
      Lam xs _ _ -> "λ" <+> hsep (map pretty xs)
      If e1 _ _ _ -> "if" <+> pretty e1
      Let {} -> "let"
      LetRec {} -> "letrec"
      Op1 op1 e1 _ -> pretty op1 <+> showTopLvl e1
      Op2 op2 e1 e2 _ -> pretty op2 <+> showTopLvl e1 <> "," <> showTopLvl e2
      OpVar opvar es _ -> pretty opvar <+> hsep (map showTopLvl es)
      Error _ _ -> "error"
      Breakpoint _ -> "breakpoint"
  
  controlFlow :: Expr -> Maybe Expr
  controlFlow e = case e of
    App {} -> Just e
    LetRec {} -> Just e
    _ -> Nothing
  
  instance IsString (State Label Expr) where
    fromString = var_ . fromString
  
  instance Labellable Expr where
    toLabelValue a = textLabelValue $ renderLazy $ layoutPretty defaultLayoutOptions $ showTopLvl a
  
  instance HasLabel Expr where
    label e = case e of
      Lit _ l -> l
      Nil l -> l
      Cons _ _ l -> l
      Begin _ l -> l
      App _ _ l -> l
      Apply _ l -> l
    -- | Scheme expressions
      Var _ l -> l
      Set _ _ l -> l
      Define _ _ l -> l
      Lam _ _ l -> l
      If _ _ _ l -> l
      Let _ _ l -> l
      LetRec _ _ l -> l
    -- | Scheme standard procedures
      Op1 _ _ l -> l
      Op2 _ _ _ l -> l
      OpVar _ _ l -> l
      Error _ l -> l
      Breakpoint e' -> label e'
  
  instance Hashable Expr where
    hashWithSalt s e = s `hashWithSalt` label e
  