455848a · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Better context information for typed hole errors (#2247)

455848aPhil Freeman10 years ago

src/Language/PureScript/AST/Declarations.hs+5−2

compare with golang

unifiedsplit

@@ -26,6 +26,9 @@ import qualified Language.PureScript.Bundle as Bundle

27import qualified Text.Parsec as P

29+-- | A map of locally-bound names in scope.

30+type Context = [(Ident, Type)]

31+

29-- | A type of error messages

32-- | A type of error messages

30data SimpleErrorMessage

33data SimpleErrorMessage

31 = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

34 = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

@@ -96,8 +99,8 @@ data SimpleErrorMessage

96 | ShadowedName Ident

99 | ShadowedName Ident

97 | ShadowedTypeVar String

100 | ShadowedTypeVar String

98 | UnusedTypeVar String

101 | UnusedTypeVar String

99− | WildcardInferredType Type

102+ | WildcardInferredType Type Context

100− | HoleInferredType String Type [(Ident, Type)]

103+ | HoleInferredType String Type Context

101 | MissingTypeDeclaration Ident Type

104 | MissingTypeDeclaration Ident Type

102 | OverlappingPattern [[Binder]] Bool

105 | OverlappingPattern [[Binder]] Bool

103 | IncompleteExhaustivityCheck

106 | IncompleteExhaustivityCheck

src/Language/PureScript/Docs/Convert.hs+1−1

@@ -158,7 +158,7 @@ insertValueTypes env m =

158 either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent

159

160 lookupName name =

161− let key = (modName m, name)

161+ let key = P.Qualified (Just (modName m)) name

162 in case Map.lookup key (P.names env) of

163 Just (ty, _, _) ->

164 ty

src/Language/PureScript/Environment.hs+2−3

@@ -25,7 +25,7 @@ data Environment = Environment {

25 -- |

26 -- Value names currently in scope

27 --

28− names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

28+ names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)

29 -- |

30 -- Type names currently in scope

31 --

@@ -273,7 +273,6 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of

273-- Finds information about values from the current environment.

274--

275lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)

276−lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env

276+lookupValue env ident = ident `M.lookup` names env

277−lookupValue _ _ = Nothing

278

277

279$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)

278$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)

src/Language/PureScript/Errors.hs+26−21

@@ -17,6 +17,7 @@ import Control.Monad.Writer

17import Data.Char (isSpace)

18import Data.Either (lefts, rights)

19import Data.Foldable (fold)

20+import Data.Functor.Identity (Identity(..))

20import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

21import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

21import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

22import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

22import Data.Ord (comparing)

23import Data.Ord (comparing)

@@ -243,7 +244,10 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

243 Just (_, s', _) -> return (Skolem name s' sko ss)

244 Just (_, s', _) -> return (Skolem name s' sko ss)

244 replaceTypes other = return other

245 replaceTypes other = return other

245

246

247+onTypesInErrorMessage :: (Type -> Type) -> ErrorMessage -> ErrorMessage

248+onTypesInErrorMessage f = runIdentity . onTypesInErrorMessageM (Identity . f)

249+

246−onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

250+onTypesInErrorMessageM :: Applicative m => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

247onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple

251onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple

248 where

252 where

249 gSimple (InfiniteType t) = InfiniteType <$> f t

253 gSimple (InfiniteType t) = InfiniteType <$> f t

@@ -258,11 +262,10 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

258 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

262 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

259 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

263 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

260 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

264 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

261− gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty

265+ gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx

262− gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env

266+ gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx

263 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

267 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

264 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

268 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

265−

266 gSimple other = pure other

269 gSimple other = pure other

267

270

268 gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2

271 gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2

@@ -289,7 +292,7 @@ errorSuggestion err = case err of

289 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

292 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

290 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

293 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

291 MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty

294 MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty

292− WildcardInferredType ty -> suggest $ prettyPrintType ty

295+ WildcardInferredType ty _ -> suggest $ prettyPrintType ty

293 _ -> Nothing

296 _ -> Nothing

294

297

295 where

298 where

@@ -721,24 +724,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

