-
Notifications
You must be signed in to change notification settings - Fork 1
/
Pinned.hs
298 lines (281 loc) · 12.6 KB
/
Pinned.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
{-# LANGUAGE TypeFamilies #-}
module Inferno.Infer.Pinned
( pinExpr,
insertHardcodedModule,
insertBuiltinModule,
openModule,
)
where
import Control.Monad (foldM, forM, unless, when)
import Control.Monad.Except (MonadError (throwError))
import Control.Monad.State (get, put, runStateT)
import Data.Functor.Foldable (cata)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Inferno.Infer.Error (TypeError (..))
import Inferno.Module.Builtin (builtinModule)
import Inferno.Types.Module (Module (..))
import Inferno.Types.Syntax (Expr (..), ExtIdent (..), Ident (..), ImplExpl (..), Import (..), ModuleName (..), Pat (..), PatF (..), Scoped (..), blockPosition, elementPosition)
import Inferno.Types.Type (Namespace (..))
import Inferno.Types.VersionControl (Pinned (..), VCObjectHash)
import Text.Megaparsec (SourcePos (..))
insertIntoLocalScope ::
Map Namespace (Pinned a) ->
Map (Scoped ModuleName) (Map Namespace (Pinned a)) ->
Map (Scoped ModuleName) (Map Namespace (Pinned a))
insertIntoLocalScope m = Map.alter (Just . addModuleToLocalScope) LocalScope
where
addModuleToLocalScope maybeMap = case maybeMap of
Nothing -> m
Just m' -> m `Map.union` m'
insertHardcodedModule ::
ModuleName ->
Map Namespace (Pinned a) ->
Map (Scoped ModuleName) (Map Namespace (Pinned a)) ->
Map (Scoped ModuleName) (Map Namespace (Pinned a))
insertHardcodedModule modNm m moduleMap =
insertIntoLocalScope (Map.filterWithKey isModuleNamespace m) $
Map.insert (Scope modNm) m moduleMap
where
isModuleNamespace :: Namespace -> p -> Bool
isModuleNamespace k _v = case k of
ModuleNamespace _ -> True
_ -> False
insertBuiltinModule ::
Map (Scoped ModuleName) (Map Namespace (Pinned a)) ->
Map (Scoped ModuleName) (Map Namespace (Pinned a))
insertBuiltinModule =
openModule "Builtin"
. insertHardcodedModule "Builtin" (Map.map Builtin builtinTysToHash)
where
builtinTysToHash :: Map Namespace VCObjectHash
Module {moduleObjects = (builtinTysToHash, _, _)} = builtinModule
openModule ::
ModuleName ->
Map (Scoped ModuleName) (Map Namespace (Pinned a)) ->
Map (Scoped ModuleName) (Map Namespace (Pinned a))
openModule modNm moduleMap = case Map.lookup (Scope modNm) moduleMap of
Nothing -> error $ "openModule: Module " <> show modNm <> " does not exist."
Just m -> insertIntoLocalScope m moduleMap
lookupName ::
(MonadError [TypeError SourcePos] m, Eq a) =>
(SourcePos, SourcePos) ->
Scoped ModuleName ->
Namespace ->
Map (Scoped ModuleName) (Map Namespace (Pinned a)) ->
m (Pinned a)
lookupName loc modNm ns m = case Map.lookup modNm m of
Just m' -> case Map.lookup ns m' of
Just r -> pure r
Nothing -> throwError [UnboundNameInNamespace modNm (Right ns) loc]
Nothing -> case modNm of
Scope nm -> throwError [ModuleDoesNotExist nm loc]
LocalScope -> throwError [UnboundNameInNamespace modNm (Right ns) loc]
pinPat :: (MonadError [TypeError SourcePos] m, Eq a) => Map (Scoped ModuleName) (Map Namespace (Pinned a)) -> Pat h SourcePos -> m (Pat (Pinned a) SourcePos)
pinPat m pat =
let patPos = blockPosition pat
in case pat of
PVar p i -> pure $ PVar p i
PEnum p _ modNm x -> do
hash <- lookupName patPos modNm (EnumNamespace x) m
pure $ PEnum p hash modNm x
PLit p l -> pure $ PLit p l
POne p e -> POne p <$> pinPat m e
PEmpty p -> pure $ PEmpty p
PArray p1 es p2 -> do
es' <- mapM (\(e, p3) -> (,p3) <$> pinPat m e) es
pure $ PArray p1 es' p2
PTuple p1 es p2 -> do
es' <- mapM (\(e, p3) -> (,p3) <$> pinPat m e) es
pure $ PTuple p1 es' p2
PRecord p1 es p2 -> do
es' <- mapM (\(f, e, p3) -> (f,,p3) <$> pinPat m e) es
pure $ PRecord p1 es' p2
PCommentAbove c e -> PCommentAbove c <$> pinPat m e
PCommentAfter e c -> (`PCommentAfter` c) <$> pinPat m e
PCommentBelow e c -> (`PCommentBelow` c) <$> pinPat m e
-- pinExpr ::
-- (MonadError [TypeError SourcePos] m, Eq a) =>
-- Map ModuleName (Map Namespace (Pinned a)) ->
-- Expr h SourcePos ->
-- m (Expr (Pinned a) SourcePos)
-- pinExpr nameMap = pinExpr nameMapWithBuiltin
-- where
-- Module {moduleObjects = (builtinTysToHash, _, _)} = builtinModule
-- nameMapWithBuiltin =
-- let moduleNames = Map.filterWithKey isModNs $ Map.unions $ Map.elems nameMap
-- in Map.insert LocalScope (Map.map Builtin builtinTysToHash `Map.union` moduleNames) $
-- Map.mapKeysMonotonic Scope $ Map.insert "Builtin" (Map.map Builtin builtinTysToHash) nameMap
patVars :: Pat hash pos -> [Ident]
patVars p =
flip cata p $
\case
PVarF _ (Just v) -> [v]
rest -> concat rest
isModNs :: Namespace -> p -> Bool
isModNs k _v = case k of
ModuleNamespace _ -> True
_ -> False
pinExpr :: (MonadError [TypeError SourcePos] m, Eq a) => Map (Scoped ModuleName) (Map Namespace (Pinned a)) -> Expr h SourcePos -> m (Expr (Pinned a) SourcePos)
pinExpr m expr =
let exprPos = blockPosition expr
alterFun k v = \case
Just m' -> Just $ Map.insert k v m'
Nothing -> Just $ Map.singleton k v
insertLocal k = Map.alter (alterFun (FunNamespace k) Local) LocalScope
in case expr of
Lit p l -> pure $ Lit p l
Var p _hash modNm (Impl x) -> pure $ Var p Local modNm (Impl x)
Var p _hash modNm i@(Expl (ExtIdent (Left _))) -> pure $ Var p Local modNm i
Var p _hash modNm i@(Expl (ExtIdent (Right x))) ->
case modNm of
Scope (ModuleName a) ->
-- `a.b` can be either Mod.foo or record.field
-- First check if `a` is a local var (record)
case lookupName exprPos LocalScope (FunNamespace $ Ident a) m of
Right _ ->
pure $ RecordField p (Ident a) (Ident x)
Left _ ->
-- Else assume `a.b` is Mod.foo
pinScopedVar
LocalScope -> pinScopedVar
where
pinScopedVar = do
hash <- lookupName exprPos modNm (FunNamespace $ Ident x) m
pure $ Var p hash modNm i
OpVar p _hash modNm x -> do
hash <- lookupName exprPos modNm (OpNamespace x) m
pure $ OpVar p hash modNm x
TypeRep p t -> pure $ TypeRep p t
Enum p _hash modNm x -> do
hash <- lookupName exprPos modNm (EnumNamespace x) m
pure $ Enum p hash modNm x
InterpolatedString p1 xs p2 -> do
xs' <- mapM (\(p3, e, p4) -> (p3,,p4) <$> pinExpr m e) xs
pure $ InterpolatedString p1 xs' p2
Record p1 es p2 -> do
es' <- mapM (\(f, e, p3) -> (f,,p3) <$> pinExpr m e) es
pure $ Record p1 es' p2
RecordField p1 r f ->
pure $ RecordField p1 r f
Array p1 es p2 -> do
es' <- mapM (\(e, p3) -> (,p3) <$> pinExpr m e) es
pure $ Array p1 es' p2
ArrayComp p1 e p2 sels cond p3 -> do
(sels', m') <- flip runStateT m $
forM sels $ \(p4, i, p5, e1, p6) -> do
currentM <- get
e1' <- pinExpr currentM e1
put $ insertLocal i currentM
pure (p4, i, p5, e1', p6)
cond' <- mapM (\(p4, e1) -> (p4,) <$> pinExpr m' e1) cond
e' <- pinExpr m' e
pure $ ArrayComp p1 e' p2 sels' cond' p3
Lam p1 args p2 e -> do
let m' =
foldr
( \(_, mIdent) m'' -> case mIdent of
Just (ExtIdent (Right i)) -> insertLocal (Ident i) m''
_ -> m''
)
m
args
Lam p1 args p2 <$> pinExpr m' e
App e1 e2 -> App <$> pinExpr m e1 <*> pinExpr m e2
LetAnnot p1 loc x@(ExtIdent (Right i)) pT t p2 e1 p3 e2 -> do
e1' <- pinExpr m e1
e2' <- pinExpr (insertLocal (Ident i) m) e2
pure $ LetAnnot p1 loc x pT t p2 e1' p3 e2'
LetAnnot p1 loc x@(ExtIdent (Left _)) pT t p2 e1 p3 e2 -> do
e1' <- pinExpr m e1
e2' <- pinExpr m e2
pure $ LetAnnot p1 loc x pT t p2 e1' p3 e2'
Let p1 loc x@(Expl (ExtIdent (Right i))) p2 e1 p3 e2 -> do
e1' <- pinExpr m e1
e2' <- pinExpr (insertLocal (Ident i) m) e2
pure $ Let p1 loc x p2 e1' p3 e2'
Let p1 loc x@(Expl (ExtIdent (Left _))) p2 e1 p3 e2 -> do
e1' <- pinExpr m e1
e2' <- pinExpr m e2
pure $ Let p1 loc x p2 e1' p3 e2'
Let p1 loc (Impl x) p2 e1 p3 e2 -> do
e1' <- pinExpr m e1
e2' <- pinExpr m e2
pure $ Let p1 loc (Impl x) p2 e1' p3 e2'
Op e1 p1 _ meta modNm op e2 -> do
hash <- lookupName exprPos modNm (OpNamespace op) m
(\e1' e2' -> Op e1' p1 hash meta modNm op e2')
<$> pinExpr m e1
<*> pinExpr m e2
PreOp loc _ meta modNm op e -> do
hash <- lookupName exprPos modNm (FunNamespace op) m
PreOp loc hash meta modNm op <$> pinExpr m e
If p1 cond p2 tr p3 fl ->
(\c t f -> If p1 c p2 t p3 f) <$> pinExpr m cond <*> pinExpr m tr <*> pinExpr m fl
Tuple p1 es p2 -> do
es' <- mapM (\(e, p3) -> (,p3) <$> pinExpr m e) es
pure $ Tuple p1 es' p2
Assert p1 cond p2 e ->
(\cond' e' -> Assert p1 cond' p2 e')
<$> pinExpr m cond
<*> pinExpr m e
Empty p -> pure $ Empty p
One p e -> One p <$> pinExpr m e
Case p1 e p2 patExprs p3 -> do
e' <- pinExpr m e
patExprs' <-
mapM
( \(p4, pat, p5, e1) -> do
pat' <- pinPat m pat
let m' = foldr insertLocal m $ patVars pat
e1' <- pinExpr m' e1
pure (p4, pat', p5, e1')
)
patExprs
pure $ Case p1 e' p2 patExprs' p3
CommentAbove c e -> CommentAbove c <$> pinExpr m e
CommentAfter e c -> (`CommentAfter` c) <$> pinExpr m e
CommentBelow e c -> (`CommentBelow` c) <$> pinExpr m e
Bracketed p1 e p2 -> (\e' -> Bracketed p1 e' p2) <$> pinExpr m e
RenameModule l1 newNm l2 oldNm l3 e -> do
hash <- lookupName exprPos LocalScope (ModuleNamespace oldNm) m
when (Scope newNm `Map.member` m) $ throwError [ModuleNameTaken newNm $ elementPosition l1 newNm]
case Map.lookup (Scope oldNm) m of
Nothing -> throwError [ModuleDoesNotExist oldNm (l2, l3)]
Just oldNmMod -> do
let m' = Map.alter (alterFun (ModuleNamespace newNm) hash) LocalScope $ Map.insert (Scope newNm) oldNmMod m
RenameModule l1 newNm l2 oldNm l3 <$> pinExpr m' e
OpenModule p1 _mHash modNm@(ModuleName mn) imports p2 e -> do
hash <- lookupName exprPos LocalScope (ModuleNamespace modNm) m
let modPos = elementPosition p1 $ Ident mn
case Map.lookup (Scope modNm) m of
Nothing -> throwError [ModuleDoesNotExist modNm modPos]
Just openMod' -> do
let openMod = Map.filterWithKey (\k v -> not $ isModNs k v) openMod'
let localM = fromMaybe mempty $ Map.lookup LocalScope m
checkedImports <- case imports of
[] -> pure openMod
_ -> Map.fromList <$> foldM (collectImports openMod modPos) [] (map fst imports)
let intersectionWithLocal = localM `Map.intersection` checkedImports
unless (Map.null intersectionWithLocal) $ throwError [AmbiguousName modNm i modPos | i <- Map.keys checkedImports]
OpenModule p1 hash modNm imports p2 <$> pinExpr (Map.insertWith Map.union LocalScope checkedImports m) e
where
collectImports openMod pos xs = \case
IVar _ i -> do
let k = FunNamespace i
unless (k `Map.member` openMod) $ throwError [NameInModuleDoesNotExist modNm i pos]
return $ (k, openMod Map.! k) : xs
IOpVar _ i -> do
let k = FunNamespace i
unless (k `Map.member` openMod) $ throwError [NameInModuleDoesNotExist modNm i pos]
return $ (k, openMod Map.! k) : xs
IEnum _ _ i -> do
let k = TypeNamespace i
unless (k `Map.member` openMod) $ throwError [NameInModuleDoesNotExist modNm i pos]
let enumHash = openMod Map.! k
return $
Map.toList (Map.filter (== enumHash) openMod) ++ xs
ICommentAbove _ x' -> collectImports openMod pos xs x'
ICommentAfter x' _ -> collectImports openMod pos xs x'
ICommentBelow x' _ -> collectImports openMod pos xs x'