]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Write.hs
bump to ghc-9.0.1 to get a levity-polymorphic CodeQ
[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 Charable WriteComb where
107 satisfy _f = "sat"
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 _ps bs a d = WriteComb $ \inh ->
119 pairWriteCombInh inh op $
120 Just "conditional " <>
121 Just "[" <>
122 Just (mconcat (List.intersperse ", " $
123 catMaybes $ (Pre.<$> bs) $ \x ->
124 unWriteComb x inh{writeCombInh_op=(infixN 0, SideL)})) <>
125 Just "] " <>
126 unWriteComb a inh <> 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 instance Foldable WriteComb where
140 chainPre f x = WriteComb $ \inh ->
141 pairWriteCombInh inh op $
142 Just "chainPre " <>
143 unWriteComb f inh <> Just " " <>
144 unWriteComb x inh
145 where op = infixN 9
146 chainPost f x = WriteComb $ \inh ->
147 pairWriteCombInh inh op $
148 Just "chainPost " <>
149 unWriteComb f inh <> Just " " <>
150 unWriteComb x inh
151 where op = infixN 9