{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OrPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
module Gyehoek.Scheme.Syntax
  ( Name(..)
  , Prim(..)
  , Lit(..)
  , Define(..)
  , Exp(..)
  , Sexp(..)
  , primSexpIso
  )
  where

import Data.Text (Text)
import Data.List (List)
import Language.SexpGrammar
  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
import Language.SexpGrammar qualified as Sexp
import Language.SexpGrammar.Generic
import GHC.Generics
import Prelude hiding ((.), id)
import Control.Category
import Data.List.NonEmpty (NonEmpty ((:|)))
import Gyehoek.Sexp qualified
import Gyehoek.GenSym (Gen)
import Control.Lens (Each)
import Data.String (IsString)
import Data.Hashable (Hashable)


newtype Name = MkName { getName :: Text }
  deriving newtype (Show, Eq, IsString, Gen, Hashable)
  deriving stock (Generic)

data Prim e
  = PrimAdd e e
  | PrimSub e e
  | PrimMul e e
  | PrimDiv e e
  | PrimCons e e
  | PrimCar e
  | PrimCdr e
  | PrimImmediateP e
  | PrimConsP e
  | PrimIntegerP e
  | PrimWrite e
  | PrimZeroP e
  | PrimNewline
  deriving (Show, Generic, Functor, Foldable, Traversable)

instance Each (Prim e) (Prim e') e e'

data Lit
  = LitInt Int
  | LitNil
  | LitBool Bool
  | LitString Text
  | LitQuote Sexp
  deriving (Show, Generic)

data Define
  = DefineConstant Name Exp
  | DefineProcedure Name (List Name) (List Exp)
  deriving (Show, Generic)

data Exp
  = ExpLet (NonEmpty (Name, Exp)) Exp
  | ExpPrim (Prim Exp)
  | ExpBegin (List Exp)
  | ExpDefine Define
  | ExpIf Exp Exp Exp
  | ExpLit Lit
  | ExpLambda (List Name) Exp
  | ExpVar Name
  | ExpApply Exp (List Exp)
  deriving (Show, Generic)

data Sexp
  = SexpCons Sexp Sexp
  | SexpSymbol Text
  | SexpLit Lit
  deriving (Show, Generic)



instance SexpIso Name where
  sexpIso = symbol >>> Sexp.partialOsi f g
    where
      f = Right . MkName
      g (MkName s) = s

primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
primSexpIso namefn a = match
    $ With (. binop "+")
    $ With (. binop "-")
    $ With (. binop "*")
    $ With (. binop "/")
    $ With (. binop "cons")
    $ With (. unop "car")
    $ With (. unop "cdr")
    $ With (. unop "immediate?")
    $ With (. unop "cons?")
    $ With (. unop "integer?")
    $ With (. unop "write")
    $ With (. unop "zero?")
    $ With (. nullop "newline")
    $ End
    where
      idn s = el (sym (namefn s))
      nullop s = list $ idn s
      unop s = list $ idn s >>> el a
      binop s = list $ idn s >>> el a >>> el a

instance SexpIso a => SexpIso (Prim a) where
  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
  sexpIso = primSexpIso id sexpIso

instance SexpIso Lit where
  sexpIso = match
    $ With (. sexpIso)
    $ With (. sym "nil")
    $ With (. sexpIso)
    $ With (. sexpIso)
    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
    $ End

instance SexpIso Sexp where
  sexpIso = match
    $ With (\cons -> cons . Gyehoek.Sexp.todo)
    $ With (\s -> s . symbol)
    $ With (\lit -> lit . sexpIso)
    $ End

instance SexpIso Define where
  sexpIso = match
    $ With (. defconst)
    $ With (. defun)
    $ End
    where
      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
      args = list $ el sexpIso >>> rest sexpIso
  
instance SexpIso Exp where
  sexpIso = match
    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
    $ With (. sexpIso)
    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
    $ With (. sexpIso)
    $ With (. if_)
    $ With (. sexpIso)
    $ With (. lam)
    $ With (. sexpIso)
    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
    $ End
    where
      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
      lam = list
        ( el Gyehoek.Sexp.lambdaKeyword
          >>> el (sexpIso @(List Name))
          >>> el sexpIso )