Skip to content

Commit c7d2699

Browse files
paf31paf31
committed
Revert "Initial work on purescript#242"
This reverts commit 1a087e7.
1 parent 1a087e7 commit c7d2699

File tree

11 files changed

+106
-191
lines changed

11 files changed

+106
-191
lines changed

‎examples/failing/TypeClasses.purs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
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‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,5 @@
11
module Main where
22

3-
import Prelude ()
4-
53
class Show a where
64
show :: a -> String
75

‎psc-make/Main.hs‎

Lines changed: 1 addition & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -115,12 +115,8 @@ browserNamespace :: Term String
115115
browserNamespace = 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-
122118
options :: Term P.Options
123-
options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure [] <*> verboseErrors
119+
options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []
124120

125121
inputFilesAndPrelude :: FilePath -> Term [FilePath]
126122
inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles

‎psc/Main.hs‎

Lines changed: 1 addition & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -122,12 +122,8 @@ codeGenModules :: Term [String]
122122
codeGenModules = 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-
129125
options :: Term P.Options
130-
options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules <*> verboseErrors
126+
options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules
131127

132128
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
133129
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles

‎psci/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -194,7 +194,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
194194
-- | Compilation options.
195195
--
196196
options :: P.Options
197-
options = P.Options False True False True (Just "Main") True "PS" [] [] False
197+
options = P.Options False True False True (Just "Main") True "PS" [] []
198198

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

‎src/Language/PureScript.hs‎