721 paras [ line "hiding imports cannot be used to hide modules."

724 paras [ line "hiding imports cannot be used to hide modules."

722 , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)

725 , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)

723 ]

726 ]

724− renderSimpleErrorMessage (WildcardInferredType ty) =

727+ renderSimpleErrorMessage (WildcardInferredType ty ctx) =

725− paras [ line "Wildcard type definition has the inferred type "

728+ paras $ [ line "Wildcard type definition has the inferred type "

726− , markCodeBox $ indent $ typeAsBox ty

729+ , markCodeBox $ indent $ typeAsBox ty

727− ]

730+ ] ++ renderContext ctx

728− renderSimpleErrorMessage (HoleInferredType name ty env) =

731+ renderSimpleErrorMessage (HoleInferredType name ty ctx) =

729 paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

732 paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

730 , markCodeBox $ indent $ typeAsBox ty

733 , markCodeBox $ indent $ typeAsBox ty

731− ] ++ if null env then [] else envInfo

734+ ] ++ renderContext ctx

732− where

733− envInfo :: [Box.Box]

734− envInfo = [ line "in the following context:"

735− , indent $ paras

736− [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")

737− , markCodeBox $ typeAsBox ty'

738− ]

739− | (ident, ty') <- take 5 env

740− ]

741− ]

742 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

735 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

743 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."

736 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."

744 , line "It is good practice to provide type declarations as a form of documentation."

737 , line "It is good practice to provide type declarations as a form of documentation."

@@ -951,6 +944,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

951 , detail

944 , detail

952 ]

945 ]

953

946

947+ renderContext :: Context -> [Box.Box]

948+ renderContext [] = []

949+ renderContext ctx =

950+ [ line "in the following context:"

951+ , indent $ paras

952+ [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")

953+ , markCodeBox $ typeAsBox ty'

954+ ]

955+ | (ident, ty') <- take 5 ctx

956+ ]

957+ ]

958+

954 printName :: Qualified Name -> String

959 printName :: Qualified Name -> String

955 printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)

960 printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)

956

961

src/Language/PureScript/Externs.hs+2−2

@@ -140,7 +140,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

140 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }

141 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }

142 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }

143− applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }

143+ applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }

144 applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }

145 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

146 where

@@ -201,7 +201,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

201 ]

202 _ -> internalError "toExternsDeclaration: Invalid input"

203 toExternsDeclaration (ValueRef ident)

204− | Just (ty, _, _) <- (mn, ident) `M.lookup` names env

204+ | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env

205 = [ EDValue ident ty ]

206 toExternsDeclaration (TypeClassRef className)

207 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env

src/Language/PureScript/Interactive.hs+1−1

@@ -234,7 +234,7 @@ handleTypeOf val = do

234 case e of

235 Left errs -> printErrors errs

236 Right (_, env') ->

237− case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

237+ case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of

238 Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty

239 Nothing -> liftIO $ putStrLn "Could not find type"

240

src/Language/PureScript/Interactive/Printer.hs+8−5

@@ -19,9 +19,10 @@ import qualified Text.PrettyPrint.Boxes as Box

19printModuleSignatures :: P.ModuleName -> P.Environment -> String

20printModuleSignatures moduleName (P.Environment {..}) =

21 -- get relevant components of a module from environment

22− let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names

22+ let moduleNamesIdent = byModuleName names

23− moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses

23+ moduleTypeClasses = byModuleName typeClasses

24− moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types

24+ moduleTypes = byModuleName types

25+ byModuleName = filter ((== Just moduleName) . P.getQual) . M.keys

26 in

27 in

27 -- print each component

28 -- print each component

@@ -33,8 +34,10 @@ printModuleSignatures moduleName (P.Environment {..}) =

34 where printModule's showF = Box.vsep 1 Box.left . showF

35 where printModule's showF = Box.vsep 1 Box.left . showF

36− findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

37+ findNameType :: M.Map (P.Qualified P.Ident) (P.Type, P.NameKind, P.NameVisibility)

38+ -> P.Qualified P.Ident

39+ -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

37− findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

40+ findNameType envNames m = (P.disqualify m, M.lookup m envNames)

39 showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

42 showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

40 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

43 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

src/Language/PureScript/TypeChecker.hs+5−5

@@ -91,7 +91,7 @@ valueIsNotDefined

91 -> m ()

92valueIsNotDefined moduleName name = do

93 env <- getEnv

94− case M.lookup (moduleName, name) (names env) of

94+ case M.lookup (Qualified (Just moduleName) name) (names env) of

95 Just _ -> throwError . errorMessage $ RedefinedIdent name

96 Nothing -> return ()

@@ -104,7 +104,7 @@ addValue

104 -> m ()

105addValue moduleName name ty nameKind = do

106 env <- getEnv

107− putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

107+ putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, nameKind, Defined) (names env) })

