{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
{-# LANGUAGE DeriveGeneric #-} -- For NFData instances
{-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
{-# LANGUAGE ConstraintKinds #-} -- For Dict
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-} -- For nextInput
{-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Machine.Generate where

import Control.DeepSeq (NFData(..))
import Control.Monad (Monad(..))
import Control.Monad.ST (ST, runST)
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..), either)
import Data.Foldable (toList, null)
import Data.Function (($), (.), id, on)
import Data.Functor (Functor, (<$>), (<$))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.String (String)
import Data.Traversable (Traversable(..))
import Data.Tuple (snd)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import GHC.Generics (Generic)
import GHC.Show (showCommaSpace)
import Language.Haskell.TH (CodeQ)
import Prelude ((+), (-), error)
import Text.Show (Show(..), showParen, showString)
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Internal as Map_
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Set.Internal as Set_
import qualified Data.STRef as ST
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

import Symantic.Derive
import Symantic.ObserveSharing
import Symantic.Parser.Grammar.ObserveSharing
import Symantic.Parser.Grammar.Combinators
  ( UnscopedRegister(..)
  , Exception(..)
  , Failure(..)
  , SomeFailure(..)
  , inputTokenProxy
  )
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import qualified Language.Haskell.TH.HideName as TH
import qualified Symantic.Lang as Prod
import qualified Symantic.Optimize as Prod

--import Debug.Trace

-- | Convenient utility to generate some final 'TH.CodeQ'.
genCode :: Splice a -> CodeQ a
genCode = derive . Prod.normalOrderReduction

-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
data Gen inp vs a = Gen
  { genAnalysisByLet :: OpenRecs TH.Name (CallTrace -> GenAnalysis)
    -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
  , genAnalysis :: OpenRec TH.Name (CallTrace -> GenAnalysis)
    -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
  , unGen :: forall st.
      GenCtx st inp vs a ->
      CodeQ (ST st (Either (ParsingError inp) a))
  }

{-# INLINE returnST #-}
returnST :: forall s a. a -> ST s a
returnST = return @(ST s)

-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
-- parsing the given 'input' according to the given 'Machine'.
generateCode ::
  {-
  Eq (InputToken inp) =>
  NFData (InputToken inp) =>
  Show (InputToken inp) =>
  Typeable (InputToken inp) =>
  TH.Lift (InputToken inp) =>
  -}
  -- InputToken inp ~ Char =>
  --forall inp a.
  Inputable inp =>
  Show (Cursor inp) =>
  Gen inp '[] a ->
  CodeQ (inp -> Either (ParsingError inp) a)
generateCode Gen{unGen=k, ..} = [|| \(input :: inp) ->
    -- Pattern bindings containing unlifted types
    -- should use an outermost bang pattern.
    let !(# init, readMore, readNext #) = $$(cursorOf [||input||])
        finalRet = \_farInp _farExp v _inp -> returnST $ Right v
        finalRaise :: forall st b. (Catcher st inp b)
          = \ !exn _failInp !farInp !farExp ->
          returnST $ Left ParsingError
          { parsingErrorOffset = offset farInp
          , parsingErrorException = exn
          , parsingErrorUnexpected =
              if readMore farInp
              then Just (let (# c, _ #) = readNext farInp in c)
              else Nothing
          , parsingErrorExpecting = farExp
          }
    in runST $$(
      let
        -- | Defines 'inputTokenProxy' so that the TemplateHaskell code
        -- can refer to @(InputToken inp)@ through it.
        defInputTokenProxy :: TH.CodeQ a -> TH.CodeQ a
        defInputTokenProxy exprCode =
          TH.unsafeCodeCoerce [|
            let $(return (TH.VarP inputTokenProxy)) = Proxy :: Proxy (InputToken inp) in
            $(TH.unTypeQ (TH.examineCode exprCode))
          |]
      in
      defInputTokenProxy $
      k GenCtx
        { valueStack = ValueStackEmpty
        , catchStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (Catcher s inp a)))
        , defaultCatch = [||finalRaise||]
        , analysisCallStack = []
        , returnCall = [||finalRet||] :: CodeQ (Return s inp a a)
        , input = [||init||]
        , nextInput = [||readNext||]
        , moreInput = [||readMore||]
        -- , farthestError = [||Nothing||]
        , farthestInput = [||init||]
        , farthestExpecting = [||Set.empty||]
        , checkedHorizon = 0
        , horizonStack = []
        , finalGenAnalysisByLet = runOpenRecs genAnalysisByLet
        }
      )
    ||]

-- ** Type 'ParsingError'
data ParsingError inp
  =  ParsingError
  {  parsingErrorOffset :: Offset
  ,  parsingErrorException :: Exception
     -- | Note: if a 'FailureHorizon' greater than 1
     -- is amongst the 'parsingErrorExpecting'
     -- then 'parsingErrorUnexpected' is only the 'InputToken'
     -- at the begining of the expected 'Horizon'.
  ,  parsingErrorUnexpected :: Maybe (InputToken inp)
  ,  parsingErrorExpecting :: Set SomeFailure
  } deriving (Generic)
deriving instance NFData (InputToken inp) => NFData (ParsingError inp)
--deriving instance Show (InputToken inp) => Show (ParsingError inp)
instance Show (InputToken inp) => Show (ParsingError inp) where
  showsPrec p ParsingError{..} =
    showParen (p >= 11) $
      showString "ParsingErrorStandard {" .
      showString "parsingErrorOffset = " .
      showsPrec 0 parsingErrorOffset .
      showCommaSpace .
      showString "parsingErrorException = " .
      showsPrec 0 parsingErrorException .
      showCommaSpace .
      showString "parsingErrorUnexpected = " .
      showsPrec 0 parsingErrorUnexpected .
      showCommaSpace .
      showString "parsingErrorExpecting = fromList " .
      showsPrec 0 (
        -- Sort on the string representation
        -- because the 'Ord' of the 'SomeFailure'
        -- is based upon hashes ('typeRepFingerprint')
        -- depending on packages' ABI and whether
        -- cabal-install's setup is --inplace or not,
        -- and that would be too unstable for golden tests.
        List.sortBy (compare `on` show) $
        Set.toList parsingErrorExpecting
      ) .
      showString "}"

-- ** Type 'ErrorLabel'
type ErrorLabel = String

-- * Type 'GenAnalysis'
data GenAnalysis = GenAnalysis
  { minReads :: Either Exception Horizon
  , mayRaise :: Map Exception ()
  } deriving (Show)

-- ** Type 'Offset'
type Offset = Int
-- ** Type 'Horizon'
-- | Minimal input length required for a successful parsing.
type Horizon = Offset

-- altGenAnalysis = List.foldl' (\acc x -> either Left (\h -> Right (either (const h) (min h) acc)) x)
-- | Merge given 'GenAnalysis' as sequences.
seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
seqGenAnalysis aas@(a:|as) = GenAnalysis
  { minReads = List.foldl' (\acc x ->
        acc >>= \r -> (r +) <$> minReads x
      ) (minReads a) as
  , mayRaise = sconcat (mayRaise <$> aas)
  }
-- | Merge given 'GenAnalysis' as alternatives.
altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
altGenAnalysis aas@(a:|as) = GenAnalysis
  { minReads = List.foldl' (\acc x ->
      case acc of
        Left l ->
          case minReads x of
            Left{} -> Left l
            Right r -> Right r
        Right r ->
          case minReads x of
            Left{} -> Right r
            Right r' -> Right (min r r')
      ) (minReads a) as
  , mayRaise = sconcat (mayRaise <$> aas)
  }


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

-- ** Type 'GenCtx'
-- | This is an inherited (top-down) context
-- only present at compile-time, to build TemplateHaskell splices.
data GenCtx st inp vs a =
  ( Cursorable (Cursor inp)
  {-
  , TH.Lift (InputToken inp)
  , Show (InputToken inp)
  , Eq (InputToken inp)
  , Typeable (InputToken inp)
  , NFData (InputToken inp)
  -}
  ) => GenCtx
  { valueStack :: ValueStack vs
  , catchStackByLabel :: Map Exception (NonEmpty (CodeQ (Catcher st inp a)))
    -- | Default 'Catcher' defined at the begining of the generated 'CodeQ',
    -- hence a constant within the 'Gen'eration.
  , defaultCatch :: forall b. CodeQ (Catcher st inp b)
    -- | Used by 'checkToken' to get 'GenAnalysis' from 'genAnalysis'.
  , analysisCallStack :: [TH.Name]
  , returnCall :: CodeQ (Return st 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 (Set SomeFailure)
    -- | Remaining horizon already checked.
    -- Use to factorize 'input' length checks,
    -- instead of checking the 'input' length
    -- one 'InputToken' at a time at each 'read'.
    -- Updated by 'checkHorizon'
    -- and reset elsewhere when needed.
  , checkedHorizon :: Horizon
  -- | Used by 'pushInput' and 'loadInput'
  -- to restore the 'Horizon' at the restored 'input'.
  , horizonStack :: [Horizon]
  -- | Output of 'runOpenRecs'.
  , finalGenAnalysisByLet :: LetRecs TH.Name GenAnalysis
  }

-- ** Type 'ValueStack'
data ValueStack vs where
  ValueStackEmpty :: ValueStack '[]
  ValueStackCons ::
    { valueStackHead :: Splice v
    , valueStackTail :: ValueStack vs
    } -> ValueStack (v ': vs)

instance InstrValuable Gen where
  pushValue x k = k
    { unGen = \ctx -> {-trace "unGen.pushValue" $-} unGen k ctx
      { valueStack = ValueStackCons x (valueStack ctx) }
    }
  popValue k = k
    { unGen = \ctx -> {-trace "unGen.popValue" $-} unGen k ctx
      { valueStack = valueStackTail (valueStack ctx) }
    }
  lift2Value f k = k
    { unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
      { valueStack =
        let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
        ValueStackCons (f Prod..@ x Prod..@ y) vs
      }
    }
  swapValue k = k
    { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
      { valueStack =
          let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
          ValueStackCons x (ValueStackCons y vs)
      }
    }
instance InstrBranchable Gen where
  caseBranch kx ky = Gen
    { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
    , genAnalysis = \final ct -> altGenAnalysis $ genAnalysis kx final ct :| [genAnalysis ky final ct]
    , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
      let ValueStackCons v vs = valueStack ctx in
      [||
        case $$(genCode v) of
          Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
          Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
      ||]
    }
  choicesBranch bs default_ = Gen
    { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
    , genAnalysis = \final ct -> altGenAnalysis $
        (\k -> genAnalysis k final ct)
        <$> (default_:|(snd <$> bs))
    , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
      let ValueStackCons v vs = valueStack ctx0 in
      let ctx = ctx0{valueStack = vs} in
      let
        go x ((p,b):bs') = [||
          if $$(genCode (p Prod..@ x))
          then
            let _ = "choicesBranch.then" in
            $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
          else
            let _ = "choicesBranch.else" in
            $$(go x bs')
          ||]
        go _ _ = unGen default_ ctx
      in go v bs
    }
instance InstrExceptionable Gen where
  raise exn = Gen
    { genAnalysisByLet = HM.empty
    , genAnalysis = \_final _ct -> GenAnalysis
        { minReads = Left (ExceptionLabel exn)
        , mayRaise = Map.singleton (ExceptionLabel exn) ()
        }
    , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
        $$(raiseException ctx (ExceptionLabel exn))
          (ExceptionLabel $$(TH.liftTyped exn))
          {-failInp-}$$(input ctx)
          {-farInp-}$$(input ctx)
          $$(farthestExpecting ctx)
      ||]
    }
  fail fs = Gen
    { genAnalysisByLet = HM.empty
    , genAnalysis = \_final _ct -> GenAnalysis
        { minReads = Left ExceptionFailure
        , mayRaise = Map.singleton ExceptionFailure ()
        }
    , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
      if null fs
      then [|| -- Raise without updating the farthest error.
          $$(raiseException ctx ExceptionFailure)
            ExceptionFailure
            {-failInp-}$$(input ctx)
            $$(farthestInput ctx)
            $$(farthestExpecting ctx)
        ||]
      else raiseFailure ctx [||fs||]
    }
  commit exn k = k
    { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
      unGen k ctx{catchStackByLabel =
        Map.update (\case
            _r0:|(r1:rs) -> Just (r1:|rs)
            _ -> Nothing
          )
        exn (catchStackByLabel ctx)
      }
    }
  catch exn ok ko = Gen
    { genAnalysisByLet = genAnalysisByLet ok <> genAnalysisByLet ko
    , genAnalysis = \final ct ->
        let okGA = genAnalysis ok final ct in
        altGenAnalysis $
          okGA{ mayRaise = Map.delete exn (mayRaise okGA) } :|
          [ genAnalysis ko final ct ]
    , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
        let _ = $$(liftTypedString ("catch "<>show exn)) in
        let catchHandler !_exn !failInp !farInp !farExp =
              let _ = $$(liftTypedString ("catch.ko "<>show exn)) in
              $$({-trace ("unGen.catch.ko: "<>show exn) $-} unGen ko ctx
                -- Push 'input' and 'checkedHorizon'
                -- as they were when entering 'catch',
                -- they will be available to 'loadInput', if any.
                { valueStack =
                    ValueStackCons (splice (input ctx)) $
                    --ValueStackCons (Prod.var [||exn||]) $
                    valueStack ctx
                , horizonStack =
                    checkedHorizon ctx : horizonStack ctx
                -- Note that 'catchStackByLabel' is reset.
                -- Move the input to the failing position.
                , input = [||failInp||]
                -- The 'checkedHorizon' at the 'raise's are not known here.
                -- Nor whether 'failInp' is after 'checkedHorizon' or not.
                -- Hence fallback to a safe value.
                , checkedHorizon = 0
                -- Set the farthestInput to the farthest computed in 'fail'.
                , farthestInput = [||farInp||]
                , farthestExpecting = [||farExp||]
                })
        in
        $$({-trace ("unGen.catch.ok: "<>show es) $-} unGen ok ctx
        { catchStackByLabel =
            Map.insertWith (<>) exn
              (NE.singleton [||catchHandler||])
              (catchStackByLabel ctx)
        }
      ) ||]
    }
instance InstrInputable Gen where
  pushInput k = k
    { unGen = \ctx ->
        {-trace "unGen.pushInput" $-}
        unGen k ctx
          { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
          , horizonStack = checkedHorizon ctx : horizonStack ctx
          }
    }
  loadInput k = k
    { unGen = \ctx ->
        {-trace "unGen.loadInput" $-}
        let ValueStackCons input vs = valueStack ctx in
        let (h, hs) = case horizonStack ctx of
                        [] -> (0, [])
                        x:xs -> (x, xs) in
        unGen k ctx
          { valueStack = vs
          , horizonStack = hs
          , input = genCode input
          , checkedHorizon = h
          }
    , genAnalysis = \final ct -> GenAnalysis
        { minReads = 0 <$ minReads (genAnalysis k final ct)
        , mayRaise = mayRaise (genAnalysis k final ct)
        }
    }
instance InstrCallable Gen where
  defLet defs k = k
    { unGen = \ctx@GenCtx{} ->
        {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
        TH.unsafeCodeCoerce $ do
          decls <- traverse (makeDecl ctx) (HM.toList defs)
          body <- TH.unTypeQ $ TH.examineCode $
            {-trace "unGen.defLet.body" $-}
            unGen k ctx
          return $ TH.LetE (
            -- | Use 'List.sortBy' to output more deterministic code
            -- to be able to golden test it, at the cost of more computations
            -- (at compile-time only though).
            List.sortBy (compare `on` TH.hideName) $
            toList decls
            ) body
    , genAnalysisByLet =
        HM.unions
          $ genAnalysisByLet k
          : ((\(SomeLet sub) -> genAnalysis sub) <$> defs)
          : ((\(SomeLet sub) -> genAnalysisByLet sub) <$> HM.elems defs)
    }
    where
    makeDecl ctx (subName, SomeLet sub) = do
      body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
        -- TODO: takeFreeRegisters
        -- Called by 'call' or 'jump'.
        \ !callReturn{-from generateSuspend or returnCall-}
          !callInput
          !callCatchStackByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
          $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
            { valueStack = ValueStackEmpty
            -- Build a 'catchStackByLabel' for the 'mayRaise' of the subroutine,
            -- where each 'Catcher' calls the one passed by the 'call'-site (in 'callCatchStackByLabel').
            -- Note that currently the 'call'-site can supply in 'callCatchStackByLabel'
            -- a subset of the 'mayRaise' needed by this subroutine,
            -- because 'Map.findWithDefault' is used instead of 'Map.!'.
            , catchStackByLabel = Map.mapWithKey
                (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl callCatchStackByLabel||])
                ({-trace ("mayRaise: "<>show subName) $-}
                  mayRaise (finalGenAnalysisByLet ctx HM.! subName))
            , input = [||callInput||]
            , returnCall = {-trace ("unGen.defLet.sub.returnCall: "<>show subName) $-} [||callReturn||]

            -- These are passed by the caller via 'callReturn' or 'ko'
            -- , farthestInput = 
            -- , farthestExpecting = 

            -- Some callers can call this 'defLet'
            -- with zero 'checkedHorizon', hence use this minimum.
            -- TODO: maybe it could be improved a bit
            -- by taking the minimum of the checked horizons
            -- before all the 'call's and 'jump's to this 'defLet'.
            , checkedHorizon = 0
            })
        ||]
      let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []]
      return decl
  jump (LetName n) = Gen
    { genAnalysisByLet = HM.empty
    , genAnalysis = \final ct ->
        if n`List.elem`ct
        then GenAnalysis
          { minReads = Right 0
          , mayRaise = Map.empty
          }
        else (final HM.! n) (n:ct)
    , unGen = \ctx -> {-trace ("unGen.jump: "<>show n) $-} [||
      let _ = "jump" in
      $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
        {-ok-}$$(returnCall ctx)
        $$(input ctx)
        $$(liftTypedRaiseByLabel $
          catchStackByLabel ctx
          -- Pass only the labels raised by the 'defLet'.
          `Map.intersection`
          (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
        )
      ||]
    }
  call (LetName n) k = k
    { genAnalysis = \final ct ->
        if n`List.elem`ct
        then GenAnalysis
          { minReads = Right 0
          , mayRaise = Map.empty
          }
        else seqGenAnalysis $
          (final HM.! n) (n:ct) :|
          [ genAnalysis k final ct ]
    , unGen = {-trace ("unGen.call: "<>show n) $-} \ctx ->
      -- let ks = (Map.keys (catchStackByLabel ctx)) in
      [||
      -- let _ = $$(liftTypedString $ "call exceptByLet("<>show n<>")="<>show (Map.keys (Map.findWithDefault Map.empty n (exceptByLet ctx))) <> " catchStackByLabel(ctx)="<> show ks) in
      $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
        {-ok-}$$(generateSuspend k ctx{analysisCallStack = n : analysisCallStack ctx})
        $$(input ctx)
        $$(liftTypedRaiseByLabel $
          -- FIXME: maybe it should rather pass all the 'mayRaise' of 'n'
          -- and 'defaultCatch' be removed from 'makeDecl''s 'catchStackByLabel'.
          catchStackByLabel ctx
          -- Pass only the labels raised by the 'defLet'.
          `Map.intersection`
          (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
        )
      ||]
    }
  ret = Gen
    { genAnalysisByLet = HM.empty
    , genAnalysis = \_final _ct -> GenAnalysis
        { minReads = Right 0
        , mayRaise = Map.empty
        }
    , unGen = \ctx -> {-trace "unGen.ret" $-}
      {-trace "unGen.ret.generateResume" $-}
      generateResume ({-trace "unGen.ret.returnCall" $-} returnCall ctx) ctx
    }

-- | Like 'TH.liftString' but on 'TH.Code'.
-- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
liftTypedString :: String -> TH.Code TH.Q a
liftTypedString = TH.unsafeCodeCoerce . TH.liftString

-- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
-- which already contains 'CodeQ' terms.
-- Moreover, only the 'Catcher' at the top of the stack
-- is needed and thus generated in the resulting 'CodeQ'.
--
-- TODO: Use an 'Array' instead of a 'Map'?
liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
  [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]

instance TH.Lift a => TH.Lift (Set a) where
  liftTyped Set_.Tip = [|| Set_.Tip ||]
  liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]

-- ** Type 'Return'
type Return st inp v a =
  {-farthestInput-}Cursor inp ->
  {-farthestExpecting-}(Set SomeFailure) ->
  v ->
  Cursor inp ->
  ST st (Either (ParsingError inp) a)

-- | Generate a 'returnCall' 'Return'inuation to be called with 'generateResume'.
-- Used when 'call' 'ret'urns.
-- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
generateSuspend ::
  {-k-}Gen inp (v ': vs) a ->
  GenCtx st inp vs a ->
  CodeQ (Return st inp v a)
generateSuspend k ctx = [||
  let _ = $$(liftTypedString $ "suspend") in
  \farInp farExp v !inp ->
    $$({-trace "unGen.generateSuspend" $-} unGen k ctx
      { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} splice [||v||]) (valueStack ctx)
      , input = [||inp||]
      , farthestInput = [||farInp||]
      , farthestExpecting = [||farExp||]
      , checkedHorizon = 0
      }
    )
  ||]

