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