1a087e7 · rowtype-yoga/purescript-native

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

Initial work on #242

commit1a087e746637af668dbcc8c55f83fefdafda4495 authorPhil Freeman <paf31@cantab.net> dateThu 27 Mar 2014, 18:27 (13 years ago) parent33cfbe7

11 files changed+191−106

compare with golang

unifiedsplit

examples/failing/TypeClasses.purs−7 examples/failing/TypeClasses2.purs+2 psc-make/Main.hs+5−1 psc/Main.hs+5−1 psci/Main.hs+1−1 src/Language/PureScript.hs+7−6 src/Language/PureScript/Options.hs+5−1 src/Language/PureScript/TypeChecker.hs+14−14 src/Language/PureScript/TypeChecker/Kinds.hs+19−13 src/Language/PureScript/TypeChecker/Monad.hs+90−17 src/Language/PureScript/TypeChecker/Types.hs+43−45

examples/failing/TypeClasses.pursdeleted−7

@@ -1,7 +0,0 @@

1−module TypeClasses where

2−

3−class Show a where

4− show :: a -> String

5−

6−instance TypeClasses.Show ([[String]]) where

7− show _ = "array"

examples/failing/TypeClasses2.purs+2

@@ -1,5 +1,7 @@

11module Main where

3+import Prelude ()

35class Show a where

46 show :: a -> String

psc-make/Main.hs+5−1

@@ -115,8 +115,12 @@ browserNamespace :: Term String

115115browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])

116116 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }

117117

118+verboseErrors :: Term Bool

119+verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])

120+ { optDoc = "Display verbose error messages" }

121+

118122options :: Term P.Options

119−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []

123+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure [] <*> verboseErrors

120124

121125inputFilesAndPrelude :: FilePath -> Term [FilePath]

122126inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles

psc/Main.hs+5−1

@@ -122,8 +122,12 @@ codeGenModules :: Term [String]

122122codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])

123123 { optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }

124124

125+verboseErrors :: Term Bool

126+verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])

127+ { optDoc = "Display verbose error messages" }

128+

125129options :: Term P.Options

126−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules

130+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules <*> verboseErrors

127131

128132stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])

129133stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles

psci/Main.hs+1−1

@@ -194,7 +194,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions

194194-- | Compilation options.

195195--

196196options :: P.Options

197−options = P.Options False True False True (Just "Main") True "PS" [] []

197+options = P.Options False True False True (Just "Main") True "PS" [] [] False

198198

199199-- |

200200-- Makes a volatile module to execute the current expression.

src/Language/PureScript.hs+7−6

@@ -71,7 +71,7 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String,

7171compile' env opts ms = do

7272 (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)

7373 desugared <- desugar sorted

