Program.hs

{-# 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 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 es ret.
  -- This is the next instruction
  SomeInstr repr inp (a ': vs) ('Succ es) ret ->
  -- This is the current instruction
  SomeInstr repr inp vs ('Succ es) ret }

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

instance
  Stackable repr =>
  Applicable (Program repr inp) where
  pure x = Program (push (trans x))
  Program f <*> Program x = Program (f . x . appI)
  liftA2 f (Program x) (Program y) =
    Program (x . y . liftI2 (trans f))
  Program x *> Program y = Program (x . pop . y)
  Program x <* Program y = Program (x . y . pop)
instance
  ( Cursorable (Cursor inp)
  , Branchable repr
  , Failable repr
  , Inputable repr
  , Joinable repr
  , Stackable repr
  ) => Alternable (Program repr inp) where
  empty = Program $ \_next -> fail []
  Program l <|> Program r = joinNext $ Program $ \next ->
    catchFail
      (l (popFail next))
      (failIfConsumed (r next))
  try (Program x) = Program $ \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.
failIfConsumed ::
  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
failIfConsumed k = pushInput (liftI2 (H.Term sameOffset) (ifI 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 ::
  Joinable 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
  ( tok ~ InputToken inp
  , Readable tok repr
  , Typeable tok
  ) => Satisfiable tok (Program repr inp) where
  satisfy es p = Program $ read es (trans p)
instance
  ( Branchable repr
  , Joinable repr
  , Stackable repr
  ) => Selectable (Program repr inp) where
  branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
    lr (caseI
      (l (swap (appI next)))
      (r (swap (appI next))))
instance
  ( Branchable repr
  , Joinable repr
  ) => Matchable (Program repr inp) where
  conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next ->
    a (choices
      (trans Functor.<$> ps)
      ((\(Program 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 (Program repr inp) where
  look (Program x) = Program $ \next ->
    pushInput (x (swap (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 ->
    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 (Program repr inp) where
  def n (Program v) = Program $ \next ->
    subroutine (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 '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 (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
  -}