455848a · rowtype-yoga/purescript-native

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

Better context information for typed hole errors (#2247)

* Better context information for typed hole errors * Context information in wildcard warnings

commit455848a5494dc041b3c6f1ae5133528c5204ac19 authorPhil Freeman <paf31@cantab.net> dateSun 31 Jul 2016, 10:26 (10 years ago) parenteb09a8a

12 files changed+128−126

compare with golang

unifiedsplit

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

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

2626

2727import qualified Text.Parsec as P

2828

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

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

31+

2932-- | A type of error messages

3033data SimpleErrorMessage

3134 = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

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

9699 | ShadowedName Ident

97100 | ShadowedTypeVar String

98101 | UnusedTypeVar String

99− | WildcardInferredType Type

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

102+ | WildcardInferredType Type Context

103+ | HoleInferredType String Type Context

101104 | MissingTypeDeclaration Ident Type

102105 | OverlappingPattern [[Binder]] Bool

103106 | IncompleteExhaustivityCheck

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

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

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

159159

160160 lookupName name =

161− let key = (modName m, name)

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

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

163163 Just (ty, _, _) ->

164164 ty

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

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

2525 -- |

2626 -- Value names currently in scope

2727 --

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

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

2929 -- |

3030 -- Type names currently in scope

3131 --

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

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

274274--

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

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

277−lookupValue _ _ = Nothing

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

278277

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

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

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

1717import Data.Char (isSpace)

1818import Data.Either (lefts, rights)

1919import Data.Foldable (fold)

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

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

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

2223import Data.Ord (comparing)

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

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

244245 replaceTypes other = return other

245246

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

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

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

249+

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

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

248252 where

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

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

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

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

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

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

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

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

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

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

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

265−

266269 gSimple other = pure other

267270

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

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

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

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

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

292− WildcardInferredType ty -> suggest $ prettyPrintType ty

295+ WildcardInferredType ty _ -> suggest $ prettyPrintType ty

293296 _ -> Nothing

294297

295298 where

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

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

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

723726 ]

724− renderSimpleErrorMessage (WildcardInferredType ty) =

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

726− , markCodeBox $ indent $ typeAsBox ty

727− ]

728− renderSimpleErrorMessage (HoleInferredType name ty env) =

727+ renderSimpleErrorMessage (WildcardInferredType ty ctx) =

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

729+ , markCodeBox $ indent $ typeAsBox ty

730+ ] ++ renderContext ctx

731+ renderSimpleErrorMessage (HoleInferredType name ty ctx) =

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

730733 , markCodeBox $ indent $ typeAsBox ty

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

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− ]

734+ ] ++ renderContext ctx

742735 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

744737 , 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

951944 , detail

952945 ]

953946

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+

954959 printName :: Qualified Name -> String

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

956961

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

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

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

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

142142 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) }

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

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

146146 where

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

201201 ]

202202 _ -> internalError "toExternsDeclaration: Invalid input"

203203 toExternsDeclaration (ValueRef ident)

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

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

205205 = [ EDValue ident ty ]

206206 toExternsDeclaration (TypeClassRef className)

207207 | 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

234234 case e of

235235 Left errs -> printErrors errs

236236 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

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

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

240240

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

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

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

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

2121 -- get relevant components of a module from environment

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

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

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

22+ let moduleNamesIdent = byModuleName names

23+ moduleTypeClasses = byModuleName typeClasses

24+ moduleTypes = byModuleName types

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

2526

2627 in

2728 -- print each component

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

3334

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

3536

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 envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

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))

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

3841

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

4043 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

9191 -> m ()

9292valueIsNotDefined moduleName name = do

9393 env <- getEnv

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

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

9595 Just _ -> throwError . errorMessage $ RedefinedIdent name

9696 Nothing -> return ()

9797

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

104104 -> m ()

105105addValue moduleName name ty nameKind = do

106106 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) })

108108

109109addTypeClass

110110 :: (MonadState CheckState m)

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

259259 env <- getEnv

260260 kind <- kindOf ty

261261 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

263263 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) })

265265 return d

266266 go d@FixityDeclaration{} = return d

267267 go d@ImportDeclaration{} = return d

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

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

361361 return ()

362362 checkMemberExport extract dr@(ValueRef name) = do

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

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

364364 checkExport dr extract ty

365365 checkMemberExport _ _ = return ()

366366

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

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

22-- Type class entailment

33--

44module Language.PureScript.TypeChecker.Entailment

5− ( Context

5+ ( InstanceContext

66 , replaceTypeClassDictionaries

77 ) where

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

2828import Language.PureScript.Types

2929import qualified Language.PureScript.Constants as C

3030

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

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

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

34− (M.Map (Qualified Ident)

35− TypeClassDictionaryInScope))

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

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

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

34+ (M.Map (Qualified Ident)

35+ TypeClassDictionaryInScope))

3636

3737-- | Merge two type class contexts

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

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

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

4040

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

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

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

6363 => Bool

6464 -> ModuleName

65− -> Context

65+ -> InstanceContext

6666 -> Constraint

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

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

6868entails shouldGeneralize moduleName context = solve

6969 where

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

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

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

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

7373

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

7777 ctorModules (TypeApp ty _) = ctorModules ty

7878 ctorModules _ = Nothing

7979

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

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

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

8282

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

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

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

8585 (dict, unsolved) <- go 0 con

8686 return (dictionaryValueToValue dict, unsolved)

8787 where

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

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

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

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

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

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

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

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

110110 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

112112 -- future.

113113 let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing

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

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

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

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

147147 -- 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)])

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

150150 solveSubgoals subst (Just subgoals) = do

151151 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

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

6767bindNames

6868 :: MonadState CheckState m

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

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

7070 -> m a