108

109addTypeClass

110 :: (MonadState CheckState m)

@@ -259,9 +259,9 @@ typeCheckAll moduleName _ = traverse go

259 env <- getEnv

260 kind <- kindOf ty

261 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

262− case M.lookup (moduleName, name) (names env) of

262+ case M.lookup (Qualified (Just moduleName) name) (names env) of

263 Just _ -> throwError . errorMessage $ RedefinedIdent name

264− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

264+ Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) })

265 return d

266 go d@FixityDeclaration{} = return d

267 go d@ImportDeclaration{} = return d

@@ -360,7 +360,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =

360 Just (_, _, ty, _) -> checkExport dr extract ty

361 return ()

362 checkMemberExport extract dr@(ValueRef name) = do

363− ty <- lookupVariable mn (Qualified (Just mn) name)

363+ ty <- lookupVariable (Qualified (Just mn) name)

364 checkExport dr extract ty

365 checkMemberExport _ _ = return ()

366

src/Language/PureScript/TypeChecker/Entailment.hs+15−15

@@ -2,7 +2,7 @@

2-- Type class entailment

3--

4module Language.PureScript.TypeChecker.Entailment

5− ( Context

5+ ( InstanceContext

6 , replaceTypeClassDictionaries

7 ) where

@@ -28,14 +28,14 @@ import Language.PureScript.TypeClassDictionaries

28import Language.PureScript.Types

29import qualified Language.PureScript.Constants as C

31−-- | The 'Context' tracks those constraints which can be satisfied.

31+-- | The 'InstanceContext' tracks those constraints which can be satisfied.

32−type Context = M.Map (Maybe ModuleName)

32+type InstanceContext = M.Map (Maybe ModuleName)

33− (M.Map (Qualified (ProperName 'ClassName))

33+ (M.Map (Qualified (ProperName 'ClassName))

34− (M.Map (Qualified Ident)

34+ (M.Map (Qualified Ident)

35− TypeClassDictionaryInScope))

35+ TypeClassDictionaryInScope))

37-- | Merge two type class contexts

38−combineContexts :: Context -> Context -> Context

38+combineContexts :: InstanceContext -> InstanceContext -> InstanceContext

39combineContexts = M.unionWith (M.unionWith M.union)

41-- | Replace type class dictionary placeholders with inferred type class dictionaries

@@ -62,12 +62,12 @@ entails

62 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

63 => Bool

64 -> ModuleName

65− -> Context

65+ -> InstanceContext

66 -> Constraint

67− -> StateT Context m (Expr, [(Ident, Constraint)])

67+ -> StateT InstanceContext m (Expr, [(Ident, Constraint)])

68entails shouldGeneralize moduleName context = solve

69 where

70− forClassName :: Context -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

70+ forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

71 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

72 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

@@ -77,15 +77,15 @@ entails shouldGeneralize moduleName context = solve

77 ctorModules (TypeApp ty _) = ctorModules ty

78 ctorModules _ = Nothing

80− findDicts :: Context -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

80+ findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

81 findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

83− solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)])

83+ solve :: Constraint -> StateT InstanceContext m (Expr, [(Ident, Constraint)])

84 solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do

85 (dict, unsolved) <- go 0 con

86 return (dictionaryValueToValue dict, unsolved)

87 where

88− go :: Int -> Constraint -> StateT Context m (DictionaryValue, [(Ident, Constraint)])

88+ go :: Int -> Constraint -> StateT InstanceContext m (DictionaryValue, [(Ident, Constraint)])

89 go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

90 go work con'@(Constraint className' tys' _) = do

91 -- Get the inferred constraint context so far, and merge it with the global context

@@ -108,7 +108,7 @@ entails shouldGeneralize moduleName context = solve

108 -- Generate a fresh name for the unsolved constraint's new dictionary

109 ident <- freshIdent ("dict" ++ runProperName pn)

110 let qident = Qualified Nothing ident

111− -- Store the new dictionary in the Context so that we can solve this goal in

111+ -- Store the new dictionary in the InstanceContext so that we can solve this goal in

112 -- future.

113 let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing

114 newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))