74− (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

74+ (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

7575 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

7676 let entryPoints = moduleNameFromString `map` optionsModules opts

7777 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

@@ -100,8 +100,9 @@ typeCheckModule mainModuleName (Module mn decls exps) = do

100100 checkTypesAreExported (ValueRef name) = do

101101 ty <- lookupVariable mn (Qualified (Just mn) name)

102102 case find isTconHidden (findTcons ty) of

103− Just hiddenType -> throwError $ "Error in module '" ++ show mn ++ "':\n\

104− \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"

103+ Just hiddenType -> throwError . strMsg $

104+ "Error in module '" ++ show mn ++ "':\n\

105+ \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"

105106 Nothing -> return ()

106107 checkTypesAreExported _ = return ()

107108

@@ -118,7 +119,7 @@ typeCheckModule mainModuleName (Module mn decls exps) = do

118119 where

119120 go (TypeRef tyName' _) = tyName' /= tyName

120121 go _ = True

121−

122+

122123

123124generateMain :: Environment -> Options -> [JS] -> Either String [JS]

124125generateMain env opts js =

@@ -191,7 +192,7 @@ make opts ms = do

191192 go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()

192193 go _ [] = return ()

193194 go env ((False, m) : ms') = do

194− (_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m

195+ (_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m

195196

196197 go env' ms'

197198 go env ((True, m@(Module moduleName' _ exps)) : ms') = do

@@ -199,7 +200,7 @@ make opts ms = do

199200 jsFile = "js" ++ pathSeparator : filePath ++ ".js"

200201 externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"

201202

202− (Module _ elaborated _, env') <- liftError . runCheck' env $ typeCheckModule Nothing m

203+ (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m

203204

204205 regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

205206

src/Language/PureScript/Options.hs+5−1

@@ -57,10 +57,14 @@ data Options = Options {

5757 -- The modules to code gen

5858 --

5959 , optionsCodeGenModules :: [String]

60+ -- |

61+ -- Verbose error message

62+ --

63+ , optionsVerboseErrors :: Bool

6064 } deriving Show

6165

6266-- |

6367-- Default compiler options

6468--

6569defaultOptions :: Options

66−defaultOptions = Options False False False False Nothing False "PS" [] []

70+defaultOptions = Options False False False False Nothing False "PS" [] [] False

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

@@ -26,6 +26,7 @@ import Language.PureScript.TypeChecker.Types as T

2626import Language.PureScript.TypeChecker.Synonyms as T

2727

2828import Data.Maybe

29+import Data.Monoid ((<>))

2930import qualified Data.Map as M

3031import Control.Monad.State

3132import Control.Monad.Error

@@ -36,14 +37,13 @@ import Language.PureScript.Kinds

3637import Language.PureScript.Declarations

3738import Language.PureScript.TypeClassDictionaries

3839import Language.PureScript.Environment

39−import Language.PureScript.Pretty.Types

4040

4141addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

4242addDataType moduleName name args dctors ctorKind = do

4343 env <- getEnv

4444 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

4545 forM_ dctors $ \(dctor, tys) ->

46− rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $

46+ rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $

4747 addDataConstructor moduleName name args dctor tys

4848

4949addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

@@ -64,7 +64,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()

6464valueIsNotDefined moduleName name = do

6565 env <- getEnv

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

67− Just _ -> throwError $ show name ++ " is already defined"

67+ Just _ -> throwError . strMsg $ show name ++ " is already defined"

6868 Nothing -> return ()

6969

7070addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()

@@ -85,10 +85,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()

8585checkTypeClassInstance _ (TypeVar _) = return ()

8686checkTypeClassInstance _ (TypeConstructor ctor) = do

8787 env <- getEnv

88− when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

88+ when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"

8989 return ()

9090checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2

91−checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid: " ++ prettyPrintType ty

91+checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instance head is invalid." (Just (TypeError ty))

9292

9393-- |

9494-- Type check all declarations in a module

@@ -106,13 +106,13 @@ checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid:

106106typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]

107107typeCheckAll _ _ [] = return []

108108typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do

109− rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

109+ rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do

110110 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

111111 addDataType moduleName name args dctors ctorKind

112112 ds <- typeCheckAll mainModuleName moduleName rest

113113 return $ d : ds

114114typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

115− rethrow ("Error in data binding group:\n" ++) $ do

115+ rethrow (strMsg "Error in data binding group" <>) $ do

116116 let syns = mapMaybe toTypeSynonym tys

117117 let dataDecls = mapMaybe toDataDecl tys

118118 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

@@ -128,14 +128,14 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

128128 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)

129129 toDataDecl _ = Nothing

130130typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

131− rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

131+ rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

132132 kind <- kindsOf False moduleName name args [ty]

133133 addTypeSynonym moduleName name args ty kind

134134 ds <- typeCheckAll mainModuleName moduleName rest

135135 return $ d : ds

136136typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

137137typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do

138− d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

138+ d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do

139139 valueIsNotDefined moduleName name

140140 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

141141 addValue moduleName name ty nameKind

@@ -144,7 +144,7 @@ typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothin

144144 return $ d : ds

145145typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"

146146typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do

147− d <- rethrow (("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals) ++ ":\n") ++) $ do

147+ d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do

148148 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

149149 valueIsNotDefined moduleName name

150150 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

@@ -160,19 +160,19 @@ typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : re

160160 ds <- typeCheckAll mainModuleName moduleName rest

161161 return $ d : ds

162162typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

163− rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

163+ rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do

164164 env <- getEnv

165165 kind <- kindOf moduleName ty

166− guardWith "Expected kind *" $ kind == Star

166+ guardWith (strMsg "Expected kind *") $ kind == Star

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

168− Just _ -> throwError $ show name ++ " is already defined"

168+ Just _ -> throwError . strMsg $ show name ++ " is already defined"

169169 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })

170170 ds <- typeCheckAll mainModuleName moduleName rest

171171 return $ d : ds

172172typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do

173173 ds <- typeCheckAll mainModuleName moduleName rest

174174 env <- getEnv

175− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

175+ guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env

176176 return $ d : ds

177177typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do

178178 env <- getEnv

src/Language/PureScript/TypeChecker/Kinds.hs+19−13

@@ -14,7 +14,7 @@

1414-----------------------------------------------------------------------------

1515

1616{-# OPTIONS_GHC -fno-warn-orphans #-}

17−{-# LANGUAGE MultiParamTypeClasses #-}

17+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

1818

1919module Language.PureScript.TypeChecker.Kinds (

2020 kindOf,

@@ -36,6 +36,7 @@ import Control.Monad.Unify

3636import Control.Applicative

3737

3838import qualified Data.Map as M

39+import Data.Monoid ((<>))

3940

4041instance Partial Kind where

4142 unknown = KUnknown

@@ -52,14 +53,14 @@ instance Unifiable Check Kind where

5253 FunKind k1 k2 =?= FunKind k3 k4 = do

5354 k1 =?= k3

5455 k2 =?= k4

55− k1 =?= k2 = UnifyT . lift . throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

56+ k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

5657

5758-- |

5859-- Infer the kind of a single type

5960--

6061kindOf :: ModuleName -> Type -> Check Kind

6162kindOf _ ty =

62− rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $

63+ rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $

6364 fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty

6465 where

6566 tidyUp (k, sub) = sub $? k

@@ -105,7 +106,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

105106-- |

106107-- Solve the set of kind constraints associated with the data constructors for a type constructor

107108--

108−solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind

109+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind

109110solveTypes isData ts kargs tyCon = do

110111 ks <- mapM infer ts

111112 when isData $ do

@@ -128,39 +129,44 @@ starIfUnknown k = k

128129-- Infer a kind for a type

129130--

130131infer :: Type -> UnifyT Kind Check Kind

131−infer (TypeVar v) = do

132+infer ty = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty

133+

134+infer' :: Type -> UnifyT Kind Check Kind

135+infer' (TypeVar v) = do

132136 Just moduleName <- checkCurrentModule <$> get

133137 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

134−infer (TypeConstructor v) = do

138+infer' c@(TypeConstructor v) = do

135139 env <- liftCheck getEnv

136140 case M.lookup v (types env) of

137− Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"

141+ Nothing -> UnifyT . lift . throwError $ mkUnifyErrorStack "Unknown type constructor" (Just (TypeError c))

138142 Just (kind, _) -> return kind

139−infer (TypeApp t1 t2) = do

143+infer' (TypeApp t1 t2) = do

140144 k0 <- fresh

141145 k1 <- infer t1

142146 k2 <- infer t2

143147 k1 =?= FunKind k2 k0

144148 return k0

145−infer (ForAll ident ty _) = do

149+infer' (ForAll ident ty _) = do

146150 k1 <- fresh

147151 Just moduleName <- checkCurrentModule <$> get

148152 k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty

149153 k2 =?= Star

150154 return Star

151−infer REmpty = do

155+infer' REmpty = do

152156 k <- fresh

153157 return $ Row k

154−infer (RCons _ ty row) = do

158+infer' (RCons _ ty row) = do

155159 k1 <- infer ty

156160 k2 <- infer row

157161 k2 =?= Row k1

158162 return $ Row k1

159−infer (ConstrainedType deps ty) = do

163+infer' (ConstrainedType deps ty) = do

160164 forM_ deps $ \(className, tys) -> do

161165 _ <- infer $ foldl TypeApp (TypeConstructor className) tys

162166 return ()

163167 k <- infer ty

164168 k =?= Star

165169 return Star

166−infer _ = error "Invalid argument to infer"

170+infer' _ = error "Invalid argument to infer"

171+

172+

src/Language/PureScript/TypeChecker/Monad.hs+90−17

@@ -21,10 +21,14 @@ module Language.PureScript.TypeChecker.Monad where

2121import Language.PureScript.Types

2222import Language.PureScript.Kinds

2323import Language.PureScript.Names

24+import Language.PureScript.Declarations

2425import Language.PureScript.Environment

2526import Language.PureScript.TypeClassDictionaries

27+import Language.PureScript.Pretty

28+import Language.PureScript.Options

2629

2730import Data.Maybe

31+import Data.Monoid

2832

2933import Control.Applicative

3034import Control.Monad.State

@@ -32,6 +36,77 @@ import Control.Monad.Error

3236import Control.Monad.Unify

3337

3438import qualified Data.Map as M

39+import Data.List (intercalate)

40+

41+-- |

42+-- Type for sources of type checking errors

43+--

44+data UnifyErrorSource

45+ -- |

46+ -- An error which originated at a Value

47+ --

48+ = ValueError Value

49+ -- |

50+ -- An error which originated at a Type

51+ --

52+ | TypeError Type deriving (Show)

53+

54+-- |

55+-- Unification errors

56+--

57+data UnifyError = UnifyError {

58+ -- |

59+ -- Error message

60+ --

61+ unifyErrorMessage :: String

62+ -- |

63+ -- The value where the error occurred

64+ --

65+ , unifyErrorValue :: Maybe UnifyErrorSource

66+ } deriving (Show)

67+

68+-- |

69+-- A stack trace for an error

70+--

71+newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)

72+

73+instance Error UnifyErrorStack where

74+ strMsg s = UnifyErrorStack [UnifyError s Nothing]

75+ noMsg = UnifyErrorStack []

76+

77+prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String

78+prettyPrintUnifyErrorStack opts (UnifyErrorStack es) | optionsVerboseErrors opts = intercalate "\n" (map showError es)

79+prettyPrintUnifyErrorStack _ (UnifyErrorStack es) =

80+ let

81+ errorsWithValues = filter (isJust . unifyErrorValue) es

82+ mostSpecificError = last es

83+ in case (length errorsWithValues, isJust (unifyErrorValue mostSpecificError)) of

84+ (0, _) -> showError mostSpecificError

85+ (1, True) -> showError mostSpecificError

86+ (1, False) ->

87+ let errorWithValue = head errorsWithValues

88+ in showError errorWithValue ++ "\n" ++

89+ showError mostSpecificError

90+ (_, True) ->

91+ let errorWithValue = head errorsWithValues

92+ in showError errorWithValue ++ "\n" ++

93+ showError mostSpecificError

94+ (_, False) ->

95+ let

96+ leastSpecificErrorWithValue = head errorsWithValues

97+ mostSpecificErrorWithValue = last errorsWithValues

98+ in

99+ showError leastSpecificErrorWithValue ++ "\n" ++

100+ showError mostSpecificErrorWithValue ++ "\n" ++

101+ showError mostSpecificError

102+

103+showError :: UnifyError -> String

104+showError (UnifyError msg Nothing) = msg

105+showError (UnifyError msg (Just (ValueError val))) = "Error in value " ++ prettyPrintValue val ++ ": \n" ++ msg

106+showError (UnifyError msg (Just (TypeError ty))) = "Error in type " ++ prettyPrintType ty ++ ": \n" ++ msg

107+

108+mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack

109+mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t]

35110

36111-- |

37112-- Temporarily bind a collection of names to values

@@ -89,21 +164,21 @@ bindLocalTypeVariables moduleName bindings =

89164-- |

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

91166--

92−lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type

167+lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

93168lookupVariable currentModule (Qualified moduleName var) = do

94169 env <- getEnv

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

96− Nothing -> throwError $ show var ++ " is undefined"

171+ Nothing -> throwError . strMsg $ show var ++ " is undefined"

97172 Just (ty, _) -> return ty

98173

99174-- |

100175-- Lookup the kind of a type by name in the @Environment@

101176--

102−lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind

177+lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

103178lookupTypeVariable currentModule (Qualified moduleName name) = do

104179 env <- getEnv

105180 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

106− Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

181+ Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"

107182 Just (k, _) -> return k

108183

109184-- |

@@ -131,8 +206,8 @@ data CheckState = CheckState {

131206-- |

132207-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

133208--

134−newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

135− deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)

209+newtype Check a = Check { unCheck :: StateT CheckState (Either UnifyErrorStack) a }

210+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError UnifyErrorStack)

136211

137212-- |

138213-- Get the current @Environment@

@@ -155,14 +230,14 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

155230-- |

156231-- Run a computation in the Check monad, starting with an empty @Environment@

157232--

158−runCheck :: Check a -> Either String (a, Environment)

159−runCheck = runCheck' initEnvironment

233+runCheck :: Options -> Check a -> Either String (a, Environment)

234+runCheck opts = runCheck' opts initEnvironment

160235

161236-- |

162237-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

163238--

164−runCheck' :: Environment -> Check a -> Either String (a, Environment)

165−runCheck' env c = do

239+runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)

240+runCheck' opts env c = either (Left . prettyPrintUnifyErrorStack opts) Right $ do

166241 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

167242 return (a, checkEnv s)

168243

@@ -192,7 +267,7 @@ freshDictionaryName = do

192267-- Lift a computation in the @Check@ monad into the substitution monad.

193268--

194269liftCheck :: Check a -> UnifyT t Check a

195−liftCheck = UnifyT . lift . lift

270+liftCheck = UnifyT . lift

196271

197272-- |

198273-- Run a computation in the substitution monad, generating a return value and the final substitution.

@@ -200,9 +275,7 @@ liftCheck = UnifyT . lift . lift

200275liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)

201276liftUnify unify = do

202277 st <- get

203− e <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify

204− case e of

205− Left err -> throwError err

206− Right (a, ust) -> do

207− modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

208− return (a, unifyCurrentSubstitution ust)

278+ (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify

279+ modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

280+ return (a, unifyCurrentSubstitution ust)

281+

src/Language/PureScript/TypeChecker/Types.hs+43−45

@@ -14,6 +14,7 @@

1414-----------------------------------------------------------------------------

1515

1616{-# OPTIONS_GHC -fno-warn-orphans #-}

17+{-# LANGUAGE FlexibleInstances #-}

1718{-# LANGUAGE FlexibleContexts #-}

1819{-# LANGUAGE MultiParamTypeClasses #-}

1920

@@ -70,6 +71,7 @@ import Control.Arrow (Arrow(..))

7071import qualified Data.Map as M

7172import Data.Function (on)

7273import Data.Ord (comparing)

74+import Data.Monoid ((<>))

7375

7476instance Partial Type where

7577 unknown = TUnknown

@@ -83,7 +85,7 @@ instance Unifiable Check Type where

8385-- Unify two types, updating the current substitution

8486--

8587unifyTypes :: Type -> Type -> UnifyT Type Check ()

86−unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $

88+unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $

8789 unifyTypes' t1 t2

8890 where

8991 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

@@ -100,16 +102,16 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

100102 let sk1 = skolemize ident1 sko sc1' ty1

101103 let sk2 = skolemize ident2 sko sc2' ty2

102104 sk1 `unifyTypes` sk2

103− _ -> throwError (prettyPrintType ty1)

105+ _ -> error "Skolemized type variable was not given a scope"

104106 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do

105107 sko <- newSkolemConstant

106108 let sk = skolemize ident sko sc ty1

107109 sk `unifyTypes` ty2

108− unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"

110+ unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"

109111 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

110112 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

111113 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =

112− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)

114+ guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)

113115 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

114116 t3 `unifyTypes` t5

115117 t4 `unifyTypes` t6

@@ -118,10 +120,9 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

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

119121 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

120122 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

121− unifyTypes' t@(ConstrainedType _ _) _ = throwError $ "Attempted to unify a constrained type " ++ prettyPrintType t ++

122− " with another type."

123+ unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."

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

124− unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

125+ unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

125126

126127-- |

127128-- Unify two rows, updating the current substitution

@@ -154,7 +155,7 @@ unifyRows r1 r2 =

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

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

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

157− unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."

158+ unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"

158159

159160-- |

160161-- Infer the types of multiple mutually-recursive values, and return elaborated values including

@@ -217,7 +218,7 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do

217218 (ident, (val', Just (ty, checkType))) -> do

218219 -- Kind check

219220 kind <- liftCheck $ kindOf moduleName ty

220− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

221+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

221222 -- Check the type with the new names in scope

222223 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

223224 val'' <- bindNames dict' $ if checkType

@@ -270,7 +271,7 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)

270271entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value

271272entails env moduleName context goal@(className, tys) = do

272273 case go goal of

273− [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)

274+ [] -> throwError . strMsg $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)

274275 (dict : _) -> return dict

275276 where

276277 go (className', tys') =

@@ -362,7 +363,7 @@ skolemEscapeCheck root@TypedValue{} =

362363 -- an escaped skolem variable.

363364 case everythingWithContext [] (++) (mkQ ((,) []) go) root of

364365 [] -> return ()

365− ((binding, val) : _) -> throwError $ "Rigid/skolem type variable bound by " ++ maybe "<unknown>" prettyPrintValue binding ++ " has escaped at " ++ prettyPrintValue val

366+ ((binding, val) : _) -> throwError $ mkUnifyErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))

366367 where

367368 go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])

368369 go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)

@@ -381,7 +382,7 @@ skolemEscapeCheck root@TypedValue{} =

381382 where

382383 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val

383384 go' _ = Nothing

384−skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val

385+skolemEscapeCheck val = throwError $ mkUnifyErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))

385386

386387-- |

387388-- Ensure a row contains no duplicate labels

@@ -444,10 +445,10 @@ replaceAllTypeSynonyms' env d =

444445 in

445446 saturateAllTypeSynonyms syns d

446447

447−replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d

448+replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => (D.Data d) => d -> m d

448449replaceAllTypeSynonyms d = do

449450 env <- getEnv

450− either throwError return $ replaceAllTypeSynonyms' env d

451+ either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d

451452

452453-- |

453454-- \"Desaturate\" @SaturatedTypeSynonym@s

@@ -469,12 +470,12 @@ expandTypeSynonym' env name args =

469470 replaceAllTypeSynonyms' env repl

470471 Nothing -> error "Type synonym was not defined"

471472

472−expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type

473+expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type

473474expandTypeSynonym name args = do

474475 env <- getEnv

475− either throwError return $ expandTypeSynonym' env name args

476+ either (throwError . strMsg) return $ expandTypeSynonym' env name args

476477

477−expandAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Type -> m Type

478+expandAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

478479expandAllTypeSynonyms = everywhereM' (mkM go)

479480 where

480481 go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

@@ -483,14 +484,14 @@ expandAllTypeSynonyms = everywhereM' (mkM go)

483484-- |

484485-- Ensure a set of property names and value does not contain duplicate labels

485486--

486−ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()

487−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

487+ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Value)] -> m ()

