Program.hs

{-# LANGUAGE ConstraintKinds #-}
{-# 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.Function (($))
import System.IO (IO)
import Type.Reflection (Typeable)
import Control.DeepSeq (NFData)
import Data.Bool (Bool(..))
import Data.Eq (Eq)
import Data.Function ((.))
import Data.Ord (Ord)
import Text.Show (Show(..))
import qualified Data.Functor as Functor
import qualified Data.HashMap.Strict as HM
import qualified Data.Set as Set
import qualified Data.Traversable as Traversable
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Symantic.Typed.Lang as Prod

import Symantic.Typed.Derive
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,
-- 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.newName' in 'joinNext'.
  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 (Program f) = derive Functor.<$> f @'[] ret

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

instance
  ( Cursorable (Cursor inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrValuable repr
  , InstrReadable (InputToken inp) repr
  , Typeable (InputToken inp)
  ) =>
  Derivable (Comb CombAlternable (Program repr inp)) where
  derive = \case
    Alt ExceptionFailure
      (Comb (SatisfyOrFail _fs p :: Comb (CombSatisfiable (InputToken inp)) (Program repr inp) a))
      (Comb (Failure sf)) ->
      satisfyOrFail (Set.singleton sf) p
    Alt exn x y -> alt exn (derive x) (derive y)
    Empty -> empty
    Failure sf -> failure sf
    Throw exn -> throw exn
    Try x -> try (derive x)

instance
  ( Cursorable (Cursor inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => CombAlternable (Program repr inp) where
  alt exn (Program l) (Program r) = joinNext $ Program $ \next ->
    liftM2 (catch exn)
      (l (commit exn next))
      (failIfConsumed exn Functor.<$> r next)
  throw exn = Program $ \_next -> return $ raise exn
  failure flr = Program $ \_next -> return $ fail (Set.singleton flr)
  empty = Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEmpty))
  try (Program x) = Program $ \next ->
    liftM2 (catch ExceptionFailure)
      (x (commit ExceptionFailure next))
      -- On exception, reset the input, and propagate the failure.
      (return $ loadInput $ fail Set.empty)

-- | 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 =>
  Exception ->
  SomeInstr repr inp vs ret ->
  SomeInstr repr inp (Cursor inp ': vs) ret
failIfConsumed exn k =
  pushInput $
  lift2Value (splice sameOffset) $
  ifBranch k $
    case exn of
      ExceptionLabel lbl -> raise lbl
      ExceptionFailure -> fail Set.empty

-- | @('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
  -- 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{}))) -> 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
  InstrValuable repr =>
  CombApplicable (Program repr inp) where
  pure x = Program $ return . pushValue (prodCode x)
  Program f <*> Program x = Program $ (f <=< x) . applyValue
  liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (prodCode 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
  ) => CombFoldable (Program repr inp) where
  {-
  chainPre op p = go <*> p
    where go = (Prod..) <$> op <*> go <|> pure Prod.id
  chainPost p op = p <**> go
    where go = (Prod..) <$> op <*> go <|> pure Prod.id
  -}
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
    -- 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 (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
  ( Eq (InputToken inp)
  , Cursorable (Cursor inp)
  , InstrBranchable repr
  , InstrExceptionable repr
  , InstrInputable repr
  , InstrJoinable repr
  , InstrReadable (InputToken inp) repr
  , Typeable (InputToken inp)
  , InstrValuable repr
  ) => CombLookable (Program repr inp) where
  look (Program x) = Program $ \next ->
    liftM pushInput (x (swapValue (loadInput next)))
  eof = negLook (satisfy (Prod.const Prod..@ Prod.bool True))
        -- This sets a better failure message
        <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
  negLook (Program x) = Program $ \next ->
    liftM2 (catch ExceptionFailure)
      -- On x success, discard the result,
      -- and replace this 'Catcher' 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 $ commit ExceptionFailure $
          loadInput $ fail Set.empty)
      -- On x failure, reset the input,
      -- and go on with the next 'Instr'uctions.
      (return $ loadInput $ pushValue Prod.unit next)
instance
  ( InstrBranchable repr
  , InstrJoinable repr
  ) => CombMatchable (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 (prodCode Functor.<$> ps) bs') (d next)
instance
  ( tok ~ InputToken inp
  , InstrReadable tok repr
  , Typeable tok
  ) => CombSatisfiable tok (Program repr inp) where
  -- Note: 'read' is left with the responsability
  -- to apply 'normalOrderReduction' if need be.
  satisfyOrFail fs p = Program $ return . read fs (prodCode p)
instance
  ( InstrBranchable repr
  , InstrJoinable repr
  , InstrValuable repr
  ) => CombSelectable (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)))