]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/View.hs
replace ValueCode by Production
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / View.hs
1 module Symantic.Parser.Grammar.View where
2
3 import Data.Bool (Bool)
4 import Data.Eq (Eq(..))
5 import Data.Function (($), (.), id, on)
6 import Data.Ord (Ord(..))
7 import Data.Semigroup (Semigroup(..))
8 import Data.String (String)
9 import Data.Tuple (fst)
10 import Text.Show (Show(..))
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
15
16 import Symantic.Univariant.Letable
17 import qualified Symantic.Univariant.Trans as Sym
18 import qualified Symantic.Univariant.Data as Sym
19 import qualified Symantic.Univariant.View as Sym
20 import Symantic.Parser.Grammar.Combinators
21 import qualified Symantic.Parser.Grammar.Production as Prod
22
23 -- * Type 'ViewGrammar'
24 newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
25 Tree.Tree (String, String) }
26
27 viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a
28 viewGrammar = id
29
30 instance Show (ViewGrammar sN a) where
31 show = List.unlines . draw . unViewGrammar
32 where
33 draw :: Tree.Tree (String, String) -> [String]
34 draw (Tree.Node (x, n) ts0) =
35 (List.zipWith (<>) (List.lines x) (n : List.repeat "")) <>
36 (drawTrees ts0)
37 drawTrees [] = []
38 drawTrees [t] = shift "` " " " (draw t)
39 drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
40 shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
41
42 instance CombAlternable (ViewGrammar sN) where
43 empty = ViewGrammar $ Tree.Node ("empty", "") []
44 alt exn x y = ViewGrammar $ Tree.Node
45 ("<|>" <> if exn == ExceptionFailure then "" else ("^"<>show exn), "")
46 [unViewGrammar x, unViewGrammar y]
47 throw exn = ViewGrammar $ Tree.Node ("throw "<>show exn, "") []
48 failure _sf = ViewGrammar $ Tree.Node ("failure", "") []
49 try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
50 instance CombApplicable (ViewGrammar sN) where
51 _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
52 pure a = ViewGrammar $ Tree.Node ("pure "{-FIXME: <>showsPrec 10 a ""-}, "") []
53 x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
54 x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
55 x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
56 instance CombFoldable (ViewGrammar sN) where
57 chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
58 chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]
59 instance
60 ShowLetName sN letName =>
61 Letable letName (ViewGrammar sN) where
62 shareable name x = ViewGrammar $
63 Tree.Node ("shareable", " "<>showLetName @sN name) [unViewGrammar x]
64 ref isRec name = ViewGrammar $
65 Tree.Node
66 ( if isRec then "rec" else "ref"
67 , " "<>showLetName @sN name
68 ) []
69 instance
70 ShowLetName sN letName =>
71 Letsable letName (ViewGrammar sN) where
72 lets defs x = ViewGrammar $
73 Tree.Node ("lets", "") $
74 (<> [unViewGrammar x]) $
75 List.sortBy (compare `on` (((fst Functor.<$>) Functor.<$>) . Tree.levels)) $
76 HM.foldrWithKey'
77 (\name (SomeLet val) ->
78 (Tree.Node ("let", " "<>showLetName @sN name) [unViewGrammar val] :))
79 [] defs
80 instance CombLookable (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 CombMatchable (ViewGrammar sN) where
85 conditional a _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
86 [ unViewGrammar a
87 , Tree.Node ("branches", "") (unViewGrammar Functor.<$> bs)
88 , unViewGrammar b
89 ]
90 instance CombSatisfiable tok (ViewGrammar sN) where
91 satisfyOrFail _fs _p = ViewGrammar $ Tree.Node ("satisfy", "") []
92 instance CombSelectable (ViewGrammar sN) where
93 branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
94 [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]