]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Write.hs
rename Symantic.{Univariant => Typed}
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Write.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 module Symantic.Parser.Grammar.Write where
3
4 import Data.Bool (Bool(..))
5 import Control.Monad (Monad(..))
6 import Data.Function (($))
7 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
8 import Data.Monoid (Monoid(..))
9 import Data.Semigroup (Semigroup(..))
10 import Data.String (IsString(..))
11 import Text.Show (Show(..))
12 import qualified Data.Functor as Functor
13 import qualified Data.HashMap.Strict as HM
14 import qualified Data.List as List
15 import qualified Data.Text.Lazy as TL
16 import qualified Data.Text.Lazy.Builder as TLB
17
18 import Symantic.Typed.Letable
19 import Symantic.Parser.Grammar.Combinators
20 import Symantic.Parser.Grammar.Fixity
21
22 -- * Type 'WriteGrammar'
23 newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar ::
24 WriteGrammarInh -> Maybe TLB.Builder }
25
26 instance IsString (WriteGrammar sN a) where
27 fromString s = WriteGrammar $ \_inh ->
28 if List.null s then Nothing
29 else Just (fromString s)
30
31 -- ** Type 'WriteGrammarInh'
32 data WriteGrammarInh
33 = WriteGrammarInh
34 { writeGrammarInh_indent :: TLB.Builder
35 , writeGrammarInh_op :: (Infix, Side)
36 , writeGrammarInh_pair :: Pair
37 }
38
39 emptyWriteGrammarInh :: WriteGrammarInh
40 emptyWriteGrammarInh = WriteGrammarInh
41 { writeGrammarInh_indent = "\n"
42 , writeGrammarInh_op = (infixN0, SideL)
43 , writeGrammarInh_pair = pairParen
44 }
45
46 writeGrammar :: WriteGrammar sN a -> TL.Text
47 writeGrammar (WriteGrammar go) =
48 TLB.toLazyText $ fromMaybe "" $
49 go emptyWriteGrammarInh
50
51 pairWriteGrammarInh ::
52 Semigroup s => IsString s =>
53 WriteGrammarInh -> Infix -> Maybe s -> Maybe s
54 pairWriteGrammarInh inh op s =
55 if isPairNeeded (writeGrammarInh_op inh) op
56 then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
57 else s
58 where (o,c) = writeGrammarInh_pair inh
59
60 instance CombAlternable (WriteGrammar sN) where
61 alt exn x y = WriteGrammar $ \inh ->
62 pairWriteGrammarInh inh op $
63 unWriteGrammar x inh
64 { writeGrammarInh_op = (op, SideL)
65 , writeGrammarInh_pair = pairParen
66 } <>
67 Just (" |^"<>fromString (show exn)<>" ") <>
68 unWriteGrammar y inh
69 { writeGrammarInh_op = (op, SideR)
70 , writeGrammarInh_pair = pairParen
71 }
72 where op = infixB SideL 3
73 throw exn = WriteGrammar $ \inh ->
74 pairWriteGrammarInh inh op $
75 Just ("throw "<>fromString (show exn))
76 where
77 op = infixN 9
78 failure _sf = "failure"
79 empty = "empty"
80 try x = WriteGrammar $ \inh ->
81 pairWriteGrammarInh inh op $
82 Just "try " <> unWriteGrammar x inh
83 where
84 op = infixN 9
85 instance CombApplicable (WriteGrammar sN) where
86 pure _ = WriteGrammar $ return Nothing
87 -- pure _ = "pure"
88 WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
89 let inh' side = inh
90 { writeGrammarInh_op = (op, side)
91 , writeGrammarInh_pair = pairParen
92 } in
93 case x (inh' SideL) of
94 Nothing -> y (inh' SideR)
95 Just xt ->
96 case y (inh' SideR) of
97 Nothing -> Just xt
98 Just yt ->
99 pairWriteGrammarInh inh op $
100 Just $ xt <> ", " <> yt
101 where
102 op = infixN 1
103 instance CombFoldable (WriteGrammar sN) where
104 chainPre f x = WriteGrammar $ \inh ->
105 pairWriteGrammarInh inh op $
106 Just "chainPre " <>
107 unWriteGrammar f inh <> Just " " <>
108 unWriteGrammar x inh
109 where op = infixN 9
110 chainPost f x = WriteGrammar $ \inh ->
111 pairWriteGrammarInh inh op $
112 Just "chainPost " <>
113 unWriteGrammar f inh <> Just " " <>
114 unWriteGrammar x inh
115 where op = infixN 9
116 instance
117 ShowLetName sN letName =>
118 Letable letName (WriteGrammar sN) where
119 shareable name x = WriteGrammar $ \inh ->
120 pairWriteGrammarInh inh op $
121 Just "shareable "
122 <> Just (fromString (showLetName @sN name))
123 <> unWriteGrammar x inh
124 where
125 op = infixN 9
126 ref rec name = WriteGrammar $ \inh ->
127 pairWriteGrammarInh inh op $
128 Just (if rec then "rec " else "ref ") <>
129 Just (fromString (showLetName @sN name))
130 where
131 op = infixN 9
132 instance
133 ShowLetName sN letName =>
134 Letsable letName (WriteGrammar sN) where
135 lets defs x = WriteGrammar $ \inh ->
136 pairWriteGrammarInh inh op $
137 Just "let "
138 <> HM.foldMapWithKey
139 (\name (SomeLet val) ->
140 Just (fromString (showLetName @sN name))
141 <> unWriteGrammar val inh)
142 defs
143 <> unWriteGrammar x inh
144 where
145 op = infixN 9
146 instance CombLookable (WriteGrammar sN) where
147 look x = WriteGrammar $ \inh ->
148 pairWriteGrammarInh inh op $
149 Just "look " <> unWriteGrammar x inh
150 where op = infixN 9
151 negLook x = WriteGrammar $ \inh ->
152 pairWriteGrammarInh inh op $
153 Just "negLook " <> unWriteGrammar x inh
154 where op = infixN 9
155 eof = "eof"
156 instance CombMatchable (WriteGrammar sN) where
157 conditional a _ps bs d = WriteGrammar $ \inh ->
158 pairWriteGrammarInh inh op $
159 Just "conditional " <>
160 unWriteGrammar a inh <>
161 Just " [" <>
162 Just (mconcat (List.intersperse ", " $
163 catMaybes $ (Functor.<$> bs) $ \x ->
164 unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
165 Just "] " <>
166 unWriteGrammar d inh
167 where
168 op = infixN 9
169 instance CombSatisfiable tok (WriteGrammar sN) where
170 satisfyOrFail _fs _f = "satisfy"
171 instance CombSelectable (WriteGrammar sN) where
172 branch lr l r = WriteGrammar $ \inh ->
173 pairWriteGrammarInh inh op $
174 Just "branch " <>
175 unWriteGrammar lr inh <> Just " " <>
176 unWriteGrammar l inh <> Just " " <>
177 unWriteGrammar r inh
178 where
179 op = infixN 9