1 module Symantic.Parser.Grammar.View where
3 import Data.Bool (Bool)
4 import Data.Function (($), (.), id, on)
5 import Data.Ord (Ord(..))
6 import Data.Semigroup (Semigroup(..))
7 import Data.String (String)
8 import Data.Tuple (fst)
9 import Text.Show (Show(..))
10 import qualified Control.Applicative as Fct
11 import qualified Data.Functor as Functor
12 import qualified Data.HashMap.Strict as HM
13 import qualified Data.List as List
14 import qualified Data.Tree as Tree
16 import Symantic.Univariant.Letable
17 import Symantic.Parser.Grammar.Combinators
19 -- * Type 'ViewGrammar'
20 newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
21 Tree.Tree (String, String) }
23 viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
26 instance Show (ViewGrammar sN a) where
27 show = List.unlines . draw . unViewGrammar
29 draw :: Tree.Tree (String, String) -> [String]
30 draw (Tree.Node (x, n) ts0) =
31 (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
34 drawTrees [t] = shift "` " " " (draw t)
35 drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
36 shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
39 ShowLetName sN letName =>
40 Letable letName (ViewGrammar sN) where
41 shareable name x = ViewGrammar $
42 Tree.Node ("shareable", " "<>showLetName @sN name) [unViewGrammar x]
43 ref isRec name = ViewGrammar $
45 ( if isRec then "rec" else "ref"
46 , " "<>showLetName @sN name
49 ShowLetName sN letName =>
50 Letsable letName (ViewGrammar sN) where
51 lets defs x = ViewGrammar $
52 Tree.Node ("lets", "") $
53 (<> [unViewGrammar x]) $
54 List.sortBy (compare `on` (((fst Functor.<$>) Functor.<$>) . Tree.levels)) $
56 (\name (SomeLet val) ->
57 (Tree.Node ("let", " "<>showLetName @sN name) [unViewGrammar val] :))
59 instance Applicable (ViewGrammar sN) where
60 _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
61 pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "", "") []
62 x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
63 x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
64 x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
65 instance Alternable (ViewGrammar sN) where
66 empty = ViewGrammar $ Tree.Node ("empty", "") []
67 x <|> y = ViewGrammar $ Tree.Node ("<|>", "") [unViewGrammar x, unViewGrammar y]
68 try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
69 instance Satisfiable tok (ViewGrammar sN) where
70 satisfy _es _p = ViewGrammar $ Tree.Node ("satisfy", "") []
71 instance Selectable (ViewGrammar sN) where
72 branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
73 [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
74 instance Matchable (ViewGrammar sN) where
75 conditional a _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
77 , Tree.Node ("branches", "") (unViewGrammar Fct.<$> bs)
80 instance Lookable (ViewGrammar sN) where
81 look x = ViewGrammar $ Tree.Node ("look", "") [unViewGrammar x]
82 negLook x = ViewGrammar $ Tree.Node ("negLook", "") [unViewGrammar x]
83 eof = ViewGrammar $ Tree.Node ("eof", "") []
84 instance Foldable (ViewGrammar sN) where
85 chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
86 chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]