test: save

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

diff --git a/src/Symantic/Parser/Machine/Instructions.hs b/src/Symantic/Parser/Machine/Instructions.hs
index 21cb87ac6b3b23b5354c723b752e2ceb3d7f4829..18700ba22c01d80f77164517caf3e84d45a83535 100644 (file)
--- a/src/Symantic/Parser/Machine/Instructions.hs
+++ b/src/Symantic/Parser/Machine/Instructions.hs
@@ -15,7 +15,7 @@ import Text.Show (Show(..), showString)
 import qualified Data.Functor as Functor
 import qualified Language.Haskell.TH as TH
 import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Parser.Haskell as H
+import qualified Symantic.Parser.Grammar.Pure as H
 
 import Symantic.Parser.Grammar
 import Symantic.Parser.Machine.Input
@@ -122,17 +122,18 @@ data Instr input valueStack (failStack::Peano) returnValue where
 
 -- ** Type 'InstrPure'
 data InstrPure a where
-  InstrPureHaskell :: H.Haskell a -> InstrPure a
-  InstrPureSameOffset :: Cursorable cur => InstrPure (cur -> cur -> Bool)
+  InstrPure :: H.CombPure a -> InstrPure a
+  InstrPureSameOffset :: CodeQ (cur -> cur -> Bool) -> InstrPure (cur -> cur -> Bool)
+  InstrP
 
 instance Show (InstrPure a) where
   showsPrec p = \case
-    InstrPureHaskell x -> showsPrec p x
-    InstrPureSameOffset -> showString "InstrPureSameOffset"
+    InstrPure x -> showsPrec p x
+    InstrPureSameOffset{} -> showString "InstrPureSameOffset"
 instance Trans InstrPure TH.CodeQ where
   trans = \case
-    InstrPureHaskell x -> trans x
-    InstrPureSameOffset -> sameOffset
+    InstrPure x -> trans x
+    InstrPureSameOffset x -> x
 
 -- ** Type 'LetName'
 newtype LetName a = LetName { unLetName :: TH.Name }
@@ -266,14 +267,14 @@ pattern Fmap ::
   InstrPure (x -> y) ->
   Instr inp (y ': xs) es ret ->
   Instr inp (x ': xs) es ret
-pattern Fmap f k = Push f (LiftI2 (InstrPureHaskell (H.Flip H.:@ (H.:$))) k)
+pattern Fmap f k = Push f (LiftI2 (InstrPure (H.Flip H.:@ (H.:$))) k)
 
 -- | @('App' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
 -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
 pattern App ::
   Instr inp (y : vs) es ret ->
   Instr inp (x : (x -> y) : vs) es ret
-pattern App k = LiftI2 (InstrPureHaskell (H.:$)) k
+pattern App k = LiftI2 (InstrPure (H.:$)) k
 
 -- | @('If' ok ko)@ pops a 'Bool' from the 'valueStack'
 -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
@@ -282,7 +283,7 @@ pattern If ::
   Instr inp vs es ret ->
   Instr inp vs es ret ->
   Instr inp (Bool ': vs) es ret
-pattern If ok ko = Choices [InstrPureHaskell H.Id] [ok] ko
+pattern If ok ko = Choices [InstrPure H.Id] [ok] ko
 
 -- * Type 'Machine'
 -- | Making the control-flow explicit.
@@ -302,10 +303,10 @@ runMachine (Machine auto) =
   auto Ret
 
 instance Applicable (Machine inp) where
-  pure x = Machine $ Push (InstrPureHaskell x)
+  pure x = Machine $ Push (InstrPure x)
   Machine f <*> Machine x = Machine $ f . x . App
   liftA2 f (Machine x) (Machine y) = Machine $
-    x . y . LiftI2 (InstrPureHaskell f)
+    x . y . LiftI2 (InstrPure f)
   Machine x *> Machine y = Machine $ x . Pop . y
   Machine x <* Machine y = Machine $ x . y . Pop
 instance
@@ -330,7 +331,7 @@ failIfConsumed ::
   Cursorable (Cursor inp) =>
   Instr inp vs ('Succ es) ret ->
   Instr inp (Cursor inp : vs) ('Succ es) ret
-failIfConsumed k = PushInput (LiftI2 InstrPureSameOffset (If k (Fail [])))
+failIfConsumed k = PushInput (LiftI2 (InstrPureSameOffset sameOffset) (If k (Fail [])))
 
 -- | @('makeJoin' k f)@ factorizes @(k)@ in @(f)@,
 -- by introducing a 'DefJoin' if necessary,
@@ -353,7 +354,7 @@ makeJoin k =
   \f -> DefJoin joinName k (f (RefJoin joinName))
 
 instance tok ~ InputToken inp => Satisfiable (Machine inp) tok where
-  satisfy es p = Machine $ Read es (InstrPureHaskell p)
+  satisfy es p = Machine $ Read es (InstrPure p)
 instance Selectable (Machine inp) where
   branch (Machine lr) (Machine l) (Machine r) = Machine $ \k ->
     makeJoin k $ \j ->
@@ -362,7 +363,7 @@ instance Selectable (Machine inp) where
 instance Matchable (Machine inp) where
   conditional ps bs (Machine m) (Machine default_) = Machine $ \k ->
     makeJoin k $ \j ->
-    m (Choices (InstrPureHaskell Functor.<$> ps)
+    m (Choices (InstrPure Functor.<$> ps)
                ((\b -> unMachine b j) Functor.<$> bs)
                (default_ j))
 instance
@@ -391,7 +392,7 @@ instance
       (PushInput (x (Pop (PopFail (LoadInput (Fail []))))))
       -- On x failure, reset the input,
       -- and go on with the next 'Instr'uctions.
-      (LoadInput (Push (InstrPureHaskell H.unit) k))
+      (LoadInput (Push (InstrPure H.unit) k))
 instance Letable TH.Name (Machine inp) where
   def n v = Machine $ \k ->
     Subroutine (LetName n) (unMachine v Ret) (Call (LetName n) k)