]> Git — Sourcephile - haskell/symantic.git/blob - symantic/Language/Symantic/Typing/Grammar.hs
Update to lastest symantic-document
[haskell/symantic.git] / symantic / Language / Symantic / Typing / Grammar.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE PolyKinds #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE UndecidableInstances #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Language.Symantic.Typing.Grammar where
7
8 import Control.Applicative (Applicative(..))
9 import Data.List (foldl1')
10 import Data.Map.Strict (Map)
11 import Data.Maybe (fromMaybe)
12 import Data.Semigroup (Semigroup(..))
13 import Data.String (IsString(..))
14 import qualified Data.Char as Char
15 import qualified Data.Map.Strict as Map
16 import qualified Data.Text as Text
17
18 import Language.Symantic.Grammar as G
19 import Language.Symantic.Typing.Kind
20 import Language.Symantic.Typing.Variable
21 import Language.Symantic.Typing.List
22 import Language.Symantic.Typing.Module
23 import Language.Symantic.Typing.Type
24
25 -- * Type 'AST_Type'
26 -- | /Abstract Syntax Tree/ of 'Token_Type'.
27 type AST_Type src = BinTree (Token_Type src)
28
29 -- ** Type 'Token_Type'
30 data Token_Type src
31 = Token_Type_Const (TypeTLen src)
32 | Token_Type_Var (Sourced src NameVar)
33 -- deriving (Eq, Show)
34 instance Source src => Eq (Token_Type src) where
35 Token_Type_Const (TypeTLen x) == Token_Type_Const (TypeTLen y) = x LenZ == y LenZ
36 Token_Type_Var (Sourced _ x) == Token_Type_Var (Sourced _ y) = x == y
37 _ == _ = False
38 instance (Source src, Show (TypeT src '[])) => Show (Token_Type src) where
39 showsPrec p (Token_Type_Const x) =
40 showParen (p >= 10) $
41 showString "Token_Type_Const" .
42 showChar ' ' . showsPrec 10 x
43 showsPrec p (Token_Type_Var (Sourced _ x)) =
44 showParen (p >= 10) $
45 showString "Token_Type_Var" .
46 showChar ' ' . showsPrec 10 x
47
48 -- * Type 'ModulesTy'
49 type ModulesTy src = Map (Mod NameTy) (TypeTLen src)
50
51 -- ** Type 'TypeTLen'
52 -- | Like 'TypeT', but needing a @(@'Len'@ vs)@ to be built.
53 --
54 -- Useful to build a 'ModulesTy' which can be used
55 -- whatever will be the @(@'Len'@ vs)@ given to 'readTyVars'.
56 newtype TypeTLen src = TypeTLen (forall vs. Len vs -> TypeT src vs)
57 instance Source src => Eq (TypeTLen src) where
58 TypeTLen x == TypeTLen y = x LenZ == y LenZ
59 instance (Source src, Show (TypeT src '[])) => Show (TypeTLen src) where
60 showsPrec p (TypeTLen t) = showsPrec p $ t LenZ
61
62 typeTLen ::
63 forall c src.
64 Source src =>
65 Constable c =>
66 KindInjP (Ty_of_Type (K c)) =>
67 K c ~ Type_of_Ty (Ty_of_Type (K c)) =>
68 src ->
69 TypeTLen src
70 typeTLen src =
71 TypeTLen $ \len -> TypeT $
72 TyConst src len $
73 constKiInj @(K c) @c $
74 kindInjP @(Ty_of_Type (K c)) noSource
75
76 -- ** Class 'ModulesTyInj'
77 -- | Derive a 'ModulesTy' from the given type-level list
78 -- of 'Proxy'-fied /type constants/.
79 class ModulesTyInj ts where
80 modulesTyInj :: Source src => ModulesTy src
81 instance ModulesTyInj '[] where
82 modulesTyInj = Map.empty
83 instance
84 ( KindInjP (Ty_of_Type (K c))
85 , K c ~ Type_of_Ty (Ty_of_Type (K c))
86 , Constable c
87 , ModulesTyInj ts
88 ) => ModulesTyInj (Proxy c ': ts) where
89 modulesTyInj =
90 Map.insert
91 (nameTyOf $ Proxy @c)
92 (typeTLen @c noSource) $
93 modulesTyInj @ts
94
95
96 -- * Class 'Gram_Mod'
97 class
98 ( Gram_Char g
99 , Gram_Rule g
100 , Gram_Alt g
101 , Gram_Try g
102 , Gram_App g
103 , Gram_AltApp g
104 , Gram_RegL g
105 , Gram_CF g
106 , Gram_Comment g
107 , Gram_Op g
108 ) => Gram_Mod g where
109 g_PathMod :: CF g PathMod
110 g_PathMod = rule "PathMod" $
111 infixrG
112 (pure <$> g_NameMod)
113 (op <$ char '.')
114 where op = (<>)
115 g_NameMod :: CF g NameMod
116 g_NameMod = rule "NameMod" $
117 NameMod . Text.pack <$> identG
118 where
119 identG = (:) <$> headG <*> many (cfOf tailG)
120 headG = unicat $ Unicat Char.UppercaseLetter
121 tailG :: Terminal g Char
122 tailG =
123 unicat Unicat_Letter <+>
124 unicat Unicat_Number
125
126 deriving instance Gram_Mod g => Gram_Mod (CF g)
127 instance Gram_Mod EBNF
128 instance Gram_Mod RuleEBNF
129
130 -- * Class 'Gram_Type_Name'
131 class
132 ( Gram_Char g
133 , Gram_Rule g
134 , Gram_Alt g
135 , Gram_Try g
136 , Gram_App g
137 , Gram_AltApp g
138 , Gram_RegL g
139 , Gram_CF g
140 , Gram_Comment g
141 , Gram_Op g
142 , Gram_Mod g
143 ) => Gram_Type_Name g where
144 g_ModNameTy :: CF g (Mod NameTy)
145 g_ModNameTy = rule "ModNameTy" $
146 lexeme $
147 g_ModNameTyId <+>
148 parens g_ModNameTyOp
149
150 g_ModNameTyId :: CF g (Mod NameTy)
151 g_ModNameTyId = rule "ModNameTyId" $
152 Mod
153 <$> option [] (try $ g_PathMod <* char '.')
154 <*> g_NameTyId
155 g_NameTyId :: CF g NameTy
156 g_NameTyId = rule "NameTyId" $
157 NameTy . Text.pack <$> identTyG
158 where
159 identTyG = (:) <$> headTyG <*> many (cfOf tailTyG)
160 headTyG = unicat $ Unicat Char.UppercaseLetter
161 tailTyG :: Terminal g Char
162 tailTyG =
163 unicat Unicat_Letter <+>
164 unicat Unicat_Number
165
166 g_ModNameTyOp :: CF g (Mod NameTy)
167 g_ModNameTyOp = rule "ModNameTyOp" $
168 Mod
169 <$> option [] (try $ g_PathMod <* char '.')
170 <*> g_NameTyOp
171 g_NameTyOp :: CF g NameTy
172 g_NameTyOp = rule "NameTyOp" $
173 NameTy . Text.pack <$> many (cfOf okG)
174 where
175 okG :: Terminal g Char
176 okG = choice (unicat <$>
177 [ Unicat_Symbol
178 , Unicat_Punctuation
179 , Unicat_Mark
180 ]) `but` koG
181 koG = choice (char <$> ['(', ')', '`', '\'', '[', ']'])
182
183 deriving instance Gram_Type_Name g => Gram_Type_Name (CF g)
184 instance Gram_Type_Name EBNF
185 instance Gram_Type_Name RuleEBNF
186
187 -- * Class 'Gram_Type'
188 -- | Read an 'AST_Type' from a textual source.
189 class
190 ( Gram_Source src g
191 , Gram_Char g
192 , Gram_Rule g
193 , Gram_Alt g
194 , Gram_Try g
195 , Gram_App g
196 , Gram_AltApp g
197 , Gram_CF g
198 , Gram_Comment g
199 , Gram_Op g
200 , Gram_Type_Name g
201 , Gram_Error (Error_Type src) g
202 , Gram_State (Imports NameTy, ModulesTy src) g
203 , Constable (->)
204 , Constable []
205 , Constable (,)
206 ) => Gram_Type src g where
207 g_type :: CF g (AST_Type src)
208 g_type = rule "Type" $ g_type_fun
209 g_type_fun :: CF g (AST_Type src)
210 g_type_fun = rule "TypeFun" $
211 infixrG g_type_list (source $ op <$ symbol "->")
212 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ typeTLen @(->) src)
213 -- TODO: maybe not harcoding g_type_list and g_type_tuple2
214 g_type_list :: CF g (AST_Type src)
215 g_type_list = rule "TypeList" $
216 source $ inside mk
217 (symbol "[") (optional g_type) (symbol "]")
218 (const <$> g_type_tuple2)
219 where
220 mk Nothing src = tok src
221 mk (Just a) src = BinTree2 (tok src) a
222 tok = BinTree0 . Token_Type_Const . typeTLen @[]
223 g_type_tuple2 :: CF g (AST_Type src)
224 g_type_tuple2 = rule "TypeTuple2" $
225 try (parens (infixrG (g_type) (source $ op <$ symbol ","))) <+> (g_type_app)
226 where op src = BinTree2 . BinTree2 (BinTree0 $ Token_Type_Const $ typeTLen @(,) src)
227 g_type_app :: CF g (AST_Type src)
228 g_type_app = rule "TypeApp" $
229 foldl1' BinTree2 <$> some (g_type_atom)
230 g_type_atom :: CF g (AST_Type src)
231 g_type_atom = rule "TypeAtom" $
232 try (parens g_type) <+>
233 g_type_const <+>
234 g_type_var
235 g_type_const :: CF g (AST_Type src)
236 g_type_const = rule "TypeConst" $
237 lexeme $ catch $ source $ getBefore $
238 (\n (impsTy, modsTy) src -> BinTree0 . Token_Type_Const <$> readTyName impsTy modsTy src n)
239 <$> g_ModNameTy
240 g_type_var :: CF g (AST_Type src)
241 g_type_var = rule "TypeVar" $
242 lexeme $ source $
243 (\n ns src -> BinTree0 $ Token_Type_Var $ Sourced src $ fromString $ n:ns)
244 <$> unicat (Unicat Char.LowercaseLetter)
245 <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
246
247 deriving instance Gram_Type src g => Gram_Type src (CF g)
248 instance
249 ( Gram_Source src EBNF
250 , Constable (->)
251 , Constable (,)
252 , Constable []
253 ) => Gram_Type src EBNF
254 instance
255 ( Gram_Source src RuleEBNF
256 , Constable (->)
257 , Constable (,)
258 , Constable []
259 ) => Gram_Type src RuleEBNF
260
261 -- | Lookup a 'TyConst' or 'Type' synonym
262 -- associated with given 'NameTy' in given 'ModulesTy',
263 -- building it for a @vs@ of given 'Len'.
264 readTyName ::
265 Source src =>
266 Imports NameTy ->
267 ModulesTy src -> src -> Mod NameTy ->
268 Either (Error_Type src) (TypeTLen src)
269 readTyName is ms src name@(m `Mod` n) =
270 let m' = fromMaybe m $ lookupImports FixyInfix name is in
271 case Map.lookup (m' `Mod` n) ms of
272 Just t -> Right t
273 Nothing -> Left $ Error_Type_Constant_unknown $ Sourced src name
274
275 -- * Type 'Error_Type'
276 data Error_Type src
277 = Error_Type_Constant_unknown (Sourced src (Mod NameTy))
278 | Error_Type_Con_Kind (Con_Kind src)
279 deriving (Eq, Show)
280 instance ErrorInj (Error_Type src) (Error_Type src) where
281 errorInj = id
282 instance ErrorInj (Con_Kind src) (Error_Type src) where
283 errorInj = Error_Type_Con_Kind
284
285 -- | List of the rules of 'Gram_Type'.
286 gram_type :: Gram_Type () g => [CF g (AST_Type ())]
287 gram_type =
288 [ g_type
289 , g_type_fun
290 , g_type_list
291 , g_type_tuple2
292 , g_type_app
293 , g_type_atom
294 , g_type_const
295 , g_type_var
296 -- , g_type_symbol
297 ]