summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--app/Command/REPL.hs2
-rw-r--r--examples/failing/2806.purs7
-rw-r--r--examples/passing/2806.purs14
-rw-r--r--purescript.cabal4
-rw-r--r--src/Language/PureScript/Interactive.hs74
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs21
-rw-r--r--tests/TestPsci/TestEnv.hs2
7 files changed, 79 insertions, 45 deletions
diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs
index 8698607..24132b7 100644
--- a/app/Command/REPL.hs
+++ b/app/Command/REPL.hs
@@ -334,7 +334,7 @@ command = loop <$> options
. runInputT (setComplete completion settings)
handleCommand' :: state -> Command -> StateT PSCiState (ReaderT PSCiConfig IO) ()
- handleCommand' state = handleCommand (liftIO . eval state) (liftIO (reload state))
+ handleCommand' state = handleCommand (liftIO . eval state) (liftIO (reload state)) (liftIO . putStrLn)
go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
go state = do
diff --git a/examples/failing/2806.purs b/examples/failing/2806.purs
new file mode 100644
index 0000000..52103e1
--- /dev/null
+++ b/examples/failing/2806.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith NoInstanceFound
+module X where
+
+data E a b = L a | R b
+
+g :: forall a b . E a b -> a
+g e | L x <- e = x
diff --git a/examples/passing/2806.purs b/examples/passing/2806.purs
new file mode 100644
index 0000000..848b3a3
--- /dev/null
+++ b/examples/passing/2806.purs
@@ -0,0 +1,14 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+data Stream a = Cons a (Stream a)
+
+step :: forall a. Stream a -> Stream a
+step (Cons _ xs) = xs
+
+head :: forall a. Stream a -> a
+head xs | Cons x _ <- step xs = x
+
+main = log "Done"
diff --git a/purescript.cabal b/purescript.cabal
index d8b37eb..4932d25 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -3,7 +3,7 @@
-- see: https://github.com/sol/hpack
name: purescript
-version: 0.11.2
+version: 0.11.3
cabal-version: >= 1.10
build-type: Simple
license: BSD3
@@ -83,6 +83,7 @@ extra-source-files:
examples/failing/2567.purs
examples/failing/2601.purs
examples/failing/2616.purs
+ examples/failing/2806.purs
examples/failing/365.purs
examples/failing/438.purs
examples/failing/881.purs
@@ -306,6 +307,7 @@ extra-source-files:
examples/passing/2756.purs
examples/passing/2787.purs
examples/passing/2795.purs
+ examples/passing/2806.purs
examples/passing/652.purs
examples/passing/810.purs
examples/passing/862.purs
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index f589536..ce075fc 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -90,22 +90,23 @@ make ms = do
-- | Performs a PSCi command
handleCommand
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
- => (String -> m ())
- -> m ()
+ => (String -> m ()) -- ^ evaluate JS
+ -> m () -- ^ reload
+ -> (String -> m ()) -- ^ print into console
-> Command
-> m ()
-handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage
-handleCommand _ r ReloadState = handleReloadState r
-handleCommand _ r ClearState = handleClearState r
-handleCommand c _ (Expression val) = handleExpression c val
-handleCommand _ _ (Import im) = handleImport im
-handleCommand _ _ (Decls l) = handleDecls l
-handleCommand _ _ (TypeOf val) = handleTypeOf val
-handleCommand _ _ (KindOf typ) = handleKindOf typ
-handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName
-handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules
-handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules
-handleCommand _ _ _ = P.internalError "handleCommand: unexpected command"
+handleCommand _ _ p ShowHelp = p helpMessage
+handleCommand _ r _ ReloadState = handleReloadState r
+handleCommand _ r _ ClearState = handleClearState r
+handleCommand e _ _ (Expression val) = handleExpression e val
+handleCommand _ _ _ (Import im) = handleImport im
+handleCommand _ _ _ (Decls l) = handleDecls l
+handleCommand _ _ p (TypeOf val) = handleTypeOf p val
+handleCommand _ _ p (KindOf typ) = handleKindOf p typ
+handleCommand _ _ p (BrowseModule moduleName) = handleBrowse p moduleName
+handleCommand _ _ p (ShowInfo QueryLoaded) = handleShowLoadedModules p
+handleCommand _ _ p (ShowInfo QueryImport) = handleShowImportedModules p
+handleCommand _ _ _ _ = P.internalError "handleCommand: unexpected command"
-- | Reload the application state
handleReloadState
@@ -169,23 +170,25 @@ handleDecls ds = do
-- | Show actual loaded modules in psci.
handleShowLoadedModules
:: (MonadState PSCiState m, MonadIO m)
- => m ()
-handleShowLoadedModules = do
+ => (String -> m ())
+ -> m ()
+handleShowLoadedModules print' = do
loadedModules <- gets psciLoadedExterns
- liftIO $ putStrLn (readModules loadedModules)
+ print' $ readModules loadedModules
where
readModules = unlines . sort . ordNub . map (T.unpack . P.runModuleName . P.getModuleName . fst)
-- | Show the imported modules in psci.
handleShowImportedModules
:: (MonadState PSCiState m, MonadIO m)
- => m ()
-handleShowImportedModules = do
+ => (String -> m ())
+ -> m ()
+handleShowImportedModules print' = do
PSCiState { psciImportedModules = importedModules } <- get
- liftIO $ showModules importedModules >>= putStrLn
+ print' $ showModules importedModules
return ()
where
- showModules = return . unlines . sort . map (T.unpack . showModule)
+ showModules = unlines . sort . map (T.unpack . showModule)
showModule (mn, declType, asQ) =
"import " <> N.runModuleName mn <> showDeclType declType <>
foldMap (\mn' -> " as " <> N.runModuleName mn') asQ
@@ -236,9 +239,10 @@ handleImport im = do
-- | Takes a value and prints its type
handleTypeOf
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
- => P.Expr
+ => (String -> m ())
+ -> P.Expr
-> m ()
-handleTypeOf val = do
+handleTypeOf print' val = do
st <- get
let m = createTemporaryModule False st val
e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
@@ -246,15 +250,16 @@ handleTypeOf val = do
Left errs -> printErrors errs
Right (_, env') ->
case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of
- Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty
- Nothing -> liftIO $ putStrLn "Could not find type"
+ Just (ty, _, _) -> print' . P.prettyPrintType $ ty
+ Nothing -> print' "Could not find type"
-- | Takes a type and prints its kind
handleKindOf
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
- => P.Type
+ => (String -> m ())
+ -> P.Type
-> m ()
-handleKindOf typ = do
+handleKindOf print' typ = do
st <- get
let m = createTemporaryModuleForKind st typ
mName = P.ModuleName [P.ProperName "$PSCI"]
@@ -271,23 +276,24 @@ handleKindOf typ = do
check sew = fst . runWriter . runExceptT . runStateT sew
case k of
Left err -> printErrors err
- Right (kind, _) -> liftIO . putStrLn . T.unpack . P.prettyPrintKind $ kind
- Nothing -> liftIO $ putStrLn "Could not find kind"
+ Right (kind, _) -> print' . T.unpack . P.prettyPrintKind $ kind
+ Nothing -> print' "Could not find kind"
-- | Browse a module and displays its signature
handleBrowse
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
- => P.ModuleName
+ => (String -> m ())
+ -> P.ModuleName
-> m ()
-handleBrowse moduleName = do
+handleBrowse print' moduleName = do
st <- get
env <- asks psciEnvironment
if isModInEnv moduleName st
- then liftIO . putStrLn $ printModuleSignatures moduleName env
+ then print' $ printModuleSignatures moduleName env
else case lookupUnQualifiedModName moduleName st of
Just unQualifiedName ->
if isModInEnv unQualifiedName st
- then liftIO . putStrLn $ printModuleSignatures unQualifiedName env
+ then print' $ printModuleSignatures unQualifiedName env
else failNotInEnv moduleName
Nothing ->
failNotInEnv moduleName
@@ -295,6 +301,6 @@ handleBrowse moduleName = do
isModInEnv modName =
any ((== modName) . P.getModuleName . fst) . psciLoadedExterns
failNotInEnv modName =
- liftIO $ putStrLn $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."
+ print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."
lookupUnQualifiedModName quaModName st =
(\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 64db3b1..af9db13 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -200,21 +200,26 @@ missingCasesMultiple env mn = go
-- | otherwise = 1
-- is exhaustive, whereas `f x | x < 0` is not
--
+-- or in case of a pattern guard if the pattern is exhaustive.
+--
-- The function below say whether or not a guard has an `otherwise` expression
-- It is considered that `otherwise` is defined in Prelude
--
-isExhaustiveGuard :: [GuardedExpr] -> Bool
-isExhaustiveGuard [GuardedExpr [] _] = True
-isExhaustiveGuard gs =
+isExhaustiveGuard :: Environment -> ModuleName -> [GuardedExpr] -> Bool
+isExhaustiveGuard _ _ [MkUnguarded _] = True
+isExhaustiveGuard env moduleName gs =
not . null $ filter (\(GuardedExpr grd _) -> isExhaustive grd) gs
where
- checkGuard :: Guard -> Bool
- checkGuard (ConditionGuard cond) = isTrueExpr cond
- checkGuard (PatternGuard bind _) = isIrrefutable bind
-
isExhaustive :: [Guard] -> Bool
isExhaustive = all checkGuard
+ checkGuard :: Guard -> Bool
+ checkGuard (ConditionGuard cond) = isTrueExpr cond
+ checkGuard (PatternGuard binder _) =
+ case missingCasesMultiple env moduleName [NullBinder] [binder] of
+ ([], _) -> True -- there are no missing pattern for this guard
+ _ -> False
+
-- |
-- Returns the uncovered set of case alternatives
--
@@ -223,7 +228,7 @@ missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAl
missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
missingAlternative env mn ca uncovered
- | isExhaustiveGuard (caseAlternativeResult ca) = mcases
+ | isExhaustiveGuard env mn (caseAlternativeResult ca) = mcases
| otherwise = ([uncovered], snd mcases)
where
mcases = missingCases env mn uncovered ca
diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs
index 519f8fb..8f71d9a 100644
--- a/tests/TestPsci/TestEnv.hs
+++ b/tests/TestPsci/TestEnv.hs
@@ -64,7 +64,7 @@ runAndEval comm eval =
Right command ->
-- the JS result can be ignored, as it's already written in a source file
-- for the detail, please refer to Interactive.hs
- handleCommand (\_ -> eval) (return ()) command
+ handleCommand (\_ -> eval) (return ()) (\_ -> return ()) command
-- | Run a PSCi command and ignore the output
run :: String -> TestPSCi ()
generated by cgit v0.10.2 at 2021-03-09 09:53:56 (GMT)