{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-} -- For nextInput
{-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
module Symantic.Parser.Machine.Eval where

import Control.Monad (Monad(..))
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($))
-- import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord, Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Language.Haskell.TH (CodeQ, Code(..))
import Prelude (($!))
import Text.Show (Show(..))
import qualified Data.Eq as Eq
import qualified Data.Set as Set
import qualified Language.Haskell.TH.Syntax as TH

import Symantic.Univariant.Trans
import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import qualified Symantic.Parser.Staging as H

-- * Type 'Eval'
-- | Generate the 'CodeQ' parsing the input.
newtype Eval inp vs es a = Eval { unEval ::
  EvalCtx inp vs es a ->
  CodeQ (Either (ParsingError inp) a)
}

-- ** Type 'ParsingError'
data ParsingError inp
  =  ParsingErrorStandard
  {  parsingErrorOffset :: Offset
  ,  parsingErrorUnexpected :: Maybe (InputToken inp)
  ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
  }
deriving instance Show (InputToken inp) => Show (ParsingError inp)

-- ** Type 'Offset'
type Offset = Int

-- ** Type 'Cont'
type Cont inp v a =
  {-farthestInput-}Cursor inp ->
  {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  v ->
  Cursor inp ->
  Either (ParsingError inp) a

-- ** Type 'SubRoutine'
type SubRoutine inp v a =
  {-ok-}Cont inp v a ->
  Cursor inp ->
  {-ko-}FailHandler inp a ->
  Either (ParsingError inp) a

-- ** Type 'FailHandler'
type FailHandler inp a =
  {-failureInput-}Cursor inp ->
  {-farthestInput-}Cursor inp ->
  {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  Either (ParsingError inp) a

{-
-- *** Type 'FarthestError'
data FarthestError inp = FarthestError
  { farthestInput :: Cursor inp
  , farthestExpecting :: [ErrorItem (InputToken inp)]
  }
-}

eval ::
  forall inp ret.
  Ord (InputToken inp) =>
  Show (InputToken inp) =>
  TH.Lift (InputToken inp) =>
  -- InputToken inp ~ Char =>
  Input inp =>
  CodeQ inp ->
  Show (Cursor inp) =>
  Eval inp '[] ('Succ 'Zero) ret ->
  CodeQ (Either (ParsingError inp) ret)
eval input (Eval k) = [||
  let _ = "eval" in
  -- Pattern bindings containing unlifted types
  -- should use an outermost bang pattern.
  let !(# init, readMore, readNext #) = $$(cursorOf input) in
  let evalRet = \_farInp _farExp v _inp -> Right v in
  let evalFail _failInp !farInp !farExp =
        Left ParsingErrorStandard
        { parsingErrorOffset = offset farInp
        , parsingErrorUnexpected =
            if readMore farInp
            then Just (let (# c, _ #) = readNext farInp in c)
            else Nothing
        , parsingErrorExpecting = Set.fromList farExp
        } in
  $$(k EvalCtx
    { valueStack = ValueStackEmpty
    , failStack = FailStackCons [||evalFail||] FailStackEmpty
    , retCode = [||evalRet||]
    , input = [||init||]
    , nextInput = [||readNext||]
    , moreInput = [||readMore||]
    -- , farthestError = [||Nothing||]
    , farthestInput = [||init||]
    , farthestExpecting = [|| [] ||]
    })
  ||]

-- ** Type 'EvalCtx'
-- | This is a context only present at compile-time.
data EvalCtx inp vs (es::Peano) a =
  ( TH.Lift (InputToken inp)
  , Cursorable (Cursor inp)
  , Show (InputToken inp)
  -- , InputToken inp ~ Char
  ) => EvalCtx
  { valueStack :: ValueStack vs
  , failStack :: FailStack inp es a
  , retCode :: CodeQ (Cont inp a a)
  , input :: CodeQ (Cursor inp)
  , moreInput :: CodeQ (Cursor inp -> Bool)
  , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
  , farthestInput :: CodeQ (Cursor inp)
  , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
  }

-- ** Type 'ValueStack'
data ValueStack vs where
  ValueStackEmpty :: ValueStack '[]
  ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)
                    -- TODO: maybe use H.Haskell instead of CodeQ ?
                    -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46

-- ** Type 'FailStack'
data FailStack inp es a where
  FailStackEmpty :: FailStack inp 'Zero a
  FailStackCons ::
    CodeQ (FailHandler inp a) ->
    FailStack inp es a ->
    FailStack 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 Failable Eval where
  fail failExp = Eval $ \inh@EvalCtx{} ->
    let FailStackCons e _es = failStack inh in
    [||
    let (# farInp, farExp #) =
          case $$compareOffset $$(farthestInput inh) $$(input inh) of
            LT -> (# $$(input inh), failExp #)
            EQ -> (# $$(farthestInput inh), ($$(farthestExpecting inh) <> failExp) #)
            GT -> (# $$(farthestInput inh), $$(farthestExpecting inh) #) in
    {-
    trace ("fail: "
      <>" failExp="<>show @[ErrorItem Char] failExp
      <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting inh))
      <>" farExp="<>show @[ErrorItem Char] farExp) $
    -}
    $$e $$(input inh) farInp farExp
    ||]
  popFail k = Eval $ \inh ->
    let FailStackCons _e es = failStack inh in
    unEval k inh{failStack = es}
  catchFail ok ko = Eval $ \inh@EvalCtx{} -> [||
    let _ = "catchFail" in $$(unEval ok inh
      { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
          -- trace ("catchFail: " <> "farExp="<>show farExp) $
          $$(unEval ko inh
            -- Push the input as it was when entering the catchFail.
            { valueStack = ValueStackCons (input inh) (valueStack inh)
            -- Move the input to the failing position.
            , input = [||failInp||]
            -- Set the farthestInput to the farthest computed by 'fail'
            , farthestInput = [||farInp||]
            , farthestExpecting = [||farExp||]
            })
        ||] (failStack inh)
      })
    ||]
instance Inputable Eval where
  loadInput k = Eval $ \inh ->
    let ValueStackCons input vs = valueStack inh in
    unEval k inh{valueStack = vs, input}
  pushInput k = Eval $ \inh ->
    unEval k inh{valueStack = ValueStackCons (input inh) (valueStack inh)}
instance Routinable Eval where
  call (LetName n) k = Eval $ \inh ->
    callWithContinuation
      {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
      {-ok-}(suspend k inh)
      (input inh)
      {-ko-}(failStack inh)
  jump (LetName n) = Eval $ \inh ->
    callWithContinuation
      {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
      {-ok-}(retCode inh)
      (input inh)
      {-ko-}(failStack inh)
  ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
  subroutine (LetName n) sub k = Eval $ \inh -> Code $ TH.unsafeTExpCoerce $ do
    val <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
      \(!ok) (!inp) ko ->
        $$(unEval sub inh
          { valueStack = ValueStackEmpty
          , failStack = FailStackCons [||ko||] FailStackEmpty
          , input = [||inp||]
          , retCode = [||ok||]
          })
      ||]
    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) ->
  {-ok-}CodeQ (Cont inp v a) ->
  CodeQ (Cursor inp) ->
  FailStack inp ('Succ es) a ->
  CodeQ (Either (ParsingError inp) a)
callWithContinuation sub ok inp (FailStackCons ko _) =
  [|| let _ = "callWithContinuation" in $$sub $$ok $$inp $! $$ko ||]

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

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 $$(farthestInput inh) $$(farthestExpecting inh) $$v $$(input inh) ||]

instance Readable Eval Char where
  read farExp p k =
    -- TODO: piggy bank
    maybeEmitCheck (Just 1) k
    where
    maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
    maybeEmitCheck (Just n) ok = Eval $ \inh ->
      let FailStackCons e es = failStack inh in
      [||
      let readFail = $$(e) in -- Factorize failure code
      $$((`unEval` inh{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
        {-ok-}(sat (liftCode p) ok
          {-ko-}(fail farExp))
        {-ko-}(fail farExp))
      ||]

sat ::
  forall inp vs es a.
  -- Cursorable (Cursor inp) =>
  -- InputToken inp ~ Char =>
  Ord (InputToken inp) =>
  TH.Lift (InputToken inp) =>
  {-predicate-}CodeQ (InputToken inp -> Bool) ->
  {-ok-}Eval inp (InputToken inp ': vs) ('Succ es) a ->
  {-ko-}Eval inp vs ('Succ es) a ->
  Eval inp vs ('Succ es) a
sat p ok ko = Eval $ \inh -> [||
  let !(# c, cs #) = $$(nextInput inh) $$(input inh) in
  if $$p c
  then $$(unEval ok inh
    { valueStack = ValueStackCons [||c||] (valueStack inh)
    , input = [||cs||]
    })
  else let _ = "sat.else" in $$(unEval ko inh)
  ||]

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

emitLengthCheck ::
  TH.Lift (InputToken inp) =>
  Int -> Eval inp vs es a -> Eval inp vs es a -> Eval inp vs es a
emitLengthCheck 0 ok _ko = ok
emitLengthCheck 1 ok ko = Eval $ \inh -> [||
  if $$(moreInput inh) $$(input inh)
  then $$(unEval ok inh)
  else let _ = "sat.length-check.else" in $$(unEval ko inh)
  ||]
{-
emitLengthCheck n ok ko inh = Eval $ \inh -> [||
  if $$moreInput ($$shiftRight $$(input inh) (n - 1))
  then $$(unEval ok inh)
  else $$(unEval ko inh {farthestExpecting = [||farExp||]})
  ||]
-}


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

liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
liftCode1 p a = case p of
  InstrPureSameOffset -> [|| $$sameOffset $$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 -> [|| $$sameOffset $$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 ||]