@@ -145,7 +145,7 @@ entails shouldGeneralize moduleName context = solve

145 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

146 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

147 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

148− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)])

148+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT InstanceContext m (Maybe [DictionaryValue], [(Ident, Constraint)])

149 solveSubgoals _ Nothing = return (Nothing, [])

150 solveSubgoals subst (Just subgoals) = do

151 zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals

src/Language/PureScript/TypeChecker/Monad.hs+21−19

@@ -66,7 +66,7 @@ type Unknown = Int

66-- | Temporarily bind a collection of names to values

67bindNames

68 :: MonadState CheckState m

69− => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

69+ => M.Map (Qualified Ident) (Type, NameKind, NameVisibility)

70 -> m a

71 -> m a

72bindNames newNames action = do

@@ -160,12 +160,11 @@ lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDict

160-- | Temporarily bind a collection of names to local variables

161bindLocalVariables

162 :: (MonadState CheckState m)

163− => ModuleName

164− -> [(Ident, Type, NameVisibility)]

163+ => [(Ident, Type, NameVisibility)]

165 -> m a

164 -> m a

166 -> m a

165 -> m a

167−bindLocalVariables moduleName bindings =

166+bindLocalVariables bindings =

168− bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

167+ bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> (Qualified Nothing name, (ty, Private, visibility)))

169

168

170-- | Temporarily bind a collection of names to local type variables

169-- | Temporarily bind a collection of names to local type variables

171bindLocalTypeVariables

170bindLocalTypeVariables

@@ -196,35 +195,32 @@ preservingNames action = do

196-- | Lookup the type of a value by name in the @Environment@

195-- | Lookup the type of a value by name in the @Environment@

197lookupVariable

196lookupVariable

198 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

197 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

199− => ModuleName

200− -> Qualified Ident

198+ => Qualified Ident

201 -> m Type

199 -> m Type

202−lookupVariable currentModule (Qualified moduleName var) = do

200+lookupVariable qual = do

203 env <- getEnv

201 env <- getEnv

204− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

202+ case M.lookup qual (names env) of

205− Nothing -> throwError . errorMessage $ NameIsUndefined var

203+ Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)

206 Just (ty, _, _) -> return ty

204 Just (ty, _, _) -> return ty

207

205

208-- | Lookup the visibility of a value by name in the @Environment@

206-- | Lookup the visibility of a value by name in the @Environment@

209getVisibility

207getVisibility

210 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

208 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

211− => ModuleName

212− -> Qualified Ident

209+ => Qualified Ident

213 -> m NameVisibility

210 -> m NameVisibility

214−getVisibility currentModule (Qualified moduleName var) = do

211+getVisibility qual = do

215 env <- getEnv

212 env <- getEnv

216− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

213+ case M.lookup qual (names env) of

217− Nothing -> throwError . errorMessage $ NameIsUndefined var

214+ Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)

218 Just (_, _, vis) -> return vis

215 Just (_, _, vis) -> return vis

219

216

220-- | Assert that a name is visible

217-- | Assert that a name is visible

221checkVisibility

218checkVisibility

222 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

219 :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

223− => ModuleName

224− -> Qualified Ident

220+ => Qualified Ident

225 -> m ()

221 -> m ()

226−checkVisibility currentModule name@(Qualified _ var) = do

222+checkVisibility name@(Qualified _ var) = do

227− vis <- getVisibility currentModule name

223+ vis <- getVisibility name

228 case vis of

224 case vis of

229 Undefined -> throwError . errorMessage $ CycleInDeclaration var

225 Undefined -> throwError . errorMessage $ CycleInDeclaration var

