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