-- | Generate a call to the 'generateSuspend' continuation.
-- Used when 'call' 'ret'urns.
generateResume ::
  CodeQ (Return st inp v a) ->
  GenCtx st inp (v ': vs) a ->
  CodeQ (ST st (Either (ParsingError inp) a))
generateResume k = \ctx -> {-trace "generateResume" $-} [||
  let _ = "resume" in
  $$k
    $$(farthestInput ctx)
    $$(farthestExpecting ctx)
    (let _ = "resume.genCode" in $$({-trace "generateResume.genCode" $-}
      genCode $ valueStackHead $ valueStack ctx))
    $$(input ctx)
  ||]

-- ** Type 'Catcher'
type Catcher st inp a =
  Exception ->
  {-failInp-}Cursor inp ->
  {-farInp-}Cursor inp ->
  {-farExp-}(Set SomeFailure) ->
  ST st (Either (ParsingError inp) a)

instance InstrJoinable Gen where
  defJoin (LetName n) sub k = k
    { unGen = \ctx ->
        {-trace ("unGen.defJoin: "<>show n) $-}
        TH.unsafeCodeCoerce [|
          let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
                -- Called by 'generateResume'.
                \farInp farExp v !inp ->
                  $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
                    { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
                    , input = [||inp||]
                    , farthestInput = [||farInp||]
                    , farthestExpecting = [||farExp||]
                    , checkedHorizon = 0
                    {- FIXME:
                    , catchStackByLabel = Map.mapWithKey
                        (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
                        (mayRaise sub raiseLabelsByLetButSub)
                    -}
                    })
                ||])
          in $(TH.unTypeQ $ TH.examineCode $
            {-trace ("unGen.defJoin.expr: "<>show n) $-}
            unGen k ctx)
        |]
    , genAnalysisByLet =
        (genAnalysisByLet sub <>) $
        HM.insert n (genAnalysis sub) $
        genAnalysisByLet k
    }
  refJoin (LetName n) = Gen
    { unGen = \ctx ->
        {-trace ("unGen.refJoin: "<>show n) $-}
        generateResume
          (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
    , genAnalysisByLet = HM.empty
    , genAnalysis = \final ct ->
        if n`List.elem`ct -- FIXME: useless
        then GenAnalysis
          { minReads = Right 0
          , mayRaise = Map.empty
          }
        else HM.findWithDefault
          (error (show (n,ct,HM.keys final)))
          n final (n:ct)
    }
instance InstrReadable Char Gen where
  read fs p = checkHorizon . checkToken fs p
instance InstrReadable Word8 Gen where
  read fs p = checkHorizon . checkToken fs p
instance InstrIterable Gen where
  iter (LetName jumpName) loop done = Gen
    { genAnalysisByLet =
      HM.insert jumpName (genAnalysis loop) $
      genAnalysisByLet loop <>
      genAnalysisByLet done
    , genAnalysis = \final ct ->
      GenAnalysis
        { minReads = minReads (genAnalysis done final ct)
        , mayRaise =
            Map.delete ExceptionFailure
              (mayRaise (genAnalysis loop final ct)) <>
            mayRaise (genAnalysis done final ct)
        }
    , unGen = \ctx -> TH.unsafeCodeCoerce [|
        let _ = "iter" in
        let
            {-
            Exception ->
            {-failInp-}Cursor inp ->
            {-farInp-}Cursor inp ->
            {-farExp-}(Set SomeFailure) ->
            ST st (Either (ParsingError inp) a)
            -}
          catchHandler loopInput !_exn !failInp !farInp !farExp =
            $(TH.unTypeCode $ {-trace ("unGen.catch.ko: "<>show exn) $-} unGen done ctx
                -- Push 'input' and 'checkedHorizon'
                -- as they were when entering 'catch',
                -- they will be available to 'loadInput', if any.
                { valueStack = ValueStackCons (splice (TH.unsafeCodeCoerce [|loopInput|])) (valueStack ctx)
                , horizonStack = checkedHorizon ctx : horizonStack ctx
                -- Note that 'catchStackByLabel' is reset.
                -- Move the input to the failing position.
                , input = TH.unsafeCodeCoerce [|failInp|]
                -- The 'checkedHorizon' at the 'raise's are not known here.
                -- Nor whether 'failInp' is after 'checkedHorizon' or not.
                -- Hence fallback to a safe value.
                , checkedHorizon = 0
                -- Set the farthestInput to the farthest computed in 'fail'.
                , farthestInput = TH.unsafeCodeCoerce [|farInp|]
                , farthestExpecting = TH.unsafeCodeCoerce [|farExp|]
                })
          $(return $ TH.VarP jumpName) = \_callReturn callInput callCatchStackByLabel ->
            $(TH.unTypeCode $ unGen loop ctx
              { valueStack = ValueStackEmpty
              , catchStackByLabel =
                {-
                Map.mapWithKey
                  (\lbl () -> NE.singleton $ TH.unsafeCodeCoerce [|
                    Map.findWithDefault $(TH.unTypeCode $ defaultCatch ctx) lbl koByLabel
                  |])
                  (mayRaise (finalGenAnalysisByLet ctx HM.! jumpName))
                -}
                Map.insertWith (<>) ExceptionFailure
                  (NE.singleton $ TH.unsafeCodeCoerce [|catchHandler callInput|])
                  (catchStackByLabel ctx)
              , input = TH.unsafeCodeCoerce [|callInput|]
              -- FIXME: promote to compile time error?
              , returnCall = TH.unsafeCodeCoerce [|error "invalid return"|]
              , checkedHorizon = 0
              })
        in $(TH.unTypeCode $ unGen (jump (LetName jumpName)) ctx{valueStack=ValueStackEmpty})
       |]
    }
instance InstrRegisterable Gen where
  newRegister (UnscopedRegister r) k = k
    { unGen = \ctx ->
      let ValueStackCons v vs = valueStack ctx in
      TH.unsafeCodeCoerce [|
      do
        let dupv = $(TH.unTypeCode $ genCode v)
        $(return (TH.VarP r)) <- ST.newSTRef dupv
        $(TH.unTypeCode $ unGen k ctx{valueStack=vs})
      |]
    }
  readRegister (UnscopedRegister r) k = k
    { unGen = \ctx -> [|| do
        sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
        $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
      ||]
    }
  writeRegister (UnscopedRegister r) k = k
    { unGen = \ctx ->
      let ValueStackCons v vs = valueStack ctx in
      [|| do
        let dupv = $$(genCode v)
        ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv
        $$(unGen k ctx{valueStack=vs})
      ||]
    }

checkHorizon ::
  forall inp vs a.
  -- Those constraints are not used anyway
  -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
  Ord (InputToken inp) =>
  Show (InputToken inp) =>
  TH.Lift (InputToken inp) =>
  NFData (InputToken inp) =>
  Typeable (InputToken inp) =>
  {-ok-}Gen inp vs a ->
  Gen inp vs a
checkHorizon ok = ok
  { genAnalysis = \final ct -> seqGenAnalysis $
      GenAnalysis { minReads = Right 1
                  , mayRaise = Map.singleton ExceptionFailure ()
                  } :|
      [ genAnalysis ok final ct ]
  , unGen = \ctx0@GenCtx{} ->
    {-trace "unGen.checkHorizon" $-}
    let raiseFail = raiseException ctx0 ExceptionFailure in
    [||
      -- Factorize generated code for raising the "fail".
      let readFail = $$(raiseFail) in
      $$(
        let ctx = ctx0{catchStackByLabel =
                    Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
                      ExceptionFailure (catchStackByLabel ctx0)} in
        if checkedHorizon ctx >= 1
        then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
        else let minHoriz =
                    either (\_err -> 0) id $
                    minReads $ finalGenAnalysis ctx ok in
          [||
          if $$(moreInput ctx)
               $$(if minHoriz > 0
                 then [||$$shiftRight minHoriz $$(input ctx)||]
                 else input ctx)
          then $$(unGen ok ctx{checkedHorizon = minHoriz})
          else let _ = "checkHorizon.else" in
            -- TODO: return a resuming continuation (eg. Partial)
            $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) (minHoriz + 1))) ctx)
          ||]
      )
    ||]
  }

-- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
-- with farthest parameters set to or updated with @(fs)@
-- according to the relative position of 'input' wrt. 'farthestInput'.
raiseFailure ::
  Cursorable (Cursor inp) =>
  GenCtx st inp cs a ->
  TH.CodeQ (Set SomeFailure) ->
  TH.CodeQ (ST st (Either (ParsingError inp) a))
raiseFailure ctx fs = [||
  let failExp = $$fs in
  let (# farInp, farExp #) =
        case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
          LT -> (# $$(input ctx), failExp #)
          EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
          GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
  in $$(raiseException ctx ExceptionFailure)
    ExceptionFailure
    {-failInp-}$$(input ctx) farInp farExp
  ||]
-- | @('raiseException' ctx exn)@ raises exception @(exn)@
-- using any entry in 'catchStackByLabel', or 'defaultCatch' if none.
raiseException ::
  GenCtx st inp vs a -> Exception ->
  CodeQ (Exception -> Cursor inp -> Cursor inp -> Set SomeFailure -> ST st (Either (ParsingError inp) a))
raiseException ctx exn =
  NE.head $ Map.findWithDefault
    (NE.singleton (defaultCatch ctx))
    exn (catchStackByLabel ctx)

finalGenAnalysis :: GenCtx st inp vs a -> Gen inp cs a -> GenAnalysis
finalGenAnalysis ctx k =
  --(\f -> f (error "callTrace")) $
  (\f -> f (analysisCallStack ctx)) $
  genAnalysis k $
  ((\f _ct -> f) <$>) $
  finalGenAnalysisByLet ctx

checkToken ::
  Set SomeFailure ->
  {-predicate-}Splice (InputToken inp -> Bool) ->
  {-ok-}Gen inp (InputToken inp ': vs) a ->
  Gen inp vs a
checkToken fs p ok = ok
  { unGen = \ctx -> {-trace "unGen.read" $-} [||
    let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
    $$(genCode $
      Prod.ifThenElse
        (p Prod..@ splice [||c||])
        (splice $ unGen ok ctx
          { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
          , input = [||cs||]
          })
        (splice [||
          let _ = "checkToken.else" in
          $$(unGen (fail fs) ctx)
        ||])
    )||]
  }