488+ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps

488489

489490-- |

490491-- Infer a type for a value, rethrowing any error to provide a more useful error message

491492--

492493infer :: Value -> UnifyT Type Check Value

493−infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val

494+infer val = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val

494495

495496-- |

496497-- Infer a type for a value

@@ -551,7 +552,7 @@ infer' (Var var) = do

551552infer' v@(Constructor c) = do

552553 env <- getEnv

553554 case M.lookup c (dataConstructors env) of

554− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

555+ Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

555556 Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

556557 return $ TypedValue True v ty'

557558infer' (Case vals binders) = do

@@ -571,7 +572,7 @@ infer' (Let ds val) = do

571572infer' (TypedValue checkType val ty) = do

572573 Just moduleName <- checkCurrentModule <$> get

573574 kind <- liftCheck $ kindOf moduleName ty

574− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

575+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

575576 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

576577 val' <- if checkType then check val ty' else return val

577578 return $ TypedValue True val' ty'

@@ -631,8 +632,8 @@ inferBinder val (ConstructorBinder ctor binders) = do

631632 return M.empty

632633 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

633634 M.union <$> inferBinder obj binder <*> go binders' ret

634− go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor

635− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

635+ go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor

636+ _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"

636637inferBinder val (ObjectBinder props) = do

637638 row <- fresh

