]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Generate.hs
rename Machine.{Eval => Gen}
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Generate.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
3 {-# LANGUAGE TemplateHaskell #-}
4 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
5 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
6 module Symantic.Parser.Machine.Generate where
7
8 import Control.Monad (Monad(..))
9 import Data.Bool (Bool)
10 import Data.Char (Char)
11 import Data.Either (Either(..))
12 import Data.Function (($))
13 -- import Data.Functor ((<$>))
14 import Data.Int (Int)
15 import Data.Maybe (Maybe(..))
16 import Data.Ord (Ord, Ordering(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.Set (Set)
19 import Language.Haskell.TH (CodeQ, Code(..))
20 import Prelude (($!))
21 import Text.Show (Show(..))
22 import qualified Data.Eq as Eq
23 import qualified Data.Set as Set
24 import qualified Language.Haskell.TH.Syntax as TH
25
26 import Symantic.Univariant.Trans
27 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
28 import Symantic.Parser.Machine.Input
29 import Symantic.Parser.Machine.Instructions
30 import qualified Symantic.Parser.Haskell as H
31
32 -- * Type 'Gen'
33 -- | Generate the 'CodeQ' parsing the input.
34 newtype Gen inp vs es a = Gen { unGen ::
35 GenCtx inp vs es a ->
36 CodeQ (Either (ParsingError inp) a)
37 }
38
39 -- ** Type 'ParsingError'
40 data ParsingError inp
41 = ParsingErrorStandard
42 { parsingErrorOffset :: Offset
43 , parsingErrorUnexpected :: Maybe (InputToken inp)
44 , parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
45 }
46 deriving instance Show (InputToken inp) => Show (ParsingError inp)
47
48 -- ** Type 'Offset'
49 type Offset = Int
50
51 -- ** Type 'Cont'
52 type Cont inp v a =
53 {-farthestInput-}Cursor inp ->
54 {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
55 v ->
56 Cursor inp ->
57 Either (ParsingError inp) a
58
59 -- ** Type 'SubRoutine'
60 type SubRoutine inp v a =
61 {-ok-}Cont inp v a ->
62 Cursor inp ->
63 {-ko-}FailHandler inp a ->
64 Either (ParsingError inp) a
65
66 -- ** Type 'FailHandler'
67 type FailHandler inp a =
68 {-failureInput-}Cursor inp ->
69 {-farthestInput-}Cursor inp ->
70 {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
71 Either (ParsingError inp) a
72
73 {-
74 -- *** Type 'FarthestError'
75 data FarthestError inp = FarthestError
76 { farthestInput :: Cursor inp
77 , farthestExpecting :: [ErrorItem (InputToken inp)]
78 }
79 -}
80
81 -- | @('generate' input mach)@ generates @TemplateHaskell@ code
82 -- parsing given 'input' according to given 'mach'ine.
83 generate ::
84 forall inp ret.
85 Ord (InputToken inp) =>
86 Show (InputToken inp) =>
87 TH.Lift (InputToken inp) =>
88 -- InputToken inp ~ Char =>
89 Input inp =>
90 CodeQ inp ->
91 Show (Cursor inp) =>
92 Gen inp '[] ('Succ 'Zero) ret ->
93 CodeQ (Either (ParsingError inp) ret)
94 generate input (Gen k) = [||
95 -- Pattern bindings containing unlifted types
96 -- should use an outermost bang pattern.
97 let !(# init, readMore, readNext #) = $$(cursorOf input) in
98 let finalRet = \_farInp _farExp v _inp -> Right v in
99 let finalFail _failInp !farInp !farExp =
100 Left ParsingErrorStandard
101 { parsingErrorOffset = offset farInp
102 , parsingErrorUnexpected =
103 if readMore farInp
104 then Just (let (# c, _ #) = readNext farInp in c)
105 else Nothing
106 , parsingErrorExpecting = Set.fromList farExp
107 } in
108 $$(k GenCtx
109 { valueStack = ValueStackEmpty
110 , failStack = FailStackCons [||finalFail||] FailStackEmpty
111 , retCode = [||finalRet||]
112 , input = [||init||]
113 , nextInput = [||readNext||]
114 , moreInput = [||readMore||]
115 -- , farthestError = [||Nothing||]
116 , farthestInput = [||init||]
117 , farthestExpecting = [|| [] ||]
118 })
119 ||]
120
121 -- ** Type 'GenCtx'
122 -- | This is a context only present at compile-time.
123 data GenCtx inp vs (es::Peano) a =
124 ( TH.Lift (InputToken inp)
125 , Cursorable (Cursor inp)
126 , Show (InputToken inp)
127 -- , InputToken inp ~ Char
128 ) => GenCtx
129 { valueStack :: ValueStack vs
130 , failStack :: FailStack inp es a
131 , retCode :: CodeQ (Cont inp a a)
132 , input :: CodeQ (Cursor inp)
133 , moreInput :: CodeQ (Cursor inp -> Bool)
134 , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
135 , farthestInput :: CodeQ (Cursor inp)
136 , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
137 }
138
139 -- ** Type 'ValueStack'
140 data ValueStack vs where
141 ValueStackEmpty :: ValueStack '[]
142 ValueStackCons ::
143 -- TODO: maybe use H.Haskell instead of CodeQ ?
144 -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
145 { valueStackHead :: CodeQ v
146 , valueStackTail :: ValueStack vs
147 } -> ValueStack (v ': vs)
148
149 -- ** Type 'FailStack'
150 data FailStack inp es a where
151 FailStackEmpty :: FailStack inp 'Zero a
152 FailStackCons ::
153 { failStackHead :: CodeQ (FailHandler inp a)
154 , failStackTail :: FailStack inp es a
155 } ->
156 FailStack inp ('Succ es) a
157
158 instance Stackable Gen where
159 push x k = Gen $ \ctx -> unGen k ctx
160 { valueStack = ValueStackCons (liftCode x) (valueStack ctx) }
161 pop k = Gen $ \ctx -> unGen k ctx
162 { valueStack = valueStackTail (valueStack ctx) }
163 liftI2 f k = Gen $ \ctx -> unGen k ctx
164 { valueStack =
165 let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
166 ValueStackCons (liftCode2 f x y) xs
167 }
168 swap k = Gen $ \ctx -> unGen k ctx
169 { valueStack =
170 let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
171 ValueStackCons x (ValueStackCons y xs)
172 }
173 instance Branchable Gen where
174 case_ kx ky = Gen $ \ctx ->
175 let ValueStackCons v vs = valueStack ctx in
176 [||
177 case $$v of
178 Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons [||x||] vs })
179 Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons [||y||] vs })
180 ||]
181 choices fs ks kd = Gen $ \ctx ->
182 let ValueStackCons v vs = valueStack ctx in
183 go ctx{valueStack = vs} v fs ks
184 where
185 go ctx x (f:fs') (Gen k:ks') = [||
186 if $$(liftCode1 f x) then $$(k ctx)
187 else $$(go ctx x fs' ks')
188 ||]
189 go ctx _ _ _ = unGen kd ctx
190 instance Failable Gen where
191 fail failExp = Gen $ \ctx@GenCtx{} -> [||
192 let (# farInp, farExp #) =
193 case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
194 LT -> (# $$(input ctx), failExp #)
195 EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
196 GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
197 {-
198 trace ("fail: "
199 <>" failExp="<>show @[ErrorItem Char] failExp
200 <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting ctx))
201 <>" farExp="<>show @[ErrorItem Char] farExp) $
202 -}
203 $$(failStackHead (failStack ctx))
204 $$(input ctx) farInp farExp
205 ||]
206 popFail k = Gen $ \ctx ->
207 let FailStackCons _e es = failStack ctx in
208 unGen k ctx{failStack = es}
209 catchFail ok ko = Gen $ \ctx@GenCtx{} -> [||
210 let _ = "catchFail" in $$(unGen ok ctx
211 { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
212 -- trace ("catchFail: " <> "farExp="<>show farExp) $
213 $$(unGen ko ctx
214 -- Push the input as it was when entering the catchFail.
215 { valueStack = ValueStackCons (input ctx) (valueStack ctx)
216 -- Move the input to the failing position.
217 , input = [||failInp||]
218 -- Set the farthestInput to the farthest computed by 'fail'
219 , farthestInput = [||farInp||]
220 , farthestExpecting = [||farExp||]
221 })
222 ||] (failStack ctx)
223 })
224 ||]
225 instance Inputable Gen where
226 loadInput k = Gen $ \ctx ->
227 let ValueStackCons input vs = valueStack ctx in
228 unGen k ctx{valueStack = vs, input}
229 pushInput k = Gen $ \ctx ->
230 unGen k ctx{valueStack = ValueStackCons (input ctx) (valueStack ctx)}
231 instance Routinable Gen where
232 call (LetName n) k = Gen $ \ctx -> [||
233 let _ = "call" in
234 $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
235 $$(suspend k ctx)
236 $$(input ctx)
237 $! $$(failStackHead (failStack ctx))
238 ||]
239 jump (LetName n) = Gen $ \ctx -> [||
240 let _ = "jump" in
241 $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
242 $$(retCode ctx)
243 $$(input ctx)
244 $! $$(failStackHead (failStack ctx))
245 ||]
246 ret = Gen $ \ctx -> unGen (resume (retCode ctx)) ctx
247 subroutine (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do
248 body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
249 -- SubRoutine
250 -- Why using $! at call site and not ! here on ko?
251 \ !ok !inp ko ->
252 $$(unGen sub ctx
253 { valueStack = ValueStackEmpty
254 , failStack = FailStackCons [||ko||] FailStackEmpty
255 , input = [||inp||]
256 , retCode = [||ok||]
257 -- , farthestInput = [|inp|]
258 -- , farthestExpecting = [|| [] ||]
259 })
260 ||]
261 let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
262 expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))
263 return (TH.LetE [decl] expr)
264
265 suspend ::
266 {-k-}Gen inp (v ': vs) es a ->
267 GenCtx inp vs es a ->
268 CodeQ (Cont inp v a)
269 suspend k ctx = [||
270 let _ = "suspend" in
271 \farInp farExp v !inp ->
272 $$(unGen k ctx
273 { valueStack = ValueStackCons [||v||] (valueStack ctx)
274 , input = [||inp||]
275 , farthestInput = [||farInp||]
276 , farthestExpecting = [||farExp||]
277 }
278 )
279 ||]
280
281 resume :: CodeQ (Cont inp v a) -> Gen inp (v ': vs) es a
282 resume k = Gen $ \ctx -> [||
283 let _ = "resume" in
284 $$k
285 $$(farthestInput ctx)
286 $$(farthestExpecting ctx)
287 $$(valueStackHead (valueStack ctx))
288 $$(input ctx)
289 ||]
290
291 instance Joinable Gen where
292 defJoin (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do
293 body <- TH.unTypeQ $ TH.examineCode $ [||
294 \farInp farExp v !inp ->
295 $$(unGen sub ctx
296 { valueStack = ValueStackCons [||v||] (valueStack ctx)
297 , input = [||inp||]
298 , farthestInput = [||farInp||]
299 , farthestExpecting = [||farExp||]
300 })
301 ||]
302 let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
303 expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))
304 return (TH.LetE [decl] expr)
305 refJoin (LetName n) =
306 resume (Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
307 instance Readable Gen Char where
308 read farExp p k =
309 -- TODO: piggy bank
310 maybeEmitCheck (Just 1) k
311 where
312 maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
313 maybeEmitCheck (Just n) ok = Gen $ \ctx ->
314 let FailStackCons e es = failStack ctx in
315 [||
316 let readFail = $$(e) in -- Factorize failure code
317 $$((`unGen` ctx{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
318 {-ok-}(sat (liftCode p) ok
319 {-ko-}(fail farExp))
320 {-ko-}(fail farExp))
321 ||]
322
323 sat ::
324 forall inp vs es a.
325 -- Cursorable (Cursor inp) =>
326 -- InputToken inp ~ Char =>
327 Ord (InputToken inp) =>
328 TH.Lift (InputToken inp) =>
329 {-predicate-}CodeQ (InputToken inp -> Bool) ->
330 {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
331 {-ko-}Gen inp vs ('Succ es) a ->
332 Gen inp vs ('Succ es) a
333 sat p ok ko = Gen $ \ctx -> [||
334 let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
335 if $$p c
336 then $$(unGen ok ctx
337 { valueStack = ValueStackCons [||c||] (valueStack ctx)
338 , input = [||cs||]
339 })
340 else let _ = "sat.else" in $$(unGen ko ctx)
341 ||]
342
343 {-
344 evalSat ::
345 -- Cursorable inp =>
346 -- HandlerOps inp =>
347 InstrPure (Char -> Bool) ->
348 Gen inp (Char ': vs) ('Succ es) a ->
349 Gen inp vs ('Succ es) a
350 evalSat p k = do
351 bankrupt <- asks isBankrupt
352 hasChange <- asks hasCoin
353 if | bankrupt -> maybeEmitCheck (Just 1) <$> k
354 | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
355 | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
356 where
357 maybeEmitCheck Nothing mk ctx = sat (genDefunc p) mk (raise ctx) ctx
358 maybeEmitCheck (Just n) mk ctx =
359 [|| let bad = $$(raise ctx) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] ctx)||]
360 -}
361
362 emitLengthCheck ::
363 TH.Lift (InputToken inp) =>
364 Int -> Gen inp vs es a -> Gen inp vs es a -> Gen inp vs es a
365 emitLengthCheck 0 ok _ko = ok
366 emitLengthCheck 1 ok ko = Gen $ \ctx -> [||
367 if $$(moreInput ctx) $$(input ctx)
368 then $$(unGen ok ctx)
369 else let _ = "sat.length-check.else" in $$(unGen ko ctx)
370 ||]
371 {-
372 emitLengthCheck n ok ko ctx = Gen $ \ctx -> [||
373 if $$moreInput ($$shiftRight $$(input ctx) (n - 1))
374 then $$(unGen ok ctx)
375 else $$(unGen ko ctx {farthestExpecting = [||farExp||]})
376 ||]
377 -}
378
379
380 liftCode :: InstrPure a -> CodeQ a
381 liftCode = trans
382 {-# INLINE liftCode #-}
383
384 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
385 liftCode1 p a = case p of
386 InstrPureSameOffset -> [|| $$sameOffset $$a ||]
387 InstrPureHaskell h -> go a h
388 where
389 go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
390 go qa = \case
391 (H.:$) -> [|| \x -> $$qa x ||]
392 (H.:.) -> [|| \g x -> $$qa (g x) ||]
393 H.Flip -> [|| \x y -> $$qa y x ||]
394 (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
395 H.Const -> [|| \_ -> $$qa ||]
396 H.Flip H.:@ H.Const -> H.id
397 h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
398 H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
399 H.Id -> qa
400 h -> [|| $$(trans h) $$qa ||]
401
402 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
403 liftCode2 p a b = case p of
404 InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
405 InstrPureHaskell h -> go a b h
406 where
407 go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
408 go qa qb = \case
409 (H.:$) -> [|| $$qa $$qb ||]
410 (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
411 H.Flip -> [|| \x -> $$qa x $$qb ||]
412 H.Flip H.:@ H.Const -> [|| $$qb ||]
413 H.Flip H.:@ f -> go qb qa f
414 H.Const -> [|| $$qa ||]
415 H.Cons -> [|| $$qa : $$qb ||]
416 h -> [|| $$(trans h) $$qa $$qb ||]