{-# LANGUAGE TemplateHaskell #-}
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 ret a = Eval { unEval ::
  EvalCtx inp vs es ret a -> CodeQ (Either ParsingError a)
}

type Cont inp a x = x -> inp -> Either ParsingError a
type SubRoutine inp a x = Cont inp a x -> inp -> ExceptionHandler inp a -> Either ParsingError a
type ParsingError = String
type ExceptionHandler inp a = inp -> Either ParsingError a

-- ** Type 'EvalCtx'
data EvalCtx inp vs (es::Peano) r a = EvalCtx
  { valueStack :: ValueStack vs
  , exceptionStack :: ExceptionStack inp es a
  , input :: CodeQ inp
  , inputOps :: InputOps inp
  , retCode :: CodeQ (Cont inp a r)
  }

-- ** 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
    [|| $$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
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 (Code $ TH.unsafeTExpCoerce (return (TH.VarE n))) (suspend k inh) (input inh) (exceptionStack inh)
  jump (Label n) = Eval $ \inh ->
    callWithContinuation (Code $ TH.unsafeTExpCoerce (return (TH.VarE n))) (retCode inh) (input inh) (exceptionStack inh)
  ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
  subroutine _n _v k = k
instance Readable Eval where
  read p k = sat (liftCode p) k fail

{-
evalSat ::
  -- InputPosition inp =>
  -- HandlerOps inp =>
  InstrPure (Char -> Bool) ->
  Eval inp (Char ': vs) ('Succ es) r a ->
  Eval inp vs ('Succ es) r 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 r a ->
  Eval inp vs es r a ->
  Eval inp vs es r a
sat p k bad = Eval $ \inh ->
  next (inputOps inh) (input inh) $ \c inp -> [||
    if $$p $$c
    then $$(unEval k inh
      { valueStack = ValueStackCons c (valueStack inh)
      , input = inp
      })
    else $$(unEval bad inh)
  ||]


callWithContinuation ::
  CodeQ (SubRoutine inp a x) ->
  CodeQ (Cont inp a x) ->
  CodeQ inp ->
  ExceptionStack inp ('Succ es) a ->
  CodeQ (Either ParsingError a)
callWithContinuation sub r inp (ExceptionStackCons h _) =
  [|| $$sub $$r $$inp $! $$h ||]

suspend ::
  Eval inp (x ': xs) es r a ->
  EvalCtx inp xs es r a ->
  CodeQ (Cont inp a x)
suspend k inh = [|| \x !inp ->
  $$(unEval k inh
    { valueStack = ValueStackCons [||x||] (valueStack inh)
    , input = [||inp||]
    }
  )||]

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

setupHandler ::
  EvalCtx inp vs es r a ->
  (CodeQ inp -> CodeQ (ExceptionHandler inp a)) ->
  Eval inp vs ('Succ es) r a ->
  CodeQ (Either ParsingError a)
setupHandler inh handler k = [||
  $$(unEval k inh
    { exceptionStack = ExceptionStackCons
      (handler (input inh))
      (exceptionStack inh)
    })
  ||]
buildHandler ::
  EvalCtx inp vs es r a ->
  Eval inp (inp ': vs) es r a ->
  CodeQ inp -> CodeQ (ExceptionHandler inp a)
buildHandler inh handler e = [|| \inp ->
  $$(unEval handler inh
    { valueStack = ValueStackCons e (valueStack inh)
    , input = [||inp||]
    })
  ||]

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