230 _ -> return ()

226 _ -> return ()

@@ -245,6 +241,12 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

245getEnv :: (MonadState CheckState m) => m Environment

241getEnv :: (MonadState CheckState m) => m Environment

246getEnv = checkEnv <$> get

242getEnv = checkEnv <$> get

247

243

244+-- | Get locally-bound names in context, to create an error message.

245+getLocalContext :: MonadState CheckState m => m Context

246+getLocalContext = do

247+ env <- getEnv

248+ return [ (ident, ty') | ((Qualified Nothing ident@Ident{}), (ty', _, Defined)) <- M.toList (names env) ]

249+

248-- | Update the @Environment@

250-- | Update the @Environment@

249putEnv :: (MonadState CheckState m) => Environment -> m ()

251putEnv :: (MonadState CheckState m) => Environment -> m ()

250putEnv env = modify (\s -> s { checkEnv = env })

252putEnv env = modify (\s -> s { checkEnv = env })

src/Language/PureScript/TypeChecker/Types.hs+34−48

@@ -26,7 +26,6 @@ module Language.PureScript.TypeChecker.Types

27import Prelude.Compat

29−import Control.Arrow (second)

30import Control.Monad

29import Control.Monad

31import Control.Monad.Error.Class (MonadError(..))

30import Control.Monad.Error.Class (MonadError(..))

32import Control.Monad.State.Class (MonadState(..), gets)

31import Control.Monad.State.Class (MonadState(..), gets)

@@ -71,7 +70,7 @@ typesOf ::

71 m [(Ident, (Expr, Type))]

70 m [(Ident, (Expr, Type))]

72typesOf bindingGroupType moduleName vals = do

71typesOf bindingGroupType moduleName vals = do

73 tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do

72 tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do

74− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

73+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals

75 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

74 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

76 ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

75 ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

77 return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

76 return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

@@ -117,26 +116,21 @@ typesOf bindingGroupType moduleName vals = do

117 tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

116 tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

118

117

119 -- Replace all the wildcards types with their inferred types

118 -- Replace all the wildcards types with their inferred types

120− replace sub (ErrorMessage hints (WildcardInferredType ty)) =

121− ErrorMessage hints . WildcardInferredType $ substituteType sub ty

122− replace sub (ErrorMessage hints (HoleInferredType name ty env)) =

123− ErrorMessage hints $ HoleInferredType name (substituteType sub ty)

124− (map (second (substituteType sub)) env)

119+ replace sub = onTypesInErrorMessage (substituteType sub)

125− replace _ em = em

126

120

127 isHoleError :: ErrorMessage -> Bool

121 isHoleError :: ErrorMessage -> Bool

128 isHoleError (ErrorMessage _ HoleInferredType{}) = True

122 isHoleError (ErrorMessage _ HoleInferredType{}) = True

129 isHoleError _ = False

123 isHoleError _ = False

130

124

131−type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

125+type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)

132

126

133type UntypedData = [(Ident, Type)]

127type UntypedData = [(Ident, Type)]

134

128

135−typeDictionaryForBindingGroup ::

129+typeDictionaryForBindingGroup

136− (MonadState CheckState m) =>

130+ :: (MonadState CheckState m)

137− ModuleName ->

131+ => Maybe ModuleName

138− [(Ident, Expr)] ->

132+ -> [(Ident, Expr)]

139− m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

133+ -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

140typeDictionaryForBindingGroup moduleName vals = do

134typeDictionaryForBindingGroup moduleName vals = do

141 let

135 let

142 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

136 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

@@ -154,15 +148,15 @@ typeDictionaryForBindingGroup moduleName vals = do

154 -- Make a map of names to the unification variables of untyped declarations

148 -- Make a map of names to the unification variables of untyped declarations

155 untypedDict = zip (map fst untyped) untypedNames

149 untypedDict = zip (map fst untyped) untypedNames

156 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

150 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

157− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)

