diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 9b5b322dde..d1f92b1a4f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -54,10 +54,10 @@ jobs: fail-fast: false # do not cancel builds for other OSes if one fails matrix: include: - - image: haskell:9.6.6 # Also upgrade version in the lint job below + - image: haskell:9.8.4 # Also upgrade version in the lint job below os: ubuntu-latest # Exact version is not important, as it's only the container host) - - image: haskell:9.6.6 + - image: haskell:9.8.4 os: ubuntu-24.04-arm # Exact version is not important, as it's only the container host - os: macos-13 # x64 @@ -92,7 +92,7 @@ jobs: if: startsWith(matrix.os, 'macos') || startsWith(matrix.os, 'windows') uses: "haskell-actions/setup@v2" with: - ghc-version: "9.6.6" + ghc-version: "9.8.4" enable-stack: true stack-version: "${{ env.STACK_VERSION }}" stack-no-global: true @@ -202,7 +202,7 @@ jobs: run: "gh release upload --clobber ${{ github.ref_name }} sdist-test/bundle/*.{tar.gz,sha}" lint: - container: haskell:9.6.6 + container: haskell:9.8.4 runs-on: ubuntu-latest # Exact version is not important, as it's only the container host steps: @@ -220,7 +220,7 @@ jobs: - run: "ci/fix-home ci/run-hlint.sh --git" env: - VERSION: "3.5" + VERSION: "3.10" - name: Install weeder run: | diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md new file mode 100644 index 0000000000..7f3fb0e074 --- /dev/null +++ b/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md @@ -0,0 +1,2 @@ +* Upgrade GHC to [`9.8.4`](https://downloads.haskell.org/~ghc/9.8.4/docs/users_guide/9.8.4-notes.html), Stackage LTS `23.18` +* Use [HLint 3.10](https://github.com/ndmitchell/hlint/blob/master/CHANGES.txt) in CI diff --git a/INSTALL.md b/INSTALL.md index 03f7748636..6854652cb3 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,13 +4,13 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 9.6.6, and should be able to run on any operating system supported by GHC 9.6.6. +The PureScript compiler is built using GHC 9.8.4, and should be able to run on any operating system supported by GHC 9.8.4. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.6.6 supports. +See also for more details about the operating systems which GHC 9.8.4 supports. ## Official prebuilt binaries diff --git a/cabal.project b/cabal.project index 61c5c9bd35..453d64732d 100644 --- a/cabal.project +++ b/cabal.project @@ -4,4 +4,4 @@ packages: source-repository-package type: git location: https://github.com/purescript/cheapskate.git - tag: 8bfaf4beeb108e97a274ed51303f278905979e87 + tag: 633c69024e061ad956f1aecfc137fb99a7a7a20b diff --git a/purescript.cabal b/purescript.cabal index 401775a5e2..0ff5ecd27d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -92,6 +92,7 @@ common defaults -Wno-missing-export-lists -Wno-missing-kind-signatures -Wno-partial-fields + -Wno-missing-role-annotations default-language: Haskell2010 default-extensions: BangPatterns @@ -124,8 +125,6 @@ common defaults TupleSections TypeFamilies ViewPatterns - build-tool-depends: - happy:happy ==1.20.1.1 build-depends: -- NOTE: Please do not edit these version constraints manually. They are -- deliberately made narrow because changing the dependency versions in @@ -159,65 +158,63 @@ common defaults -- modules must be parseable by this library otherwise the compiler -- will reject them. It should therefore always be pinned to a single -- specific version. - aeson >=2.0.3.0 && <2.2, + aeson >=2.2.3.0 && <2.3, aeson-better-errors >=0.9.1.3 && <0.10, - ansi-terminal >=0.11.3 && <1.1, - array >=0.5.4.0 && <0.6, - intern, - base >=4.16.2.0 && <4.19, - blaze-html >=0.9.1.2 && <0.10, + ansi-terminal >=1.1.2 && <1.2, + array >=0.5.8.0 && <0.6, + base >=4.19.2.0 && <4.20, + blaze-html >=0.9.2.0 && <0.10, bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, - bytestring >=0.11.3.1 && <0.12, + bytestring >=0.12.1.0 && <0.13, Cabal >=3.10.3.0 && <3.11, - cborg >=0.2.7.0 && <0.3, + cborg >=0.2.10.0 && <0.3, cheapskate >=0.1.1.2 && <0.2, - clock >=0.8.3 && <0.9, - containers >=0.6.5.1 && <0.7, - -- unordered-containers, - -- hashable, - cryptonite ==0.30.*, + clock >=0.8.4 && <0.9, + containers >=0.6.8 && <0.7, + cryptonite >=0.30 && <0.31, data-ordlist >=0.4.7.0 && <0.5, - deepseq >=1.4.6.1 && <1.5, - directory >=1.3.6.2 && <1.4, - dlist ==1.0.*, + deepseq >=1.5.1.0 && <1.6, + directory >=1.3.8.5 && <1.4, + dlist >=1.0 && <1.1, edit-distance >=0.2.2.1 && <0.3, - file-embed >=0.0.15.0 && <0.1, - filepath >=1.4.2.2 && <1.5, + file-embed >=0.0.16.0 && <0.1, + filepath >=1.4.301.0 && <1.5, Glob >=0.10.2 && <0.11, haskeline ==0.8.2, + intern >=0.9.2 && <0.10, language-javascript ==0.7.0.0, - lens >=5.1.1 && <5.3, - lifted-async >=0.10.2.2 && <0.11, + lens >=5.3.4 && <5.4, + lifted-async >=0.10.2.7 && <0.11, lifted-base >=0.2.3.12 && <0.3, - memory >=0.17.0 && <0.19, + memory >=0.18.0 && <0.19, monad-control >=1.0.3.1 && <1.1, - monad-logger >=0.3.36 && <0.4, - monoidal-containers >=0.6.2.0 && <0.7, - mtl >=2.2.2 && <2.4, + monad-logger >=0.3.42 && <0.4, + monoidal-containers >=0.6.6.0 && <0.7, + mtl >=2.3.1 && <2.4, parallel >=3.2.2.0 && <3.3, - parsec >=3.1.15.0 && <3.2, - process >=1.6.19.0 && <1.7, - protolude >=0.3.1 && <0.4, - regex-tdfa >=1.3.1.2 && <1.4, - safe >=0.3.19 && <0.4, - scientific >=0.3.7.0 && <0.4, - semialign >=1.2.0.1 && <1.4, - semigroups ==0.20.*, - serialise >=0.2.5.0 && <0.3, + parsec >=3.1.17.0 && <3.2, + process >=1.6.25.0 && <1.7, + protolude >=0.3.4 && <0.4, + regex-tdfa >=1.3.2.3 && <1.4, + safe >=0.3.21 && <0.4, + scientific >=0.3.8.0 && <0.4, + semialign >=1.3.1 && <1.4, + semigroups >=0.20 && <0.21, + serialise >=0.2.6.1 && <0.3, sourcemap >=0.1.7 && <0.2, - sqlite-simple, - stm >=2.5.0.2 && <2.6, + sqlite-simple >= 0.4.18 && <0.5, + stm >=2.5.3.1 && <2.6, stringsearch >=0.3.6.6 && <0.4, - template-haskell >=2.18.0.0 && <2.21, - text >=1.2.5.0 && <2.1, - these >=1.1.1.1 && <1.3, - time >=1.11.1.1 && <1.13, - transformers >=0.5.6.2 && <0.7, + template-haskell >=2.21.0.0 && <2.22, + text >=2.1.1 && <2.2, + these >=1.2.1 && <1.3, + time >=1.12.2 && <1.13, + transformers >=0.6.1.0 && <0.7, transformers-base >=0.4.6 && <0.5, utf8-string >=1.0.2 && <1.1, - vector >=0.12.3.1 && <0.14, - witherable >=0.4.2 && <0.5, + vector >=0.13.2.0 && <0.14, + witherable >=0.5 && <0.6, library import: defaults @@ -418,17 +415,17 @@ executable purs main-is: Main.hs ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages build-depends: - prettyprinter >=1.6 && <1.8, - prettyprinter-ansi-terminal >=1.1.1 && <1.2, - exceptions >=0.10.4 && <0.11, - network >=3.1.2.7 && <3.2, - optparse-applicative >=0.17.0.0 && <0.19, + prettyprinter >=1.7.1 && <1.8, + prettyprinter-ansi-terminal >=1.1.3 && <1.2, + exceptions >=0.10.7 && <0.11, + network >=3.2.7.0 && <3.3, + optparse-applicative >=0.18.1.0 && <0.19, purescript if flag(release) cpp-options: -DRELEASE else build-depends: - gitrev >=1.2.0 && <1.4 + gitrev >=1.3.1 && <1.4, other-modules: Command.Bundle Command.Compile @@ -457,13 +454,13 @@ test-suite tests build-depends: purescript, generic-random >=1.5.0.1 && <1.6, - hspec >= 2.11.10 && < 3, + hspec >=2.11.12 && <2.12, HUnit >=1.6.2.0 && <1.7, newtype >=0.2.2.0 && <0.3, - QuickCheck >=2.14.2 && <2.15, - regex-base >=0.94.0.2 && <0.95, - split >=0.2.3.4 && <0.3, - typed-process >=0.2.10.1 && <0.3 + QuickCheck >=2.14.3 && <2.15, + regex-base >=0.94.0.3 && <0.95, + split >=0.2.5 && <0.3, + typed-process >=0.2.12.0 && <0.3, build-tool-depends: hspec-discover:hspec-discover -any -- we need the compiler's executable available for the ide tests @@ -488,6 +485,7 @@ test-suite tests TestGraph TestHierarchy TestIde + TestInteractive TestMake TestPrimDocs TestPsci diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index c75d333dcc..59b68adf1d 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -16,6 +16,7 @@ module Language.PureScript.CST.Convert ) where import Prelude hiding (take) +import Protolude (headDef) import Data.Bifunctor (bimap, first) import Data.Char (toLower) @@ -446,7 +447,7 @@ convertDeclaration :: String -> Declaration a -> [AST.Declaration] convertDeclaration fileName decl = case decl of DeclData _ (DataHead _ a vars) bd -> do let - ctrs :: SourceToken -> DataCtor a -> [(SourceToken, DataCtor a)] -> [AST.DataConstructorDeclaration] + ctrs :: SourceToken -> DataCtor b -> [(SourceToken, DataCtor b)] -> [AST.DataConstructorDeclaration] ctrs st (DataCtor _ name fields) tl = AST.DataConstructorDeclaration (sourceAnnCommented fileName st (nameTok name)) (nameValue name) (zip ctrFields $ convertType fileName <$> fields) : (case tl of @@ -460,7 +461,7 @@ convertDeclaration fileName decl = case decl of (goTypeVar <$> vars) (convertType fileName bd) DeclNewtype _ (DataHead _ a vars) st x ys -> do - let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(head ctrFields, convertType fileName ys)]] + let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(headDef (internalError "No constructor name") ctrFields, convertType fileName ys)]] pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do let diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs index 31887c890a..2b79f1a9b3 100644 --- a/src/Language/PureScript/CST/Monad.hs +++ b/src/Language/PureScript/CST/Monad.hs @@ -102,9 +102,11 @@ mkParserError stack toks ty = , errType = ty } where - range = case toks of - [] -> SourceRange (SourcePos 0 0) (SourcePos 0 0) - _ -> widen (tokRange . tokAnn $ head toks) (tokRange . tokAnn $ last toks) + range = case NE.nonEmpty toks of + Nothing -> SourceRange (SourcePos 0 0) (SourcePos 0 0) + Just neToks -> widen + (tokRange . tokAnn $ NE.head neToks) + (tokRange . tokAnn $ NE.last neToks) addFailure :: [SourceToken] -> ParserErrorType -> Parser () addFailure toks ty = Parser $ \st _ ksucc -> diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index b941cf5fcf..68dcf7d87c 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -1,6 +1,7 @@ module Language.PureScript.CST.Utils where import Prelude +import Protolude (headDef) import Control.Monad (unless) import Data.Coerce (coerce) @@ -86,16 +87,20 @@ unexpectedLabel :: SourceToken -> Label unexpectedLabel tok = Label tok "" unexpectedExpr :: Monoid a => [SourceToken] -> Expr a -unexpectedExpr toks = ExprIdent mempty (unexpectedQual (head toks)) +unexpectedExpr toks = + ExprIdent mempty (unexpectedQual (headDef placeholder toks)) unexpectedBinder :: Monoid a => [SourceToken] -> Binder a -unexpectedBinder toks = BinderVar mempty (unexpectedName (head toks)) +unexpectedBinder toks = + BinderVar mempty (unexpectedName (headDef placeholder toks)) unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a -unexpectedRecordUpdate toks = RecordUpdateLeaf (unexpectedLabel (head toks)) (head toks) (unexpectedExpr toks) +unexpectedRecordUpdate toks = + RecordUpdateLeaf (unexpectedLabel (headDef placeholder toks)) (headDef placeholder toks) (unexpectedExpr toks) unexpectedRecordLabeled :: [SourceToken] -> RecordLabeled a -unexpectedRecordLabeled toks = RecordPun (unexpectedName (head toks)) +unexpectedRecordLabeled toks = + RecordPun (unexpectedName (headDef placeholder toks)) rangeToks :: TokenRange -> [SourceToken] rangeToks (a, b) = [a, b] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3a4e371187..890cc1cd27 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -7,7 +7,7 @@ module Language.PureScript.CodeGen.JS ) where import Prelude -import Protolude (ordNub) +import Protolude (ordNub, headDef) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) @@ -310,7 +310,8 @@ moduleBindToJs mn = bindToJs let (f, args) = unApp e [] args' <- mapM valueToJs args case f of - Var (_, _, Just IsNewtype) _ -> return (head args') + Var (_, _, Just IsNewtype) _ -> + return (headDef (internalError "Newtype constructor without constructor name") args') Var (_, _, Just (IsConstructor _ fields)) name | length args == length fields -> return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index a1d4a47c2b..db133f5ac8 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -5,8 +5,8 @@ import Prelude import Control.Applicative (empty) import Control.Monad (guard) -import Control.Monad.State (State, evalState, get, modify) -import Data.Functor (($>), (<&>)) +import Control.Monad.State (State, evalState, gets, modify) +import Data.Functor (($>)) import Data.Set qualified as S import Data.Text (Text, pack) import Language.PureScript.CoreImp.AST (AST(..), InitializerEffects(..), UnaryOperator(..), everything, everywhereTopDownM) @@ -23,7 +23,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where copyVar arg = "$copy_" <> arg tcoDoneM :: State Int Text - tcoDoneM = get <&> \count -> "$tco_done" <> + tcoDoneM = gets $ \count -> "$tco_done" <> if count == 0 then "" else pack . show $ count tcoLoop :: Text diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index e4460183af..e03ccabc31 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -67,7 +67,7 @@ nullRenderContext = HtmlRenderContext packageAsHtml :: (InPackage P.ModuleName -> Maybe HtmlRenderContext) - -> Package a + -> Package x -> HtmlOutput Html packageAsHtml getHtmlCtx Package{..} = HtmlOutput indexFile modules @@ -242,7 +242,7 @@ codeAsHtml r = outputWith elemAsHtml isOp = isRight . runParser CST.parseOperator - runParser :: CST.Parser a -> Text -> Either String a + runParser :: CST.Parser x -> Text -> Either String x runParser p' = bimap (CST.prettyPrintError . NE.head) snd . CST.runTokenParser p' diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index c4e6cbecaa..ea13066556 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -875,7 +875,7 @@ instance A.ToJSON a => A.ToJSON (InPackage a) where Local y -> withPackage (Nothing :: Maybe ()) y FromDep pn y -> withPackage (Just pn) y where - withPackage :: (A.ToJSON p, A.ToJSON x) => p -> x -> A.Value + withPackage :: (A.ToJSON p, A.ToJSON y) => p -> y -> A.Value withPackage p y = A.object [ "package" .= p , "item" .= y diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 4a75f0f362..a8a0ce1307 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -8,6 +8,8 @@ import Prelude import Data.Maybe (fromJust) import Data.List (isPrefixOf) import Data.Tuple (swap) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty qualified as NEL import Language.PureScript.Interactive.Types (Directive(..)) @@ -15,40 +17,40 @@ import Language.PureScript.Interactive.Types (Directive(..)) -- A mapping of directives to the different strings that can be used to invoke -- them. -- -directiveStrings :: [(Directive, [String])] +directiveStrings :: [(Directive, NonEmpty String)] directiveStrings = - [ (Help , ["?", "help"]) - , (Quit , ["quit"]) - , (Reload , ["reload"]) - , (Clear , ["clear"]) - , (Browse , ["browse"]) - , (Type , ["type"]) - , (Kind , ["kind"]) - , (Show , ["show"]) - , (Paste , ["paste"]) - , (Complete , ["complete"]) - , (Print , ["print"]) + [ (Help , NEL.fromList ["?", "help"]) + , (Quit , NEL.singleton "quit") + , (Reload , NEL.singleton "reload") + , (Clear , NEL.singleton "clear") + , (Browse , NEL.singleton "browse") + , (Type , NEL.singleton "type") + , (Kind , NEL.singleton "kind") + , (Show , NEL.singleton "show") + , (Paste , NEL.singleton "paste") + , (Complete , NEL.singleton "complete") + , (Print , NEL.singleton "print") ] -- | --- Like directiveStrings, but the other way around. +-- Like `directiveStrings`, but the other way around. -- directiveStrings' :: [(String, Directive)] directiveStrings' = concatMap go directiveStrings where - go (dir, strs) = map (, dir) strs + go (dir, strs) = map (, dir) $ NEL.toList strs -- | -- Returns all possible string representations of a directive. -- -stringsFor :: Directive -> [String] +stringsFor :: Directive -> NonEmpty String stringsFor d = fromJust (lookup d directiveStrings) -- | -- Returns the default string representation of a directive. -- stringFor :: Directive -> String -stringFor = head . stringsFor +stringFor = NEL.head . stringsFor -- | -- Returns the list of directives which could be expanded from the string @@ -84,4 +86,3 @@ help = , (Complete, "", "Show completions for as if pressing tab") , (Print, "", "Set the repl's printing function to (which must be fully qualified)") ] - diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index e8a2eb0f2c..10f0aec7a7 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -5,7 +5,7 @@ module Language.PureScript.Linter.Imports ) where import Prelude -import Protolude (ordNub) +import Protolude (ordNub, tailDef, headDef) import Control.Monad (join, unless, foldM, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -91,7 +91,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do let unwarned = imps \\ warned duplicates = join - . map tail + . map (tailDef $ internalError "lintImports: duplicates") . filter ((> 1) . length) . groupBy ((==) `on` defQual) . sortOn defQual @@ -195,7 +195,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do Just (Qualified _ name) -> Just (k, Qualified mnq (toName name)) _ -> Nothing | isQualifiedWith k q = - case importName (head is) of + case importName (headDef (internalError "extractByQual: empty import list") is) of Qualified (ByModuleName mn') name -> Just (mn', Qualified mnq (toName name)) _ -> internalError "unqualified name in extractByQual" go _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 2ab8b00d5c..092b8e2478 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -20,7 +20,7 @@ module Language.PureScript.Sugar.Names.Env import Prelude -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, (>=>)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -28,7 +28,7 @@ import Data.Function (on) import Data.Foldable (find) import Data.List (groupBy, sortOn, delete) import Data.Maybe (mapMaybe) -import Safe (headMay) +import Safe (headMay, headDef) import Data.Map qualified as M import Data.Set qualified as S @@ -482,8 +482,9 @@ checkImportConflicts ss currentModule toName xs = byOrig = sortOn importSourceModule xs groups = groupBy ((==) `on` importSourceModule) byOrig nonImplicit = filter ((/= FromImplicit) . importProvenance) xs - name = toName . disqualify . importName $ head xs - conflictModules = mapMaybe (getQual . importName . head) groups + name = toName . disqualify . importName $ + headDef (internalError "checkImportConflicts: No imports found") xs + conflictModules = mapMaybe (headMay >=> (getQual . importName)) groups in if length groups > 1 then case nonImplicit of @@ -494,8 +495,8 @@ checkImportConflicts ss currentModule toName xs = return (mnNew, mnOrig) _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules else - case head byOrig of - ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _ -> + case headMay byOrig of + Just (ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _) -> return (mnNew, mnOrig) _ -> internalError "checkImportConflicts: ImportRecord should be qualified" diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index cbe273f828..67b1560a77 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -4,6 +4,7 @@ module Language.PureScript.Sugar.Names.Exports ) where import Prelude +import Protolude (headDef) import Control.Monad (filterM, foldM, liftM2, unless, void, when) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -127,7 +128,8 @@ resolveExports env ss mn imps exps refs = -> (a -> Name) -> M.Map (Qualified a) [ImportRecord a] -> m [Qualified a] - extract ss' useQual name toName = fmap (map (importName . head . snd)) . go . M.toList + extract ss' useQual name toName = + fmap (map (importName . headDef (internalError "Missing value in extract") . snd)) . go . M.toList where go = filterM $ \(name', options) -> do let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 3a43faf7fd..77c65ba3c5 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -7,7 +7,7 @@ module Language.PureScript.Sugar.Names.Imports import Prelude -import Control.Monad (foldM, when) +import Control.Monad (foldM, when, unless) import Control.Monad.Error.Class (MonadError(..)) import Data.Foldable (for_, traverse_) @@ -147,7 +147,7 @@ resolveImport importModule exps imps impQual = resolveByType -> ProperName 'ConstructorName -> m () checkDctorExists ss tcon exports dctor - = when (dctor `notElem` exports) + = unless (dctor `elem` exports) . throwError . errorMessage' ss $ UnknownImportDataConstructor importModule tcon dctor diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4f3129baf8..d24485e044 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -237,7 +237,8 @@ desugarDecl mn exps = go expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef expRef name className tys - | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name UserNamed + | isExportedClass className && all (all isExportedType . getConstructors) tys = + Just $ TypeInstanceRef genSpan name UserNamed | otherwise = Nothing isExportedClass :: Qualified (ProperName 'ClassName) -> Bool diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index fd4e7c7982..c0d92e0c7a 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -8,7 +8,7 @@ module Language.PureScript.TypeChecker ) where import Prelude -import Protolude (headMay, maybeToLeft, ordNub) +import Protolude (headMay, maybeToLeft, ordNub, headDef) import Control.Lens ((^..), _2) import Control.Monad (when, unless, void, forM, zipWithM_) @@ -408,7 +408,9 @@ typeCheckAll moduleName = traverse go checkInstanceMembers :: [Declaration] -> TypeCheckM [Declaration] checkInstanceMembers instDecls = do - let idents = sort . map head . group . map memberName $ instDecls + let idents = sort + . map (headDef $ internalError "checkInstanceMembers: Empty instance declaration list") + . group . map memberName $ instDecls for_ (firstDuplicate idents) $ \ident -> throwError . errorMessage $ DuplicateValueDeclaration ident return instDecls @@ -730,7 +732,9 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = checkClassMembersAreExported :: DeclarationRef -> TypeCheckM () checkClassMembersAreExported dr@(TypeClassRef ss' name) = do - let members = ValueRef ss' `map` head (mapMaybe findClassMembers decls) + let members = ValueRef ss' `map` + (headDef $ internalError "checkClassMembersAreExported: Empty class member list") + (mapMaybe findClassMembers decls) let missingMembers = members \\ exps unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr missingMembers where diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 502a3dc05d..067241a724 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -1,6 +1,7 @@ {- HLINT ignore "Unused LANGUAGE pragma" -} -- HLint doesn't recognize that TypeApplications is used in a pattern {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeAbstractions #-} module Language.PureScript.TypeChecker.Deriving (deriveInstance) where import Protolude hiding (Type) @@ -503,7 +504,7 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con hasInstance :: InstanceContext -> Qualified (Either Text (ProperName 'TypeName)) -> Qualified (ProperName 'ClassName) -> Bool hasInstance tcds ht@(Qualified qb _) cn@(Qualified cqb _) = - any tcdAppliesToType $ concatMap (findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) + any (any tcdAppliesToType . findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) where tcdAppliesToType tcd = case tcdInstanceTypes tcd of [headOfType -> ht'] -> ht == ht' diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7895e541b1..8898caf2fd 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker.Entailment ) where import Prelude -import Protolude (ordNub, headMay) +import Protolude (ordNub, headMay, headDef) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) @@ -254,7 +254,7 @@ entails SolverOptions{..} constraint context hints = , typeClassDependencies , typeClassIsEmpty , typeClassCoveringSets - , typeClassMembers + , typeClassMembers } <- case M.lookup className' classesInScope of Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd @@ -278,8 +278,8 @@ entails SolverOptions{..} constraint context hints = else Left (Left (tcdToInstanceDescription tcd)) -- can't continue with this chain yet, need proof of apartness lefts [found] - solution <- lift . lift - $ unique kinds'' tys'' ambiguous instances + solution <- lift . lift + $ unique kinds'' tys'' ambiguous instances $ unknownsInAllCoveringSets (fst . (typeClassArguments !!)) typeClassMembers tys'' typeClassCoveringSets case solution of Solved substs tcd -> do @@ -290,7 +290,7 @@ entails SolverOptions{..} constraint context hints = -- Now enforce any functional dependencies, using unification -- Note: we need to generate fresh types for any unconstrained -- type variables before unifying. - let subst = fmap head substs + let subst = fmap (headDef $ internalError "entails: empty substitution") substs currentSubst <- lift . lift $ gets checkSubstitution subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst) lift . lift $ zipWithM_ (\t1 t2 -> do @@ -428,9 +428,9 @@ entails SolverOptions{..} constraint context hints = unknownsInAllCoveringSets :: (Int -> Text) -> [(Ident, SourceType, Maybe (S.Set (NEL.NonEmpty Int)))] -> [SourceType] -> S.Set (S.Set Int) -> UnknownsHint unknownsInAllCoveringSets indexToArgText tyClassMembers tyArgs coveringSets = do let unkIndices = findIndices containsUnknowns tyArgs - if all (\s -> any (`S.member` s) unkIndices) coveringSets then + if all (\s -> any (`S.member` s) unkIndices) coveringSets then fromMaybe Unknowns unknownsRequiringVtas - else + else NoUnknowns where unknownsRequiringVtas = do @@ -449,15 +449,15 @@ entails SolverOptions{..} constraint context hints = (_, getVars, _, _, _) = everythingOnValues (++) ignore getVarIdents ignore ignore ignore ignore = const [] getVarIdents = \case - Var _ ident | Just vtas <- M.lookup ident tyClassMemberVta -> + Var _ ident | Just vtas <- M.lookup ident tyClassMemberVta -> [(ident, vtas)] - _ -> + _ -> [] getECTExpr = \case ErrorCheckingType expr _ -> Just expr _ -> Nothing - + tyClassMembers' <- headMay $ mapMaybe (fmap tyClassMembersInExpr . getECTExpr) hints membersWithVtas <- NEL.nonEmpty tyClassMembers' pure $ UnknownsWithVtaRequiringArgs membersWithVtas @@ -665,7 +665,7 @@ entails SolverOptions{..} constraint context hints = , l, r , rowFromList (fixed, rowVar) , Just [ srcConstraint C.RowUnion kinds [rest, r, rowVar] Nothing ] - , [("r", kindRow (head kinds))] + , [("r", kindRow (headDef (internalError "unionRows: empty kinds") kinds))] ) solveRowCons :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index bc1d8f329d..681eb7f60e 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -26,6 +26,7 @@ module Language.PureScript.TypeChecker.Kinds ) where import Prelude +import Protolude (headDef) import Control.Arrow ((***)) import Control.Lens ((^.), _1, _2, _3) @@ -633,7 +634,7 @@ kindOfData -> DataDeclarationArgs -> TypeCheckM DataDeclarationResult kindOfData moduleName dataDecl = - head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] + headDef (internalError "kindOfData: empty list") . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] inferDataDeclaration :: @@ -685,7 +686,7 @@ kindOfTypeSynonym -> TypeDeclarationArgs -> TypeCheckM TypeDeclarationResult kindOfTypeSynonym moduleName typeDecl = - head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] + headDef (internalError "kindOfTypeSynonym: empty list") . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] inferTypeSynonym :: @@ -802,7 +803,7 @@ kindOfClass -> ClassDeclarationArgs -> TypeCheckM ClassDeclarationResult kindOfClass moduleName clsDecl = - head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] + headDef (internalError "kindOfClass: empty list") . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] inferClassDeclaration :: diff --git a/stack.yaml b/stack.yaml index 858a1b929d..144a1c909d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: lts-22.43 +resolver: lts-23.18 pvp-bounds: both packages: - '.' @@ -19,7 +19,7 @@ extra-deps: - aeson-better-errors-0.9.1.3 - github: purescript/cheapskate - commit: 8bfaf4beeb108e97a274ed51303f278905979e87 + commit: 633c69024e061ad956f1aecfc137fb99a7a7a20b nix: packages: @@ -38,3 +38,4 @@ flags: allow-newer: true allow-newer-deps: - haskeline +- weeder diff --git a/stack.yaml.lock b/stack.yaml.lock index 0af2cebb41..8a4853c3fa 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -42,17 +42,17 @@ packages: - completed: name: cheapskate pantry-tree: - sha256: a2253619f50d26f0137a802e51e5e7103ee52b1f71bc060d93a0979dcbefa2c8 + sha256: b130a35ad29a61ac64c2d29bb09309ddf07b139342c67ef01ccc59ad4167d529 size: 12069 - sha256: 959fc7a6ca7e0a743b06b0c287aa4a1c3ec7fc740e5830a4a841d43e925a6d73 - size: 62502 - url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz + sha256: 2b495e2b6d571c33b91ebb76c1b7fe9c9b56ff90ca0804106a3260f2bbdc9a9a + size: 62489 + url: https://github.com/purescript/cheapskate/archive/633c69024e061ad956f1aecfc137fb99a7a7a20b.tar.gz version: 0.1.1.2 original: - url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz + url: https://github.com/purescript/cheapskate/archive/633c69024e061ad956f1aecfc137fb99a7a7a20b.tar.gz snapshots: - completed: - sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146 - size: 720271 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml - original: lts-22.43 + sha256: d133abe75e408a407cce3f032c96ac1bbadf474a93b5156ebf4135b53382d56b + size: 683827 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/18.yaml + original: lts-23.18 diff --git a/tests/Main.hs b/tests/Main.hs index b8f6ea979e..a01dc09e1b 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -12,6 +12,7 @@ import TestCoreFn qualified import TestCst qualified import TestDocs qualified import TestHierarchy qualified +import TestInteractive qualified import TestPrimDocs qualified import TestPsci qualified import TestIde qualified @@ -40,6 +41,7 @@ main = do describe "sourcemaps" TestSourceMaps.spec describe "make" TestMake.spec describe "psci" TestPsci.spec + describe "interactive" TestInteractive.spec describe "corefn" TestCoreFn.spec describe "docs" TestDocs.spec describe "prim-docs" TestPrimDocs.spec diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index d2b805ff0e..09a76ceb7a 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,6 +1,7 @@ module TestDocs where import Prelude +import Protolude (tailDef) import Data.Bifunctor (first) import Data.List (findIndex) @@ -952,7 +953,7 @@ testCases = codeToString (Docs.renderType ty) == expected shouldBeOrdered mn declNames = - zipWith (ShouldComeBefore mn) declNames (tail declNames) + zipWith (ShouldComeBefore mn) declNames (tailDef mempty declNames) testTagsCases :: [(Text, [TagsAssertion])] testTagsCases = diff --git a/tests/TestInteractive.hs b/tests/TestInteractive.hs new file mode 100644 index 0000000000..13fdb806ce --- /dev/null +++ b/tests/TestInteractive.hs @@ -0,0 +1,97 @@ +module TestInteractive where + +import Prelude + +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Data.List.NonEmpty qualified as NEL +import Data.List (nub) + +import Language.PureScript.Interactive.Directive + ( directiveStrings + , directiveStrings' + , stringsFor + , stringFor + , directivesFor + , directivesFor' + , help + ) +import Language.PureScript.Interactive.Types (Directive(..)) + +spec :: Spec +spec = do + describe "Interactive.Directive" $ do + directiveStringsTests + directiveStrings'Tests + stringsForTests + stringForTests + directivesFor'Tests + directivesForTests + helpTests + +directiveStringsTests :: Spec +directiveStringsTests = describe "directiveStrings" $ do + it "should have non-empty string lists for each directive" $ do + let allHaveElements = not (any (null . NEL.toList . snd) directiveStrings) + allHaveElements `shouldBe` True + +directiveStrings'Tests :: Spec +directiveStrings'Tests = describe "directiveStrings'" $ do + it "should be a flattened version of directiveStrings" $ do + let expectedLength = sum (length . NEL.toList . snd <$> directiveStrings) + length directiveStrings' `shouldBe` expectedLength + + it "should contain appropriate directives" $ do + lookup "help" directiveStrings' `shouldBe` Just Help + lookup "?" directiveStrings' `shouldBe` Just Help + lookup "quit" directiveStrings' `shouldBe` Just Quit + lookup "reload" directiveStrings' `shouldBe` Just Reload + +stringsForTests :: Spec +stringsForTests = describe "stringsFor" $ do + it "should return all strings for a directive" $ do + NEL.toList (stringsFor Help) `shouldBe` ["?", "help"] + NEL.toList (stringsFor Quit) `shouldBe` ["quit"] + NEL.toList (stringsFor Reload) `shouldBe` ["reload"] + +stringForTests :: Spec +stringForTests = describe "stringFor" $ do + it "should return the first string for a directive" $ do + stringFor Help `shouldBe` "?" + stringFor Quit `shouldBe` "quit" + stringFor Reload `shouldBe` "reload" + +directivesFor'Tests :: Spec +directivesFor'Tests = describe "directivesFor'" $ do + it "should return matching directives and their string representations" $ do + directivesFor' "h" `shouldBe` [(Help, "help")] + directivesFor' "he" `shouldBe` [(Help, "help")] + directivesFor' "?" `shouldBe` [(Help, "?")] + directivesFor' "q" `shouldBe` [(Quit, "quit")] + + it "should handle ambiguous prefixes" $ do + directivesFor' "" `shouldSatisfy` (not . null) + length (directivesFor' "") `shouldBe` length directiveStrings' + + it "should return empty list for non-matching prefixes" $ do + directivesFor' "xyz" `shouldBe` [] + +directivesForTests :: Spec +directivesForTests = describe "directivesFor" $ do + it "should return just the directive part" $ do + directivesFor "h" `shouldBe` [Help] + directivesFor "q" `shouldBe` [Quit] + directivesFor "xyz" `shouldBe` [] + +helpTests :: Spec +helpTests = describe "help" $ do + it "should contain help for all directives" $ do + let helpDirectives = map (\(d, _, _) -> d) help + length (nub helpDirectives) `shouldBe` length directiveStrings + + it "should contain descriptive help text" $ do + let helpTexts = map (\(_, _, text) -> text) help + not (any null helpTexts) `shouldBe` True + + it "should include parameters where needed" $ do + lookup Browse (map (\(d, a, _) -> (d, a)) help) `shouldBe` Just "" + lookup Type (map (\(d, a, _) -> (d, a)) help) `shouldBe` Just ""