{-# 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 -}