{-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
-- | Build the 'Instr'uctions 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 'joinNextInstr').
module Symantic.Parser.Machine.Build where

import Data.Bool (Bool(..))
import Data.Ord (Ord)
import Data.Function (($), (.))
import Type.Reflection (Typeable)
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 'Machine'
-- | A 'Machine' 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 Machine repr inp a = Machine { unMachine ::
    forall vs es ret.
    -- This is the next instruction
    SomeInstr repr inp (a ': vs) ('Succ es) ret ->
    -- This is the built instruction
    SomeInstr repr inp vs ('Succ es) ret
  }

-- | Build a 'Machine'.
optimizeMachine ::
  forall inp es repr a.
  Executable (InputToken inp) repr =>
  Machine repr inp a ->
  repr inp '[] ('Succ es) a
optimizeMachine (Machine m) = trans (m @'[] @es ret)

instance
  Stackable repr =>
  Applicable (Machine repr inp) where
  pure x = Machine (push (trans x))
  Machine f <*> Machine x = Machine (f . x . appI)
  liftA2 f (Machine x) (Machine y) =
    Machine (x . y . liftI2 (trans f))
  Machine x *> Machine y = Machine (x . pop . y)
  Machine x <* Machine y = Machine (x . y . pop)
instance
  ( Cursorable (Cursor inp)
  , Branchable repr
  , Failable repr
  , Inputable repr
  , Joinable repr
  , Stackable repr
  ) => Alternable (Machine repr inp) where
  empty = Machine $ \_next -> fail []
  Machine l <|> Machine r = joinNextInstr $ Machine $ \next ->
    catchFail
      (l (popFail next))
      (instrFailIfConsumed (r next))
  try (Machine x) = Machine $ \next ->
    catchFail
      (x (popFail 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 'Fail'ure.
instrFailIfConsumed ::
  Cursorable (Cursor inp) =>
  Branchable repr =>
  Failable repr =>
  Inputable repr =>
  Stackable repr =>
  SomeInstr repr inp vs ('Succ es) ret ->
  SomeInstr repr inp (Cursor inp : vs) ('Succ es) ret
instrFailIfConsumed k = pushInput (liftI2 (H.Term sameOffset) (ifI k (fail [])))

-- | @('joinNextInstr' 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' 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.
joinNextInstr ::
  Joinable repr =>
  Machine repr inp v ->
  Machine repr inp v
joinNextInstr (Machine m) = Machine $ \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-point.
  next@(Instr Ret{}) -> m next
  -- Introduce a join-node.
  next -> defJoin joinName next (m (refJoin joinName))
    where joinName = LetName $ unsafePerformIO $ TH.qNewName "join"

instance
  ( tok ~ InputToken inp
  , Readable tok repr
  , Typeable tok
  ) => Satisfiable tok (Machine repr inp) where
  satisfy es p = Machine $ read es (trans p)
instance
  ( Branchable repr
  , Joinable repr
  , Stackable repr
  ) => Selectable (Machine repr inp) where
  branch (Machine lr) (Machine l) (Machine r) = joinNextInstr $ Machine $ \next ->
    lr (caseI
      (l (swap (appI next)))
      (r (swap (appI next))))
instance
  ( Branchable repr
  , Joinable repr
  ) => Matchable (Machine repr inp) where
  conditional (Machine a) ps bs (Machine d) = joinNextInstr $ Machine $ \next ->
    a (choices
      (trans Functor.<$> ps)
      ((\(Machine b) -> b next) Functor.<$> bs)
      (d next))
instance
  ( Ord (InputToken inp)
  , Cursorable (Cursor inp)
  , Branchable repr
  , Failable repr
  , Inputable repr
  , Joinable repr
  , Readable (InputToken inp) repr
  , Typeable (InputToken inp)
  , Stackable repr
  ) => Lookable (Machine repr inp) where
  look (Machine x) = Machine $ \next ->
    pushInput (x (swap (loadInput next)))
  eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))
        -- This sets a better failure message
        <|> (Machine $ \_k -> fail [ErrorItemEnd])
  negLook (Machine x) = Machine $ \next ->
    catchFail
      -- On x success, discard the result,
      -- and replace this 'CatchFail''s failure handler
      -- by a 'Fail'ure 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 (pop (popFail (loadInput (fail []))))))
      -- On x failure, reset the input,
      -- and go on with the next 'Instr'uctions.
      (loadInput (push H.unit next))
instance
  Routinable repr =>
  Letable TH.Name (Machine repr inp) where
  def n (Machine v) = Machine $ \next ->
    subroutine (LetName n) (v ret) (call (LetName n) next)
  ref _isRec n = Machine $ \case
    -- Returning just after a 'call' is useless:
    -- using 'jump' lets the 'ret' of the 'subroutine'
    -- directly return where it would in two 'ret's.
    Instr Ret{} -> jump (LetName n)
    next -> call (LetName n) next
instance
  ( Cursorable (Cursor inp)
  , Branchable repr
  , Failable repr
  , Inputable repr
  , Joinable repr
  , Stackable repr
  ) => Foldable (Machine 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
  -}