test: save

[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Generate.hs

diff --git a/src/Symantic/Parser/Machine/Generate.hs b/src/Symantic/Parser/Machine/Generate.hs
index c66eea9c0a0ec8d458889e5d479297d3c1273393..b28d87b38fff84b4822dfa8454c16f77c2c4318f 100644 (file)
--- a/src/Symantic/Parser/Machine/Generate.hs
+++ b/src/Symantic/Parser/Machine/Generate.hs
@@ -31,7 +31,7 @@ import Symantic.Univariant.Trans
 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
 import Symantic.Parser.Machine.Input
 import Symantic.Parser.Machine.Instructions
-import qualified Symantic.Parser.Haskell as H
+import qualified Symantic.Parser.Grammar.Pure as H
 
 -- * Type 'Gen'
 -- | Generate the 'CodeQ' parsing the input.
@@ -46,6 +46,10 @@ data Gen inp vs es a = Gen
 data ParsingError inp
   =  ParsingErrorStandard
   {  parsingErrorOffset :: Offset
+    -- | Note that if an 'ErrorItemHorizon' greater than 1
+    -- is amongst the 'parsingErrorExpecting'
+    -- then this is only the 'InputToken'
+    -- at the begining of the expected 'Horizon'.
   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
   ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
   }
@@ -160,7 +164,7 @@ data GenCtx inp vs (es::Peano) a =
 data ValueStack vs where
   ValueStackEmpty :: ValueStack '[]
   ValueStackCons ::
-    -- TODO: maybe use H.Haskell instead of CodeQ ?
+    -- TODO: maybe use H.CombPure instead of CodeQ ?
     -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
     { valueStackHead :: CodeQ v
     , valueStackTail :: ValueStack vs
@@ -447,39 +451,56 @@ checkToken farExp p ok = ok
   }
 
 liftCode :: InstrPure a -> CodeQ a
-liftCode = trans
-{-# INLINE liftCode #-}
+liftCode x = trans x
+{-
+liftCode p = case p of
+  InstrPureSameOffset -> [|| $$sameOffset ||]
+  InstrPure h -> go h
+  where
+  go :: H.CombPure a -> CodeQ a
+  go = \case
+    ((H.:.) H.:@ f) H.:@ (H.Const H.:@ x) -> [|| $$(go f) $$(go x) ||]
+    a -> trans a
+-}
+-- {-# INLINE liftCode #-}
 
 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
 liftCode1 p a = case p of
-  InstrPureSameOffset -> [|| $$sameOffset $$a ||]
-  InstrPureHaskell h -> go a h
+  InstrPureSameOffset f -> [|| $$f $$a ||]
+  InstrPure h -> go a h
   where
-  go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
+  go :: CodeQ a -> H.CombPure (a -> b) -> CodeQ b
   go qa = \case
     (H.:$) -> [|| \x -> $$qa x ||]
     (H.:.) -> [|| \g x -> $$qa (g x) ||]
     H.Flip -> [|| \x y -> $$qa y x ||]
+    -- ((H.:.) H.:@ f) H.:@ (H.Const H.@ x) -> [|| $$(go (go qa g) f) ||]
     (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
+    H.Cons -> [|| ($$qa :) ||]
     H.Const -> [|| \_ -> $$qa ||]
     H.Flip H.:@ H.Const -> H.id
-    h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
+    h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPure h) qa [||x||]) ||]
+    H.Id H.:@ x -> go qa x
     H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
     H.Id -> qa
-    h -> [|| $$(trans h) $$qa ||]
+    H.CombPure (H.ValueCode _a2b qa2b) -> [|| $$qa2b $$qa ||]
+    -- h -> [|| $$(liftCode h) $$qa ||]
 
 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
 liftCode2 p a b = case p of
-  InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
-  InstrPureHaskell h -> go a b h
+  InstrPureSameOffset f -> [|| $$f $$a $$b ||]
+  InstrPure h -> go a b h
   where
-  go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
+  go :: CodeQ a -> CodeQ b -> H.CombPure (a -> b -> c) -> CodeQ c
   go qa qb = \case
     (H.:$) -> [|| $$qa $$qb ||]
     (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
     H.Flip -> [|| \x -> $$qa x $$qb ||]
     H.Flip H.:@ H.Const -> [|| $$qb ||]
     H.Flip H.:@ f -> go qb qa f
-    H.Const -> [|| $$qa ||]
+    H.Id H.:@ x -> go qa qb x
+    H.Id -> [|| $$qa $$qb ||]
     H.Cons -> [|| $$qa : $$qb ||]
-    h -> [|| $$(trans h) $$qa $$qb ||]
+    H.Const -> [|| $$qa ||]
+    H.CombPure (H.ValueCode _a2b2c qa2b2c) -> [|| $$qa2b2c $$qa $$qb ||]
+    --h -> [|| $$(trans h) $$qa $$qb ||]