diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -334,7 +334,7 @@ . 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 --- /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 --- /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 --- 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -90,22 +90,23 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -200,21 +200,26 @@ -- | 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 @@ 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 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -64,7 +64,7 @@ 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 ()