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
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]
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 ]