151+ dict = M.fromList (map (\(ident, ty) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)

158 return (untyped, typed, dict, untypedDict)

152 return (untyped, typed, dict, untypedDict)

159

153

160−checkTypedBindingGroupElement ::

154+checkTypedBindingGroupElement

161− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

155+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

162− ModuleName ->

156+ => ModuleName

163− (Ident, (Expr, Type, Bool)) ->

157+ -> (Ident, (Expr, Type, Bool))

164− TypeData ->

158+ -> TypeData

165− m (Ident, (Expr, Type))

159+ -> m (Ident, (Expr, Type))

166checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

160checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

167 -- Replace type wildcards

161 -- Replace type wildcards

168 ty' <- replaceTypeWildcards ty

162 ty' <- replaceTypeWildcards ty

@@ -176,12 +170,12 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

176 else return (TypedValue False val' ty'')

170 else return (TypedValue False val' ty'')

177 return (ident, (val'', ty''))

171 return (ident, (val'', ty''))

178

172

179−typeForBindingGroupElement ::

173+typeForBindingGroupElement

180− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

174+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

181− (Ident, Expr) ->

175+ => (Ident, Expr)

182− TypeData ->

176+ -> TypeData

183− UntypedData ->

177+ -> UntypedData

184− m (Ident, (Expr, Type))

178+ -> m (Ident, (Expr, Type))

185typeForBindingGroupElement (ident, val) dict untypedDict = do

179typeForBindingGroupElement (ident, val) dict untypedDict = do

186 -- Infer the type with the new names in scope

180 -- Infer the type with the new names in scope

187 TypedValue _ val' ty <- bindNames dict $ infer val

181 TypedValue _ val' ty <- bindNames dict $ infer val

@@ -275,8 +269,7 @@ infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val pro

275 return $ TypedValue True (Accessor prop typed) field

269 return $ TypedValue True (Accessor prop typed) field

276infer' (Abs (Left arg) ret) = do

270infer' (Abs (Left arg) ret) = do

277 ty <- freshType

271 ty <- freshType

278− Just moduleName <- checkCurrentModule <$> get

279− withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

272+ withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do

280 body@(TypedValue _ _ bodyTy) <- infer' ret

273 body@(TypedValue _ _ bodyTy) <- infer' ret

281 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

274 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

282infer' (Abs (Right _) _) = internalError "Binder was not desugared"

275infer' (Abs (Right _) _) = internalError "Binder was not desugared"

@@ -285,9 +278,8 @@ infer' (App f arg) = do

285 (ret, app) <- checkFunctionApplication f' ft arg Nothing

278 (ret, app) <- checkFunctionApplication f' ft arg Nothing

286 return $ TypedValue True app ret

279 return $ TypedValue True app ret

287infer' (Var var) = do

280infer' (Var var) = do

288− Just moduleName <- checkCurrentModule <$> get

289− checkVisibility moduleName var

281+ checkVisibility var

290− ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var

282+ ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var

291 case ty of

283 case ty of

292 ConstrainedType constraints ty' -> do

284 ConstrainedType constraints ty' -> do

293 dicts <- getTypeClassDictionaries

285 dicts <- getTypeClassDictionaries

@@ -329,9 +321,7 @@ infer' (TypedValue checkType val ty) = do

329 return $ TypedValue True val' ty'

321 return $ TypedValue True val' ty'

330infer' (Hole name) = do

322infer' (Hole name) = do

331 ty <- freshType

323 ty <- freshType

332− env <- M.toList . names <$> getEnv

324+ ctx <- getLocalContext

333− Just moduleName <- checkCurrentModule <$> get

334− let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ]

335 tell . errorMessage $ HoleInferredType name ty ctx

325 tell . errorMessage $ HoleInferredType name ty ctx

336 return $ TypedValue True (Hole name) ty

326 return $ TypedValue True (Hole name) ty

337infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do

327infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do

@@ -351,20 +341,19 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue

351 Just moduleName <- checkCurrentModule <$> get

341 Just moduleName <- checkCurrentModule <$> get

352 (kind, args) <- kindOfWithScopedVars ty

342 (kind, args) <- kindOfWithScopedVars ty

353 checkTypeKind ty kind

343 checkTypeKind ty kind

354− let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

344+ let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined)

355 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

345 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

356 TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv

346 TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv

357− bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

347+ bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

358inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

348inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

359 valTy <- freshType

349 valTy <- freshType

360− Just moduleName <- checkCurrentModule <$> get

361− let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)

