{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
-- | Build the 'Instr'uction 'Program' of a 'Machine'
-- from the 'Comb'inators of a 'Grammar'.
-- 'Instr'uctions are kept introspectable
-- to enable more optimizations made possible now because
-- of a broader knowledge of the 'Instr'uctions around
-- those generated (see for instance 'joinNext').
module Symantic.Parser.Machine.Program where

import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
import Data.Bool (Bool(..))
import Data.Eq (Eq)
import Data.Function (($), (.))
import Data.Ord (Ord)
import Data.Maybe (Maybe(..))
import Data.String (IsString(..))
import Data.Either (Either (..))
import Data.Semigroup (Semigroup(..))
import System.IO (IO)
import Text.Show (Show(..))
import Type.Reflection (Typeable)
import qualified Data.Functor as Functor
import qualified Data.Traversable as Traversable
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH.Show as TH
import qualified Symantic.Syntaxes.Classes as Prod
import qualified Symantic.Semantics.Data as Prod

import Symantic.Syntaxes.Derive
import Symantic.Semantics.Data (SomeData(..))
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import Symantic.Parser.Machine.Optimize

-- * Type 'Program'
-- | A 'Program' is a tree of 'Instr'uctions generated from 'Comb'inators.
-- Each 'Instr'uction is built by a continuation
-- to be able to introspect, duplicate and/or change
-- the next 'Instr'uction.
data Program repr inp a = Program
  { programWriter :: WriteGrammar 'True a
  , unProgram ::
  forall vs ret.
  -- This is the next instruction.
  SomeInstr repr inp (a ': vs) ret ->
  -- This is the current instruction
  -- IO is needed for 'TH.newName'.
  IO (SomeInstr repr inp vs ret)
  }

-- | Build an interpreter of the 'Program' of the given 'Machinable'.
optimizeMachine ::
  forall inp repr a.
  Machinable (InputToken inp) repr =>
  Program repr inp a ->
  IO (repr inp '[] a)
optimizeMachine p = derive Functor.<$> unProgram p @'[] ret

-- * Class 'Machinable'
-- | All the 'Instr'uctions.
type Machinable tok repr =
  ( InstrBranchable repr
  , InstrComment repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrCallable repr
  , InstrValuable repr
  , InstrReadable tok repr
  , InstrIterable repr
  , InstrRegisterable repr
  , Eq tok
  , Ord tok
  , TH.Lift tok
  , NFData tok
  , Show tok
  , Typeable tok
  )

instance
  ( Positionable (InputPosition inp)
  , InstrBranchable repr
  , InstrComment repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => CombAlternable (Program repr inp) where
  alt exn lP rP = joinNext $ Program (alt exn (programWriter lP) (programWriter rP)) $ \next ->
    liftM2
      (catch exn)
      (unProgram lP $ commit exn next)
      (raiseAgainIfConsumed exn Functor.<$> unProgram rP next)
  throw exn = Program (throw exn) $ \_next -> return $ raise exn
  empty = Program empty $ \_next -> return $ fail $ FailModeNewFailure [||SomeFailure empty||]
  try xP = Program (try (programWriter xP)) $ \next ->
    liftM2
      (catch ExceptionFailure)
      (unProgram xP $ commit ExceptionFailure next)
      -- On 'ExceptionFailure', reset the input, and propagate the failure.
      (return $ loadInput $ fail $ FailModePreserve)

-- | @(raiseAgainIfConsumed exn ok)@
-- compares the stacked input position with the current one,
-- in case they're the same then continue with @(ok)@,
-- otherwise, re-'raise' @(exn)@,
-- without updating the farthest error
-- (which is usually done when 'fail'ing).
raiseAgainIfConsumed ::
  Positionable (InputPosition inp) =>
  InstrBranchable repr =>
  InstrComment repr =>
  InstrExceptionable repr =>
  InstrInputable repr =>
  InstrValuable repr =>
  Exception ->
  SomeInstr repr inp vs ret ->
  SomeInstr repr inp (InputPosition inp ': vs) ret
raiseAgainIfConsumed exn ok =
  comment "raiseAgainIfConsumed" $
  saveInput $
  lift2Value (splice samePosition) $
  ifBranch ok $
    case exn of
      ExceptionLabel lbl -> raise lbl
      ExceptionFailure -> fail $ FailModePreserve

-- | @('joinNext' m)@ factorize the next 'Instr'uction
-- to be able to reuse it multiple times without duplication.
-- It does so by introducing a 'defJoin'
-- and passing the corresponding 'refJoin'
-- as next 'Instr'uction to @(m)@,
-- unless factorizing is useless because the next 'Instr'uction
-- is already a 'refJoin' or a 'ret'.
-- It should be used each time the next 'Instr'uction
-- is used multiple times.
joinNext ::
  InstrJoinable repr =>
  Program repr inp v ->
  Program repr inp v
joinNext xP = Program (programWriter xP) $ \case
  -- Double refJoin Optimization:
  -- If a join-node points directly to another join-node,
  -- then reuse it
  next@(Instr RefJoin{}) -> unProgram xP next
  -- If a join-node points directly to a 'jump',
  -- then reuse it.
  -- Because 'Jump' expects an empty 'valueStack',
  -- a 'PopValue' has to be here to drop
  -- the value normaly expected by the 'next' 'Instr'uction.
  next@(Instr (PopValue (Instr Jump{}))) -> unProgram xP next
  -- Terminal refJoin Optimization:
  -- If a join-node points directly to a terminal operation,
  -- then it's useless to introduce a join-node.
  next@(Instr Ret{}) -> unProgram xP next
  -- Introduce a join-node.
  next -> do
    !joinName <- TH.newName "join"
    defJoin (LetName joinName) next
      Functor.<$> unProgram xP (refJoin (LetName joinName))

instance
  InstrValuable repr =>
  CombApplicable (Program repr inp) where
  pure a = Program (pure a) $ return . pushValue (prodCode a)
  fP <*> xP = Program (programWriter fP <*> programWriter xP) $ (unProgram fP <=< unProgram xP) . applyValue
  liftA2 f xP yP = Program (liftA2 f (programWriter xP) (programWriter yP)) $ (unProgram xP <=< unProgram yP) . lift2Value (prodCode f)
  xP *> yP = Program (programWriter xP *> programWriter yP) (unProgram xP <=< return . popValue <=< unProgram yP)
  xP <* yP = Program (programWriter xP <* programWriter yP) (unProgram xP <=< unProgram yP <=< return . popValue)
instance
  ( Positionable (InputPosition inp)
  , InstrBranchable repr
  , InstrCallable repr
  , InstrComment repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrIterable repr
  , InstrJoinable repr
  , InstrRegisterable repr
  , InstrValuable repr
  ) => CombFoldable (Program repr inp) where
  chainPre opP doneP =
    new (pure Prod.id) $ \(Register r) -> Program (chainPre (programWriter opP) (programWriter doneP)) $ \next -> do
      !loopName <- TH.newName "loop"
      liftM2 (iter (LetName loopName))
        (unProgram opP $
          mapValue (Prod.flip Prod..@ (Prod..)) $
          modifyRegister r $
          jump True (LetName loopName) )
        (raiseAgainIfConsumed ExceptionFailure .
          readRegister r Functor.<$>
          (unProgram doneP (applyValue next)))
  chainPost doneP opP =
    new (pure Prod.id) $ \(Register r) -> Program (chainPost (programWriter doneP) (programWriter opP)) $ \next -> do
      !loopName <- TH.newName "loop"
      liftM2 (iter (LetName loopName))
        (unProgram opP $
          modifyRegister (UnscopedRegister (unUnscopedRegister r)) $
          -- recursive call
          jump True (LetName loopName) )
        (raiseAgainIfConsumed ExceptionFailure .
          readRegister r Functor.<$>
          (unProgram doneP (applyValue next)))
instance
  InstrCallable repr =>
  Referenceable TH.Name (Program repr inp) where
  -- TODO: isRec should be passed to 'call' and 'jump'
  -- instead of redoing the work with 'CallTrace'.
  ref isRec name = Program (ref isRec name) $ \case
    -- Tail Call Optimization:
    -- returning just after a 'call' is useless:
    -- using 'jump' lets the 'ret' of the 'defLet'
    -- directly return where it would in two 'ret's.
    Instr Ret{} -> return $ jump isRec (LetName name)
    next -> return $ call isRec (LetName name) next
  {-
  refable n (Program sub) = Program $ \next -> do
    sub' <- sub ret
    return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
  -}
instance
  InstrCallable repr =>
  Letsable TH.Name (Program repr inp) where
  lets defs bodyP = Program (lets ((\(SomeLet valP) -> SomeLet (programWriter valP)) Functor.<$> defs) (programWriter bodyP)) $ \next -> do
    -- Every definition becomes a 'call'able subroutine.
    defs' <- Traversable.traverse
      (\(SomeLet valP) -> liftM SomeLet (unProgram valP ret))
      defs
    liftM (defLet defs') (unProgram bodyP next)
instance
  ( tok ~ InputToken inp
  , TH.Lift tok, Eq tok, Ord tok, Show tok, Typeable tok, NFData tok
  , Positionable (InputPosition inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrReadable tok repr
  , InstrValuable repr
  , InstrComment repr
  ) => CombLookable (Program repr inp) where
  look xP = Program (look (programWriter xP)) $ \next ->
    liftM (comment "look") $
    liftM saveInput $
    unProgram xP $
    swapValue $
    loadInput next
  -- FIXME: checkHorizon is enough instead of FailureAny
  eof = negLook item
  -- (negLook xP) always ignore the error information inside xP,
  -- which is the simplest approach, and also gives a consistent result for (negLook (negLook xP))
  negLook xP = Program (negLook (programWriter xP)) $ \next ->
    liftM (comment "negLook") $
    liftM2 (catch ExceptionFailure)
      -- On the success of x: discard the result,
      -- and replace this 'OnException' by a failure
      -- whose 'farthestExpecting' is negated,
      (
        liftM (comment "negLook.ahead") $
        liftM saveInput $
        unProgram xP $ -- if x fails, goes to negLook.reset
        popValue $
        commit ExceptionFailure $
        -- Rule: not.2
        -- Reset the input position to that when entering negLook,
        -- otherwise the overall failure of the parsing
        -- might be blamed on something in xP that, if corrected,
        -- still makes xP succeed and (negLook xP) fail.
        loadInput $
        -- Because of the previous 'commit',
        -- that failure is no longer caught by 'negLook''s 'catch'.
        fail $ FailModeNewFailure [||SomeFailure (WriteGrammar (\inh ->
          Just (fromString $$(TH.liftTypedString $ showsPrec 0
            (negLook (programWriter xP)) ""))))||]
      )
      -- On the failure of x: reset the input,
      -- and go on with the next 'Instr'uctions.
      (
        -- Rule: not.1
        liftM (comment "negLook.reset") $
        return $
          loadInput $
          pushValue Prod.unit next
      )
instance
  ( InstrBranchable repr
  , InstrJoinable repr
  ) => CombMatchable (Program repr inp) where
  conditional aP bs dP = joinNext $ Program
    (conditional (programWriter aP) ((programWriter Functor.<$>) Functor.<$> bs) (programWriter dP)) $ \next -> do
    bs' <- Control.Monad.sequence $ (\(p, b) -> (prodCode p,) Functor.<$> unProgram b next) Functor.<$> bs
    unProgram aP =<< liftM (choicesBranch bs') (unProgram dP next)
instance
  ( tok ~ InputToken inp
  , InstrReadable tok repr
  , InstrComment repr
  , Typeable tok
  ) => CombSatisfiable tok (Program repr inp) where
  satisfy pred = Program (satisfy pred) $ \next ->
    return $
      comment ("satisfy "<>showsPrec 11 (prodCode pred) "") $
      read (prodCode pred) next
instance
  ( InstrBranchable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => CombSelectable (Program repr inp) where
  branch lrP lP rP = joinNext $ Program (branch (programWriter lrP) (programWriter lP) (programWriter rP)) $ \next ->
    unProgram lrP =<< liftM2 caseBranch
      (unProgram lP (swapValue (applyValue next)))
      (unProgram rP (swapValue (applyValue next)))
instance
  ( InstrValuable repr
  , InstrRegisterable repr
  ) => CombRegisterable (Program repr inp) where
  new xP k = Program (new (programWriter xP) (programWriter . k)) $ \next -> do
    !regName <- TH.newName "reg"
    unProgram xP =<< liftM (newRegister (UnscopedRegister regName))
      (unProgram (k (Register (UnscopedRegister regName))) next)
  get reg@(Register r) = Program (get reg) $ \next ->
    return $ readRegister r next
  put reg@(Register r) xP = Program (put reg (programWriter xP)) $ \next ->
    unProgram xP $ writeRegister r $ pushValue Prod.unit next
instance
  ( InstrValuable repr
  , InstrRegisterable repr
  ) => CombRegisterableUnscoped (Program repr inp) where
  newUnscoped r xP kP = Program (newUnscoped r (programWriter xP) (programWriter kP)) $ \next ->
    unProgram xP =<< liftM (newRegister r) (unProgram kP next)
  getUnscoped r = Program (getUnscoped r) $ return . readRegister r
  putUnscoped r xP = Program (putUnscoped r (programWriter xP)) $
    unProgram xP . writeRegister r . pushValue Prod.unit