1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
3 -- | Build the 'Instr'uction 'Program' of a 'Machine'
4 -- from the 'Comb'inators of a 'Grammar'.
5 -- 'Instr'uctions are kept introspectable
6 -- to enable more optimizations now possible because
7 -- of a broader knowledge of the 'Instr'uctions around
8 -- those generated (eg. by using 'joinNext').
9 module Symantic.Parser.Machine.Program where
11 import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
12 import Data.Function (($))
14 import Type.Reflection (Typeable)
15 import Control.DeepSeq (NFData)
16 import Data.Bool (Bool(..))
17 import Data.Eq (Eq(..))
18 import Data.Function ((.))
19 import Text.Show (Show(..))
20 import qualified Data.Functor as Functor
21 import qualified Data.HashMap.Strict as HM
22 import qualified Data.Set as Set
23 import qualified Data.Traversable as Traversable
24 import qualified Language.Haskell.TH as TH
25 import qualified Language.Haskell.TH.Syntax as TH
26 import qualified Symantic.Typed.Lang as Prod
28 import Symantic.Parser.Grammar
29 import Symantic.Parser.Machine.Input
30 import Symantic.Parser.Machine.Instructions
31 import Symantic.Parser.Machine.Optimize
32 import Symantic.Typed.Trans
35 -- | A 'Program' is a tree of 'Instr'uctions,
36 -- where each 'Instr'uction is built by a continuation
37 -- to be able to introspect, duplicate and/or change
38 -- the next 'Instr'uction.
39 data Program repr inp a = Program { unProgram ::
41 -- This is the next instruction
42 SomeInstr repr inp (a ': vs) ret ->
43 -- This is the current instruction
44 -- IO is needed for 'TH.newName' in 'joinNext'.
45 IO (SomeInstr repr inp vs ret)
48 -- | Build an interpreter of the 'Program' of the given 'Machinable'.
51 Machinable (InputToken inp) repr =>
54 optimizeMachine (Program f) = trans Functor.<$> f @'[] ret
56 -- * Class 'Machinable'
57 -- | All the 'Instr'uctions.
58 type Machinable tok repr =
59 ( InstrBranchable repr
60 , InstrExceptionable repr
65 , InstrReadable tok repr
74 ( Cursorable (Cursor inp)
75 , InstrBranchable repr
76 , InstrExceptionable repr
80 , InstrReadable (InputToken inp) repr
81 , Typeable (InputToken inp)
83 Trans (Comb CombAlternable (Program repr inp)) (Program repr inp) where
86 (Comb (SatisfyOrFail _fs p :: Comb (CombSatisfiable (InputToken inp)) (Program repr inp) a))
87 (Comb (Failure sf)) ->
88 Program $ return . read (Set.singleton sf) (prodCode p)
89 Alt exn x y -> alt exn (trans x) (trans y)
91 Failure sf -> failure sf
92 Throw exn -> throw exn
93 Try x -> try (trans x)
96 ( Cursorable (Cursor inp)
97 , InstrBranchable repr
98 , InstrExceptionable repr
102 ) => CombAlternable (Program repr inp) where
103 alt exn (Program l) (Program r) = joinNext $ Program $ \next ->
105 (l (commit exn next))
106 (failIfConsumed exn Functor.<$> r next)
107 throw exn = Program $ \_next -> return $ raise exn
108 failure flr = Program $ \_next -> return $ fail (Set.singleton flr)
109 empty = Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEmpty))
110 try (Program x) = Program $ \next ->
111 liftM2 (catch ExceptionFailure)
112 (x (commit ExceptionFailure next))
113 -- On exception, reset the input, and propagate the failure.
114 (return $ loadInput $ fail Set.empty)
116 -- | If no input has been consumed by the failing alternative
117 -- then continue with the given continuation.
118 -- Otherwise, propagate the failure.
120 Cursorable (Cursor inp) =>
121 InstrBranchable repr =>
122 InstrExceptionable repr =>
123 InstrInputable repr =>
124 InstrValuable repr =>
126 SomeInstr repr inp vs ret ->
127 SomeInstr repr inp (Cursor inp ': vs) ret
128 failIfConsumed exn k =
130 lift2Value (splice sameOffset) $
133 ExceptionLabel lbl -> raise lbl
134 ExceptionFailure -> fail Set.empty
136 -- | @('joinNext' m)@ factorize the next 'Instr'uction
137 -- to be able to reuse it multiple times without duplication.
138 -- It does so by introducing a 'defJoin'
139 -- and passing the corresponding 'refJoin'
140 -- as next 'Instr'uction to @(m)@,
141 -- unless factorizing is useless because the next 'Instr'uction
142 -- is already a 'refJoin' or a 'ret'.
143 -- It should be used each time the next 'Instr'uction
144 -- is used multiple times.
146 InstrJoinable repr =>
147 Program repr inp v ->
149 joinNext (Program m) = Program $ \case
150 -- Double refJoin Optimization:
151 -- If a join-node points directly to another join-node,
153 next@(Instr RefJoin{}) -> m next
154 -- If a join-node points directly to a 'jump',
156 -- Because 'Jump' expects an empty 'valueStack',
157 -- a 'PopValue' has to be here to drop
158 -- the value normaly expected by the 'next' 'Instr'uction.
159 next@(Instr (PopValue (Instr Jump{}))) -> m next
160 -- Terminal refJoin Optimization:
161 -- If a join-node points directly to a terminal operation,
162 -- then it's useless to introduce a join-node.
163 next@(Instr Ret{}) -> m next
164 -- Introduce a join-node.
166 !joinName <- TH.newName "join"
167 defJoin (LetName joinName) next
168 Functor.<$> m (refJoin (LetName joinName))
171 InstrValuable repr =>
172 CombApplicable (Program repr inp) where
173 pure x = Program $ return . pushValue (prodCode x)
174 Program f <*> Program x = Program $ (f <=< x) . applyValue
175 liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (prodCode f)
176 Program x *> Program y = Program (x <=< return . popValue <=< y)
177 Program x <* Program y = Program (x <=< y <=< return . popValue)
179 ( Cursorable (Cursor inp)
180 , InstrBranchable repr
181 , InstrExceptionable repr
182 , InstrInputable repr
185 ) => CombFoldable (Program repr inp) where
187 chainPre op p = go <*> p
188 where go = (Prod..) <$> op <*> go <|> pure Prod.id
189 chainPost p op = p <**> go
190 where go = (Prod..) <$> op <*> go <|> pure Prod.id
193 InstrCallable repr =>
194 Letable TH.Name (Program repr inp) where
195 shareable n (Program sub) = Program $ \next -> do
197 return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
198 ref _isRec n = Program $ \case
199 -- Tail Call Optimization:
200 -- returning just after a 'call' is useless:
201 -- using 'jump' lets the 'ret' of the 'defLet'
202 -- directly return where it would in two 'ret's.
203 Instr Ret{} -> return $ jump (LetName n)
204 next -> return $ call (LetName n) next
206 InstrCallable repr =>
207 Letsable TH.Name (Program repr inp) where
208 lets defs (Program x) = Program $ \next -> do
209 defs' <- Traversable.traverse (\(SomeLet (Program val)) -> liftM SomeLet (val ret)) defs
210 liftM (defLet defs') (x next)
212 ( Eq (InputToken inp)
213 , Cursorable (Cursor inp)
214 , InstrBranchable repr
215 , InstrExceptionable repr
216 , InstrInputable repr
218 , InstrReadable (InputToken inp) repr
219 , Typeable (InputToken inp)
221 ) => CombLookable (Program repr inp) where
222 look (Program x) = Program $ \next ->
223 liftM pushInput (x (swapValue (loadInput next)))
224 eof = negLook (satisfy (Prod.lam1 (\_x -> Prod.bool True)))
225 -- This sets a better failure message
226 <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
227 negLook (Program x) = Program $ \next ->
228 liftM2 (catch ExceptionFailure)
229 -- On x success, discard the result,
230 -- and replace this 'Catcher' by a failure whose 'farthestExpecting' is negated,
231 -- then a failure is raised from the input
232 -- when entering 'negLook', to avoid odd cases:
233 -- - where the failure that made (negLook x)
234 -- succeed can get the blame for the overall
235 -- failure of the grammar.
236 -- - where the overall failure of
237 -- the grammar might be blamed on something in x
238 -- that, if corrected, still makes x succeed
239 -- and (negLook x) fail.
240 (liftM pushInput $ x $
241 popValue $ commit ExceptionFailure $
242 loadInput $ fail Set.empty)
243 -- On x failure, reset the input,
244 -- and go on with the next 'Instr'uctions.
245 (return $ loadInput $ pushValue Prod.unit next)
247 ( InstrBranchable repr
249 ) => CombMatchable (Program repr inp) where
250 conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
251 bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
252 a =<< liftM (choicesBranch (prodCode Functor.<$> ps) bs') (d next)
254 ( tok ~ InputToken inp
255 , InstrReadable tok repr
257 ) => CombSatisfiable tok (Program repr inp) where
258 satisfyOrFail fs p = Program $ return . read fs (prodCode p)
260 ( InstrBranchable repr
263 ) => CombSelectable (Program repr inp) where
264 branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
265 lr =<< liftM2 caseBranch
266 (l (swapValue (applyValue next)))
267 (r (swapValue (applyValue next)))