]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/View.hs
grammar: open the Comb data-type
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / View.hs
1 module Symantic.Parser.Grammar.View where
2
3 import Data.Function (($), (.), id)
4 import Data.Semigroup (Semigroup(..))
5 import Data.String (String, IsString(..))
6 import Text.Show (Show(..))
7 import qualified Control.Applicative as Fct
8 import qualified Data.Tree as Tree
9 import qualified Data.List as List
10
11 import Symantic.Univariant.Letable
12 import Symantic.Parser.Grammar.Combinators
13
14 -- * Type 'ViewGrammar'
15 newtype ViewGrammar a = ViewGrammar { unViewGrammar :: Tree.Tree String }
16
17 viewGrammar :: ViewGrammar a -> ViewGrammar a
18 viewGrammar = id
19
20 instance Show (ViewGrammar a) where
21 show = drawTree . unViewGrammar
22 where
23 drawTree :: Tree.Tree String -> String
24 drawTree = List.unlines . draw
25 draw :: Tree.Tree String -> [String]
26 draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0
27 where
28 drawSubTrees [] = []
29 drawSubTrees [t] = shift "` " " " (draw t)
30 drawSubTrees (t:ts) = shift "+ " "| " (draw t) <> drawSubTrees ts
31 shift first other = List.zipWith (<>) (first : List.repeat other)
32 instance IsString (ViewGrammar a) where
33 fromString s = ViewGrammar $ Tree.Node (fromString s) []
34
35 instance Show letName => Letable letName ViewGrammar where
36 def name x = ViewGrammar $
37 Tree.Node ("def "<>show name) [unViewGrammar x]
38 ref rec name = ViewGrammar $
39 Tree.Node
40 ( (if rec then "rec " else "ref ")
41 <> show name
42 ) []
43 instance Applicable ViewGrammar where
44 _f <$> x = ViewGrammar $ Tree.Node "<$>" [unViewGrammar x]
45 pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "") []
46 x <*> y = ViewGrammar $ Tree.Node "<*>" [unViewGrammar x, unViewGrammar y]
47 x <* y = ViewGrammar $ Tree.Node "<*" [unViewGrammar x, unViewGrammar y]
48 x *> y = ViewGrammar $ Tree.Node "*>" [unViewGrammar x, unViewGrammar y]
49 instance Alternable ViewGrammar where
50 empty = ViewGrammar $ Tree.Node "empty" []
51 x <|> y = ViewGrammar $ Tree.Node "<|>" [unViewGrammar x, unViewGrammar y]
52 try x = ViewGrammar $ Tree.Node "try" [unViewGrammar x]
53 instance Satisfiable tok ViewGrammar where
54 satisfy _es _p = ViewGrammar $ Tree.Node "satisfy" []
55 instance Selectable ViewGrammar where
56 branch lr l r = ViewGrammar $ Tree.Node "branch"
57 [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
58 instance Matchable ViewGrammar where
59 conditional a _ps bs b = ViewGrammar $ Tree.Node "conditional"
60 [ unViewGrammar a
61 , Tree.Node "bs" (unViewGrammar Fct.<$> bs)
62 , unViewGrammar b
63 ]
64 instance Lookable ViewGrammar where
65 look x = ViewGrammar $ Tree.Node "look" [unViewGrammar x]
66 negLook x = ViewGrammar $ Tree.Node "negLook" [unViewGrammar x]
67 eof = ViewGrammar $ Tree.Node "eof" []
68 instance Foldable ViewGrammar where
69 chainPre f x = ViewGrammar $ Tree.Node "chainPre" [unViewGrammar f, unViewGrammar x]
70 chainPost x f = ViewGrammar $ Tree.Node "chainPost" [unViewGrammar x, unViewGrammar f]