{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TemplateHaskell #-}
module Gyehoek.CPS.Syntax
  ( Val(..)
  , Kappa(..)
  , Exp(..)
  , Name(..)
  , Prim(..)
  , pattern Halt
  , pattern Halt1
  , _MkKappa
  , _ExpPrim
  , _ExpFix
  , _ExpApply
  )
  where

import Language.SexpGrammar qualified as S
import Gyehoek.Sexp qualified
import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit)
import Data.Text (Text)
import Data.List (List)
import GHC.Generics (Generic)
import Language.SexpGrammar.Generic
import Control.Category
import Control.Lens
import Data.Text qualified as T
import Data.Generics.Labels
import Prelude hiding ((.), id)
import Data.List.NonEmpty (NonEmpty)

-- Data types

data Val
  = ValLabel Name
  | ValVar Name
  | ValLit Lit
  deriving (Show, Generic)

data Kappa = MkKappa (List Name) Exp
  deriving (Show, Generic)

data Exp
  = ExpPrim (Prim Val) (List Name) Exp
  | ExpFix (NonEmpty (Name, Kappa)) Exp
  | ExpApply Val (List Val)
  | ExpIf Val Exp Exp
  deriving (Show, Generic)

pattern Halt :: List Val -> Exp
pattern Halt xs = ExpApply (ValVar "halt") xs

pattern Halt1 :: Val -> Exp
pattern Halt1 x = ExpApply (ValVar "halt") [x]

makePrisms ''Kappa
makePrisms ''Exp


-- SexpIso instances

instance S.SexpIso Val where
  sexpIso = match
    $ With (. label)
    $ With (. var)
    $ With (. S.sexpIso)
    $ End
    where
      label = S.keyword >>> S.iso MkName getName
      var = S.sexpIso

instance S.SexpIso Kappa where
  sexpIso = match
    $ With (. kappa)
    $ End
    where
      kappa = S.list $
        S.el Gyehoek.Sexp.kappaKeyword
        >>> S.el (S.list $ S.rest S.sexpIso)
        >>> S.el S.sexpIso

instance S.SexpIso Exp where
  sexpIso = match
    $ With (. prim)
    $ With (. let_)
    $ With (. app)
    $ With (. if_)
    $ End
    where
      let_ = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
      if_ = S.list $ S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
      app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso
      prim = S.list $
        S.el (S.sym "prim")
        >>> S.el (primSexpIso id (S.sexpIso @Val))
        >>> S.el S.sexpIso
        >>> S.el S.sexpIso