doc: fix reference to Symantic.Typed

[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 80f3e93f570683e5625d7fedf767572e5c14f51d..622f4f3bc9a8bf0b9dd9a81d6f8273fd4e4689b5 100644 (file)
--- a/src/Symantic/Parser/Machine/Instructions.hs
+++ b/src/Symantic/Parser/Machine/Instructions.hs
@@ -14,25 +14,18 @@ import Data.Kind (Type)
 import Data.Set (Set)
 import Text.Show (Show(..))
 import qualified Language.Haskell.TH as TH
-import qualified Symantic.Parser.Haskell as H
 
 import Symantic.Parser.Grammar
 import Symantic.Parser.Machine.Input
+import qualified Symantic.Typed.Lang as Prod
+import qualified Symantic.Typed.Data as Sym
 
--- * Type 'TermInstr'
-type TermInstr = H.Term TH.CodeQ
+-- * Type 'Splice'
+type Splice = Sym.SomeData TH.CodeQ
 
--- * Class 'Machine'
--- | All the 'Instr'uctions.
-type Machine tok repr =
-  ( InstrBranchable repr
-  , InstrExceptionable repr
-  , InstrInputable repr
-  , InstrJoinable repr
-  , InstrCallable repr
-  , InstrValuable repr
-  , InstrReadable tok repr
-  )
+-- | Lift a 'TH.CodeQ' into a 'Sym.SomeData'.
+splice :: TH.CodeQ a -> Splice a
+splice x = Sym.SomeData (Sym.Var x)
 
 -- ** Type 'ReprInstr'
 type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
@@ -50,7 +43,7 @@ class InstrValuable (repr::ReprInstr) where
   -- | @('pushValue' x k)@ pushes @(x)@ on the 'valueStack'
   -- and continues with the next 'Instr'uction @(k)@.
   pushValue ::
-    TermInstr v ->
+    Splice v ->
     repr inp (v ': vs) a ->
     repr inp vs a
   -- | @('popValue' k)@ pushes @(x)@ on the 'valueStack'.
@@ -60,7 +53,7 @@ class InstrValuable (repr::ReprInstr) where
   -- | @('lift2Value' f k)@ pops two values from the 'valueStack',
   -- and pushes the result of @(f)@ applied to them.
   lift2Value ::
-    TermInstr (x -> y -> z) ->
+    Splice (x -> y -> z) ->
     repr inp (z ': vs) a ->
     repr inp (y ': x ': vs) a
   -- | @('swapValue' k)@ pops two values on the 'valueStack',
@@ -71,22 +64,25 @@ class InstrValuable (repr::ReprInstr) where
     repr inp (y ': x ': vs) a
   -- | @('mapValue' f k)@.
   mapValue ::
-    TermInstr (x -> y) ->
+    Splice (x -> y) ->
     repr inp (y ': vs) a ->
     repr inp (x ': vs) a
-  mapValue f = pushValue f . lift2Value (H.flip H..@ (H.$))
+  mapValue f = pushValue f . lift2Value (Prod.flip Prod..@ (Prod.$))
   -- | @('applyValue' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
   -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
   applyValue ::
     repr inp (y ': vs) a ->
     repr inp (x ': (x -> y) ': vs) a
-  applyValue = lift2Value (H.$)
+  applyValue = lift2Value (Prod.$)
 
 -- ** Class 'InstrExceptionable'
 class InstrExceptionable (repr::ReprInstr) where
   -- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
   raise :: ExceptionLabel -> repr inp vs a
   -- | @('fail' fs)@ raises 'ExceptionFailure' @(exn)@.
+  -- As a special case, giving an empty 'Set' of failures
+  -- raises 'ExceptionFailure' without using the current position
+  -- to update the farthest error.
   fail :: Set SomeFailure -> repr inp vs a
   -- | @('commit' exn k)@ removes the 'Catcher'
   -- from the 'catchStackByLabel' for the given 'Exception' @(exn)@,
@@ -111,7 +107,7 @@ class InstrBranchable (repr::ReprInstr) where
     repr inp (Either x y ': vs) r
   -- | @('choicesBranch' ps bs d)@.
   choicesBranch ::
-    [TermInstr (v -> Bool)] ->
+    [Splice (v -> Bool)] ->
     [repr inp vs a] ->
     repr inp vs a ->
     repr inp (v ': vs) a
@@ -122,7 +118,7 @@ class InstrBranchable (repr::ReprInstr) where
     repr inp vs a ->
     repr inp vs a ->
     repr inp (Bool ': vs) a
-  ifBranch ok ko = choicesBranch [H.id] [ok] ko
+  ifBranch ok ko = choicesBranch [Prod.id] [ok] ko
 
 -- ** Class 'InstrCallable'
 class InstrCallable (repr::ReprInstr) where
@@ -177,6 +173,6 @@ class InstrReadable (tok::Type) (repr::ReprInstr) where
   read ::
     tok ~ InputToken inp =>
     Set SomeFailure ->
-    TermInstr (tok -> Bool) ->
+    Splice (tok -> Bool) ->
     repr inp (tok ': vs) a ->
     repr inp vs a