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