+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
-- | Build the 'Instr'uction 'Program' of a 'Machine'
-- from the 'Comb'inators of a 'Grammar'.
-- those generated (eg. by using 'joinNext').
module Symantic.Parser.Machine.Program where
-import Data.Bool (Bool(..))
-import Data.Ord (Ord)
-import Data.Function (($), (.))
+import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
+import Data.Function (($))
+import System.IO (IO)
import Type.Reflection (Typeable)
-import System.IO.Unsafe (unsafePerformIO)
+import Control.DeepSeq (NFData)
+import Data.Bool (Bool(..))
+import Data.Eq (Eq(..))
+import Data.Function ((.))
+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.Parser.Haskell as H
+import qualified Symantic.Typed.Lang as Prod
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import Symantic.Parser.Machine.Optimize
-import Symantic.Univariant.Trans
+import Symantic.Typed.Trans
-- * Type 'Program'
-- | A 'Program' is a tree of 'Instr'uctions,
-- to be able to introspect, duplicate and/or change
-- the next 'Instr'uction.
data Program repr inp a = Program { unProgram ::
- forall vs es ret.
+ forall vs ret.
-- This is the next instruction
- SomeInstr repr inp (a ': vs) ('Succ es) ret ->
+ SomeInstr repr inp (a ': vs) ret ->
-- This is the current instruction
- SomeInstr repr inp vs ('Succ es) ret }
+ -- IO is needed for 'TH.newName' in 'joinNext'.
+ IO (SomeInstr repr inp vs ret)
+ }
--- | Build an interpreter of the 'Program' of the given 'Machine'.
+-- | Build an interpreter of the 'Program' of the given 'Machinable'.
optimizeMachine ::
- forall inp es repr a.
- Machine (InputToken inp) repr =>
+ forall inp repr a.
+ Machinable (InputToken inp) repr =>
Program repr inp a ->
- repr inp '[] ('Succ es) a
-optimizeMachine (Program f) = trans (f @'[] @es ret)
+ IO (repr inp '[] a)
+optimizeMachine (Program f) = trans 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
+ , TH.Lift tok
+ , NFData tok
+ , Show tok
+ , Typeable tok
+ )
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)
+ ( Cursorable (Cursor inp)
+ , InstrBranchable repr
+ , InstrExceptionable repr
+ , InstrInputable repr
+ , InstrJoinable repr
+ , InstrValuable repr
+ , InstrReadable (InputToken inp) repr
+ , Typeable (InputToken inp)
+ ) =>
+ Trans (Comb CombAlternable (Program repr inp)) (Program repr inp) where
+ trans = \case
+ Alt ExceptionFailure
+ (Comb (SatisfyOrFail _fs p :: Comb (CombSatisfiable (InputToken inp)) (Program repr inp) a))
+ (Comb (Failure sf)) ->
+ Program $ return . read (Set.singleton sf) (prodCode p)
+ Alt exn x y -> alt exn (trans x) (trans y)
+ Empty -> empty
+ Failure sf -> failure sf
+ Throw exn -> throw exn
+ Try x -> try (trans x)
+
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))
+ , 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 ->
- catchFail
- (x (popFail next))
- -- On exception, reset the input,
- -- and propagate the failure.
- (loadInput (fail []))
+ 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 'Fail'ure.
+-- Otherwise, propagate the failure.
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 [])))
+ 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 should be used each time the next 'Instr'uction
-- is used multiple times.
joinNext ::
- Joinable repr =>
+ InstrJoinable repr =>
Program repr inp v ->
Program repr inp v
joinNext (Program m) = Program $ \case
-- 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 -> defJoin joinName next (m (refJoin joinName))
- where joinName = LetName $ unsafePerformIO $ TH.qNewName "join"
+ next -> do
+ !joinName <- TH.newName "join"
+ defJoin (LetName joinName) next
+ Functor.<$> m (refJoin (LetName joinName))
instance
- ( tok ~ InputToken inp
- , Readable tok repr
- , Typeable tok
- ) => Satisfiable tok (Program repr inp) where
- satisfy es p = Program $ read es (trans p)
+ 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
- ( 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))))
+ ( 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
- ( 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))
+ 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
- ( Ord (InputToken inp)
+ 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)
- , Branchable repr
- , Failable repr
- , Inputable repr
- , Joinable repr
- , Readable (InputToken inp) repr
+ , InstrBranchable repr
+ , InstrExceptionable repr
+ , InstrInputable repr
+ , InstrJoinable repr
+ , InstrReadable (InputToken inp) repr
, Typeable (InputToken inp)
- , Stackable repr
- ) => Lookable (Program repr inp) where
+ , InstrValuable repr
+ ) => CombLookable (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)))
+ liftM pushInput (x (swapValue (loadInput next)))
+ eof = negLook (satisfy (Prod.lam1 (\_x -> Prod.bool True)))
-- This sets a better failure message
- <|> (Program $ \_k -> fail [ErrorItemEnd])
+ <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
negLook (Program x) = Program $ \next ->
- catchFail
+ liftM2 (catch ExceptionFailure)
-- On x success, discard the result,
- -- and replace this 'CatchFail''s failure handler
- -- by a 'Fail'ure whose 'farthestExpecting' is negated,
+ -- 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)
-- 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 []))))))
+ -- 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.
- (loadInput (push H.unit next))
+ (return $ loadInput $ pushValue Prod.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
+ ( 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
- ( 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
- -}
+ ( tok ~ InputToken inp
+ , InstrReadable tok repr
+ , Typeable tok
+ ) => CombSatisfiable tok (Program repr inp) where
+ 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)))
sourcephile / git / haskell / symantic-parser.git / blobdiff