638639 rest <- fresh

@@ -711,15 +712,13 @@ introduceSkolemScope = everywhereM (mkM go)

711712-- Check the type of a value, rethrowing errors to provide a better error message

712713--

713714check :: Value -> Type -> UnifyT Type Check Value

714−check val ty = rethrow errorMessage $ check' val ty

715+check val ty = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty

715716 where

716− errorMessage msg =

717+ errorMessage =

717718 "Error checking type of term " ++

718719 prettyPrintValue val ++

719720 " against type " ++

720− prettyPrintType ty ++

721− ":\n" ++

722− msg

721+ prettyPrintType ty

723722

724723-- |

725724-- Check the type of a value

@@ -773,16 +772,16 @@ check' v@(Var var) ty = do

773772 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

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

775774 case v' of

776− Nothing -> throwError "Unable to check type subsumption"

775+ Nothing -> throwError . strMsg $ "Unable to check type subsumption"

777776 Just v'' -> return $ TypedValue True v'' ty'

778777check' (TypedValue checkType val ty1) ty2 = do

779778 Just moduleName <- checkCurrentModule <$> get

780779 kind <- liftCheck $ kindOf moduleName ty1

781− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

780+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

782781 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

783782 val' <- subsumes (Just val) ty1' ty2

784783 case val' of

