{-# 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 now possible because
-- of a broader knowledge of the 'Instr'uctions around
-- those generated (eg. by using 'joinNext').
module Symantic.Parser.Machine.Program where

import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
import Data.Bool (Bool(..))
import Data.Function (($), (.))
import Data.Ord (Ord)
import Data.Proxy (Proxy(..))
import System.IO (IO)
import Type.Reflection (Typeable)
import qualified Data.Functor as Functor
import qualified Data.HashMap.Strict as HM
import qualified Data.Traversable as Traversable
import qualified Language.Haskell.TH as TH
import qualified Symantic.Parser.Haskell as H

import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import Symantic.Parser.Machine.Optimize
import Symantic.Univariant.Trans

-- * Type 'Program'
-- | A 'Program' is a tree of 'Instr'uctions,
-- where 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 { 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.qNewName'.
  IO (SomeInstr repr inp vs ret)
  }

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

instance
  InstrValuable repr =>
  Applicable (Program repr inp) where
  pure x = Program $ return . pushValue (trans x)
  Program f <*> Program x = Program $ (f <=< x) . applyValue
  liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (trans f)
  Program x *> Program y = Program (x <=< return . popValue <=< y)
  Program x <* Program y = Program (x <=< y <=< return . popValue)
instance
  ( Cursorable (Cursor inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => Alternable (Program repr inp) where
  empty = Program $ \_next -> return $ fail []
  Program l <|> Program r = joinNext $ Program $ \next ->
    liftM2 (catchException (Proxy @"fail"))
      (l (popException (Proxy @"fail") next))
      (failIfConsumed Functor.<$> r next)
  try (Program x) = Program $ \next ->
    liftM2 (catchException (Proxy @"fail"))
      (x (popException (Proxy @"fail") next))
      -- On exception, reset the input,
      -- and propagate the failure.
      (return $ loadInput (fail []))

-- | If no input has been consumed by the failing alternative
-- then continue with the given continuation.
-- Otherwise, propagate the failure.
failIfConsumed ::
  Cursorable (Cursor inp) =>
  InstrBranchable repr =>
  InstrExceptionable repr =>
  InstrInputable repr =>
  InstrValuable repr =>
  SomeInstr repr inp vs ret ->
  SomeInstr repr inp (Cursor inp ': vs) ret
failIfConsumed k =
  pushInput $
  lift2Value (H.Term sameOffset) $
  ifBranch k (fail [])

-- | @('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 (Program m) = Program $ \case
  -- Double refJoin Optimization:
  -- If a join-node points directly to another join-node,
  -- then reuse it
  next@(Instr RefJoin{}) -> m 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{}) -> m next
  -- Introduce a join-node.
  next -> do
    !joinName <- TH.newName "join"
    defJoin (LetName joinName) next
      Functor.<$> m (refJoin (LetName joinName))

instance
  InstrExceptionable repr =>
  Throwable (Program repr inp) where
  type ThrowableLabel (Program repr inp) lbl =
    ()
  throw lbl = Program $ \_next -> return $ raiseException lbl []
instance
  ( tok ~ InputToken inp
  , InstrReadable tok repr
  , Typeable tok
  ) => Satisfiable tok (Program repr inp) where
  satisfy es p = Program $ return . read es (trans p)
instance
  ( InstrBranchable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => Selectable (Program repr inp) where
  branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
    lr =<< liftM2 caseBranch
      (l (swapValue (applyValue next)))
      (r (swapValue (applyValue next)))
instance
  ( InstrBranchable repr
  , InstrJoinable repr
  ) => Matchable (Program repr inp) where
  conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
    bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
    a =<< liftM (choicesBranch (trans Functor.<$> ps) bs') (d next)
instance
  ( Ord (InputToken inp)
  , Cursorable (Cursor inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrReadable (InputToken inp) repr
  , Typeable (InputToken inp)
  , InstrValuable repr
  ) => Lookable (Program repr inp) where
  look (Program x) = Program $ \next ->
    liftM pushInput (x (swapValue (loadInput next)))
  eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))
        -- This sets a better failure message
        <|> (Program $ \_next -> return $ fail [ErrorItemEnd])
  negLook (Program x) = Program $ \next ->
    liftM2 (catchException (Proxy @"fail"))
      -- On x success, discard the result,
      -- and replace this 'CatchException''s failure handler
      -- by a failure whose 'farthestExpecting' is negated,
      -- then a failure is raised from the input
      -- when entering 'negLook', to avoid odd cases:
      -- - where the failure that made (negLook x)
      --   succeed can get the blame for the overall
      --   failure of the grammar.
      -- - where the overall failure of
      --   the grammar might be blamed on something in x
      --   that, if corrected, still makes x succeed and
      --   (negLook x) fail.
      (liftM pushInput (x
        (popValue (popException (Proxy @"fail") (loadInput
          (fail []))))))
      -- On x failure, reset the input,
      -- and go on with the next 'Instr'uctions.
      (return $ loadInput $ pushValue H.unit next)
instance
  InstrCallable repr =>
  Letable TH.Name (Program repr inp) where
  shareable n (Program sub) = Program $ \next -> do
    sub' <- sub ret
    return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
  ref _isRec n = Program $ \case
    -- 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 (LetName n)
    next -> return $ call (LetName n) next
instance
  InstrCallable repr =>
  Letsable TH.Name (Program repr inp) where
  lets defs (Program x) = Program $ \next -> do
    defs' <- Traversable.traverse (\(SomeLet (Program val)) -> liftM SomeLet (val ret)) defs
    liftM (defLet defs') (x next)
instance
  ( Cursorable (Cursor inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => Foldable (Program repr inp) where
  {-
  chainPre op p = go <*> p
    where go = (H..) <$> op <*> go <|> pure H.id
  chainPost p op = p <**> go
    where go = (H..) <$> op <*> go <|> pure H.id
  -}