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