{-# 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 Data.Bool (Bool(..))
import Data.Ord (Ord)
import Data.Function (($), (.))
import Type.Reflection (Typeable)
import Data.Proxy (Proxy(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Functor as Functor
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax 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
  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 ->
  repr inp '[] a
optimizeMachine (Program f) = trans (f @'[] ret)

instance
  InstrValuable repr =>
  Applicable (Program repr inp) where
  pure x = Program (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 . popValue . y)
  Program x <* Program y = Program (x . y . popValue)
instance
  ( Cursorable (Cursor inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => Alternable (Program repr inp) where
  empty = Program $ \_next -> fail []
  Program l <|> Program r = joinNext $ Program $ \next ->
    catchException (Proxy @"fail")
      (l (popException (Proxy @"fail") next))
      (failIfConsumed (r next))
  try (Program x) = Program $ \next ->
    catchException (Proxy @"fail")
      (x (popException (Proxy @"fail") next))
      -- On exception, reset the input,
      -- and propagate the failure.
      (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 -> defJoin joinName next (m (refJoin joinName))
    where joinName = LetName $ unsafePerformIO $ TH.qNewName "join"
instance
  InstrExceptionable repr =>
  Throwable (Program repr inp) where
  type ThrowableLabel (Program repr inp) lbl =
    ()
  throw lbl = Program $ \_next -> raiseException lbl []
instance
  ( tok ~ InputToken inp
  , InstrReadable tok repr
  , Typeable tok
  ) => Satisfiable tok (Program repr inp) where
  satisfy es p = Program $ 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 (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 ->
    a (choicesBranch
      (trans Functor.<$> ps)
      ((\(Program b) -> b next) Functor.<$> 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 ->
    pushInput (x (swapValue (loadInput next)))
  eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))
        -- This sets a better failure message
        <|> (Program $ \_k -> fail [ErrorItemEnd])
  negLook (Program x) = Program $ \next ->
    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.
      (pushInput (x
        (popValue (popException (Proxy @"fail") (loadInput
          (fail []))))))
      -- On x failure, reset the input,
      -- and go on with the next 'Instr'uctions.
      (loadInput (pushValue H.unit next))
instance
  InstrLetable repr =>
  Letable TH.Name (Program repr inp) where
  def n (Program v) = Program $ \next ->
    defLet (LetName n) (v ret) (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{} -> jump (LetName n)
    next -> call (LetName n) 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
  -}