{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveAnyClass #-}
module Gyehoek.Stack.Syntax
  ( Program(..)
  , Routine(..)
  , Instr(..)
  , Block(..)
  , Tail(..)
  , Val(..)
  , Lit(..)
  , Obj(..)
  , Imm(..)
  , Hob(..)
  , Prim(..)
  , Name
  , pattern ValLabel
  , stkP
  ) where

import Control.Lens
import qualified Gyehoek.Sexp as S
import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
import GHC.Exts (IsList(..))
import Data.List (intersperse)
import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
import Gyehoek.Prelude
import Gyehoek.Sexp ((:-)((:-)))


newtype Program = MkProgram
  { routines :: HashMap Name Routine
  }
  deriving stock (Show, Generic, Data)
  deriving newtype (Semigroup, Monoid)
  deriving anyclass (NFData)

instance IsList Program where
  type Item Program = Routine
  fromList rs = MkProgram
    { routines = fromList [ (r.label, r) | r <- rs ]
    }
  toList = toListOf $ #routines . each

data Routine = MkRoutine
  { label :: Name
  , params :: List Name
  , start :: Block
  }
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

data Block = MkBlock
  { code :: List Instr
  , tail :: Tail
  }
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

data Tail
  = TailCall Val (List Val)
  | If Val Block Block
  -- | Invoke a reified continuation.
  | InvokeC Val
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

data Instr
  = Pop Name
  | Push Val
  | Prim Name (Prim Val)
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

data Val
  = ValReg Name
  | ValImm Imm
  deriving stock (Show, Generic, Data, Eq)
  deriving anyclass (NFData)

pattern ValLabel :: Name -> Val
pattern ValLabel x = ValImm (ImmLabel x)


--- sexp work

pure []

instance S.DatumIso Instr where
  datumIso = S.match
    $ S.With (S.headTagged1 "pop!" regName >>>)
    $ S.With (S.headTagged1 "push!" S.datumIso >>>)
    $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
    $ S.End
    where

instance S.DataIso Block where
  dataIso = S.with \g ->
    S.flipped S.snoced
    >>> S.onHead (S.traversed $ S.sealed S.datumIso)
    >>> S.onTail (S.datumIso @Tail)
    >>> S.swap
    >>> g

instance S.DatumIso Tail where
  datumIso = S.match
    $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
    $ S.With (if_ >>>)
    $ S.With (S.headTagged1 "invoke/c" S.datumIso >>>)
    $ S.End
    where
      if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
      branch :: Text -> S.DatumGrammar Block
      branch s =
        S.listWithIndentation (S.NSpecial 0) $
            S.el (S.decorate S.SynBuiltin >>> S.sym s)
            >>> S.restData (S.dataIso @Block)

instance S.DatumIso Val where
  datumIso = S.match
    $ S.With (regName >>>)
    $ S.With (S.datumIso >>>)
    $ S.End

instance S.DatumIso Routine where
  datumIso = S.with \rout ->
      S.listWithIndentation (S.NSpecial 1)
       ( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
       >>> S.el (S.list $ S.el labelName >>> S.rest regName)
       >>> S.restData (S.dataIso @Block)
       )
      >>> rout

regName :: S.DatumGrammar Name
regName = S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
  (S.expected "register")
  (prefixed @Name "%")

instance S.DataIso Program where
  dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList

stkP :: S.QuasiQuoter
stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||]