impl: make `HideName` support newer constructors

[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 81c4f537f25d510213ce6b3d0be4f9bf53b5befb..9f71142b3bbaba8751e33cfe5c0f0f158100fb57 100644 (file)
--- a/src/Symantic/Parser/Machine/Optimize.hs
+++ b/src/Symantic/Parser/Machine/Optimize.hs
@@ -7,17 +7,19 @@
 -- is also useful to optimize with more context in the 'Machine'.
 module Symantic.Parser.Machine.Optimize where
 
+import Data.Bifunctor (second)
 import Data.Bool (Bool(..))
 import Data.Either (Either)
 import Data.Function ((.))
 import Data.Kind (Constraint)
 import Data.Maybe (Maybe(..))
 import Data.Set (Set)
+import Data.String (String)
 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
 import qualified Data.Functor as Functor
 import qualified Language.Haskell.TH as TH
 
-import Symantic.Derive
+import Symantic.Syntaxes.Derive
 import Symantic.Parser.Grammar
 import Symantic.Parser.Machine.Input
 import Symantic.Parser.Machine.Instructions
@@ -31,8 +33,8 @@ data family Instr
 type instance Derived (Instr instr repr inp vs) = repr inp vs
 
 -- | Convenient utility to pattern-match a 'SomeInstr'.
-pattern Instr :: Typeable comb =>
-  Instr comb repr inp vs a ->
+pattern Instr :: Typeable instr =>
+  Instr instr repr inp vs a ->
   SomeInstr repr inp vs a
 pattern Instr x <- (unSomeInstr -> Just x)
 
@@ -47,21 +49,20 @@ 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 gives a more undestandable code.
+-- this also gives a more understandable code.
 data SomeInstr repr inp vs a =
   forall instr.
   ( Derivable (Instr instr repr inp vs)
   , Typeable instr
-  ) =>
-  SomeInstr (Instr instr repr inp vs a)
+  ) => SomeInstr (Instr instr repr inp vs a)
 
 type instance Derived (SomeInstr repr inp vs) = repr inp vs
 instance Derivable (SomeInstr repr inp vs) where
   derive (SomeInstr x) = derive x
 
--- | @(unSomeInstr i :: 'Maybe' ('Instr' comb repr inp vs a))@
+-- | @(unSomeInstr i :: 'Maybe' ('Instr' instr repr inp vs a))@
 -- extract the data-constructor from the given 'SomeInstr'
--- iif. it belongs to the @('Instr' comb repr a)@ data-instance.
+-- iif. it belongs to the @('Instr' instr repr a)@ data-instance.
 unSomeInstr ::
   forall instr repr inp vs a.
   Typeable instr =>
@@ -70,7 +71,22 @@ unSomeInstr ::
 unSomeInstr (SomeInstr (i::Instr i repr inp vs a)) =
   case typeRep @instr `eqTypeRep` typeRep @i of
     Just HRefl -> Just i
-    Nothing -> Nothing
+    Nothing ->
+      case typeRep @InstrComment `eqTypeRep` typeRep @i of
+        Just HRefl | Comment _msg x <- i -> unSomeInstr x
+        Nothing -> Nothing
+
+-- InstrComment
+data instance Instr InstrComment repr inp vs a where
+  Comment ::
+    String ->
+    SomeInstr repr inp vs a ->
+    Instr InstrComment repr inp vs a
+instance InstrComment repr => Derivable (Instr InstrComment repr inp vs) where
+  derive = \case
+    Comment msg k -> comment msg (derive k)
+instance InstrComment repr => InstrComment (SomeInstr repr) where
+  comment msg = SomeInstr . Comment msg
 
 -- InstrValuable
 data instance Instr InstrValuable repr inp vs a where
@@ -117,7 +133,7 @@ data instance Instr InstrExceptionable repr inp vs a where
   Catch ::
     Exception ->
     SomeInstr repr inp vs ret ->
-    SomeInstr repr inp (Cursor inp ': vs) ret ->
+    SomeInstr repr inp (InputPosition inp ': vs) ret ->
     Instr InstrExceptionable repr inp vs ret
 instance InstrExceptionable repr => Derivable (Instr InstrExceptionable repr inp vs) where
   derive = \case
@@ -144,7 +160,7 @@ data instance Instr InstrBranchable repr inp vs a where
 instance InstrBranchable repr => Derivable (Instr InstrBranchable repr inp vs) where
   derive = \case
     CaseBranch l r -> caseBranch (derive l) (derive r)
-    ChoicesBranch bs d -> choicesBranch ((\(p,b) -> (p, derive b)) Functor.<$> bs) (derive d)
+    ChoicesBranch bs d -> choicesBranch (second derive Functor.<$> bs) (derive d)
 instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
   caseBranch l = SomeInstr . CaseBranch l
   choicesBranch bs = SomeInstr . ChoicesBranch bs
@@ -199,17 +215,17 @@ instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
 -- InstrInputable
 data instance Instr InstrInputable repr inp vs a where
   PushInput ::
-    SomeInstr repr inp (Cursor inp ': vs) a ->
+    SomeInstr repr inp (InputPosition inp ': vs) a ->
     Instr InstrInputable repr inp vs a
   LoadInput ::
     SomeInstr repr inp vs a ->
-    Instr InstrInputable repr inp (Cursor inp ': vs) a
+    Instr InstrInputable repr inp (InputPosition inp ': vs) a
 instance InstrInputable repr => Derivable (Instr InstrInputable repr inp vs) where
   derive = \case
-    PushInput k -> pushInput (derive k)
+    PushInput k -> saveInput (derive k)
     LoadInput k -> loadInput (derive k)
 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
-  pushInput = SomeInstr . PushInput
+  saveInput = SomeInstr . PushInput
   loadInput = SomeInstr . LoadInput
 
 -- InstrReadable
@@ -234,7 +250,7 @@ data instance Instr InstrIterable repr inp vs a where
   Iter ::
     LetName a ->
     SomeInstr repr inp '[] a ->
-    SomeInstr repr inp (Cursor inp ': vs) a ->
+    SomeInstr repr inp (InputPosition inp ': vs) a ->
     Instr InstrIterable repr inp vs a
 instance
   InstrIterable repr =>