Lines changed: 6 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String,
7171
compile' env opts ms = do
7272
(sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
7373
desugared <- desugar sorted
74-
(elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
74+
(elaborated, env') <- runCheck' 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,9 +100,8 @@ 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 . strMsg $
104-
"Error in module '" ++ show mn ++ "':\n\
105-
\Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
103+
Just hiddenType -> throwError $ "Error in module '" ++ show mn ++ "':\n\
104+
\Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
106105
Nothing -> return ()
107106
checkTypesAreExported _ = return ()
108107

@@ -119,7 +118,7 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
119118
where
120119
go (TypeRef tyName' _) = tyName' /= tyName
121120
go _ = True
122-
121+
123122

124123
generateMain :: Environment -> Options -> [JS] -> Either String [JS]
125124
generateMain env opts js =
@@ -192,15 +191,15 @@ make opts ms = do
192191
go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
193192
go _ [] = return ()
194193
go env ((False, m) : ms') = do
195-
(_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
194+
(_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
196195

197196
go env' ms'
198197
go env ((True, m@(Module moduleName' _ exps)) : ms') = do
199198
let filePath = toFileName moduleName'
200199
jsFile = "js" ++ pathSeparator : filePath ++ ".js"
201200
externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
202201

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

205204
regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
206205

‎src/Language/PureScript/Options.hs‎

Lines changed: 1 addition & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -57,14 +57,10 @@ data Options = Options {
5757
-- The modules to code gen
5858
--
5959
, optionsCodeGenModules :: [String]
60-
-- |
61-
-- Verbose error message
62-
--
63-
, optionsVerboseErrors :: Bool
6460
} deriving Show
6561

6662
-- |
6763
-- Default compiler options
6864
--
6965
defaultOptions :: Options
70-
defaultOptions = Options False False False False Nothing False "PS" [] [] False
66+
defaultOptions = Options False False False False Nothing False "PS" [] []

‎src/Language/PureScript/TypeChecker.hs‎

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,6 @@ import Language.PureScript.TypeChecker.Types as T
2626
import Language.PureScript.TypeChecker.Synonyms as T
2727

2828
import Data.Maybe
29-
import Data.Monoid ((<>))
3029
import qualified Data.Map as M
3130
import Control.Monad.State
3231
import Control.Monad.Error
@@ -37,13 +36,14 @@ import Language.PureScript.Kinds
3736
import Language.PureScript.Declarations
3837
import Language.PureScript.TypeClassDictionaries
3938
import Language.PureScript.Environment
39+
import Language.PureScript.Pretty.Types
4040

4141
addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
4242
addDataType 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 (strMsg ("Error in data constructor " ++ show dctor) <>) $
46+
rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
4747
addDataConstructor moduleName name args dctor tys
4848

4949
addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -64,7 +64,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()
6464
valueIsNotDefined moduleName name = do
6565
env <- getEnv
6666
case M.lookup (moduleName, name) (names env) of
67-
Just _ -> throwError . strMsg $ show name ++ " is already defined"
67+
Just _ -> throwError $ show name ++ " is already defined"
6868
Nothing -> return ()
6969

7070
addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
@@ -85,10 +85,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
8585
checkTypeClassInstance _ (TypeVar _) = return ()
8686
checkTypeClassInstance _ (TypeConstructor ctor) = do
8787
env <- getEnv
88-
when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
88+
when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
8989
return ()
9090
checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
91-
checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instance head is invalid." (Just (TypeError ty))
91+
checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid: " ++ prettyPrintType ty
9292

9393
-- |
9494
-- Type check all declarations in a module
@@ -106,13 +106,13 @@ checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instanc
106106
typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
107107
typeCheckAll _ _ [] = return []
108108
typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
109-
rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
109+
rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ 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
114114
typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
115-
rethrow (strMsg "Error in data binding group" <>) $ do
115+
rethrow ("Error in data binding group:\n" ++) $ 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
130130
typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
131-
rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
131+
rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ 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
136136
typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
137137
typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do
138-
d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
138+
d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ 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
145145
typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
146146
typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
147-
d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do
147+
d <- rethrow (("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals) ++ ":\n") ++) $ 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
162162
typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
163-
rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
163+
rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
164164
env <- getEnv
165165
kind <- kindOf moduleName ty
166-
guardWith (strMsg "Expected kind *") $ kind == Star
166+
guardWith "Expected kind *" $ kind == Star
167167
case M.lookup (moduleName, name) (names env) of
168-
Just _ -> throwError . strMsg $ show name ++ " is already defined"
168+
Just _ -> throwError $ 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
172172
typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
173173
ds <- typeCheckAll mainModuleName moduleName rest
174174
env <- getEnv
175-
guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
175+
guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
176176
return $ d : ds
177177
typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
178178
env <- getEnv

‎src/Language/PureScript/TypeChecker/Kinds.hs‎

Lines changed: 13 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@
1414
-----------------------------------------------------------------------------
1515

1616
{-# OPTIONS_GHC -fno-warn-orphans #-}
17-
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
17+
{-# LANGUAGE MultiParamTypeClasses #-}
1818

1919
module Language.PureScript.TypeChecker.Kinds (
2020
kindOf,
@@ -36,7 +36,6 @@ import Control.Monad.Unify
3636
import Control.Applicative
3737

3838
import qualified Data.Map as M
39-
import Data.Monoid ((<>))
4039

4140
instance Partial Kind where
4241
unknown = KUnknown
@@ -53,14 +52,14 @@ instance Unifiable Check Kind where
5352
FunKind k1 k2 =?= FunKind k3 k4 = do
5453
k1 =?= k3
5554
k2 =?= k4
56-
k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
55+
k1 =?= k2 = UnifyT . lift . throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
5756

5857
-- |
5958
-- Infer the kind of a single type
6059
--
6160
kindOf :: ModuleName -> Type -> Check Kind
6261
kindOf _ ty =
63-
rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $
62+
rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $
6463
fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
6564
where
6665
tidyUp (k, sub) = sub $? k
@@ -106,7 +105,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
106105
-- |
107106
-- Solve the set of kind constraints associated with the data constructors for a type constructor
108107
--
109-
solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind
108+
solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
110109
solveTypes isData ts kargs tyCon = do
111110
ks <- mapM infer ts
112111
when isData $ do
@@ -129,44 +128,39 @@ starIfUnknown k = k
129128
-- Infer a kind for a type
130129
--
131130
infer :: Type -> UnifyT Kind Check Kind
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
131+
infer (TypeVar v) = do
136132
Just moduleName <- checkCurrentModule <$> get
137133
UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
138-
infer' c@(TypeConstructor v) = do
134+
infer (TypeConstructor v) = do
139135
env <- liftCheck getEnv
140136
case M.lookup v (types env) of
141-
Nothing -> UnifyT . lift . throwError $ mkUnifyErrorStack "Unknown type constructor" (Just (TypeError c))
137+
Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"
142138
Just (kind, _) -> return kind
143-
infer' (TypeApp t1 t2) = do
139+
infer (TypeApp t1 t2) = do
144140
k0 <- fresh
145141
k1 <- infer t1
146142
k2 <- infer t2
147143
k1 =?= FunKind k2 k0
148144
return k0
149-
infer' (ForAll ident ty _) = do
145+
infer (ForAll ident ty _) = do
150146
k1 <- fresh
151147
Just moduleName <- checkCurrentModule <$> get
152148
k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
153149
k2 =?= Star
154150
return Star
155-
infer' REmpty = do
151+
infer REmpty = do
156152
k <- fresh
157153
return $ Row k
158-
infer' (RCons _ ty row) = do
154+
infer (RCons _ ty row) = do
159155
k1 <- infer ty
160156
k2 <- infer row
161157
k2 =?= Row k1
162158
return $ Row k1
163-
infer' (ConstrainedType deps ty) = do
159+
infer (ConstrainedType deps ty) = do
164160
forM_ deps $ \(className, tys) -> do
165161
_ <- infer $ foldl TypeApp (TypeConstructor className) tys
166162
return ()
167163
k <- infer ty
168164
k =?= Star
169165
return Star
170-
infer' _ = error "Invalid argument to infer"
171-
172-
166+
infer _ = error "Invalid argument to infer"

0 commit comments

Comments
 (0)