{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module Symantic.Parser.Automaton.Eval where

import Control.Monad (Monad(..))
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Function (($))
import Data.String (String)
import Language.Haskell.TH (CodeQ, Code(..))
import Prelude (($!))
import qualified Data.Eq as Eq
import qualified Language.Haskell.TH.Syntax as TH

import Symantic.Univariant.Trans
import Symantic.Parser.Automaton.Input
import Symantic.Parser.Automaton.Instructions
import qualified Symantic.Parser.Staging as H

-- * Type 'Eval'
newtype Eval inp vs es a = Eval { unEval ::
  EvalCtx inp vs es a ->
  CodeQ (Either ParsingError a)
}

type ParsingError = String
type Cont inp v a = v -> inp -> Either ParsingError a
type SubRoutine inp v a =
  {-cont-}Cont inp v a ->
  inp ->
  ExceptionHandler inp a ->
  Either ParsingError a
type ExceptionHandler inp a = inp -> Either ParsingError a

eval ::
  Input inp =>
  CodeQ inp ->
  Eval (Cursor inp) '[] ('Succ 'Zero) ret ->
  CodeQ (Either ParsingError ret)
eval input (Eval k) = [||
  let _ = "eval" in
  --  Pattern bindings containing unlifted types
  --  should use an outermost bang pattern.
  let !(# init, more, next #) = $$(cursorOf input) in
  $$(k EvalCtx
    { valueStack = ValueStackEmpty
    , exceptionStack = ExceptionStackCons [|| let _ = "eval.exception" in \(!_) -> Left "fatal"||] ExceptionStackEmpty
    , retCode = [|| let _ = "eval.retCode" in \v _inp -> Right v||]
    , input = [||init||]
    , nextInput = nextInputCont [||next||]
    , moreInput = [||more||]
    })
  ||]

-- ** Type 'EvalCtx'
data EvalCtx inp vs (es::Peano) a = EvalCtx
  { valueStack :: ValueStack vs
  , exceptionStack :: ExceptionStack inp es a
  , retCode :: CodeQ (Cont inp a a)
  , input :: CodeQ inp
  , nextInput :: forall b. CodeQ inp -> (CodeQ Char -> CodeQ inp -> CodeQ b) -> CodeQ b
  , moreInput :: CodeQ (inp -> Bool)
  }

-- ** Type 'ValueStack'
data ValueStack vs where
  ValueStackEmpty :: ValueStack '[]
  ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)

-- ** Type 'ExceptionStack'
data ExceptionStack inp es a where
  ExceptionStackEmpty :: ExceptionStack inp 'Zero a
  ExceptionStackCons :: CodeQ (ExceptionHandler inp a) -> ExceptionStack inp es a -> ExceptionStack inp ('Succ es) a

instance Stackable Eval where
  push x k = Eval $ \inh -> unEval k inh
    { valueStack = ValueStackCons (liftCode x) (valueStack inh) }
  pop k = Eval $ \inh -> unEval k inh
    { valueStack = let ValueStackCons _ xs = valueStack inh in xs }
  liftI2 f k = Eval $ \inh -> unEval k inh
    { valueStack =
      let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
      ValueStackCons (liftCode2 f x y) xs
    }
  swap k = Eval $ \inh -> unEval k inh
    { valueStack =
        let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
        ValueStackCons x (ValueStackCons y xs)
    }
instance Branchable Eval where
  case_ kx ky = Eval $ \inh ->
    let ValueStackCons v vs = valueStack inh in
    [||
      case $$v of
        Left  x -> $$(unEval kx inh{ valueStack = ValueStackCons [||x||] vs })
        Right y -> $$(unEval ky inh{ valueStack = ValueStackCons [||y||] vs })
    ||]
  choices fs ks kd = Eval $ \inh ->
    let ValueStackCons v vs = valueStack inh in
    go inh{valueStack = vs} v fs ks
    where
    go inh x (f:fs') (Eval k:ks') = [||
      if $$(liftCode1 f x) then $$(k inh)
      else $$(go inh x fs' ks')
      ||]
    go inh _ _ _ = unEval kd inh
instance Exceptionable Eval where
  fail = Eval $ \inh ->
    let ExceptionStackCons e _es = exceptionStack inh in
    [|| let _ = "fail" in $$e $$(input inh) ||]
  commit k = Eval $ \inh ->
    let ExceptionStackCons _e es = exceptionStack inh in
    unEval k inh{exceptionStack = es}
  catch k h = Eval $ \inh ->
    -- setupHandler inh (buildHandler inh h) k
    [|| let _ = "catch" in $$(unEval k inh { exceptionStack =
      ExceptionStackCons (buildHandler inh h) (exceptionStack inh) }) ||]

buildHandler ::
  EvalCtx inp vs es a ->
  {-handler-}Eval inp (inp ': vs) es a ->
  CodeQ (ExceptionHandler inp a)
buildHandler inh handler = [|| let _ = "buildHandler" in \inp ->
  $$(unEval handler inh
    { valueStack = ValueStackCons (input inh) (valueStack inh)
    , input = [||inp||]
    })
  ||]

instance Inputable Eval where
  seek k = Eval $ \inh ->
    let ValueStackCons input vs = valueStack inh in
    unEval k inh{valueStack = vs, input}
  tell k = Eval $ \inh ->
    unEval k inh{valueStack = ValueStackCons (input inh) (valueStack inh)}
instance Routinable Eval where
  call (Label n) k = Eval $ \inh ->
    callWithContinuation
      {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
      {-cont-}(suspend k inh)
      (input inh)
      (exceptionStack inh)
  jump (Label n) = Eval $ \inh ->
    callWithContinuation
      {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
      {-cont-}(retCode inh)
      (input inh)
      (exceptionStack inh)
  ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
  subroutine (Label n) sub k = Eval $ \inh -> Code $ TH.unsafeTExpCoerce $ do
    val <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
      \(!r) (!inp) h ->
        $$(unEval sub inh
          { valueStack = ValueStackEmpty
          , retCode = [||r||]
          , input = [||inp||]
          , exceptionStack = ExceptionStackCons [||h||] ExceptionStackEmpty
          })
      ||]
    let decl = TH.FunD n [TH.Clause [] (TH.NormalB val) []]
    exp <- TH.unTypeQ (TH.examineCode (unEval k inh))
    return (TH.LetE [decl] exp)

callWithContinuation ::
  {-sub-}CodeQ (SubRoutine inp v a) ->
  {-cont-}CodeQ (Cont inp v a) ->
  CodeQ inp ->
  ExceptionStack inp ('Succ es) a ->
  CodeQ (Either ParsingError a)
callWithContinuation sub cont inp (ExceptionStackCons h _) =
  [|| let _ = "callWithContinuation" in $$sub $$cont $$inp $! $$h ||]

suspend ::
  {-k-}Eval inp (v ': vs) es a ->
  EvalCtx inp vs es a ->
  CodeQ (Cont inp v a)
suspend k inh = [|| let _ = "suspend" in \v !inp ->
  $$(unEval k inh
    { valueStack = ValueStackCons [||v||] (valueStack inh)
    , input = [||inp||]
    }
  )||]

resume :: CodeQ (Cont inp v a) -> Eval inp (v ': vs) es a
resume k = Eval $ \inh ->
  let ValueStackCons v _ = valueStack inh in
  [|| let _ = "resume" in $$k $$v $$(input inh) ||]

instance Readable Eval where
  read p k =
    -- TODO: piggy bank
    sat (liftCode p) k fail

{-
evalSat ::
  -- Cursorable inp =>
  -- HandlerOps inp =>
  InstrPure (Char -> Bool) ->
  Eval inp (Char ': vs) ('Succ es) a ->
  Eval inp vs ('Succ es) a
evalSat p k = do
  bankrupt <- asks isBankrupt
  hasChange <- asks hasCoin
  if | bankrupt -> maybeEmitCheck (Just 1) <$> k
     | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
     | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
  where
  maybeEmitCheck Nothing mk inh = sat (genDefunc p) mk (raise inh) inh
  maybeEmitCheck (Just n) mk inh =
    [|| let bad = $$(raise inh) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] inh)||]
-}

sat ::
  CodeQ (Char -> Bool) ->
  Eval inp (Char ': vs) es a ->
  Eval inp vs es a ->
  Eval inp vs es a
sat p k bad = Eval $ \inh ->
  nextInput inh (input inh) $ \c inp -> [||
    let _ = "sat" in
    if $$p $$c
    then $$(unEval k inh
      { valueStack = ValueStackCons c (valueStack inh)
      , input = inp
      })
    else $$(unEval bad inh)
  ||]


liftCode :: InstrPure a -> CodeQ a
liftCode = trans
{-# INLINE liftCode #-}

liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
liftCode1 p a = case p of
  InstrPureSameOffset -> [|| $$same $$a ||]
  InstrPureHaskell h -> go a h
  where
  go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
  go qa = \case
    (H.:$) -> [|| \x -> $$qa x ||]
    (H.:.) -> [|| \g x -> $$qa (g x) ||]
    H.Flip -> [|| \x y -> $$qa y x ||]
    (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
    H.Const -> [|| \_ -> $$qa ||]
    H.Flip H.:@ H.Const -> H.id
    h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
    H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
    H.Id -> qa
    h -> [|| $$(trans h) $$qa ||]

liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
liftCode2 p a b = case p of
  InstrPureSameOffset -> [|| $$same $$a $$b ||]
  InstrPureHaskell h -> go a b h
  where
  go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
  go qa qb = \case
    (H.:$) -> [|| $$qa $$qb ||]
    (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
    H.Flip -> [|| \x -> $$qa x $$qb ||]
    H.Flip H.:@ H.Const -> [|| $$qb ||]
    H.Flip H.:@ f -> go qb qa f
    H.Const -> [|| $$qa ||]
    H.Cons -> [|| $$qa : $$qb ||]
    h -> [|| $$(trans h) $$qa $$qb ||]