summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-10-29 17:05:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-10-29 17:05:00 (GMT)
commit555ad4e2bc8d64c8c948cb5ae618b956fed0f807 (patch)
tree5aa5019c862acebc38c062b5b5587af2f4059493
parentee1312317e58ffa15cb55bcb1f5fad335b3cc603 (diff)
version 0.7.5.30.7.5.3
-rw-r--r--examples/failing/EmptyClass.purs7
-rw-r--r--examples/passing/NakedConstraint.purs2
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/Errors.hs13
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs2
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs8
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs2
8 files changed, 27 insertions, 11 deletions
diff --git a/examples/failing/EmptyClass.purs b/examples/failing/EmptyClass.purs
new file mode 100644
index 0000000..fde8f7e
--- /dev/null
+++ b/examples/failing/EmptyClass.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+class Foo x where
+
+bar :: String
+bar = "hello"
diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs
index d7b58c9..1fe4e9d 100644
--- a/examples/passing/NakedConstraint.purs
+++ b/examples/passing/NakedConstraint.purs
@@ -2,7 +2,7 @@ module Main where
import Control.Monad.Eff.Console
-class Partial where
+class Partial
data List a = Nil | Cons a (List a)
diff --git a/purescript.cabal b/purescript.cabal
index 51cf166..e2e8432 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.7.5.2
+version: 0.7.5.3
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 34311e9..a5618f9 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -156,6 +156,7 @@ data ErrorMessageHint
| ErrorCheckingAccessor Expr String
| ErrorCheckingType Expr Type
| ErrorCheckingKind Type
+ | ErrorCheckingGuard
| ErrorInferringType Expr
| ErrorInApplication Expr Type Expr
| ErrorInDataConstructor ProperName
@@ -530,15 +531,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
, indent $ prettyPrintValue expr
]) binding
renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
- = paras [ line "Could not match expected type"
+ = paras [ line "Could not match type"
, indent $ typeAsBox t1
- , line "with actual type"
+ , line "with type"
, indent $ typeAsBox t2
]
renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
- paras [ line "Could not match expected kind"
+ paras [ line "Could not match kind"
, indent $ line $ prettyPrintKind k1
- , line "with actual kind"
+ , line "with kind"
, indent $ line $ prettyPrintKind k2
]
renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
@@ -730,6 +731,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
, typeAsBox ty
]
]
+ renderHint ErrorCheckingGuard detail =
+ paras [ detail
+ , line "while checking the type of a guard clause"
+ ]
renderHint (ErrorInferringType expr) detail =
paras [ detail
, Box.hsep 1 Box.top [ line "while inferring the type of"
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index d0184bc..4adc578 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -246,7 +246,7 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init
step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
step (uncovered, (nec, redundant)) ca =
let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
- (missed', approx) = splitAt 10000 (concat missed)
+ (missed', approx) = splitAt 10000 (nub (concat missed))
cond = liftA2 (&&) (or <$> sequenceA pr) nec
in (missed', ( if null approx
then cond
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index a9347d1..4a0ef87 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -201,7 +201,7 @@ parseTypeClassDeclaration = do
idents <- P.many (indented *> kindedIdent)
members <- P.option [] . P.try $ do
indented *> reserved "where"
- mark (P.many (same *> positioned parseTypeDeclaration))
+ indented *> mark (P.many (same *> positioned parseTypeDeclaration))
return $ TypeClassDeclaration className idents implies members
parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index a885348..810acef 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -22,11 +22,12 @@ import Data.List (find, nub)
import Data.Maybe (fromMaybe, mapMaybe)
#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (mempty)
import Control.Applicative (Applicative(..), (<$>), (<*>))
#endif
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Writer (MonadWriter(..))
+import Control.Monad.Writer (MonadWriter(..), censor)
import qualified Data.Map as M
@@ -47,10 +48,13 @@ import Language.PureScript.Sugar.Names.Exports
--
desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
desugarImports externs modules = do
- env <- foldM externsEnv primEnv externs
+ env <- silence $ foldM externsEnv primEnv externs
env' <- foldM updateEnv env modules
mapM (renameInModule' env') modules
where
+ silence :: m a -> m a
+ silence = censor (const mempty)
+
-- | Create an environment from a collection of externs files
externsEnv :: Env -> ExternsFile -> m Env
externsEnv env ExternsFile{..} = do
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 92255b2..fc8b616 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -418,7 +418,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
case result of
Left gs -> do
gs' <- forM gs $ \(grd, val) -> do
- grd' <- check grd tyBoolean
+ grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean
val' <- TypedValue True <$> check val ret <*> pure ret
return (grd', val')
return $ Left gs'