{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveAnyClass #-}
module Gyehoek.Stack.Syntax
  ( Program(..)
  , Routine(..)
  , Instr(..)
  , Block(..)
  , Tail(..)
  , Val(..)
  , Lit(..)
  , Obj(..)
  , Imm(..)
  , Hob(..)
  , Prim(..)
  , Name(..)
  , Reg(..)
  , Label(..)
  , pattern ValLabel
  , pattern ObjLabel
  , 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(..), pattern ObjLabel, Reg, Label)
import Gyehoek.Prelude
import Gyehoek.Sexp ((:-)((:-)))


newtype Program = MkProgram
  { routines :: HashMap Label 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 :: Label
  , 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
  -- | call the procedure at stack index `n` supplied with `n`
  -- arguments on top of the stack, then return by calling the
  -- continuation at stack index `n+1`.
  = TailCall Int
  | Call Int
  | If Val Block Block
  | Return Int
  | CallCC
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

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

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

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


--- sexp work

pure []

instance S.DatumIso Instr where
  datumIso = S.match
    $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
    $ S.With (S.headTagged1 "push!" S.datumIso >>>)
    $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
    $ S.With (S.headTagged2 "prim" S.datumIso 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.With (S.headTagged1 "call" S.datumIso >>>)
    $ S.With (if_ >>>)
    $ S.With (S.headTagged1 "return" S.datumIso >>>)
    $ S.With (S.headTagged0 "call/cc" >>>)
    $ S.End
    where
      -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
      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 (S.datumIso >>>)
    $ 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.datumIso @Label)
       >>> S.restData (S.dataIso @Block)
       )
      >>> rout

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) ||]