]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Program.hs
machine: fix recursion ending
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Program.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE TupleSections #-}
3 {-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
4 -- | Build the 'Instr'uction 'Program' of a 'Machine'
5 -- from the 'Comb'inators of a 'Grammar'.
6 -- 'Instr'uctions are kept introspectable
7 -- to enable more optimizations made possible now because
8 -- of a broader knowledge of the 'Instr'uctions around
9 -- those generated (see for instance 'joinNext').
10 module Symantic.Parser.Machine.Program where
11
12 import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
13 import Data.Function (($))
14 import System.IO (IO)
15 import Type.Reflection (Typeable)
16 import Control.DeepSeq (NFData)
17 import Data.Bool (Bool(..))
18 import Data.Eq (Eq)
19 import Data.Function ((.))
20 import Data.Ord (Ord)
21 import Text.Show (Show(..))
22 import qualified Data.Functor as Functor
23 import qualified Data.Set as Set
24 import qualified Data.Traversable as Traversable
25 import qualified Language.Haskell.TH as TH
26 import qualified Language.Haskell.TH.Syntax as TH
27 import qualified Symantic.Lang as Prod
28
29 import Symantic.Derive
30 import Symantic.Parser.Grammar
31 import Symantic.Parser.Machine.Input
32 import Symantic.Parser.Machine.Instructions
33 import Symantic.Parser.Machine.Optimize
34
35 -- * Type 'Program'
36 -- | A 'Program' is a tree of 'Instr'uctions,
37 -- where each 'Instr'uction is built by a continuation
38 -- to be able to introspect, duplicate and/or change
39 -- the next 'Instr'uction.
40 data Program repr inp a = Program { unProgram ::
41 forall vs ret.
42 -- This is the next instruction.
43 SomeInstr repr inp (a ': vs) ret ->
44 -- This is the current instruction
45 -- IO is needed for 'TH.newName'.
46 IO (SomeInstr repr inp vs ret)
47 }
48
49 -- | Build an interpreter of the 'Program' of the given 'Machinable'.
50 optimizeMachine ::
51 forall inp repr a.
52 Machinable (InputToken inp) repr =>
53 Program repr inp a ->
54 IO (repr inp '[] a)
55 optimizeMachine (Program f) = derive Functor.<$> f @'[] ret
56
57 -- * Class 'Machinable'
58 -- | All the 'Instr'uctions.
59 type Machinable tok repr =
60 ( InstrBranchable repr
61 , InstrExceptionable repr
62 , InstrInputable repr
63 , InstrJoinable repr
64 , InstrCallable repr
65 , InstrValuable repr
66 , InstrReadable tok repr
67 , InstrIterable repr
68 , InstrRegisterable repr
69 , Eq tok
70 , Ord tok
71 , TH.Lift tok
72 , NFData tok
73 , Show tok
74 , Typeable tok
75 )
76
77 instance
78 ( Cursorable (Cursor inp)
79 , InstrBranchable repr
80 , InstrExceptionable repr
81 , InstrInputable repr
82 , InstrJoinable repr
83 , InstrValuable repr
84 ) => CombAlternable (Program repr inp) where
85 alt exn (Program l) (Program r) = joinNext $ Program $ \next ->
86 liftM2 (catch exn)
87 (l (commit exn next))
88 (raiseAgainIfConsumed exn Functor.<$> r next)
89 throw exn = Program $ \_next -> return $ raise exn
90 failure flr = Program $ \_next -> return $ fail (Set.singleton flr)
91 empty = Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEmpty))
92 try (Program x) = Program $ \next ->
93 liftM2 (catch ExceptionFailure)
94 (x (commit ExceptionFailure next))
95 -- On exception, reset the input, and propagate the failure.
96 (return $ loadInput $ fail Set.empty)
97
98 -- | @(raiseAgainIfConsumed exn ok)@
99 -- compares the stacked input position with the current one,
100 -- in case they're the same then continue with @(ok)@,
101 -- otherwise, re-'raise' @(exn)@,
102 -- without updating the farthest error
103 -- (which is usually done when 'fail'ing).
104 raiseAgainIfConsumed ::
105 Cursorable (Cursor inp) =>
106 InstrBranchable repr =>
107 InstrExceptionable repr =>
108 InstrInputable repr =>
109 InstrValuable repr =>
110 Exception ->
111 SomeInstr repr inp vs ret ->
112 SomeInstr repr inp (Cursor inp ': vs) ret
113 raiseAgainIfConsumed exn ok =
114 pushInput $
115 lift2Value (splice sameOffset) $
116 ifBranch ok $
117 case exn of
118 ExceptionLabel lbl -> raise lbl
119 ExceptionFailure -> fail Set.empty
120
121 -- | @('joinNext' m)@ factorize the next 'Instr'uction
122 -- to be able to reuse it multiple times without duplication.
123 -- It does so by introducing a 'defJoin'
124 -- and passing the corresponding 'refJoin'
125 -- as next 'Instr'uction to @(m)@,
126 -- unless factorizing is useless because the next 'Instr'uction
127 -- is already a 'refJoin' or a 'ret'.
128 -- It should be used each time the next 'Instr'uction
129 -- is used multiple times.
130 joinNext ::
131 InstrJoinable repr =>
132 Program repr inp v ->
133 Program repr inp v
134 joinNext (Program m) = Program $ \case
135 -- Double refJoin Optimization:
136 -- If a join-node points directly to another join-node,
137 -- then reuse it
138 next@(Instr RefJoin{}) -> m next
139 -- If a join-node points directly to a 'jump',
140 -- then reuse it.
141 -- Because 'Jump' expects an empty 'valueStack',
142 -- a 'PopValue' has to be here to drop
143 -- the value normaly expected by the 'next' 'Instr'uction.
144 next@(Instr (PopValue (Instr Jump{}))) -> m next
145 -- Terminal refJoin Optimization:
146 -- If a join-node points directly to a terminal operation,
147 -- then it's useless to introduce a join-node.
148 next@(Instr Ret{}) -> m next
149 -- Introduce a join-node.
150 next -> do
151 !joinName <- TH.newName "join"
152 defJoin (LetName joinName) next
153 Functor.<$> m (refJoin (LetName joinName))
154
155 instance
156 InstrValuable repr =>
157 CombApplicable (Program repr inp) where
158 pure x = Program $ return . pushValue (prodCode x)
159 Program f <*> Program x = Program $ (f <=< x) . applyValue
160 liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (prodCode f)
161 Program x *> Program y = Program (x <=< return . popValue <=< y)
162 Program x <* Program y = Program (x <=< y <=< return . popValue)
163 instance
164 ( Cursorable (Cursor inp)
165 , InstrBranchable repr
166 , InstrCallable repr
167 , InstrExceptionable repr
168 , InstrInputable repr
169 , InstrIterable repr
170 , InstrJoinable repr
171 , InstrRegisterable repr
172 , InstrValuable repr
173 ) => CombFoldable (Program repr inp) where
174 chainPre (Program op) (Program done) =
175 new (pure Prod.id) $ \(Register r) -> Program $ \next -> do
176 !loopName <- TH.newName "loop"
177 liftM2 (iter (LetName loopName))
178 (op $
179 mapValue (Prod.flip Prod..@ (Prod..)) $
180 modifyRegister r $
181 jump True (LetName loopName) )
182 (raiseAgainIfConsumed ExceptionFailure .
183 readRegister r Functor.<$>
184 (done (applyValue next)))
185 chainPost (Program done) (Program op) =
186 new (pure Prod.id) $ \(Register r) -> Program $ \next -> do
187 !loopName <- TH.newName "loop"
188 liftM2 (iter (LetName loopName))
189 (op $
190 modifyRegister (UnscopedRegister (unUnscopedRegister r)) $
191 jump True (LetName loopName) )
192 (raiseAgainIfConsumed ExceptionFailure .
193 readRegister r Functor.<$>
194 (done (applyValue next)))
195 instance
196 InstrCallable repr =>
197 Referenceable TH.Name (Program repr inp) where
198 -- TODO: isRec should be passed to 'call' and 'jump'
199 -- instead of redoing the work with 'CallTrace'.
200 ref isRec name = Program $ \case
201 -- Tail Call Optimization:
202 -- returning just after a 'call' is useless:
203 -- using 'jump' lets the 'ret' of the 'defLet'
204 -- directly return where it would in two 'ret's.
205 Instr Ret{} -> return $ jump isRec (LetName name)
206 next -> return $ call isRec (LetName name) next
207 {-
208 refable n (Program sub) = Program $ \next -> do
209 sub' <- sub ret
210 return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
211 -}
212 instance
213 InstrCallable repr =>
214 Letsable TH.Name (Program repr inp) where
215 lets defs (Program body) = Program $ \next -> do
216 -- Every definition becomes a 'call'able subroutine.
217 defs' <- Traversable.traverse
218 (\(SomeLet (Program val)) -> liftM SomeLet (val ret))
219 defs
220 liftM (defLet defs') (body next)
221 instance
222 ( Eq (InputToken inp)
223 , Cursorable (Cursor inp)
224 , InstrBranchable repr
225 , InstrExceptionable repr
226 , InstrInputable repr
227 , InstrJoinable repr
228 , InstrReadable (InputToken inp) repr
229 , Typeable (InputToken inp)
230 , InstrValuable repr
231 ) => CombLookable (Program repr inp) where
232 look (Program x) = Program $ \next ->
233 liftM pushInput (x (swapValue (loadInput next)))
234 eof = negLook (satisfy (Prod.const Prod..@ Prod.bool True))
235 -- This sets a better failure message
236 <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
237 negLook (Program x) = Program $ \next ->
238 liftM2 (catch ExceptionFailure)
239 -- On x success, discard the result,
240 -- and replace this 'Catcher' by a failure whose 'farthestExpecting' is negated,
241 -- then a failure is raised from the input
242 -- when entering 'negLook', to avoid odd cases:
243 -- - where the failure that made (negLook x)
244 -- succeed can get the blame for the overall
245 -- failure of the grammar.
246 -- - where the overall failure of
247 -- the grammar might be blamed on something in x
248 -- that, if corrected, still makes x succeed
249 -- and (negLook x) fail.
250 (liftM pushInput $ x $
251 popValue $ commit ExceptionFailure $
252 loadInput $ fail Set.empty)
253 -- On x failure, reset the input,
254 -- and go on with the next 'Instr'uctions.
255 (return $ loadInput $ pushValue Prod.unit next)
256 instance
257 ( InstrBranchable repr
258 , InstrJoinable repr
259 ) => CombMatchable (Program repr inp) where
260 conditional (Program a) bs (Program d) = joinNext $ Program $ \next -> do
261 bs' <- Control.Monad.sequence $ (\(p, b) -> (prodCode p,) Functor.<$> unProgram b next) Functor.<$> bs
262 a =<< liftM (choicesBranch bs') (d next)
263 instance
264 ( tok ~ InputToken inp
265 , InstrReadable tok repr
266 , Typeable tok
267 ) => CombSatisfiable tok (Program repr inp) where
268 -- Note: 'read' is left with the responsability
269 -- to apply 'normalOrderReduction' if need be.
270 satisfyOrFail fs p = Program $ return . read fs (prodCode p)
271 instance
272 ( InstrBranchable repr
273 , InstrJoinable repr
274 , InstrValuable repr
275 ) => CombSelectable (Program repr inp) where
276 branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
277 lr =<< liftM2 caseBranch
278 (l (swapValue (applyValue next)))
279 (r (swapValue (applyValue next)))
280 instance
281 ( InstrValuable repr
282 , InstrRegisterable repr
283 ) => CombRegisterable (Program repr inp) where
284 new (Program p) k = Program $ \next -> do
285 !regName <- TH.newName "reg"
286 p =<< liftM (newRegister (UnscopedRegister regName))
287 (unProgram (k (Register (UnscopedRegister regName))) next)
288 get (Register r) = Program $ \next ->
289 return $ readRegister r next
290 put (Register r) (Program k) = Program $ \next ->
291 k $ writeRegister r $ pushValue Prod.unit next
292 instance
293 ( InstrValuable repr
294 , InstrRegisterable repr
295 ) => CombRegisterableUnscoped (Program repr inp) where
296 newUnscoped r (Program p) k = Program $ \next ->
297 p =<< liftM (newRegister r) (unProgram k next)
298 getUnscoped r = Program $ return . readRegister r
299 putUnscoped r (Program k) = Program $
300 k . writeRegister r . pushValue Prod.unit