doc: clarify the scope of HideName instances
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / View.hs
index ef88c372539d8fad34b298906e92c0e558c125f5..2f87a5168e0b4239d10b44bff6b522abbc1f8f49 100644 (file)
@@ -8,23 +8,28 @@ import Data.Ord (Ord(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (String)
 import Data.Tuple (fst)
+import Language.Haskell.TH.HideName
 import Text.Show (Show(..))
 import qualified Data.Functor as Functor
 import qualified Data.HashMap.Strict as HM
 import qualified Data.List as List
 import qualified Data.Tree as Tree
 
-import Symantic.Typed.ObserveSharing
+import Symantic.Semantics.SharingObserver
+import Symantic.Semantics.Data (normalOrderReduction)
 import Symantic.Parser.Grammar.Combinators
+import Symantic.Parser.Grammar.SharingObserver
 import qualified Symantic.Parser.Grammar.Production as Prod
 
 -- * Type 'ViewGrammar'
-newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
-  Tree.Tree (String, String) }
+newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar :: Tree.Tree (String, String) }
 
 viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
 viewGrammar = id
 
+showProduction :: Prod.Production '[] a -> String
+showProduction p = showsPrec 10 (normalOrderReduction (Prod.prodCode p)) ""
+
 instance Show (ViewGrammar sN a) where
   show = List.unlines . draw . unViewGrammar
     where
@@ -47,7 +52,7 @@ instance CombAlternable (ViewGrammar sN) where
   try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
 instance CombApplicable (ViewGrammar sN) where
   _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
-  pure a = ViewGrammar $ Tree.Node ("pure " <> showsPrec 10 (Prod.prodCode a) "", "") []
+  pure a = ViewGrammar $ Tree.Node ("pure "<>showProduction a, "") []
   x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
   x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
   x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
@@ -55,38 +60,44 @@ instance CombFoldable (ViewGrammar sN) where
   chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
   chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]
 instance
-  ShowLetName sN letName =>
-  Letable letName (ViewGrammar sN) where
-  shareable name x = ViewGrammar $
-    Tree.Node ("shareable", " "<>showLetName @sN name) [unViewGrammar x]
+  ( Show letName
+  , HideName letName
+  , HideableName sN
+  ) => Referenceable letName (ViewGrammar sN) where
   ref isRec name = ViewGrammar $
     Tree.Node
       ( if isRec then "rec" else "ref"
-      , " "<>showLetName @sN name
+      , " "<>show (hideableName @sN name)
       ) []
 instance
-  ShowLetName sN letName =>
-  Letsable letName (ViewGrammar sN) where
+  ( Show letName
+  , HideName letName
+  , HideableName sN
+  ) => Letsable letName (ViewGrammar sN) where
   lets defs x = ViewGrammar $
     Tree.Node ("lets", "") $
       (<> [unViewGrammar x]) $
       List.sortBy (compare `on` (((fst Functor.<$>) Functor.<$>) . Tree.levels)) $
       HM.foldrWithKey'
         (\name (SomeLet val) ->
-          (Tree.Node ("let", " "<>showLetName @sN name) [unViewGrammar val] :))
+          (Tree.Node ("let", " "<>show (hideableName @sN name)) [unViewGrammar val] :))
         [] defs
 instance CombLookable (ViewGrammar sN) where
   look x = ViewGrammar $ Tree.Node ("look", "") [unViewGrammar x]
   negLook x = ViewGrammar $ Tree.Node ("negLook", "") [unViewGrammar x]
   eof = ViewGrammar $ Tree.Node ("eof", "") []
 instance CombMatchable (ViewGrammar sN) where
-  conditional a _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
-    [ unViewGrammar a
-    , Tree.Node ("branches", "") (unViewGrammar Functor.<$> bs)
-    , unViewGrammar b
-    ]
+  conditional a bs d = ViewGrammar $ Tree.Node ("conditional", "")
+    $ Tree.Node ("condition", "") [unViewGrammar a]
+    : Tree.Node ("default", "") [unViewGrammar d]
+    : ((\(p,b) -> Tree.Node ("branch "<>showProduction p, "") [unViewGrammar b]) Functor.<$> bs)
 instance CombSatisfiable tok (ViewGrammar sN) where
-  satisfyOrFail _fs _p = ViewGrammar $ Tree.Node ("satisfy", "") []
+  satisfyOrFail _fs p = ViewGrammar $ Tree.Node
+    ("satisfy "<>showProduction p, "") []
 instance CombSelectable (ViewGrammar sN) where
   branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
     [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
+instance CombRegisterableUnscoped (ViewGrammar sN) where
+  newUnscoped r x y = ViewGrammar $ Tree.Node ("new "<>show r, "") [ unViewGrammar x,  unViewGrammar y ]
+  getUnscoped r = ViewGrammar $ Tree.Node ("get "<>show r, "") [ ]
+  putUnscoped r x = ViewGrammar $ Tree.Node ("put "<>show r, "") [ unViewGrammar x ]