]> Git — Sourcephile - haskell/symantic.git/blob - symantic/Language/Symantic/Typing/Module.hs
Bump versions.
[haskell/symantic.git] / symantic / Language / Symantic / Typing / Module.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE DeriveFunctor #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE PolyKinds #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 module Language.Symantic.Typing.Module where
8
9 import Data.Functor (Functor(..))
10 import Data.Maybe (fromMaybe)
11 import Data.String (IsString(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.Text (Text)
14 import Data.Typeable
15 import Data.Map.Strict (Map)
16 import qualified Data.Char as C
17 import qualified Data.List as L
18 import qualified Data.Kind as K
19 import qualified Data.Text as T
20 import qualified Data.Map.Strict as Map
21
22 import Language.Symantic.Grammar.Fixity
23
24 -- * Type 'NsT'
25 data NsT
26 = NsTerm
27 | NsType
28
29 -- * Type 'Name'
30 type Name = Text
31
32 -- * Type 'NameTy'
33 -- | 'Name' of a 'Type'.
34 newtype NameTy = NameTy Text
35 deriving (Eq, Ord, Show)
36 instance IsString NameTy where
37 fromString = NameTy . fromString
38
39 -- ** Type 'NameConst'
40 -- | 'Name' of a 'Const'.
41 type NameConst = NameTy
42
43 -- ** Type 'NameFam'
44 -- | 'Name' of a 'Fam'.
45 type NameFam = NameTy
46
47 -- ** Class 'NameOf'
48 class NameOf a where
49 nameOf :: a -> Name
50
51 -- ** Class 'NameTyOf'
52 -- | Return the 'NameTy' of something.
53 class NameTyOf (c::kc) where
54 nameTyOf :: proxy c -> Mod NameTy
55 default nameTyOf :: Typeable c => proxy c -> Mod NameTy
56 nameTyOf c = path (tyConModule repr) `Mod` fromString (tyConName repr)
57 where
58 repr = typeRepTyCon (typeRep c)
59 path = fmap fromString . L.lines . fmap (\case '.' -> '\n'; x -> x)
60
61 isNameTyOp :: proxy c -> Bool
62 default isNameTyOp :: Typeable c => proxy c -> Bool
63 isNameTyOp c = let _m `Mod` NameTy n = nameTyOf c in isOp n
64 where
65 isOp = T.all $ \case
66 '_' -> False
67 '\'' -> False
68 x -> case C.generalCategory x of
69 C.NonSpacingMark -> True
70 C.SpacingCombiningMark -> True
71 C.EnclosingMark -> True
72 C.ConnectorPunctuation -> True
73 C.DashPunctuation -> True
74 C.OpenPunctuation -> True
75 C.ClosePunctuation -> True
76 C.InitialQuote -> True
77 C.FinalQuote -> True
78 C.OtherPunctuation -> True
79 C.MathSymbol -> True
80 C.CurrencySymbol -> True
81 C.ModifierSymbol -> True
82 C.OtherSymbol -> True
83
84 C.UppercaseLetter -> False
85 C.LowercaseLetter -> False
86 C.TitlecaseLetter -> False
87 C.ModifierLetter -> False
88 C.OtherLetter -> False
89 C.DecimalNumber -> False
90 C.LetterNumber -> False
91 C.OtherNumber -> False
92 C.Space -> False
93 C.LineSeparator -> False
94 C.ParagraphSeparator -> False
95 C.Control -> False
96 C.Format -> False
97 C.Surrogate -> False
98 C.PrivateUse -> False
99 C.NotAssigned -> False
100
101 -- * Type 'Mod'
102 -- | 'PathMod' of something.
103 data Mod a = Mod PathMod a
104 deriving (Eq, Functor, Ord, Show)
105
106 -- ** Type 'PathMod'
107 -- | Path to a 'Module'.
108 type PathMod = [NameMod]
109
110 -- ** Type 'NameMod'
111 -- | 'Name' of 'Module'.
112 newtype NameMod = NameMod Name
113 deriving (Eq, Ord, Show)
114 instance IsString NameMod where
115 fromString = NameMod . fromString
116
117 -- * Type 'Imports'
118 -- | Map 'PathMod's of 'Name's.
119 newtype Imports name = Imports (Map PathMod (MapFixity (Map name PathMod)))
120 deriving (Eq, Show)
121
122 instance Ord name => Semigroup (Imports name) where
123 Imports x <> Imports y = Imports $ Map.unionWith (<>) x y
124 instance Ord name => Monoid (Imports name) where
125 mempty = Imports mempty
126 mappend = (<>)
127
128 lookupImports :: Ord name => Fixy p i q a -> Mod name -> Imports name -> Maybe PathMod
129 lookupImports f (m `Mod` n) (Imports is) =
130 Map.lookup m is >>=
131 Map.lookup n . getByFixity f
132
133 revlookupImports :: Ord name => Fixy p i q a -> Mod name -> Imports name -> Maybe PathMod
134 revlookupImports f (m `Mod` n) (Imports is) =
135 (fst . fst <$>) $ Map.minViewWithKey $
136 Map.filter (\i ->
137 case Map.lookup n $ getByFixity f i of
138 Just m' | m' == m -> True
139 _ -> False
140 ) is
141
142 -- ** Class 'ImportTypes'
143 class ImportTypes ts where
144 importTypes :: PathMod -> Imports NameTy
145
146 instance ImportTypes '[] where
147 importTypes _p = mempty
148 instance (NameTyOf t, FixityOf t, ImportTypes ts) => ImportTypes (Proxy t ': ts) where
149 importTypes p = Imports (Map.singleton p byFixy) <> importTypes @ts p
150 where
151 t = Proxy @t
152 f = Fixity2 infixN5 `fromMaybe` fixityOf t
153 m `Mod` n = nameTyOf t
154 byFixy :: MapFixity (Map NameTy PathMod)
155 byFixy = case f of
156 Fixity1 Prefix{} -> ByFixity{byPrefix = Map.singleton n m, byInfix =mempty, byPostfix=mempty}
157 Fixity2{} -> ByFixity{byInfix = Map.singleton n m, byPrefix=mempty, byPostfix=mempty}
158 Fixity1 Postfix{} -> ByFixity{byPostfix = Map.singleton n m, byPrefix=mempty, byInfix =mempty}
159
160 -- * Type 'Fixy'
161 data Fixy p i q a where
162 FixyPrefix :: Fixy p i q p
163 FixyInfix :: Fixy p i q i
164 FixyPostfix :: Fixy p i q q
165 deriving instance Eq (Fixy p i q a)
166 deriving instance Show (Fixy p i q a)
167
168 fixyOfFixity :: Fixity -> Fixy a a a a
169 fixyOfFixity (Fixity1 Prefix{}) = FixyPrefix
170 fixyOfFixity (Fixity2 Infix{}) = FixyInfix
171 fixyOfFixity (Fixity1 Postfix{}) = FixyPostfix
172
173 -- ** Class 'FixityOf'
174 -- | Return the 'Fixity' of something.
175 class FixityOf (c::kc) where
176 fixityOf :: proxy c -> Maybe Fixity
177 fixityOf _c = Nothing
178 instance FixityOf (c::K.Type)
179 instance FixityOf (c::K.Constraint)
180
181 -- ** Type 'FixyA'
182 -- | Like 'Fixy', but when all choices have the same type.
183 newtype FixyA = FixyA (forall (a:: *). Fixy a a a a)
184 deriving instance Eq FixyA
185 deriving instance Show FixyA
186
187 -- ** Type 'WithFixity'
188 data WithFixity a
189 = WithFixity a Fixity
190 deriving (Eq, Functor, Show)
191 instance IsString a => IsString (WithFixity a) where
192 fromString a = WithFixity (fromString a) (Fixity2 infixN5)
193
194 withInfix :: a -> Infix -> WithFixity a
195 withInfix a inf = a `WithFixity` Fixity2 inf
196 withInfixR :: a -> Precedence -> WithFixity a
197 withInfixR a p = a `WithFixity` Fixity2 (infixR p)
198 withInfixL :: a -> Precedence -> WithFixity a
199 withInfixL a p = a `WithFixity` Fixity2 (infixL p)
200 withInfixN :: a -> Precedence -> WithFixity a
201 withInfixN a p = a `WithFixity` Fixity2 (infixN p)
202 withInfixB :: a -> (Side, Precedence) -> WithFixity a
203 withInfixB a (lr, p) = a `WithFixity` Fixity2 (infixB lr p)
204 withPrefix :: a -> Precedence -> WithFixity a
205 withPrefix a p = a `WithFixity` Fixity1 (Prefix p)
206 withPostfix :: a -> Precedence -> WithFixity a
207 withPostfix a p = a `WithFixity` Fixity1 (Postfix p)
208
209 -- ** Type 'ByFixity'
210 -- | Fixity namespace.
211 data ByFixity p i q
212 = ByFixity
213 { byPrefix :: p
214 , byInfix :: i
215 , byPostfix :: q
216 } deriving (Eq, Show)
217 instance (Semigroup p, Semigroup i, Semigroup q) => Semigroup (ByFixity p i q) where
218 ByFixity px ix qx <> ByFixity py iy qy =
219 ByFixity (px <> py) (ix <> iy) (qx <> qy)
220 instance (Monoid p, Monoid i, Monoid q) => Monoid (ByFixity p i q) where
221 mempty = ByFixity mempty mempty mempty
222 ByFixity px ix qx `mappend` ByFixity py iy qy =
223 ByFixity (px `mappend` py) (ix `mappend` iy) (qx `mappend` qy)
224
225 getByFixity :: Fixy p i q a -> MapFixity b -> b
226 getByFixity FixyPrefix = byPrefix
227 getByFixity FixyInfix = byInfix
228 getByFixity FixyPostfix = byPostfix
229
230 selectByFixity :: Fixy p i q a -> ByFixity p i q -> a
231 selectByFixity FixyPrefix = byPrefix
232 selectByFixity FixyInfix = byInfix
233 selectByFixity FixyPostfix = byPostfix
234
235 -- *** Type 'MapFixity'
236 -- | Like 'ByFixity', but with the same type parameter.
237 type MapFixity a = ByFixity a a a
238
239 mapMapFixity :: (a -> b) -> MapFixity a -> MapFixity b
240 mapMapFixity f (ByFixity p i q) = ByFixity (f p) (f i) (f q)