@@ -34,14 +34,14 @@ import Control.Monad.Supply.Class (MonadSupply)
34import Control.Monad.Writer.Class (MonadWriter(..))
34import Control.Monad.Writer.Class (MonadWriter(..))
36import Data.Bifunctor (bimap)
36import Data.Bifunctor (bimap)
37−import Data.Either (lefts, rights)
37+import Data.Either (partitionEithers)
38import Data.Functor (($>))
38import Data.Functor (($>))
39import Data.List (transpose, nub, (\\), partition, delete)
39import Data.List (transpose, nub, (\\), partition, delete)
40import Data.Maybe (fromMaybe)
40import Data.Maybe (fromMaybe)
41import Data.Monoid ((<>))
41import Data.Monoid ((<>))
42import qualified Data.Map as M
42import qualified Data.Map as M
43import qualified Data.Set as S
43import qualified Data.Set as S
44−import Data.Text (Text)
44+import Data.Traversable (for)
46import Language.PureScript.AST
46import Language.PureScript.AST
47import Language.PureScript.Crash
47import Language.PureScript.Crash
@@ -60,7 +60,8 @@ import Language.PureScript.TypeChecker.Synonyms
60import Language.PureScript.TypeChecker.TypeSearch
60import Language.PureScript.TypeChecker.TypeSearch
61import Language.PureScript.TypeChecker.Unify
61import Language.PureScript.TypeChecker.Unify
62import Language.PureScript.Types
62import Language.PureScript.Types
63−
63+import Language.PureScript.Label (Label(..))
64+import Language.PureScript.PSString (PSString)
65data BindingGroupType
66data BindingGroupType
66 = RecursiveBindingGroup
67 = RecursiveBindingGroup
@@ -77,9 +78,9 @@ typesOf
77 -> m [(Ident, (Expr, Type))]
78 -> m [(Ident, (Expr, Type))]
78typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
79typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
79 tys <- capturingSubstitution tidyUp $ do
80 tys <- capturingSubstitution tidyUp $ do
80− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
81+ SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals
81 ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict
82 ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict
82− ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict
83+ ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict
83 return (map (False, ) ds1 ++ map (True, ) ds2)
84 return (map (False, ) ds1 ++ map (True, ) ds2)
85 inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do
86 inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do
@@ -165,81 +166,101 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
165 isHoleError (ErrorMessage _ HoleInferredType{}) = True
166 isHoleError (ErrorMessage _ HoleInferredType{}) = True
166 isHoleError _ = False
167 isHoleError _ = False
169+-- | A binding group contains multiple value definitions, some of which are typed
170+-- and some which are not.
172+-- This structure breaks down a binding group into typed and untyped parts.
173+data SplitBindingGroup = SplitBindingGroup
174+ { _splitBindingGroupUntyped :: [(Ident, (Expr, Type))]
175+ -- ^ The untyped expressions
176+ , _splitBindingGroupTyped :: [(Ident, (Expr, Type, Bool))]
177+ -- ^ The typed expressions, along with their type annotations
168−type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
178+ , _splitBindingGroupNames :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
169−
179+ -- ^ A map containing all expressions and their assigned types (which might be
170−type UntypedData = [(Ident, Type)]
180+ -- fresh unification variables). These will be added to the 'Environment' after
171−
181+ -- the binding group is checked, so the value type of the 'Map' is chosen to be
182+ -- compatible with the type of 'bindNames'.
185+-- | This function breaks a binding group down into two sets of declarations:
186+-- those which contain type annotations, and those which don't.
187+-- This function also generates fresh unification variables for the types of
188+-- declarations without type annotations, returned in the 'UntypedData' structure.
172typeDictionaryForBindingGroup
189typeDictionaryForBindingGroup
173− :: (MonadState CheckState m)
190+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
174 => Maybe ModuleName
191 => Maybe ModuleName
175 -> [(Ident, Expr)]
192 -> [(Ident, Expr)]
176− -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
193+ -> m SplitBindingGroup
177typeDictionaryForBindingGroup moduleName vals = do
194typeDictionaryForBindingGroup moduleName vals = do
178− let
195+ -- Filter the typed and untyped declarations and make a map of names to typed declarations.
179− -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
196+ -- Replace type wildcards here so that the resulting dictionary of types contains the
180− es = map isTyped vals
197+ -- fully expanded types.
181− -- Filter the typed and untyped declarations
198+ let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals)
182− untyped = lefts es
199+ (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do
183− typed = rights es
200+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
184− -- Make a map of names to typed declarations
201+ return ((ident, ty'), (ident, (expr, ty', checkType)))
185− typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed
187− -- Create fresh unification variables for the types of untyped declarations
202+ -- Create fresh unification variables for the types of untyped declarations
188− untypedNames <- replicateM (length untyped) freshType
203+ (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do
190− let
205+ return ((ident, ty), (ident, (expr, ty)))
191− -- Make a map of names to the unification variables of untyped declarations
192− untypedDict = zip (map fst untyped) untypedNames
193− -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
206+ -- Create the dictionary of all name/type pairs, which will be added to the
207+ -- environment during type checking
194− dict = M.fromList (map (\(ident, ty) -> (Qualified moduleName ident, (ty, Private, Undefined))) $ typedDict ++ untypedDict)
208+ let dict = M.fromList [ (Qualified moduleName ident, (ty, Private, Undefined))
195− return (untyped, typed, dict, untypedDict)
209+ | (ident, ty) <- typedDict <> untypedDict
211+ return (SplitBindingGroup untyped' typed' dict)
213+ -- | Check if a value contains a type annotation, and if so, separate it
214+ -- from the value itself.
215+ splitTypeAnnotation :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
216+ splitTypeAnnotation (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
217+ splitTypeAnnotation (name, PositionedValue pos c value) =
218+ bimap (second (PositionedValue pos c))
219+ (second (\(e, t, b) -> (PositionedValue pos c e, t, b)))
220+ (splitTypeAnnotation (name, value))
221+ splitTypeAnnotation (name, value) = Left (name, value)
223+-- | Check the type annotation of a typed value in a binding group.
197checkTypedBindingGroupElement
224checkTypedBindingGroupElement
198 :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
225 :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
199 => ModuleName
226 => ModuleName
200 -> (Ident, (Expr, Type, Bool))
227 -> (Ident, (Expr, Type, Bool))
201− -> TypeData
228+ -- ^ The identifier we are trying to define, along with the expression and its type annotation
229+ -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
230+ -- ^ Names brought into scope in this binding group
202 -> m (Ident, (Expr, Type))
231 -> m (Ident, (Expr, Type))
203−checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
232+checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do
204− -- Replace type wildcards
205− ty' <- replaceTypeWildcards ty
206 -- Kind check
233 -- Kind check
207 (kind, args) <- kindOfWithScopedVars ty
234 (kind, args) <- kindOfWithScopedVars ty
208 checkTypeKind ty kind
235 checkTypeKind ty kind
209 -- Check the type with the new names in scope
236 -- Check the type with the new names in scope
210− ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'
211− val'' <- if checkType
237+ val' <- if checkType
212− then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''
238+ then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty <*> pure ty
213− else return (TypedValue False val' ty'')
239+ else return (TypedValue False val ty)
214− return (ident, (val'', ty''))
240+ return (ident, (val', ty))
242+-- | Infer a type for a value in a binding group which lacks an annotation.
216typeForBindingGroupElement
243typeForBindingGroupElement
217 :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
244 :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
218− => (Ident, Expr)
245+ => (Ident, (Expr, Type))
219− -> TypeData
246+ -- ^ The identifier we are trying to define, along with the expression and its assigned type
220− -> UntypedData
247+ -- (at this point, this should be a unification variable)
248+ -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
249+ -- ^ Names brought into scope in this binding group
221 -> m (Ident, (Expr, Type))
250 -> m (Ident, (Expr, Type))
222−typeForBindingGroupElement (ident, val) dict untypedDict = do
251+typeForBindingGroupElement (ident, (val, ty)) dict = do
223 -- Infer the type with the new names in scope
252 -- Infer the type with the new names in scope
224− TypedValue _ val' ty <- bindNames dict $ infer val
253+ TypedValue _ val' ty' <- bindNames dict $ infer val
225− unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)
254+ -- Unify the type with the unification variable we chose for this definition
226− return (ident, (TypedValue True val' ty, ty))
256+ return (ident, (TypedValue True val' ty', ty'))
228−-- | Check if a value contains a type annotation
229−isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
230−isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
231−isTyped (name, PositionedValue pos c value) =
232− bimap (second (PositionedValue pos c))
233− (second (\(e, t, b) -> (PositionedValue pos c e, t, b)))
234− (isTyped (name, value))
235−isTyped (name, value) = Left (name, value)
237-- | Check the kind of a type, failing if it is not of kind *.
258-- | Check the kind of a type, failing if it is not of kind *.
238−checkTypeKind ::
259+checkTypeKind
239− (MonadError MultipleErrors m) =>
260+ :: MonadError MultipleErrors m
243checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType
264checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType
245-- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
266-- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
@@ -247,11 +268,11 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind =
248-- This is necessary during type checking to avoid unifying a polymorphic type with a
269-- This is necessary during type checking to avoid unifying a polymorphic type with a
249-- unification variable.
270-- unification variable.
250−instantiatePolyTypeWithUnknowns ::
271+instantiatePolyTypeWithUnknowns
251− (MonadState CheckState m, MonadError MultipleErrors m) =>
272+ :: (MonadState CheckState m, MonadError MultipleErrors m)
254− m (Expr, Type)
275+ -> m (Expr, Type)
255instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
276instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
256 ty' <- replaceVarWithUnknown ident ty
277 ty' <- replaceVarWithUnknown ident ty
257 instantiatePolyTypeWithUnknowns val ty'
278 instantiatePolyTypeWithUnknowns val ty'
@@ -262,17 +283,17 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
262instantiatePolyTypeWithUnknowns val ty = return (val, ty)
283instantiatePolyTypeWithUnknowns val ty = return (val, ty)
264-- | Infer a type for a value, rethrowing any error to provide a more useful error message
285-- | Infer a type for a value, rethrowing any error to provide a more useful error message
266− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
287+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
268− m Expr
289+ -> m Expr
269infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val
290infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val
271-- | Infer a type for a value
292-- | Infer a type for a value
273− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
294+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
275− m Expr
296+ -> m Expr
276infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt
297infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt
277infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber
298infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber
278infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString
299infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString
@@ -289,22 +310,22 @@ infer' (Literal (ArrayLiteral vals)) = do
289infer' (Literal (ObjectLiteral ps)) = do
310infer' (Literal (ObjectLiteral ps)) = do
290 ensureNoDuplicateProperties ps
311 ensureNoDuplicateProperties ps
291 ts <- traverse (infer . snd) ps
312 ts <- traverse (infer . snd) ps
292− let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
313+ let fields = zipWith (\name (TypedValue _ _ t) -> (Label name, t)) (map fst ps) ts
293 ty = TypeApp tyRecord $ rowFromList (fields, REmpty)
314 ty = TypeApp tyRecord $ rowFromList (fields, REmpty)
294 return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty
315 return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty
295infer' (ObjectUpdate o ps) = do
316infer' (ObjectUpdate o ps) = do
296 ensureNoDuplicateProperties ps
317 ensureNoDuplicateProperties ps
297 row <- freshType
318 row <- freshType
298 newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps
319 newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps
299− let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals
320+ let newTys = map (\(name, TypedValue _ _ ty) -> (Label name, ty)) newVals
300− oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType
321+ oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType
301 let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row)
322 let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row)
302 o' <- TypedValue True <$> check o oldTy <*> pure oldTy
323 o' <- TypedValue True <$> check o oldTy <*> pure oldTy
303 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row)
324 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row)
304infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
325infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
305 field <- freshType
326 field <- freshType
306 rest <- freshType
327 rest <- freshType
307− typed <- check val (TypeApp tyRecord (RCons prop field rest))
328+ typed <- check val (TypeApp tyRecord (RCons (Label prop) field rest))
308 return $ TypedValue True (Accessor prop typed) field
329 return $ TypedValue True (Accessor prop typed) field
309infer' (Abs (Left arg) ret) = do
330infer' (Abs (Left arg) ret) = do
310 ty <- freshType
331 ty <- freshType
@@ -369,13 +390,13 @@ infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
369 return $ TypedValue t (PositionedValue pos c v) ty
390 return $ TypedValue t (PositionedValue pos c v) ty
370infer' v = internalError $ "Invalid argument to infer: " ++ show v
391infer' v = internalError $ "Invalid argument to infer: " ++ show v
372−inferLetBinding ::
393+inferLetBinding
373− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
394+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
374− [Declaration] ->
395+ => [Declaration]
375− [Declaration] ->
396+ -> [Declaration]
377− (Expr -> m Expr) ->
398+ -> (Expr -> m Expr)
378− m ([Declaration], Expr)
399+ -> m ([Declaration], Expr)
379inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
400inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
380inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
401inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
381 Just moduleName <- checkCurrentModule <$> get
402 Just moduleName <- checkCurrentModule <$> get
@@ -393,9 +414,9 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret
393 bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
414 bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
394inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
415inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
395 Just moduleName <- checkCurrentModule <$> get
416 Just moduleName <- checkCurrentModule <$> get
396− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)
417+ SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)
397 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
418 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
398− ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
419+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict
399 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']
420 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']
400 bindNames dict $ do
421 bindNames dict $ do
401 makeBindingGroupVisible
422 makeBindingGroupVisible
@@ -406,11 +427,12 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr
406inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
427inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
408-- | Infer the types of variables brought into scope by a binder
429-- | Infer the types of variables brought into scope by a binder
409−inferBinder :: forall m.
430+inferBinder
410− (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
432+ . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
412− Binder ->
434+ -> Binder
413− m (M.Map Ident Type)
435+ -> m (M.Map Ident Type)
414inferBinder _ NullBinder = return M.empty
436inferBinder _ NullBinder = return M.empty
415inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty
437inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty
416inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
438inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
@@ -442,12 +464,12 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do
442 unifyTypes val (TypeApp tyRecord row)
464 unifyTypes val (TypeApp tyRecord row)
443 return m1
465 return m1
445− inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type)
467+ inferRowProperties :: Type -> Type -> [(PSString, Binder)] -> m (M.Map Ident Type)
446 inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty
468 inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty
447 inferRowProperties nrow row ((name, binder):binders) = do
469 inferRowProperties nrow row ((name, binder):binders) = do
448 propTy <- freshType
470 propTy <- freshType
449 m1 <- inferBinder propTy binder
471 m1 <- inferBinder propTy binder
450− m2 <- inferRowProperties nrow (RCons name propTy row) binders
472+ m2 <- inferRowProperties nrow (RCons (Label name) propTy row) binders
451 return $ m1 `M.union` m2
473 return $ m1 `M.union` m2
452inferBinder val (LiteralBinder (ArrayLiteral binders)) = do
474inferBinder val (LiteralBinder (ArrayLiteral binders)) = do
453 el <- freshType
475 el <- freshType
@@ -485,11 +507,11 @@ binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b
485binderRequiresMonotype _ = True
507binderRequiresMonotype _ = True
487-- | Instantiate polytypes only when necessitated by a binder.
509-- | Instantiate polytypes only when necessitated by a binder.
488−instantiateForBinders ::
510+instantiateForBinders
489− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
511+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
490− [Expr] ->
512+ => [Expr]
491− [CaseAlternative] ->
513+ -> [CaseAlternative]
492− m ([Expr], [Type])
514+ -> m ([Expr], [Type])
493instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
515instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
494 TypedValue _ val' ty <- infer val
516 TypedValue _ val' ty <- infer val
@@ -502,12 +524,12 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
503-- Check the types of the return values in a set of binders in a case statement
525-- Check the types of the return values in a set of binders in a case statement
505−checkBinders ::
527+checkBinders
506− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
528+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
507− [Type] ->
529+ => [Type]
509− [CaseAlternative] ->
531+ -> [CaseAlternative]
510− m [CaseAlternative]
532+ -> m [CaseAlternative]
511checkBinders _ _ [] = return []
533checkBinders _ _ [] = return []
512checkBinders nvals ret (CaseAlternative binders result : bs) = do
534checkBinders nvals ret (CaseAlternative binders result : bs) = do
513 guardWith (errorMessage $ OverlappingArgNames Nothing) $
535 guardWith (errorMessage $ OverlappingArgNames Nothing) $
@@ -531,11 +553,11 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
532-- Check the type of a value, rethrowing errors to provide a better error message
554-- Check the type of a value, rethrowing errors to provide a better error message
535− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
557+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
538− m Expr
560+ -> m Expr
539check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty
561check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty
@@ -641,14 +663,14 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do
641 -- We need to be careful to avoid duplicate labels here.
663 -- We need to be careful to avoid duplicate labels here.
642 -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.
664 -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.
643 let (propsToCheck, rest) = rowToList row
665 let (propsToCheck, rest) = rowToList row
644− (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck
666+ (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map (Label . fst) ps) propsToCheck
645 us <- zip (map fst removedProps) <$> replicateM (length ps) freshType
667 us <- zip (map fst removedProps) <$> replicateM (length ps) freshType
646 obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))
668 obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))
647 ps' <- checkProperties e ps row True
669 ps' <- checkProperties e ps row True
648 return $ TypedValue True (ObjectUpdate obj' ps') t
670 return $ TypedValue True (ObjectUpdate obj' ps') t
649check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
671check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
650 rest <- freshType
672 rest <- freshType
651− val' <- check val (TypeApp tyRecord (RCons prop ty rest))
673+ val' <- check val (TypeApp tyRecord (RCons (Label prop) ty rest))
652 return $ TypedValue True (Accessor prop val') ty
674 return $ TypedValue True (Accessor prop val') ty
653check' v@(Constructor c) ty = do
675check' v@(Constructor c) ty = do
654 env <- getEnv
676 env <- getEnv
@@ -678,13 +700,13 @@ check' val ty = do
679-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
701-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
681−checkProperties ::
703+checkProperties
682− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
704+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
684− [(Text, Expr)] ->
706+ -> [(PSString, Expr)]
687− m [(Text, Expr)]
709+ -> m [(PSString, Expr)]
688checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where
710checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where
689 go [] [] REmpty = return []
711 go [] [] REmpty = return []
690 go [] [] u@(TUnknown _)
712 go [] [] u@(TUnknown _)
@@ -694,18 +716,18 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
694 go [] [] Skolem{} | lax = return []
716 go [] [] Skolem{} | lax = return []
695 go [] ((p, _): _) _ | lax = return []
717 go [] ((p, _): _) _ | lax = return []
696 | otherwise = throwError . errorMessage $ PropertyIsMissing p
718 | otherwise = throwError . errorMessage $ PropertyIsMissing p
697− go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p
719+ go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty $ Label p
698 go ((p,v):ps') ts r =
720 go ((p,v):ps') ts r =
699− case lookup p ts of
721+ case lookup (Label p) ts of
700 Nothing -> do
722 Nothing -> do
701 v'@(TypedValue _ _ ty) <- infer v
723 v'@(TypedValue _ _ ty) <- infer v
702 rest <- freshType
724 rest <- freshType
703− unifyTypes r (RCons p ty rest)
725+ unifyTypes r (RCons (Label p) ty rest)
704 ps'' <- go ps' ts rest
726 ps'' <- go ps' ts rest
705 return $ (p, v') : ps''
727 return $ (p, v') : ps''
706 Just ty -> do
728 Just ty -> do
707 v' <- check v ty
729 v' <- check v ty
708− ps'' <- go ps' (delete (p, ty) ts) r
730+ ps'' <- go ps' (delete (Label p, ty) ts) r
709 return $ (p, v') : ps''
731 return $ (p, v') : ps''
710 go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row)
732 go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row)
@@ -771,9 +793,9 @@ checkFunctionApplication' fn u arg = do
772-- Ensure a set of property names and value does not contain duplicate labels
794-- Ensure a set of property names and value does not contain duplicate labels
774−ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m ()
796+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(PSString, Expr)] -> m ()
775ensureNoDuplicateProperties ps =
797ensureNoDuplicateProperties ps =
776 let ls = map fst ps in
798 let ls = map fst ps in
777 case ls \\ nub ls of
799 case ls \\ nub ls of
778− l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing
800+ l : _ -> throwError . errorMessage $ DuplicateLabel (Label l) Nothing
779 _ -> return ()
801 _ -> return ()