+{-# LANGUAGE OverloadedStrings #-}
module Symantic.Parser.Grammar.View where
import Data.Bool (Bool)
-import Data.Function (($), (.), id)
+import Data.Eq (Eq(..))
+import Data.Function (($), (.), id, on)
+import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String, IsString(..))
+import Data.String (String)
+import Data.Tuple (fst)
+import Language.Haskell.TH.HideName
import Text.Show (Show(..))
-import qualified Control.Applicative as Fct
-import qualified Data.Tree as Tree
+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.Univariant.Letable
+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 }
+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 = drawTree . unViewGrammar
+ show = List.unlines . draw . unViewGrammar
where
- drawTree :: Tree.Tree String -> String
- drawTree = List.unlines . draw
- draw :: Tree.Tree String -> [String]
- draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
- where
- drawSubTrees [] = []
- drawSubTrees [t] = shift "` " " " (draw t)
- drawSubTrees (t:ts) = shift "+ " "| " (draw t) <> drawSubTrees ts
- shift first other = List.zipWith (<>) (first : List.repeat other)
-instance IsString (ViewGrammar sN a) where
- fromString s = ViewGrammar $ Tree.Node (fromString s) []
+ draw :: Tree.Tree (String, String) -> [String]
+ draw (Tree.Node (x, n) ts0) =
+ (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
+ (drawTrees ts0)
+ drawTrees [] = []
+ drawTrees [t] = shift "` " " " (draw t)
+ drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
+ shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
+instance CombAlternable (ViewGrammar sN) where
+ empty = ViewGrammar $ Tree.Node ("empty", "") []
+ alt exn x y = ViewGrammar $ Tree.Node
+ ("<|>" <> if exn == ExceptionFailure then "" else ("^"<>show exn), "")
+ [unViewGrammar x, unViewGrammar y]
+ throw exn = ViewGrammar $ Tree.Node ("throw "<>show exn, "") []
+ failure _sf = ViewGrammar $ Tree.Node ("failure", "") []
+ 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 "<>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]
+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
- def name x = ViewGrammar $
- Tree.Node ("def "<>showLetName @sN name) [unViewGrammar x]
- ref rec name = ViewGrammar $
+ ( Show letName
+ , HideName letName
+ , HideableName sN
+ ) => Referenceable letName (ViewGrammar sN) where
+ ref isRec name = ViewGrammar $
Tree.Node
- ( (if rec then "rec " else "ref ")
- <> showLetName @sN name
+ ( if isRec then "rec" else "ref"
+ , " "<>show (hideableName @sN name)
) []
-instance Applicable (ViewGrammar sN) where
- _f <$> x = ViewGrammar $ Tree.Node "<$>" [unViewGrammar x]
- pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 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]
-instance Alternable (ViewGrammar sN) where
- empty = ViewGrammar $ Tree.Node "empty" []
- x <|> y = ViewGrammar $ Tree.Node "<|>" [unViewGrammar x, unViewGrammar y]
- try x = ViewGrammar $ Tree.Node "try" [unViewGrammar x]
-instance Satisfiable tok (ViewGrammar sN) where
- satisfy _es _p = ViewGrammar $ Tree.Node "satisfy" []
-instance Selectable (ViewGrammar sN) where
- branch lr l r = ViewGrammar $ Tree.Node "branch"
+instance
+ ( 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", " "<>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 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 "<>showProduction p, "") []
+instance CombSelectable (ViewGrammar sN) where
+ branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
[ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
-instance Matchable (ViewGrammar sN) where
- conditional a _ps bs b = ViewGrammar $ Tree.Node "conditional"
- [ unViewGrammar a
- , Tree.Node "bs" (unViewGrammar Fct.<$> bs)
- , unViewGrammar b
- ]
-instance Lookable (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 Foldable (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 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 ]
sourcephile / git / haskell / symantic-parser.git / blobdiff