7171 -> m a

7272bindNames newNames action = do

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

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

161161bindLocalVariables

162162 :: (MonadState CheckState m)

163− => ModuleName

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

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

165164 -> m a

166165 -> m a

167−bindLocalVariables moduleName bindings =

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

166+bindLocalVariables bindings =

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

169168

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

171170bindLocalTypeVariables

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

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

197196lookupVariable

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

199− => ModuleName

200− -> Qualified Ident

198+ => Qualified Ident

201199 -> m Type

202−lookupVariable currentModule (Qualified moduleName var) = do

200+lookupVariable qual = do

203201 env <- getEnv

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

205− Nothing -> throwError . errorMessage $ NameIsUndefined var

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

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

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

207205

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

209207getVisibility

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

211− => ModuleName

212− -> Qualified Ident

209+ => Qualified Ident

213210 -> m NameVisibility

214−getVisibility currentModule (Qualified moduleName var) = do

211+getVisibility qual = do

215212 env <- getEnv

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

217− Nothing -> throwError . errorMessage $ NameIsUndefined var

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

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

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

219216

220217-- | Assert that a name is visible

221218checkVisibility

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

223− => ModuleName

224− -> Qualified Ident

220+ => Qualified Ident

225221 -> m ()

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

227− vis <- getVisibility currentModule name

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

223+ vis <- getVisibility name

228224 case vis of

229225 Undefined -> throwError . errorMessage $ CycleInDeclaration var

230226 _ -> return ()

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

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

246242getEnv = checkEnv <$> get

247243

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+

248250-- | Update the @Environment@

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

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

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

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

2626

2727import Prelude.Compat

2828

29−import Control.Arrow (second)

3029import Control.Monad

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

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

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

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

7271typesOf bindingGroupType moduleName vals = do

7372 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

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

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

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

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

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

118117

119118 -- 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)

125− replace _ em = em

119+ replace sub = onTypesInErrorMessage (substituteType sub)

126120

127121 isHoleError :: ErrorMessage -> Bool

128122 isHoleError (ErrorMessage _ HoleInferredType{}) = True

129123 isHoleError _ = False

130124

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

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

132126

133127type UntypedData = [(Ident, Type)]

134128

135−typeDictionaryForBindingGroup ::

136− (MonadState CheckState m) =>

137− ModuleName ->

138− [(Ident, Expr)] ->

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

129+typeDictionaryForBindingGroup

130+ :: (MonadState CheckState m)

131+ => Maybe ModuleName

132+ -> [(Ident, Expr)]

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

140134typeDictionaryForBindingGroup moduleName vals = do

141135 let

142136 -- 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

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

155149 untypedDict = zip (map fst untyped) untypedNames

156150 -- 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)

158152 return (untyped, typed, dict, untypedDict)

159153

160−checkTypedBindingGroupElement ::

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

162− ModuleName ->

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

164− TypeData ->

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

154+checkTypedBindingGroupElement

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

156+ => ModuleName

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

158+ -> TypeData

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

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

167161 -- Replace type wildcards

168162 ty' <- replaceTypeWildcards ty

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

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

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

178172

179−typeForBindingGroupElement ::

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

181− (Ident, Expr) ->

182− TypeData ->

183− UntypedData ->

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

173+typeForBindingGroupElement

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

175+ => (Ident, Expr)

176+ -> TypeData

177+ -> UntypedData

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

185179typeForBindingGroupElement (ident, val) dict untypedDict = do

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

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

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

275269 return $ TypedValue True (Accessor prop typed) field

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

277271 ty <- freshType

278− Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

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

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

286279 return $ TypedValue True app ret

287280infer' (Var var) = do

288− Just moduleName <- checkCurrentModule <$> get

289− checkVisibility moduleName var

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

281+ checkVisibility var

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

291283 case ty of

292284 ConstrainedType constraints ty' -> do

293285 dicts <- getTypeClassDictionaries

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

329321 return $ TypedValue True val' ty'

330322infer' (Hole name) = do

331323 ty <- freshType

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

333− Just moduleName <- checkCurrentModule <$> get

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

324+ ctx <- getLocalContext

335325 tell . errorMessage $ HoleInferredType name ty ctx

336326 return $ TypedValue True (Hole name) ty

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

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

351341 Just moduleName <- checkCurrentModule <$> get

352342 (kind, args) <- kindOfWithScopedVars ty

353343 checkTypeKind ty kind

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

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

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

356346 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

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

359349 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)

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

363352 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

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

366355 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)

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

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

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

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

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

484473 guardWith (errorMessage $ OverlappingArgNames Nothing) $

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

486− Just moduleName <- checkCurrentModule <$> get

487475 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 ] $

489477 CaseAlternative binders <$>

490478 case result of

491479 Left gs -> do

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

577565 return $ TypedValue True array t

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

579567 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

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

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

584571check' (App f arg) ret = do

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

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

587574 return $ TypedValue True app ret

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

589− Just moduleName <- checkCurrentModule <$> get

590− checkVisibility moduleName var

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

576+ checkVisibility var

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

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

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

594580 case v' of

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

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

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

113113 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

114114 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

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

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

116+ throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2

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

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

118+ unifyTypes' t3 t4 =

119+ throwError . errorMessage $ TypesDoNotUnify t3 t4

118120

119121-- |

120122-- Unify two rows, updating the current substitution

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

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

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

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

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

152+ unifyRows' _ _ _ _ =

153+ throwError . errorMessage $ TypesDoNotUnify r1 r2

151154

152155-- |

153156-- Check that two types unify

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

195198 where

196199 replace (TypeWildcard ss) = do

197200 t <- freshType

198− warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t

201+ ctx <- getLocalContext

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

199203 return t

200204 replace other = return other

201205