350+ let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined)

362 TypedValue _ val' valTy' <- bindNames dict $ infer val

351 TypedValue _ val' valTy' <- bindNames dict $ infer val

363 unifyTypes valTy valTy'

352 unifyTypes valTy valTy'

364− bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j

353+ bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j

365inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

354inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

366 Just moduleName <- checkCurrentModule <$> get

355 Just moduleName <- checkCurrentModule <$> get

367− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

356+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)

368 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

357 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

369 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

358 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

370 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

359 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

@@ -483,9 +472,8 @@ checkBinders _ _ [] = return []

483checkBinders nvals ret (CaseAlternative binders result : bs) = do

472checkBinders nvals ret (CaseAlternative binders result : bs) = do

484 guardWith (errorMessage $ OverlappingArgNames Nothing) $

473 guardWith (errorMessage $ OverlappingArgNames Nothing) $

485 let ns = concatMap binderNames binders in length (nub ns) == length ns

474 let ns = concatMap binderNames binders in length (nub ns) == length ns

486− Just moduleName <- checkCurrentModule <$> get

487 m1 <- M.unions <$> zipWithM inferBinder nvals binders

475 m1 <- M.unions <$> zipWithM inferBinder nvals binders

488− r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $

476+ r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $

489 CaseAlternative binders <$>

477 CaseAlternative binders <$>

490 case result of

478 case result of

491 Left gs -> do

479 Left gs -> do

@@ -577,8 +565,7 @@ check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do

577 return $ TypedValue True array t

565 return $ TypedValue True array t

578check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

566check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

579 unifyTypes t tyFunction

567 unifyTypes t tyFunction

580− Just moduleName <- checkCurrentModule <$> get

581− ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

568+ ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy

582 return $ TypedValue True (Abs (Left arg) ret') ty

569 return $ TypedValue True (Abs (Left arg) ret') ty

583check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

570check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

584check' (App f arg) ret = do

571check' (App f arg) ret = do

@@ -586,9 +573,8 @@ check' (App f arg) ret = do

586 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

573 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

587 return $ TypedValue True app ret

574 return $ TypedValue True app ret

588check' v@(Var var) ty = do

575check' v@(Var var) ty = do

589− Just moduleName <- checkCurrentModule <$> get

590− checkVisibility moduleName var

576+ checkVisibility var

591− repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

577+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var

592 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

578 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

593 v' <- subsumes (Just v) repl ty'

579 v' <- subsumes (Just v) repl ty'

594 case v' of

580 case v' of

src/Language/PureScript/TypeChecker/Unify.hs+8−4

@@ -112,9 +112,11 @@ unifyTypes t1 t2 = do

112 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

113 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

114 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

115+ unifyTypes' ty1@(ConstrainedType _ _) ty2 =

115− unifyTypes' ty1@(ConstrainedType _ _) ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2

116+ throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2

116 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3

117 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3

118+ unifyTypes' t3 t4 =

117− unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4

119+ throwError . errorMessage $ TypesDoNotUnify t3 t4

118

120

119-- |

121-- |

120-- Unify two rows, updating the current substitution

122-- Unify two rows, updating the current substitution

@@ -147,7 +149,8 @@ unifyRows r1 r2 =

147 unifyRows' [] REmpty [] REmpty = return ()

149 unifyRows' [] REmpty [] REmpty = return ()

148 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

150 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

149 unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()

151 unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()

152+ unifyRows' _ _ _ _ =

150− unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2

153+ throwError . errorMessage $ TypesDoNotUnify r1 r2

151

154

152-- |

155-- |

153-- Check that two types unify

156-- Check that two types unify

@@ -195,7 +198,8 @@ replaceTypeWildcards = everywhereOnTypesM replace

195 where

198 where

196 replace (TypeWildcard ss) = do

199 replace (TypeWildcard ss) = do

197 t <- freshType

200 t <- freshType

201+ ctx <- getLocalContext

198− warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t

202+ warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t ctx

199 return t

203 return t

200 replace other = return other

204 replace other = return other

201

205