785− Nothing -> throwError "Unable to check type subsumption"

784+ Nothing -> throwError . strMsg $ "Unable to check type subsumption"

786785 Just val'' -> do

787786 val''' <- if checkType then check val'' ty1' else return val''

788787 return $ TypedValue checkType (TypedValue True val''' ty1) ty2

@@ -816,7 +815,7 @@ check' (Accessor prop val) ty = do

816815check' (Constructor c) ty = do

817816 env <- getEnv

818817 case M.lookup c (dataConstructors env) of

819− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

818+ Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

820819 Just (_, ty1) -> do

821820 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

822821 _ <- subsumes Nothing repl ty

@@ -827,7 +826,7 @@ check' (Let ds val) ty = do

827826check' val ty | containsTypeSynonyms ty = do

828827 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

829828 check val ty'

830−check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

829+check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

831830

832831containsTypeSynonyms :: Type -> Bool

833832containsTypeSynonyms = everything (||) (mkQ False go) where

@@ -846,8 +845,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

846845 return []

847846 go [] [] (Skolem _ _) | lax = return []

848847 go [] ((p, _): _) _ | lax = return []

849− | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p

850− go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row

848+ | otherwise = throwError $ mkUnifyErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))

849+ go ((p,_):_) [] REmpty = throwError $ mkUnifyErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))

