]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Generate.hs
!fixup impl: move `liftTypedString` to `Language.Haskell.TH.Show`
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Generate.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
3 {-# LANGUAGE DeriveGeneric #-} -- For NFData instances
4 {-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
5 {-# LANGUAGE ConstraintKinds #-} -- For Dict
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TupleSections #-}
8 {-# LANGUAGE MagicHash #-}
9 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
10 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 module Symantic.Parser.Machine.Generate where
13
14 import Control.DeepSeq (NFData(..))
15 import Control.Monad (Monad(..))
16 import Control.Monad.ST (ST, RealWorld)
17 import Data.Bool (Bool(..), otherwise)
18 import Data.Char (Char)
19 import Data.Either (Either(..))
20 import Data.Eq (Eq(..))
21 import Data.Foldable (foldr, toList, null)
22 import Data.Function (($), (.), on)
23 import Data.Functor ((<$>))
24 import Data.Int (Int)
25 import Data.List.NonEmpty (NonEmpty(..))
26 import Data.Map (Map)
27 import Data.Maybe (Maybe(..))
28 import Data.Ord (Ord(..), Ordering(..))
29 import Data.Proxy (Proxy(..))
30 import Data.Semigroup (Semigroup(..))
31 import Data.Set (Set)
32 import Data.String (String)
33 import Data.Traversable (Traversable(..))
34 import Data.Tuple (snd)
35 import Data.Typeable (Typeable)
36 import Data.Word (Word8)
37 import GHC.Generics (Generic)
38 import GHC.Show (showCommaSpace)
39 import Language.Haskell.TH (CodeQ)
40 import Prelude ((+), (-), error)
41 import Text.Show (Show(..), showParen, showString)
42 import qualified Data.HashMap.Strict as HM
43 import qualified Data.List as List
44 import qualified Data.List.NonEmpty as NE
45 import qualified Data.Map.Internal as Map_
46 import qualified Data.Map.Strict as Map
47 import qualified Data.Set as Set
48 import qualified Data.Set.Internal as Set_
49 import qualified Data.STRef as ST
50 import qualified Language.Haskell.TH as TH
51 import qualified Language.Haskell.TH.Syntax as TH
52
53 import qualified Symantic.Semantics.Data as Sym
54 import Symantic.Syntaxes.Derive
55 import Symantic.Semantics.SharingObserver
56 import qualified Symantic.Parser.Grammar as Gram
57 import Symantic.Parser.Grammar.Combinators
58 ( UnscopedRegister(..)
59 , Exception(..)
60 , Failure(..)
61 , SomeFailure(..)
62 , unSomeFailure
63 , inputTokenProxy
64 )
65 import Symantic.Parser.Machine.Input
66 import Symantic.Parser.Machine.Instructions
67 import qualified Language.Haskell.TH.HideName as TH
68 import qualified Symantic.Syntaxes.Classes as Prod
69 import qualified Symantic.Semantics.Data as Prod
70
71 --import Debug.Trace
72
73 -- | Convenient utility to generate some final 'TH.CodeQ'.
74 genCode :: Splice a -> CodeQ a
75 genCode = derive . Prod.normalOrderReduction
76
77 -- * Type 'Gen'
78 -- | Generate the 'CodeQ' parsing the input.
79 data Gen inp vs a = Gen
80 { genAnalysisByLet :: OpenRecs TH.Name GenAnalysis
81 -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
82 , genAnalysis :: OpenRec TH.Name GenAnalysis
83 -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
84 , unGen ::
85 GenCtx inp vs a ->
86 CodeQ (ST RealWorld (Result inp a))
87 }
88
89 {-# INLINE returnST #-}
90 returnST :: forall s a. a -> ST s a
91 returnST = return @(ST s)
92
93 -- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
94 -- parsing the given input according to the given 'Machine'.
95 generateCode ::
96 -- Not really used constraints,
97 -- just to please 'checkHorizon'.
98 Ord (InputToken inp) =>
99 Show (InputToken inp) =>
100 TH.Lift (InputToken inp) =>
101 NFData (InputToken inp) =>
102 Typeable (InputToken inp) =>
103 Inputable inp =>
104 Show (InputPosition inp) =>
105 Gen inp '[] a ->
106 CodeQ (inp -> ST RealWorld (Result inp a))
107 generateCode gen =
108 let Gen{unGen=k, ..} = checkHorizon gen in
109 [|| \(input :: inp) ->
110 -- Pattern bindings containing unlifted types
111 -- should use an outermost bang pattern.
112 let !(# initBuffer, initPos, readMore, readNext, append #) = $$(cursorOf [||input||])
113 finalRet = \_farInp _farExp v _inp _buf _end -> returnST $ ResultDone v
114 finalRaise :: ForallOnException inp -- forall b. (OnException inp b)
115 = ForallOnException $ \ !exn _failInp !farInp !farExp buf end ->
116 returnST $ ResultError ParsingError
117 { parsingErrorOffset = position farInp
118 , parsingErrorException = exn
119 , parsingErrorUnexpected =
120 if readMore buf farInp
121 then Just (let (# c, _ #) = readNext buf farInp in c)
122 else Nothing
123 , parsingErrorExpecting =
124 let (minHoriz, res) =
125 Set.foldr (\f (minH, acc) ->
126 case unSomeFailure f of
127 Just (FailureHorizon h :: Failure (Gram.CombSatisfiable (InputToken inp)))
128 | Just old <- minH -> (Just (min old h), acc)
129 | otherwise -> (Just h, acc)
130 _ -> (minH, f:acc)
131 ) (Nothing, []) farExp in
132 Set.fromList $ case minHoriz of
133 Just h -> SomeFailure (FailureHorizon @(InputToken inp) h) : res
134 Nothing -> res
135 }
136 in $$(
137 let
138 -- | Defines 'inputTokenProxy' so that the TemplateHaskell code
139 -- can refer to @(InputToken inp)@ through it.
140 defInputTokenProxy :: TH.CodeQ a -> TH.CodeQ a
141 defInputTokenProxy exprCode =
142 TH.unsafeCodeCoerce [|
143 let $(return (TH.VarP inputTokenProxy)) = Proxy :: Proxy (InputToken inp) in
144 $(TH.unTypeQ (TH.examineCode exprCode))
145 |]
146 in
147 defInputTokenProxy $
148 k GenCtx
149 { valueStack = ValueStackEmpty
150 , onExceptionStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (OnException inp a)))
151 , defaultCatch = [||unForallOnException finalRaise||]
152 , onReturn = [||finalRet||] :: CodeQ (OnReturn inp a a)
153 , input = [||initPos||]
154 , inputBuffer = [||initBuffer||]
155 , inputEnded = [||False||]
156 , nextInput = [||readNext||]
157 , moreInput = [||readMore||]
158 , appendInput = [||append||]
159 -- , farthestError = [||Nothing||]
160 , farthestInput = [||initPos||]
161 , farthestExpecting = [||Set.empty||]
162 , checkedHorizon = 0
163 , analysisByLet = mutualFix genAnalysisByLet
164 }
165 )
166 ||]
167
168 -- ** Type 'ParsingError'
169 data ParsingError inp
170 = ParsingError
171 { parsingErrorOffset :: Offset
172 , parsingErrorException :: Exception
173 -- | Note: if a 'FailureHorizon' greater than 1
174 -- is amongst the 'parsingErrorExpecting'
175 -- then 'parsingErrorUnexpected' is only the 'InputToken'
176 -- at the begining of the expected 'Horizon'.
177 , parsingErrorUnexpected :: Maybe (InputToken inp)
178 , parsingErrorExpecting :: Set SomeFailure
179 } deriving (Generic)
180 deriving instance NFData (InputToken inp) => NFData (ParsingError inp)
181 --deriving instance Show (InputToken inp) => Show (ParsingError inp)
182 instance Show (InputToken inp) => Show (ParsingError inp) where
183 showsPrec p ParsingError{..} =
184 showParen (p >= 11) $
185 showString "ParsingErrorStandard {" .
186 showString "parsingErrorOffset = " .
187 showsPrec 0 parsingErrorOffset .
188 showCommaSpace .
189 showString "parsingErrorException = " .
190 showsPrec 0 parsingErrorException .
191 showCommaSpace .
192 showString "parsingErrorUnexpected = " .
193 showsPrec 0 parsingErrorUnexpected .
194 showCommaSpace .
195 showString "parsingErrorExpecting = fromList " .
196 showsPrec 0 (
197 -- Sort on the string representation
198 -- because the 'Ord' of the 'SomeFailure'
199 -- is based upon hashes ('typeRepFingerprint')
200 -- depending on packages' ABI and whether
201 -- cabal-install's setup is --inplace or not,
202 -- and that would be too unstable for golden tests.
203 List.sortBy (compare `on` show) $
204 Set.toList parsingErrorExpecting
205 ) .
206 showString "}"
207
208 -- ** Type 'ErrorLabel'
209 type ErrorLabel = String
210
211 -- * Type 'GenAnalysis'
212 data GenAnalysis = GenAnalysis
213 { minReads :: Horizon
214 -- ^ The minimun number of input tokens to read
215 -- on the current 'input' to reach a success.
216 , mayRaise :: Map Exception ()
217 -- ^ The 'Exception's that may be raised depending on the 'input'.
218 , alwaysRaise :: Set Exception
219 -- ^ The 'Exception's raised whatever is or happen to the 'input'.
220 , freeRegs :: Set TH.Name
221 -- ^ The free registers that are used.
222 } deriving (Show)
223
224 -- ** Type 'Offset'
225 type Offset = Int
226 -- ** Type 'Horizon'
227 -- | Minimal input length required for a successful parsing.
228 type Horizon = Offset
229
230 -- | Merge given 'GenAnalysis' as sequences.
231 seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
232 seqGenAnalysis aas@(a:|as) = GenAnalysis
233 { minReads = List.foldl' (\acc -> (acc +) . minReads) (minReads a) as
234 , mayRaise = sconcat (mayRaise <$> aas)
235 , alwaysRaise = sconcat (alwaysRaise <$> aas)
236 , freeRegs = sconcat (freeRegs <$> aas)
237 }
238 -- | Merge given 'GenAnalysis' as alternatives.
239 altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
240 altGenAnalysis aas = GenAnalysis
241 { minReads =
242 case
243 (`NE.filter` aas) $ \a ->
244 -- If an alternative 'alwaysRaise's 'ExceptionFailure' whatever its 'input' is,
245 -- it __should__ remain semantically the same (up to the exact 'Failure's)
246 -- to raise an 'ExceptionFailure' even before knowing
247 -- whether that alternative branch will be taken or not,
248 -- hence an upstream 'checkHorizon' is allowed to raise an 'ExceptionFailure'
249 -- based only upon the 'minReads' of such alternatives:
250 Set.toList (alwaysRaise a) /= [ExceptionFailure]
251 of
252 [] -> 0
253 a:as -> List.foldl' (\acc -> min acc . minReads) (minReads a) as
254 , mayRaise = sconcat (mayRaise <$> aas)
255 , alwaysRaise = foldr Set.intersection Set.empty (alwaysRaise <$> aas)
256 , freeRegs = sconcat (freeRegs <$> aas)
257 }
258
259
260
261 {-
262 -- *** Type 'FarthestError'
263 data FarthestError inp = FarthestError
264 { farthestInput :: InputPosition inp
265 , farthestExpecting :: [Failure (InputToken inp)]
266 }
267 -}
268
269 -- ** Type 'ForallOnException'
270 newtype ForallOnException inp = ForallOnException {
271 unForallOnException :: forall b. OnException inp b
272 }
273
274 -- ** Type 'GenCtx'
275 -- | This is an inherited (top-down) context
276 -- only present at compile-time, to build TemplateHaskell splices.
277 data GenCtx inp vs a =
278 ( Inputable inp -- for partialCont
279 -- For checkHorizon
280 , TH.Lift (InputToken inp)
281 , Show (InputToken inp)
282 , Eq (InputToken inp)
283 , Ord (InputToken inp)
284 , Typeable (InputToken inp)
285 , NFData (InputToken inp)
286 ) => GenCtx
287 { valueStack :: ValueStack vs
288 , onExceptionStackByLabel :: Map Exception (NonEmpty (CodeQ (OnException inp a)))
289 -- | Default 'OnException' defined at the begining of the generated 'CodeQ',
290 -- hence a constant within the 'Gen'eration.
291 , defaultCatch :: forall b. CodeQ (OnException inp b)
292 , onReturn :: CodeQ (OnReturn inp a a)
293 , inputBuffer :: CodeQ (InputBuffer inp)
294 , inputEnded :: CodeQ Bool
295 , input :: CodeQ (InputPosition inp)
296 , moreInput :: CodeQ (InputBuffer inp -> InputPosition inp -> Bool)
297 , nextInput :: CodeQ (InputBuffer inp -> InputPosition inp -> (# InputToken inp, InputPosition inp #))
298 , appendInput :: CodeQ (InputBuffer inp -> inp -> InputBuffer inp)
299 , farthestInput :: CodeQ (InputPosition inp)
300 , farthestExpecting :: CodeQ (Set SomeFailure)
301 -- | Remaining horizon already checked.
302 -- Use to factorize 'input' length checks,
303 -- instead of checking the 'input' length
304 -- one 'InputToken' at a time at each 'read'.
305 -- Updated by 'checkHorizon'
306 -- and reset elsewhere when needed.
307 , checkedHorizon :: Horizon
308 -- | Output of 'mutualFix'.
309 , analysisByLet :: LetRecs TH.Name GenAnalysis
310 }
311
312 -- ** Type 'ValueStack'
313 data ValueStack vs where
314 ValueStackEmpty :: ValueStack '[]
315 ValueStackCons ::
316 { valueStackHead :: Splice v
317 , valueStackTail :: ValueStack vs
318 } -> ValueStack (v ': vs)
319
320 instance InstrComment Gen where
321 comment msg k = k
322 { unGen = \ctx -> {-trace "unGen.comment" $-}
323 [||
324 let _ = $$(TH.liftTypedString $ "comment: "<>msg) in
325 $$(unGen k ctx)
326 ||]
327 }
328 instance InstrValuable Gen where
329 pushValue x k = k
330 { unGen = \ctx -> {-trace "unGen.pushValue" $-}
331 [||
332 let _ = "pushValue" in
333 $$(unGen k ctx
334 { valueStack = ValueStackCons x (valueStack ctx) })
335 ||]
336 }
337 popValue k = k
338 { unGen = \ctx -> {-trace "unGen.popValue" $-}
339 [||
340 let _ = "popValue" in
341 $$(unGen k ctx
342 { valueStack = valueStackTail (valueStack ctx) })
343 ||]
344 }
345 lift2Value f k = k
346 { unGen = \ctx -> {-trace "unGen.lift2Value" $-}
347 [||
348 let _ = $$(TH.liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in
349 $$(unGen k ctx
350 { valueStack =
351 let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
352 ValueStackCons (f Prod..@ x Prod..@ y) vs
353 })
354 ||]
355 }
356 swapValue k = k
357 { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
358 { valueStack =
359 let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
360 ValueStackCons x (ValueStackCons y vs)
361 }
362 }
363 instance InstrBranchable Gen where
364 caseBranch kx ky = Gen
365 { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
366 , genAnalysis = \final -> altGenAnalysis $
367 genAnalysis kx final :|
368 [genAnalysis ky final]
369 , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
370 let ValueStackCons v vs = valueStack ctx in
371 [||
372 case $$(genCode v) of
373 Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
374 Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
375 ||]
376 }
377 choicesBranch bs default_ = Gen
378 { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
379 , genAnalysis = \final -> altGenAnalysis $
380 (\k -> genAnalysis k final)
381 <$> (default_:|(snd <$> bs))
382 , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
383 let ValueStackCons v vs = valueStack ctx0 in
384 let ctx = ctx0{valueStack = vs} in
385 let
386 go x ((p,b):bs') = [||
387 if $$(genCode (p Prod..@ x))
388 then
389 let _ = $$(TH.liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in
390 $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
391 else
392 let _ = "choicesBranch.else" in
393 $$(go x bs')
394 ||]
395 go _ _ = unGen default_ ctx
396 in go v bs
397 }
398 instance InstrExceptionable Gen where
399 raise exn = Gen
400 { genAnalysisByLet = HM.empty
401 , genAnalysis = \_final -> GenAnalysis
402 { minReads = 0
403 , mayRaise = Map.singleton (ExceptionLabel exn) ()
404 , alwaysRaise = Set.singleton (ExceptionLabel exn)
405 , freeRegs = Set.empty
406 }
407 , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
408 $$(raiseException ctx (ExceptionLabel exn))
409 (ExceptionLabel $$(TH.liftTyped exn))
410 {-failInp-}$$(input ctx)
411 {-farFail-}(Just $$(input ctx))
412 {-farExp-}[]
413 $$(inputBuffer ctx)
414 $$(inputEnded ctx)
415 ||]
416 }
417 fail failMode = Gen
418 { genAnalysisByLet = HM.empty
419 , genAnalysis = \_final -> GenAnalysis
420 { minReads = 0
421 , mayRaise = Map.singleton ExceptionFailure ()
422 , alwaysRaise = Set.singleton ExceptionFailure
423 , freeRegs = Set.empty
424 }
425 , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
426 case failMode of
427 FailModePreserve -> [|| -- Raise without updating the farthest error.
428 $$(raiseException ctx ExceptionFailure)
429 ExceptionFailure
430 {-failInp-}$$(input ctx)
431 $$(farthestFailure ctx)
432 $$(farthestExpecting ctx)
433 $$(inputBuffer ctx)
434 $$(inputEnded ctx)
435 ||]
436 FailModeNewFailure someFail -> raiseFailure ctx {-someFail-}someFail
437 }
438 commit exn k = k
439 { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
440 [||
441 let _ = $$(TH.liftTypedString ("commit "<>show exn)) in
442 $$(unGen k ctx{onExceptionStackByLabel =
443 Map.update (\case
444 _r0:|(r1:rs) -> Just (r1:|rs)
445 _ -> Nothing
446 )
447 exn (onExceptionStackByLabel ctx)
448 })
449 ||]
450 }
451 catch exn k onExn = Gen
452 { genAnalysisByLet = genAnalysisByLet k <> genAnalysisByLet onExn
453 , genAnalysis = \final ->
454 let kAnalysis = genAnalysis k final in
455 let onExnAnalysis = genAnalysis onExn final in
456 altGenAnalysis $
457 kAnalysis
458 { mayRaise = Map.delete exn (mayRaise kAnalysis)
459 , alwaysRaise = Set.delete exn (alwaysRaise kAnalysis)
460 } :|
461 [ onExnAnalysis ]
462 , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
463 let _ = $$(TH.liftTypedString ("catch "<>show exn<>" checkedHorizon="<>show (checkedHorizon ctx))) in
464 let onException = $$(onExceptionCode (input ctx) (checkedHorizon ctx) onExn ctx) in
465 $$(unGen k ctx
466 { onExceptionStackByLabel =
467 Map.insertWith (<>) exn
468 (NE.singleton [||onException||])
469 (onExceptionStackByLabel ctx)
470 }
471 ) ||]
472 }
473 -- ** Class 'SpliceInputable'
474 -- | Record an 'input' and a 'checkedHorizon' together
475 -- to be able to put both of them on the 'valueStack',
476 -- and having them moved together by operations
477 -- on the 'valueStack' (eg. 'lift2Value').
478 -- Used by 'saveInput' and 'loadInput'.
479 class SpliceInputable repr where
480 inputSave :: CodeQ inp -> Horizon -> repr inp
481 data instance Sym.Data SpliceInputable repr a where
482 InputSave :: CodeQ inp -> Horizon -> Sym.Data SpliceInputable repr inp
483 instance SpliceInputable (Sym.Data SpliceInputable repr) where
484 inputSave = InputSave
485 instance SpliceInputable repr => SpliceInputable (Sym.SomeData repr) where
486 inputSave inp = Sym.SomeData . InputSave inp
487 instance SpliceInputable TH.CodeQ where
488 inputSave inp _hor = inp
489 instance SpliceInputable repr => Derivable (Sym.Data SpliceInputable repr) where
490 derive = \case
491 InputSave inp hor -> inputSave inp hor
492 instance InstrInputable Gen where
493 saveInput k = k
494 { unGen = \ctx ->
495 {-trace "unGen.saveInput" $-}
496 [||
497 let _ = $$(TH.liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in
498 $$(unGen k ctx
499 { valueStack = inputSave (input ctx) (checkedHorizon ctx) `ValueStackCons` valueStack ctx
500 })
501 ||]
502 }
503 loadInput k = k
504 { unGen = \ctx@GenCtx{} ->
505 {-trace "unGen.loadInput" $-}
506 let ValueStackCons v vs = valueStack ctx in
507 let (input, checkedHorizon) = case v of
508 Sym.Data (InputSave i h) -> (i, h)
509 -- This case should never happen if 'saveInput' is used.
510 i -> (genCode i, 0) in
511 [||
512 let _ = $$(TH.liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in
513 $$(unGen (checkHorizon k) ctx
514 { valueStack = vs
515 , input
516 , checkedHorizon
517 })
518 ||]
519 , genAnalysis = \final ->
520 let analysis = genAnalysis k final in
521 -- The input is reset and thus any previous 'checkHorizon'
522 -- cannot check after this 'loadInput'.
523 analysis{minReads = 0}
524 }
525 instance InstrCallable Gen where
526 defLet defs k = k
527 { unGen = \ctx@GenCtx{} ->
528 {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
529 TH.unsafeCodeCoerce $ do
530 decls <- traverse (makeDecl ctx) (HM.toList defs)
531 body <- TH.unTypeQ $ TH.examineCode $
532 {-trace "unGen.defLet.body" $-}
533 unGen k ctx
534 return $ TH.LetE (
535 -- | Use 'List.sortBy' to output more deterministic code
536 -- to be able to golden test it, at the cost of more computations
537 -- (at compile-time only though).
538 List.sortBy (compare `on` TH.hideName) $
539 toList decls
540 ) body
541 , genAnalysisByLet =
542 HM.unions
543 $ genAnalysisByLet k
544 : ((\(SomeLet sub) -> genAnalysis sub) <$> defs)
545 : ((\(SomeLet sub) -> genAnalysisByLet sub) <$> HM.elems defs)
546 }
547 where
548 makeDecl ctx (subName, SomeLet sub) = do
549 let subAnalysis = analysisByLet ctx HM.! subName
550 body <- takeFreeRegs (freeRegs subAnalysis) $
551 TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
552 -- Called by 'call' or 'jump'.
553 \ !callerOnReturn{- From onReturnCode -}
554 !callerInput
555 !callerBuffer
556 !callerEnd
557 !callerOnExceptionStackByLabel{- from the 'call'er's 'onExceptionStackByLabel' -} ->
558 $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
559 { valueStack = ValueStackEmpty
560 -- Build an 'onExceptionStackByLabel' for the 'mayRaise' exceptions of the subroutine,
561 -- where each 'OnException' calls the one passed
562 -- by the 'call'er (in 'callerOnExceptionStackByLabel').
563 --
564 -- Note that as it currently is, the 'call'er is not required
565 -- to supply an 'OnException' stack for all the 'mayRaise' exceptions of the subroutine,
566 -- because 'Map.findWithDefault' is used instead of 'Map.!'.
567 , onExceptionStackByLabel = Map.mapWithKey
568 (\lbl () -> NE.singleton [||
569 Map.findWithDefault $$(defaultCatch ctx) lbl callerOnExceptionStackByLabel
570 ||])
571 ({-trace ("mayRaise: "<>show subName) $ -}mayRaise subAnalysis)
572 , input = [||callerInput||]
573 , inputBuffer = [||callerBuffer||]
574 , inputEnded = [||callerEnd||]
575 , onReturn = {-trace ("unGen.defLet.sub.onReturn: "<>show subName) $-} [||callerOnReturn||]
576
577 -- These are passed by the caller via 'callerOnReturn' or 'ko'
578 -- , farthestInput =
579 -- , farthestExpecting =
580
581 -- Some callers can call this declaration
582 -- with zero 'checkedHorizon', hence use this minimum.
583 -- TODO: maybe it could be improved a bit
584 -- by taking the minimum of the checked horizons
585 -- before all the 'call's and 'jump's to this declaration.
586 , checkedHorizon = 0
587 })
588 ||]
589 let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []]
590 return decl
591 jump isRec (LetName subName) = Gen
592 { genAnalysisByLet = HM.empty
593 , genAnalysis = \final ->
594 if isRec
595 then GenAnalysis
596 { minReads = 0
597 , mayRaise = Map.empty
598 , alwaysRaise = Set.empty
599 , freeRegs = Set.empty
600 }
601 else final HM.! subName
602 , unGen = \ctx -> {-trace ("unGen.jump: "<>show subName) $-}
603 let subAnalysis = analysisByLet ctx HM.! subName in
604 [||
605 let _ = "jump" in
606 $$(TH.unsafeCodeCoerce $
607 giveFreeRegs (freeRegs subAnalysis) $
608 return (TH.VarE subName))
609 {-ok-}$$(onReturn ctx)
610 $$(input ctx)
611 $$(inputBuffer ctx)
612 $$(inputEnded ctx)
613 $$(liftTypedRaiseByLabel $
614 onExceptionStackByLabel ctx
615 -- Pass only the labels raised by the 'defLet'.
616 `Map.intersection`
617 (mayRaise subAnalysis)
618 )
619 ||]
620 }
621 call isRec (LetName subName) k = k
622 { genAnalysis = \final ->
623 if isRec
624 then GenAnalysis
625 { minReads = 0
626 -- Assume 'checkToken' is used, otherwise it would loop
627 , mayRaise = Map.singleton ExceptionFailure ()
628 , alwaysRaise = Set.empty
629 , freeRegs = Set.empty
630 }
631 else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ]
632 , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx ->
633 let ks = Map.keys (onExceptionStackByLabel ctx) in
634 let subAnalysis = analysisByLet ctx HM.! subName in
635 [||
636 let _ = $$(TH.liftTypedString $ "call mayRaise("<>show subName<>")="<>show (Map.keys (mayRaise subAnalysis)) <> " onExceptionStackByLabel="<> show ks) in
637 $$(TH.unsafeCodeCoerce $
638 giveFreeRegs (freeRegs subAnalysis) $
639 return (TH.VarE subName))
640 -- TODO: more readable in a let binding
641 {-ok-}$$(onReturnCode k ctx)
642 $$(input ctx)
643 $$(inputBuffer ctx)
644 $$(inputEnded ctx)
645 $$(liftTypedRaiseByLabel $
646 -- FIXME: maybe it should rather pass all the 'mayRaise' of 'subName'
647 -- and 'defaultCatch' be removed from 'makeDecl''s 'onExceptionStackByLabel'.
648 onExceptionStackByLabel ctx
649 -- Pass only the labels raised by the 'defLet'.
650 `Map.intersection`
651 (mayRaise subAnalysis)
652 )
653 ||]
654 }
655 ret = Gen
656 { genAnalysisByLet = HM.empty
657 , genAnalysis = \_final -> GenAnalysis
658 { minReads = 0
659 , mayRaise = Map.empty
660 , alwaysRaise = Set.empty
661 , freeRegs = Set.empty
662 }
663 , unGen = \ctx -> {-trace "unGen.ret" $-}
664 {-trace "unGen.ret.returnCode" $-}
665 returnCode ({-trace "unGen.ret.onReturn" $-} onReturn ctx) ctx
666 }
667
668 takeFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
669 takeFreeRegs frs k = go (Set.toList frs)
670 where
671 go [] = k
672 go (r:rs) = [| \ $(return (TH.VarP r)) -> $(go rs) |]
673
674 giveFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
675 giveFreeRegs frs k = go (Set.toList frs)
676 where
677 go [] = k
678 go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |]
679
680 -- | Like 'TH.liftTyped' but adjusted to work on 'onExceptionStackByLabel'
681 -- which already contains 'CodeQ' terms.
682 -- Moreover, only the 'OnException' at the top of the stack
683 -- is needed and thus generated in the resulting 'CodeQ'.
684 --
685 -- TODO: Use an 'Array' instead of a 'Map'?
686 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
687 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
688 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
689 [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
690
691 instance TH.Lift a => TH.Lift (Set a) where
692 liftTyped Set_.Tip = [|| Set_.Tip ||]
693 liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
694
695 -- ** Type 'OnReturn'
696 -- | A continuation generated by 'onReturnCode' and later called by 'returnCode'.
697 type OnReturn inp v a =
698 {-farthestInput-}InputPosition inp ->
699 {-farthestExpecting-}Set SomeFailure ->
700 v ->
701 InputPosition inp ->
702 InputBuffer inp ->
703 Bool ->
704 ST RealWorld (Result inp a)
705
706 -- | Generate an 'OnReturn' continuation to be called with 'returnCode'.
707 -- Used when 'call' 'ret'urns.
708 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
709 onReturnCode ::
710 {-k-}Gen inp (v ': vs) a ->
711 GenCtx inp vs a ->
712 CodeQ (OnReturn inp v a)
713 onReturnCode k ctx = [||
714 let _ = $$(liftTypedString $ "onReturn") in
715 \farInp farExp v !inp buf end ->
716 $$({-trace "unGen.onReturnCode" $-} unGen k ctx
717 { valueStack = ValueStackCons ({-trace "unGen.onReturnCode.value" $-} splice [||v||]) (valueStack ctx)
718 , input = [||inp||]
719 , inputBuffer = [||buf||]
720 , inputEnded = [||end||]
721 , farthestInput = [||farInp||]
722 , farthestExpecting = [||farExp||]
723 , checkedHorizon = 0
724 }
725 )
726 ||]
727
728 -- | Generate a call to the 'onReturnCode' continuation.
729 -- Used when 'call' 'ret'urns.
730 returnCode ::
731 CodeQ (OnReturn inp v a) ->
732 GenCtx inp (v ': vs) a ->
733 CodeQ (ST RealWorld (Result inp a))
734 returnCode k = \ctx -> {-trace "returnCode" $-} [||
735 let _ = "resume" in
736 $$k
737 $$(farthestInput ctx)
738 $$(farthestExpecting ctx)
739 (let _ = "resume.genCode" in $$({-trace "returnCode.genCode" $-}
740 genCode $ valueStackHead $ valueStack ctx))
741 $$(input ctx)
742 $$(inputBuffer ctx)
743 $$(inputEnded ctx)
744 ||]
745
746 -- ** Type 'OnException'
747 -- | A continuation generated by 'catch' and later called by 'raise' or 'fail'.
748 type OnException inp a =
749 Exception ->
750 {-failInp-}InputPosition inp ->
751 {-farInp-}InputPosition inp ->
752 {-farExp-}Set SomeFailure ->
753 {-buffer-}InputBuffer inp ->
754 {-end-}Bool ->
755 ST RealWorld (Result inp a)
756
757 -- TODO: some static infos should be attached to 'OnException'
758 -- to avoid comparing inputs when they're the same
759 -- and to improve 'checkedHorizon'.
760 onExceptionCode ::
761 CodeQ (InputPosition inp) -> Horizon ->
762 Gen inp (InputPosition inp : vs) a ->
763 GenCtx inp vs a -> TH.CodeQ (OnException inp a)
764 onExceptionCode resetInput resetCheckedHorizon k ctx = [||
765 let _ = $$(TH.liftTypedString $ "onException") in
766 \ !_exn !failInp !farFail !farExp buf end ->
767 $$(unGen k ctx
768 -- Push 'input' and 'checkedHorizon'
769 -- as they were when entering the 'catch' or 'iter',
770 -- they will be available to 'loadInput', if any.
771 { valueStack = inputSave resetInput resetCheckedHorizon
772 `ValueStackCons` valueStack ctx
773 -- Note that 'onExceptionStackByLabel' is reset.
774 -- Move the input to the failing position.
775 , input = [||failInp||]
776 , inputBuffer = [||buf||]
777 , inputEnded = [||end||]
778 -- The 'checkedHorizon' at the 'raise's are not known here.
779 -- Nor whether 'failInp' is after 'checkedHorizon' or not.
780 -- Hence fallback to a safe value.
781 , checkedHorizon = 0
782 -- Set those to the farthest error computed in 'raiseFailure'.
783 , farthestInput = [||farInp||]
784 , farthestExpecting = [||farExp||]
785 })
786 ||]
787
788 instance InstrJoinable Gen where
789 defJoin (LetName n) sub k = k
790 { unGen = \ctx ->
791 {-trace ("unGen.defJoin: "<>show n) $-}
792 TH.unsafeCodeCoerce [|
793 let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
794 -- Called by 'returnCode'.
795 \farInp farExp v !inp buf end ->
796 $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
797 { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
798 , input = [||inp||]
799 , inputBuffer = [||buf||]
800 , inputEnded = [||end||]
801 , farthestInput = [||farInp||]
802 , farthestExpecting = [||farExp||]
803 , checkedHorizon = 0
804 {- FIXME:
805 , onExceptionStackByLabel = Map.mapWithKey
806 (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
807 (mayRaise sub raiseLabelsByLetButSub)
808 -}
809 })
810 ||])
811 in $(TH.unTypeQ $ TH.examineCode $
812 {-trace ("unGen.defJoin.expr: "<>show n) $-}
813 unGen k ctx)
814 |]
815 , genAnalysisByLet =
816 (genAnalysisByLet sub <>) $
817 HM.insert n (genAnalysis sub) $
818 genAnalysisByLet k
819 }
820 refJoin (LetName n) = Gen
821 { unGen = \ctx ->
822 {-trace ("unGen.refJoin: "<>show n) $-}
823 returnCode
824 (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
825 , genAnalysisByLet = HM.empty
826 , genAnalysis = \final ->
827 HM.findWithDefault
828 (error (show (n,HM.keys final)))
829 n final
830 }
831 instance InstrReadable Char Gen where
832 read fs p = checkHorizon . checkToken fs p
833 instance InstrReadable Word8 Gen where
834 read fs p = checkHorizon . checkToken fs p
835 instance InstrIterable Gen where
836 iter (LetName loopJump) loop done = Gen
837 { genAnalysisByLet = HM.unions
838 [ -- No need to give 'freeRegs' when 'call'ing 'loopJump'
839 -- because they're passed when 'call'ing 'iter'.
840 -- This avoids to passing those registers around.
841 HM.singleton loopJump (\final -> (genAnalysis loop final){freeRegs = Set.empty})
842 , genAnalysisByLet loop
843 , genAnalysisByLet done
844 ]
845 , genAnalysis = \final ->
846 let loopAnalysis = genAnalysis loop final in
847 let doneAnalysis = genAnalysis done final in
848 GenAnalysis
849 { minReads = minReads doneAnalysis
850 , mayRaise =
851 Map.delete ExceptionFailure (mayRaise loopAnalysis) <>
852 mayRaise doneAnalysis
853 , alwaysRaise =
854 Set.delete ExceptionFailure (alwaysRaise loopAnalysis) <>
855 alwaysRaise doneAnalysis
856 , freeRegs = freeRegs loopAnalysis <> freeRegs doneAnalysis
857 }
858 , unGen = \ctx -> TH.unsafeCodeCoerce [|
859 let _ = "iter" in
860 let
861 onException loopInput = $(TH.unTypeCode $ onExceptionCode
862 (TH.unsafeCodeCoerce [|loopInput|]) 0 done ctx)
863 $(return $ TH.VarP loopJump) = \_callerOnReturn callerInput callerBuffer callerEnded callerOnExceptionStackByLabel ->
864 $(TH.unTypeCode $ unGen loop ctx
865 { valueStack = ValueStackEmpty
866 , onExceptionStackByLabel =
867 Map.insertWith (<>) ExceptionFailure
868 (NE.singleton $ TH.unsafeCodeCoerce [|onException callerInput|])
869 (onExceptionStackByLabel ctx)
870 , input = TH.unsafeCodeCoerce [|callerInput|]
871 , inputBuffer = TH.unsafeCodeCoerce [|callerBuffer|]
872 , inputEnded = TH.unsafeCodeCoerce [|callerEnded|]
873 -- FIXME: promote to compile time error?
874 , onReturn = TH.unsafeCodeCoerce [|error "invalid onReturn"|]
875 , checkedHorizon = 0
876 })
877 in $(TH.unTypeCode $ unGen (jump True (LetName loopJump)) ctx{valueStack=ValueStackEmpty})
878 |]
879 }
880 instance InstrRegisterable Gen where
881 newRegister (UnscopedRegister r) k = k
882 { genAnalysis = \final ->
883 let analysis = genAnalysis k final in
884 analysis{freeRegs = Set.delete r $ freeRegs analysis}
885 , unGen = \ctx ->
886 let ValueStackCons v vs = valueStack ctx in
887 TH.unsafeCodeCoerce [|
888 do
889 let dupv = $(TH.unTypeCode $ genCode v)
890 $(return (TH.VarP r)) <- ST.newSTRef dupv
891 $(TH.unTypeCode $ unGen k ctx{valueStack=vs})
892 |]
893 }
894 readRegister (UnscopedRegister r) k = k
895 { genAnalysis = \final ->
896 let analysis = genAnalysis k final in
897 analysis{freeRegs = Set.insert r $ freeRegs analysis}
898 , unGen = \ctx -> [|| do
899 sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
900 $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
901 ||]
902 }
903 writeRegister (UnscopedRegister r) k = k
904 { genAnalysis = \final ->
905 let analysis = genAnalysis k final in
906 analysis{freeRegs = Set.insert r $ freeRegs analysis}
907 , unGen = \ctx ->
908 let ValueStackCons v vs = valueStack ctx in
909 [|| do
910 let dupv = $$(genCode v)
911 ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv
912 $$(unGen k ctx{valueStack=vs})
913 ||]
914 }
915
916 checkHorizon ::
917 forall inp vs a.
918 -- Those constraints are not used anyway
919 -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
920 Ord (InputToken inp) =>
921 Show (InputToken inp) =>
922 TH.Lift (InputToken inp) =>
923 NFData (InputToken inp) =>
924 Typeable (InputToken inp) =>
925 {-ok-}Gen inp vs a ->
926 Gen inp vs a
927 checkHorizon ok = ok
928 { genAnalysis = \final -> seqGenAnalysis $
929 GenAnalysis { minReads = 0
930 , mayRaise = Map.singleton ExceptionFailure ()
931 , alwaysRaise = Set.empty
932 , freeRegs = Set.empty
933 } :|
934 [ genAnalysis ok final ]
935 , unGen = \ctx0@GenCtx{} ->
936 if checkedHorizon ctx0 >= 1
937 then
938 [||
939 let _ = $$(TH.liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in
940 $$(unGen ok ctx0{checkedHorizon = checkedHorizon ctx0 - 1})
941 ||]
942 else
943 let minHoriz = minReads $ genAnalysis ok $ analysisByLet ctx0 in
944 if minHoriz == 0
945 then
946 [||
947 let _ = "checkHorizon.noCheck" in
948 $$(unGen ok ctx0)
949 ||]
950 else
951 [||
952 let partialCont buf =
953 -- Factorize generated code for raising the "fail".
954 let readFail = $$(raiseException ctx0{inputBuffer=[||buf||]} ExceptionFailure) in
955 $$(
956 let ctx = ctx0
957 { onExceptionStackByLabel =
958 Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
959 ExceptionFailure (onExceptionStackByLabel ctx0)
960 , inputBuffer = [||buf||]
961 } in
962 [||
963 let _ = $$(TH.liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in
964 if $$(moreInput ctx) buf
965 $$(if minHoriz > 1
966 then [||$$shiftRight $$(TH.liftTyped (minHoriz - 1)) $$(input ctx)||]
967 else input ctx)
968 then $$(unGen ok ctx{checkedHorizon = minHoriz})
969 else
970 let _ = $$(liftTypedString $ "checkHorizon.newCheck.fail") in
971 let noMoreInput = $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz)) ctx{inputEnded=[||True||]}) in
972 if $$(inputEnded ctx)
973 then noMoreInput
974 else returnST $ ResultPartial $ \newInput ->
975 if nullInput newInput
976 then noMoreInput
977 else partialCont ($$(appendInput ctx) buf newInput)
978 -- $$(raiseFailure ctx [||Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz||])
979 ||]
980 )
981 in partialCont $$(inputBuffer ctx0)
982 ||]
983 }
984
985 -- * Type 'Result'
986 data Result inp a
987 = ResultDone a
988 | ResultError (ParsingError inp)
989 | ResultPartial (inp -> ST RealWorld (Result inp a))
990
991 -- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
992 -- with farthest parameters set to or updated with @(fs)@
993 -- according to the relative position of 'input' wrt. 'farthestInput'.
994 raiseFailure ::
995 Positionable (InputPosition inp) =>
996 GenCtx inp cs a ->
997 TH.CodeQ (Set SomeFailure) ->
998 TH.CodeQ (ST RealWorld (Result inp a))
999 raiseFailure ctx fs = [||
1000 let failExp = $$fs in
1001 let (# farInp, farExp #) =
1002 case $$comparePosition $$(farthestInput ctx) $$(input ctx) of
1003 LT -> (# $$(input ctx), failExp #)
1004 EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
1005 GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
1006 in $$(raiseException ctx ExceptionFailure)
1007 ExceptionFailure
1008 {-failInp-}$$(input ctx) farInp farExp $$(inputBuffer ctx) $$(inputEnded ctx)
1009 ||]
1010 -- | @('raiseException' ctx exn)@ raises exception @(exn)@
1011 -- using any entry in 'onExceptionStackByLabel', or 'defaultCatch' if none.
1012 raiseException ::
1013 GenCtx inp vs a -> Exception ->
1014 CodeQ (OnException inp a)
1015 raiseException ctx exn =
1016 NE.head $ Map.findWithDefault
1017 (NE.singleton (defaultCatch ctx))
1018 exn (onExceptionStackByLabel ctx)
1019
1020 checkToken ::
1021 Set SomeFailure ->
1022 {-predicate-}Splice (InputToken inp -> Bool) ->
1023 {-ok-}Gen inp (InputToken inp ': vs) a ->
1024 Gen inp vs a
1025 checkToken fs p ok = ok
1026 { genAnalysis = \final -> seqGenAnalysis $
1027 GenAnalysis { minReads = 1
1028 , mayRaise = Map.singleton ExceptionFailure ()
1029 , alwaysRaise = Set.empty
1030 , freeRegs = Set.empty
1031 } :|
1032 [ genAnalysis ok final ]
1033 , unGen = \ctx -> {-trace "unGen.read" $-} [||
1034 let _ = "checkToken" in
1035 let !(# c, cs #) = $$(nextInput ctx) $$(inputBuffer ctx) $$(input ctx) in
1036 $$(genCode $
1037 Prod.ifThenElse
1038 (p Prod..@ splice [||c||])
1039 (splice $ unGen ok ctx
1040 { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
1041 , input = [||cs||]
1042 })
1043 (splice [||
1044 let _ = "checkToken.fail" in
1045 $$(unGen (fail fs) ctx)
1046 ||])
1047 )||]
1048 }