]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Write.hs
Polish
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Write.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 module Symantic.Parser.Grammar.Write where
3
4 import Data.Function (($))
5 import qualified Data.Functor as Pre
6 import Control.Monad (Monad(..))
7 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
8 import Data.String (IsString(..))
9 import Data.Semigroup (Semigroup(..))
10 import Data.Monoid (Monoid(..))
11 import Text.Show (Show(..))
12 import qualified Data.List as List
13 import qualified Data.Text.Lazy as TL
14 import qualified Data.Text.Lazy.Builder as TLB
15
16 import Symantic.Base.Fixity
17 import Symantic.Univariant.Letable
18 import Symantic.Parser.Grammar.Combinators
19
20 -- * Type 'WriteGrammar'
21 newtype WriteGrammar a = WriteGrammar { unWriteGrammar :: WriteGrammarInh -> Maybe TLB.Builder }
22
23 instance IsString (WriteGrammar a) where
24 fromString s = WriteGrammar $ \_inh ->
25 if List.null s then Nothing
26 else Just (fromString s)
27
28 -- ** Type 'WriteGrammarInh'
29 data WriteGrammarInh
30 = WriteGrammarInh
31 { writeGrammarInh_indent :: TLB.Builder
32 , writeGrammarInh_op :: (Infix, Side)
33 , writeGrammarInh_pair :: Pair
34 }
35
36 emptyWriteGrammarInh :: WriteGrammarInh
37 emptyWriteGrammarInh = WriteGrammarInh
38 { writeGrammarInh_indent = "\n"
39 , writeGrammarInh_op = (infixN0, SideL)
40 , writeGrammarInh_pair = pairParen
41 }
42
43 writeGrammar :: WriteGrammar a -> TL.Text
44 writeGrammar (WriteGrammar r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteGrammarInh
45
46 pairWriteGrammarInh ::
47 Semigroup s => IsString s =>
48 WriteGrammarInh -> Infix -> Maybe s -> Maybe s
49 pairWriteGrammarInh inh op s =
50 if isPairNeeded (writeGrammarInh_op inh) op
51 then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
52 else s
53 where (o,c) = writeGrammarInh_pair inh
54
55 instance Show letName => Letable letName WriteGrammar where
56 def name x = WriteGrammar $ \inh ->
57 pairWriteGrammarInh inh op $
58 Just "def "
59 <> Just (fromString (show name))
60 <> unWriteGrammar x inh
61 where
62 op = infixN 9
63 ref rec name = WriteGrammar $ \inh ->
64 pairWriteGrammarInh inh op $
65 Just (if rec then "rec " else "ref ") <>
66 Just (fromString (show name))
67 where
68 op = infixN 9
69 instance Applicable WriteGrammar where
70 pure _ = WriteGrammar $ return Nothing
71 -- pure _ = "pure"
72 WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
73 let inh' side = inh
74 { writeGrammarInh_op = (op, side)
75 , writeGrammarInh_pair = pairParen
76 } in
77 case x (inh' SideL) of
78 Nothing -> y (inh' SideR)
79 Just xt ->
80 case y (inh' SideR) of
81 Nothing -> Just xt
82 Just yt ->
83 pairWriteGrammarInh inh op $
84 Just $ xt <> ", " <> yt
85 where
86 op = infixN 1
87 instance Alternable WriteGrammar where
88 empty = "empty"
89 try x = WriteGrammar $ \inh ->
90 pairWriteGrammarInh inh op $
91 Just "try " <> unWriteGrammar x inh
92 where
93 op = infixN 9
94 x <|> y = WriteGrammar $ \inh ->
95 pairWriteGrammarInh inh op $
96 unWriteGrammar x inh
97 { writeGrammarInh_op = (op, SideL)
98 , writeGrammarInh_pair = pairParen
99 } <>
100 Just " | " <>
101 unWriteGrammar y inh
102 { writeGrammarInh_op = (op, SideR)
103 , writeGrammarInh_pair = pairParen
104 }
105 where op = infixB SideL 3
106 instance Charable WriteGrammar where
107 satisfy _f = "sat"
108 instance Selectable WriteGrammar where
109 branch lr l r = WriteGrammar $ \inh ->
110 pairWriteGrammarInh inh op $
111 Just "branch " <>
112 unWriteGrammar lr inh <> Just " " <>
113 unWriteGrammar l inh <> Just " " <>
114 unWriteGrammar r inh
115 where
116 op = infixN 9
117 instance Matchable WriteGrammar where
118 conditional _cs bs a b = WriteGrammar $ \inh ->
119 pairWriteGrammarInh inh op $
120 Just "conditional " <>
121 Just "[" <>
122 Just (mconcat (List.intersperse ", " $
123 catMaybes $ (Pre.<$> bs) $ \x ->
124 unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
125 Just "] " <>
126 unWriteGrammar a inh <> Just " " <>
127 unWriteGrammar b inh
128 where
129 op = infixN 9
130 instance Lookable WriteGrammar where
131 look x = WriteGrammar $ \inh ->
132 pairWriteGrammarInh inh op $
133 Just "look " <> unWriteGrammar x inh
134 where op = infixN 9
135 negLook x = WriteGrammar $ \inh ->
136 pairWriteGrammarInh inh op $
137 Just "negLook " <> unWriteGrammar x inh
138 where op = infixN 9
139 instance Foldable WriteGrammar where
140 chainPre f x = WriteGrammar $ \inh ->
141 pairWriteGrammarInh inh op $
142 Just "chainPre " <>
143 unWriteGrammar f inh <> Just " " <>
144 unWriteGrammar x inh
145 where op = infixN 9
146 chainPost f x = WriteGrammar $ \inh ->
147 pairWriteGrammarInh inh op $
148 Just "chainPost " <>
149 unWriteGrammar f inh <> Just " " <>
150 unWriteGrammar x inh
151 where op = infixN 9