851850 go ((p,v):ps') [] u@(TUnknown _) = do

852851 v'@(TypedValue _ _ ty) <- infer v

853852 rest <- fresh

@@ -866,18 +865,17 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

866865 v' <- check v ty

867866 ps'' <- go ps' (delete (p, ty) ts) r

868867 return $ (p, v') : ps''

869− go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (TypeApp tyObject row)

868+ go _ _ _ = throwError $ mkUnifyErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))

870869

871870-- |

872871-- Check the type of a function application, rethrowing errors to provide a better error message

873872--

874873checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)

875−checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret

874+checkFunctionApplication fn fnTy arg ret = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret

876875 where

877− errorMessage msg = "Error applying function of type "

876+ errorMessage = "Error applying function of type "

878877 ++ prettyPrintType fnTy

879878 ++ " to argument " ++ prettyPrintValue arg

880− ++ ":\n" ++ msg

881879

882880-- |

883881-- Check the type of a function application

@@ -907,7 +905,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do

907905checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

908906 dicts <- getTypeClassDictionaries

909907 checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret

910−checkFunctionApplication' _ fnTy arg _ = throwError $ "Cannot apply a function of type "

908+checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "

911909 ++ prettyPrintType fnTy

912910 ++ " to argument " ++ prettyPrintValue arg

913911

@@ -915,13 +913,12 @@ checkFunctionApplication' _ fnTy arg _ = throwError $ "Cannot apply a function o

915913-- Check whether one type subsumes another, rethrowing errors to provide a better error message

916914--

917915subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)

918−subsumes val ty1 ty2 = rethrow errorMessage $ subsumes' val ty1 ty2

916+subsumes val ty1 ty2 = rethrow (mkUnifyErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2

919917 where

920− errorMessage msg = "Error checking that type "

918+ errorMessage = "Error checking that type "

921919 ++ prettyPrintType ty1

922920 ++ " subsumes type "

923921 ++ prettyPrintType ty2

924− ++ ":\n" ++ msg

925922

926923-- |

927924-- Check whether one type subsumes another

@@ -936,7 +933,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

936933 sko <- newSkolemConstant

937934 let sk = skolemize ident sko sco' ty2

938935 subsumes val ty1 sk

939− Nothing -> throwError "Skolem variable scope is unspecified"

936+ Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"

940937subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

941938 _ <- subsumes Nothing arg2 arg1

942939 _ <- subsumes Nothing ret1 ret2

@@ -976,3 +973,4 @@ subsumes' val ty1 ty2 = do

976973 ty1 =?= ty2

977974 return val

978975

976+