parsers: commit missing file

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

diff --git a/src/Symantic/Parser/Machine/Optimize.hs b/src/Symantic/Parser/Machine/Optimize.hs
index 2b8a6f035ea60e6c47391006b56298b87ed57902..f2dec46b887f64e73de499c35ae9c931bda719f8 100644 (file)
--- a/src/Symantic/Parser/Machine/Optimize.hs
+++ b/src/Symantic/Parser/Machine/Optimize.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE PatternSynonyms #-} -- For Instr
 {-# LANGUAGE ViewPatterns #-} -- For unSomeInstr
-{-# LANGUAGE UndecidableInstances #-}
 -- | Initial encoding with bottom-up optimizations of 'Instr'uctions,
 -- re-optimizing downward as needed after each optimization.
 -- There is only one optimization (for 'pushValue') so far,
@@ -10,11 +9,10 @@ module Symantic.Parser.Machine.Optimize where
 
 import Data.Bool (Bool(..))
 import Data.Either (Either)
-import Data.Maybe (Maybe(..))
 import Data.Function ((.))
 import Data.Kind (Constraint)
-import Data.Proxy (Proxy(..))
-import GHC.TypeLits (KnownSymbol)
+import Data.Maybe (Maybe(..))
+import Data.Set (Set)
 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
 import qualified Data.Functor as Functor
 import qualified Language.Haskell.TH as TH
@@ -22,15 +20,14 @@ import qualified Language.Haskell.TH as TH
 import Symantic.Parser.Grammar
 import Symantic.Parser.Machine.Input
 import Symantic.Parser.Machine.Instructions
-import Symantic.Univariant.Trans
+import Symantic.Typed.Trans
 
 -- * Data family 'Instr'
 -- | 'Instr'uctions of the 'Machine'.
 -- This is an extensible data-type.
 data family Instr
   (instr :: ReprInstr -> Constraint)
-  (repr :: ReprInstr)
-  :: ReprInstr
+  :: ReprInstr -> ReprInstr
 
 -- | Convenient utility to pattern-match a 'SomeInstr'.
 pattern Instr :: Typeable comb =>
@@ -49,10 +46,12 @@ pattern Instr x <- (unSomeInstr -> Just x)
 -- As in 'SomeComb', a first pass of optimizations
 -- is directly applied in it
 -- to avoid introducing an extra newtype,
--- this also give a more comprehensible code.
+-- this also give a more undestandable code.
 data SomeInstr repr inp vs a =
   forall instr.
-  (Trans (Instr instr repr inp vs) (repr inp vs), Typeable instr) =>
+  ( Trans (Instr instr repr inp vs) (repr inp vs)
+  , Typeable instr
+  ) =>
   SomeInstr (Instr instr repr inp vs a)
 
 instance Trans (SomeInstr repr inp vs) (repr inp vs) where
@@ -74,14 +73,14 @@ unSomeInstr (SomeInstr (i::Instr i repr inp vs a)) =
 -- InstrValuable
 data instance Instr InstrValuable repr inp vs a where
   PushValue ::
-    TermInstr v ->
+    Splice v ->
     SomeInstr repr inp (v ': vs) a ->
     Instr InstrValuable repr inp vs a
   PopValue ::
     SomeInstr repr inp vs a ->
     Instr InstrValuable repr inp (v ': vs) a
   Lift2Value ::
-    TermInstr (x -> y -> z) ->
+    Splice (x -> y -> z) ->
     SomeInstr repr inp (z : vs) a ->
     Instr InstrValuable repr inp (y : x : vs) a
   SwapValue ::
@@ -94,6 +93,7 @@ instance InstrValuable repr => Trans (Instr InstrValuable repr inp vs) (repr inp
     Lift2Value f k -> lift2Value f (trans k)
     SwapValue k -> swapValue (trans k)
 instance InstrValuable repr => InstrValuable (SomeInstr repr) where
+  -- 'PopValue' after a 'PushValue' is a no-op.
   pushValue _v (Instr (PopValue i)) = i
   pushValue v i = SomeInstr (PushValue v i)
   popValue = SomeInstr . PopValue
@@ -102,31 +102,32 @@ instance InstrValuable repr => InstrValuable (SomeInstr repr) where
 
 -- InstrExceptionable
 data instance Instr InstrExceptionable repr inp vs a where
-  RaiseException ::
-    KnownSymbol lbl =>
-    Proxy lbl ->
-    [ErrorItem (InputToken inp)] ->
+  Raise ::
+    ExceptionLabel ->
+    Instr InstrExceptionable repr inp vs a
+  Fail ::
+    Set SomeFailure ->
     Instr InstrExceptionable repr inp vs a
-  PopException ::
-    KnownSymbol lbl =>
-    Proxy lbl ->
+  Commit ::
+    Exception ->
     SomeInstr repr inp vs ret ->
     Instr InstrExceptionable repr inp vs ret
-  CatchException ::
-    KnownSymbol lbl =>
-    Proxy lbl ->
+  Catch ::
+    Exception ->
     SomeInstr repr inp vs ret ->
     SomeInstr repr inp (Cursor inp ': vs) ret ->
     Instr InstrExceptionable repr inp vs ret
 instance InstrExceptionable repr => Trans (Instr InstrExceptionable repr inp vs) (repr inp vs) where
   trans = \case
-    RaiseException lbl err -> raiseException lbl err
-    PopException lbl k -> popException lbl (trans k)
-    CatchException lbl l r -> catchException lbl (trans l) (trans r)
+    Raise exn -> raise exn
+    Fail fs -> fail fs
+    Commit exn k -> commit exn (trans k)
+    Catch exn l r -> catch exn (trans l) (trans r)
 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
-  raiseException lbl = SomeInstr . RaiseException lbl
-  popException lbl = SomeInstr . PopException lbl
-  catchException lbl x = SomeInstr . CatchException lbl x
+  raise = SomeInstr . Raise
+  fail = SomeInstr . Fail
+  commit exn = SomeInstr . Commit exn
+  catch exn x = SomeInstr . Catch exn x
 
 -- InstrBranchable
 data instance Instr InstrBranchable repr inp vs a where
@@ -135,7 +136,7 @@ data instance Instr InstrBranchable repr inp vs a where
     SomeInstr repr inp (y ': vs) a ->
     Instr InstrBranchable repr inp (Either x y ': vs) a
   ChoicesBranch ::
-    [TermInstr (v -> Bool)] ->
+    [Splice (v -> Bool)] ->
     [SomeInstr repr inp vs a] ->
     SomeInstr repr inp vs a ->
     Instr InstrBranchable repr inp (v ': vs) a
@@ -211,16 +212,16 @@ instance InstrInputable repr => InstrInputable (SomeInstr repr) where
 -- InstrReadable
 data instance Instr (InstrReadable tok) repr inp vs a where
   Read ::
-    [ErrorItem (InputToken inp)] ->
-    TermInstr (InputToken inp -> Bool) ->
+    Set SomeFailure ->
+    Splice (InputToken inp -> Bool) ->
     SomeInstr repr inp (InputToken inp ': vs) a ->
     Instr (InstrReadable tok) repr inp vs a
 instance
   ( InstrReadable tok repr, tok ~ InputToken inp ) =>
   Trans (Instr (InstrReadable tok) repr inp vs) (repr inp vs) where
   trans = \case
-    Read es p k -> read es p (trans k)
+    Read fs p k -> read fs p (trans k)
 instance
   ( InstrReadable tok repr, Typeable tok ) =>
   InstrReadable tok (SomeInstr repr) where
-  read es p = SomeInstr . Read es p
+  read fs p = SomeInstr . Read fs p