packages feed

purescript 0.14.1 → 0.14.2

raw patch · 155 files changed

+1645/−1034 lines, 155 filesdep +QuickCheckdep −purescript-astdep −tastydep −tasty-goldendep ~hspecdep ~purescript-cst

Dependencies added: QuickCheck

Dependencies removed: purescript-ast, tasty, tasty-golden, tasty-hspec, tasty-quickcheck

Dependency ranges changed: hspec, purescript-cst

Files

+ .hspec view
@@ -0,0 +1,1 @@+--times
CONTRIBUTING.md view
@@ -33,10 +33,10 @@  Run all test suites with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. -You can run individual test suites using `stack test --test-arguments="-p PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, or `hierarchy`. You can also build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/` by using the test's filename as the pattern, e.g.:+You can run individual test suites using `stack test --test-arguments="--match PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, or `hierarchy`. You can also build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/` by using the test's filename as the pattern, e.g.:  ```-stack test --fast --test-arguments="-p 1110.purs"+stack test --fast --test-arguments="--match 1110.purs" ```  This will run whatever test uses the example file `1110.purs`.
INSTALL.md view
@@ -25,6 +25,7 @@  * NPM: `npm install -g purescript` * Homebrew (for macOS): `brew install purescript`+* FreeBSD binary packages: `pkg install hs-purescript`  ## Compiling from source @@ -43,10 +44,10 @@  ## The "curses" library -The PureScript REPL depends on the `curses` library (via the Haskell package-`terminfo`). If you are having difficulty running the compiler, it may be-because the `curses` library is missing. This problem may appear as a `libtinfo`-error:+Prior to version v0.14.2, the PureScript REPL depends on the `curses` library+by default (via the Haskell package `terminfo`). If you are having difficulty+running the compiler, it may be because the `curses` library is missing. This+problem may appear as a `libtinfo` error: ``` error while loading shared libraries: libtinfo.so.5: cannot open shared object file: No such file or directory ```@@ -56,6 +57,12 @@ ``` $ sudo apt install libtinfo5 libncurses5-dev ```++As of v0.14.2, this should no longer be necessary if you are using the prebuilt+binaries or building the compiler from source with the default configuration.+However, you can still opt into using `curses` by setting the Haskeline+`terminfo` flag to `true`. This may improve the REPL experience slightly - for+example, by providing better editing of long input lines.  ## EACCES error
LICENSE view
@@ -132,7 +132,6 @@   process   protolude   psqueues-  purescript-ast   purescript-cst   random   regex-base@@ -157,7 +156,6 @@   tagged   tagsoup   template-haskell-  terminfo   text   th-abstraction   th-compat@@ -4037,22 +4035,6 @@   OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   DAMAGE. -purescript-ast LICENSE file:--  Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other-  contributors-  All rights reserved.--  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:--  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.--  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.--  3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.--  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.- purescript-cst LICENSE file:    Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other@@ -4861,35 +4843,6 @@   OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   DAMAGE. --terminfo LICENSE file:--  Copyright 2007, Judah Jacobson.--  Redistribution and use in source and binary forms, with or without-  modification, are permitted provided that the following conditions are met:--  1. Redistributions of source code must retain the above copyright notice, this-  list of conditions and the following disclaimer.--  2. Redistributions in binary form must reproduce the above copyright notice,-  this list of conditions and the following disclaimer in the documentation-  and/or other materials provided with the distribution.--  3. Neither the name of the copyright holder nor the names of its contributors-  may be used to endorse or promote products derived from this software without-  specific prior written permission.--  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE-  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-  OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  text LICENSE file:
README.md view
@@ -2,7 +2,7 @@  A small strongly typed programming language with expressive types that compiles to JavaScript, written in and inspired by Haskell. -[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript)+[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://github.com/purescript/purescript/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/purescript/purescript/actions/workflows/ci.yml)  ## Language info
app/Command/Bundle.hs view
@@ -1,9 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-}- -- | Bundles compiled PureScript modules for the browser. module Command.Bundle (command) where @@ -52,7 +46,7 @@   when (null inputFiles) . liftIO $ do     hPutStrLn stderr "purs bundle: No input files."     exitFailure-  when (isNothing optionsOutputFile && optionsSourceMaps == True) . liftIO $ do+  when (isNothing optionsOutputFile && optionsSourceMaps) . liftIO $ do     hPutStrLn stderr "purs bundle: Source maps only supported when output file specified."     exitFailure
app/Command/Compile.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Command.Compile (command) where  import Prelude@@ -154,7 +149,7 @@   where     -- Ensure that the JS target is included if sourcemaps are     handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget-    handleTargets ts = S.fromList (if elem P.JSSourceMap ts then P.JS : ts else ts)+    handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts)  pscMakeOptions :: Opts.Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile
app/Command/Docs/Html.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}- module Command.Docs.Html   ( asHtml   , layout
app/Command/Docs/Markdown.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Command.Docs.Markdown   ( asMarkdown   , writeMarkdownModules
app/Command/Graph.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}- module Command.Graph (command) where  import Prelude
app/Command/Hierarchy.hs view
@@ -13,8 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-}- module Command.Hierarchy (command) where  import           Prelude
app/Command/Ide.hs view
@@ -12,14 +12,8 @@ -- The server accepting commands for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE LambdaCase #-}  module Command.Ide (command) where @@ -227,7 +221,7 @@ catchGoneHandle =   handle (\e -> case e of     IOError { ioe_type = ResourceVanished } ->-      putText ("[Error] psc-ide-server tried to interact with the handle, but the connection was already gone.")+      putText "[Error] psc-ide-server tried to interact with the handle, but the connection was already gone."     _ -> throwIO e)  acceptCommand
app/Command/Publish.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Command.Publish (command) where  import Prelude@@ -65,7 +63,7 @@         opts           { publishGetVersion = return ("0.0.0", Version [0,0,0] [])           , publishGetTagTime = const (liftIO getCurrentTime)-          , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn+          , publishWorkingTreeDirty = warn DirtyWorkingTreeWarn           }       else         opts
app/Command/REPL.hs view
@@ -1,14 +1,6 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}  module Command.REPL (command) where
app/Main.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}- module Main where  import Prelude@@ -17,6 +10,7 @@ import qualified Command.Ide as Ide import qualified Command.Publish as Publish import qualified Command.REPL as REPL+import           Control.Monad (join) import           Data.Foldable (fold) import qualified Options.Applicative as Opts import           System.Environment (getArgs)@@ -31,8 +25,7 @@     IO.hSetEncoding IO.stderr IO.utf8     IO.hSetBuffering IO.stdout IO.LineBuffering     IO.hSetBuffering IO.stderr IO.LineBuffering-    cmd <- Opts.handleParseResult . execParserPure opts =<< getArgs-    cmd+    join $ Opts.handleParseResult . execParserPure opts =<< getArgs   where     opts        = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList     infoModList = Opts.fullDesc <> headerInfo <> footerInfo
purescript.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               purescript-version:            0.14.1+version:            0.14.2 license:            BSD-3-Clause license-file:       LICENSE copyright:@@ -32,7 +32,6 @@     tests/purs/**/*.out     tests/json-compat/**/*.json     tests/support/*.json-    tests/support/setup-win.cmd     tests/support/psci/**/*.purs     tests/support/psci/**/*.edit     tests/support/pscide/src/**/*.purs@@ -43,6 +42,7 @@     INSTALL.md     CONTRIBUTORS.md     CONTRIBUTING.md+    .hspec  source-repository head     type:     git@@ -174,6 +174,7 @@         Language.PureScript.Sugar.Operators.Types         Language.PureScript.Sugar.TypeClasses         Language.PureScript.Sugar.TypeClasses.Deriving+        Language.PureScript.Sugar.TypeClasses.Instances         Language.PureScript.Sugar.TypeDeclarations         Language.PureScript.TypeChecker         Language.PureScript.TypeChecker.Entailment@@ -248,8 +249,7 @@         pattern-arrows >=0.0.2 && <0.1,         process >=1.6.9.0 && <1.7,         protolude >=0.3.0 && <0.4,-        purescript-ast ==0.1.1.0,-        purescript-cst ==0.1.1.0,+        purescript-cst ==0.2.0.0,         regex-tdfa >=1.3.1.0 && <1.4,         safe >=0.3.19 && <0.4,         scientific >=0.3.6.2 && <0.4,@@ -346,8 +346,7 @@         pattern-arrows >=0.0.2 && <0.1,         process >=1.6.9.0 && <1.7,         protolude >=0.3.0 && <0.4,-        purescript-ast ==0.1.1.0,-        purescript-cst ==0.1.1.0,+        purescript-cst ==0.2.0.0,         regex-tdfa >=1.3.1.0 && <1.4,         safe >=0.3.19 && <0.4,         scientific >=0.3.6.2 && <0.4,@@ -407,6 +406,7 @@         TestBundle         TestCompiler         TestCoreFn+        TestCst         TestDocs         TestGraph         TestHierarchy@@ -477,8 +477,7 @@         pattern-arrows >=0.0.2 && <0.1,         process >=1.6.9.0 && <1.7,         protolude >=0.3.0 && <0.4,-        purescript-ast ==0.1.1.0,-        purescript-cst ==0.1.1.0,+        purescript-cst ==0.2.0.0,         regex-tdfa >=1.3.1.0 && <1.4,         safe >=0.3.19 && <0.4,         scientific >=0.3.6.2 && <0.4,@@ -499,10 +498,7 @@         utf8-string >=1.0.2 && <1.1,         vector >=0.12.1.2 && <0.13,         purescript -any,-        tasty >=1.2.3 && <1.3,-        tasty-golden >=2.3.3.2 && <2.4,-        tasty-hspec >=1.1.6 && <1.2,-        tasty-quickcheck >=0.10.1.2 && <0.11,-        hspec >=2.7.8 && <2.8,+        hspec >=2.7.10 && <2.8,         HUnit >=1.6.1.0 && <1.7,+        QuickCheck >=2.14.2 && <2.15,         regex-base >=0.94.0.1 && <0.95
src/Control/Monad/Logger.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}- -- | -- A replacement for WriterT IO which uses mutable references. --
src/Language/PureScript/Bundle.hs view
@@ -311,9 +311,9 @@             mapMaybe unPropertyIdentRef $             trailingCommaList props         in-          (map (\name -> (m, name, Internal)) shorthandNames, bn)+          (map (m, , Internal) shorthandNames, bn)     toReference (JSFunctionExpression _ _ _ params _ _) bn-      = ([], bn \\ (mapMaybe unIdentifier $ commaList params))+      = ([], bn \\ mapMaybe unIdentifier (commaList params))     toReference e bn       | Just nm <- exportsAccessor e       -- exports.foo means there's a dependency on the public member "foo" of@@ -650,7 +650,7 @@           map (\(porig, pgen) -> Mapping {                 mapOriginal = Just (Pos (fromIntegral $ porig + 1) 0)               , mapSourceFile = pathToFile <$> file-              , mapGenerated = (Pos (fromIntegral $ pos + pgen) 0)+              , mapGenerated = Pos (fromIntegral $ pos + pgen) 0               , mapName = Nothing               })             (offsets (0,0) (Right 1 : positions)))
src/Language/PureScript/CodeGen/JS/Common.hs view
@@ -51,11 +51,9 @@ -- absolutely necessary. isValidJsIdentifier :: Text -> Bool isValidJsIdentifier s =-  and-    [ not (T.null s)-    , isAlpha (T.head s)-    , s == anyNameToJs s-    ]+  not (T.null s) &&+  isAlpha (T.head s) &&+  s == anyNameToJs s  -- | Attempts to find a human-readable name for a symbol, if none has been specified returns the -- ordinal value.
src/Language/PureScript/CodeGen/JS/Printer.hs view
@@ -122,7 +122,7 @@   match _ = mzero    comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen-  comment (LineComment com) = fmap mconcat $ sequence $+  comment (LineComment com) = mconcat <$> sequence     [ currentIndent     , return $ emit "//" <> emit com <> emit "\n"     ]
src/Language/PureScript/CoreFn/Desugar.hs view
@@ -6,7 +6,7 @@ import Control.Arrow (second)  import Data.Function (on)-import Data.List (sort, sortBy)+import Data.List (sort, sortOn) import Data.Maybe (mapMaybe) import Data.Tuple (swap) import qualified Data.List.NonEmpty as NEL@@ -120,7 +120,7 @@   exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal _ (A.ObjectLiteral _)) _)) =     exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit)   exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal _ (A.ObjectLiteral vs))) =-    let args = fmap (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs+    let args = exprToCoreFn ss [] Nothing . snd <$> sortOn fst vs         ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)     in foldl (App (ss, com, Nothing, Nothing)) ctor args   exprToCoreFn ss com ty  (A.TypeClassDictionaryAccessor _ ident) =
src/Language/PureScript/CoreFn/Optimizer.hs view
@@ -43,7 +43,7 @@   where     collect :: Type a -> Maybe [Label]     collect (REmptyKinded _ _) = Just []-    collect (RCons _ l _ r) = collect r >>= return . (l :)+    collect (RCons _ l _ r) = (l :) <$> collect r     collect _ = Nothing closedRecordFields _ = Nothing
src/Language/PureScript/CoreImp/Optimizer/Inliner.hs view
@@ -46,7 +46,7 @@   convert :: AST -> AST   convert (Block ss [Return _ (App _ (Function _ Nothing idents block@(Block _ body)) args)])     | all shouldInline args &&-      not (any (`isRebound` block) (map (Var Nothing) idents)) &&+      not (any ((`isRebound` block) . Var Nothing) idents) &&       not (any (`isRebound` block) args)       = Block ss (map (replaceIdents (zip idents args)) body)   convert (Function _ Nothing [] (Block _ [Return _ (App _ fn [])])) = fn@@ -284,7 +284,7 @@   goApps (App _ (App _ (App _ fn [dict']) [x]) [y])     | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y     | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x-  goApps app@(App {}) = pure . Right . (,app) <$> freshName+  goApps app@App {} = pure . Right . (,app) <$> freshName   goApps other = pure [Left other]    isFnCompose :: AST -> AST -> Bool
src/Language/PureScript/CoreImp/Optimizer/TCO.hs view
@@ -83,7 +83,7 @@       case S.minView required of         Just (r, required') -> do           required'' <- findTailPositionDeps r js-          go (S.insert (fst r) known, required' <> (S.filter (not . (`S.member` known) . fst) required''))+          go (S.insert (fst r) known, required' <> S.filter (not . (`S.member` known) . fst) required'')         Nothing ->           pure known @@ -92,7 +92,7 @@   -- identifier to be considered in tail position (or Nothing if this   -- identifier is used somewhere not as a tail call with full arity).   findTailPositionDeps :: (Text, Int) -> AST -> Maybe (S.Set (Text, Int))-  findTailPositionDeps (ident, arity) js = allInTailPosition js where+  findTailPositionDeps (ident, arity) = allInTailPosition where     countSelfReferences = countReferences ident      allInTailPosition (Return _ expr)@@ -168,7 +168,7 @@         , Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js])         , While rootSS (Unary rootSS Not (Var rootSS tcoDone))             (Block rootSS-              [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])+              [Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS . tcoVar) outerArgs ++ map (Var rootSS . copyVar) innerArgs))])         , Return rootSS (Var rootSS tcoResult)         ]     where
src/Language/PureScript/Docs/AsHtml.hs view
@@ -216,10 +216,7 @@   linkToDecl = linkToDeclaration r    startsWithUpper :: Text -> Bool-  startsWithUpper str =-    if T.null str-      then False-      else isUpper (T.index str 0)+  startsWithUpper str = not (T.null str) && isUpper (T.index str 0)    isOp = isRight . runParser CST.parseOperator @@ -319,7 +316,7 @@ v = toValue  withClass :: String -> Html -> Html-withClass className content = H.span ! A.class_ (fromString className) $ content+withClass className = H.span ! A.class_ (fromString className)  partitionChildren ::   [ChildDeclaration] ->
src/Language/PureScript/Docs/Collect.hs view
@@ -59,7 +59,7 @@           addReExports withPackage docsModules externs    docsModules <- go modulePaths-  pure ((filter (shouldKeep . modName . snd) docsModules), modulesDeps)+  pure (filter (shouldKeep . modName . snd) docsModules, modulesDeps)    where   packageDiscriminators modulesDeps =@@ -158,7 +158,7 @@   [(tag, a)] ->   m [(tag, b)] operateAndRetag keyA keyB operation input =-  fmap (map retag) $ operation (map snd input)+  map retag <$> operation (map snd input)   where   tags :: Map key tag   tags = Map.fromList $ map (\(tag, a) -> (keyA a, tag)) input@@ -226,4 +226,4 @@     InPackage FilePath ->     m (InPackage FilePath, Text)   readFileAs fi =-    liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi)+    liftIO . fmap (fi,) $ readUTF8FileT (ignorePackage fi)
src/Language/PureScript/Docs/Convert.hs view
@@ -50,7 +50,7 @@ insertValueTypes env m =   m { modDeclarations = map go (modDeclarations m) }   where-  go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) =+  go d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} } =     let       ident = P.Ident . CST.getIdent . CST.nameValue . parseIdent $ declTitle d       ty = lookupName ident@@ -100,5 +100,5 @@       >=> fmap fst . runWriterT . flip evalStateT (env, mempty) . P.desugarImports       >=> P.rebracketFiltered isInstanceDecl externs -  isInstanceDecl (P.TypeInstanceDeclaration {}) = True+  isInstanceDecl P.TypeInstanceDeclaration {} = True   isInstanceDecl _ = False
src/Language/PureScript/Docs/Convert/ReExports.hs view
@@ -12,6 +12,7 @@ import Control.Monad.Trans.State.Strict (execState)  import Data.Either+import Data.Foldable (traverse_) import Data.Map (Map) import Data.Maybe (mapMaybe, fromMaybe) import qualified Data.Map as Map@@ -47,7 +48,7 @@ updateReExports externs withPackage = execState action   where   action =-    void (traverse go traversalOrder)+    traverse_ go traversalOrder    go mn = do     mdl <- lookup' mn@@ -98,7 +99,7 @@   case Map.lookup mn externsEnv of     Nothing ->       internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))-    Just (P.ExternsFile { P.efExports = refs }) -> do+    Just P.ExternsFile { P.efExports = refs } -> do       let reExpRefs = mapMaybe toReExportRef refs       runReaderT (collectDeclarations reExpRefs) mn
src/Language/PureScript/Docs/Convert/Single.hs view
@@ -94,7 +94,7 @@ getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name)-getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just (P.showIdent name)+getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = P.showIdent <$> hush name getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle _ = Nothing
src/Language/PureScript/Docs/Prim.hs view
@@ -209,8 +209,8 @@   , declInfo =       let         tcd = lookupPrimClassOf gen title-        args = fmap (fmap (fmap ($> ()))) $ P.typeClassArguments tcd-        superclasses = fmap ($> ()) $ P.typeClassSuperclasses tcd+        args = fmap (fmap ($> ())) <$> P.typeClassArguments tcd+        superclasses = ($> ()) <$> P.typeClassSuperclasses tcd         fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd)       in         TypeClassDeclaration args superclasses fundeps
src/Language/PureScript/Docs/Render.hs view
@@ -86,8 +86,7 @@     ChildInstance constraints ty ->       maybeToList (renderConstraints constraints) ++ [ renderType ty ]     ChildDataConstructor args ->-      [ dataCtor' cdeclTitle ]-      ++ map renderTypeAtom args+      dataCtor' cdeclTitle : map renderTypeAtom args      ChildTypeClassMember ty ->       [ ident' cdeclTitle
src/Language/PureScript/Docs/RenderedCode/RenderType.hs view
@@ -1,3 +1,6 @@+-- HLint is confused by the identifier `pattern` if PatternSynonyms is enabled.+{-# LANGUAGE NoPatternSynonyms #-}+ -- | Functions for producing RenderedCode values from PureScript Type values.  module Language.PureScript.Docs.RenderedCode.RenderType@@ -30,7 +33,7 @@ typeLiterals = mkPattern match   where   match (PPTypeWildcard name) =-    Just $ maybe (syntax "_") (syntax . ("?" <>)) name+    Just $ syntax $ maybe "_" ("?" <>) name   match (PPTypeVar var) =     Just (typeVar var)   match (PPRecord labels tail_) =
src/Language/PureScript/Docs/RenderedCode/Types.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveGeneric #-}- -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation.
src/Language/PureScript/Docs/Tags.hs view
@@ -18,7 +18,7 @@   where     dtags :: Declaration -> [(T.Text, Int)]     dtags decl = case declSourceSpan decl of-      Just ss -> (declTitle decl, pos ss):(mapMaybe subtag $ declChildren decl)+      Just ss -> (declTitle decl, pos ss):mapMaybe subtag (declChildren decl)       Nothing -> mapMaybe subtag $ declChildren decl      subtag :: ChildDeclaration -> Maybe (T.Text, Int)
src/Language/PureScript/Docs/Types.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveGeneric #-}- module Language.PureScript.Docs.Types   ( module Language.PureScript.Docs.Types   , module ReExports@@ -648,7 +646,7 @@  asDataDeclType :: Parse PackageError P.DataDeclType asDataDeclType =-  withText $ \s -> case s of+  withText $ \case     "data"    -> Right P.Data     "newtype" -> Right P.Newtype     other     -> Left (InvalidDataDeclType other)@@ -690,7 +688,7 @@ asQualifiedIdent :: Parse e (P.Qualified P.Ident) asQualifiedIdent = fromAesonParser -asSourceAnn :: Parse e (P.SourceAnn)+asSourceAnn :: Parse e P.SourceAnn asSourceAnn = fromAesonParser  asModuleMap :: Parse PackageError (Map P.ModuleName PackageName)
src/Language/PureScript/Errors.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}- module Language.PureScript.Errors   ( module Language.PureScript.AST   , module Language.PureScript.Errors@@ -19,11 +16,11 @@ import           Data.Either (partitionEithers) import           Data.Foldable (fold) import           Data.Functor.Identity (Identity(..))-import           Data.List (transpose, nubBy, partition, dropWhileEnd, sort, sortBy)+import           Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn) import qualified Data.List.NonEmpty as NEL import           Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M-import           Data.Ord (comparing)+import           Data.Ord (Down(..)) import qualified Data.Set as S import qualified Data.Text as T import           Data.Text (Text)@@ -381,8 +378,7 @@ errorMessage''' sss err =   maybe (errorMessage err) (flip errorMessage'' err)     . NEL.nonEmpty-    . reverse-    . sort+    . sortOn Down     $ filter (/= NullSourceSpan) sss  -- | Create an error set from a single error message@@ -510,7 +506,7 @@         case CST.errType pe of           CST.WarnDeprecatedRowSyntax -> do             let kind = CST.printTokens $ drop 1 toks-                sugg | T.isPrefixOf " " kind = "Row" <> kind+                sugg | " " `T.isPrefixOf` kind = "Row" <> kind                      | otherwise = "Row " <> kind             suggest sugg           CST.WarnDeprecatedForeignKindSyntax -> suggest $ "data " <> CST.printTokens (drop 3 toks)@@ -702,7 +698,7 @@       paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":"             , indent . paras $                 [ line $ "The identifier " <> markCode ident <> " contains a prime (" <> markCode "'" <> ")."-                , line $ "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future."+                , line "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future."                 ]             ]     renderSimpleErrorMessage InvalidDoBind =@@ -792,20 +788,20 @@         []   -> pure . line $ "A cycle appears in a set of type synonym definitions."         [pn] -> pure . line $ "A cycle appears in the definition of type synonym " <> markCode (runProperName pn)         _    -> [ line " A cycle appears in a set of type synonym definitions:"-                , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName) names)) <> "}"+                , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName) names) <> "}"                 ]     renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) =       paras [ line $ "A type class '" <> markCode (runProperName (disqualify name)) <> "' may not have itself as a superclass." ]     renderSimpleErrorMessage (CycleInTypeClassDeclaration names) =-      paras [ line $ "A cycle appears in a set of type class definitions:"-            , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}"+      paras [ line "A cycle appears in a set of type class definitions:"+            , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}"             , line "Cycles are disallowed because they can lead to loops in the type checker."             ]     renderSimpleErrorMessage (CycleInKindDeclaration [name]) =       paras [ line $ "A kind declaration '" <> markCode (runProperName (disqualify name)) <> "' may not refer to itself in its own signature." ]     renderSimpleErrorMessage (CycleInKindDeclaration names) =-      paras [ line $ "A cycle appears in a set of kind declarations:"-            , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}"+      paras [ line "A cycle appears in a set of kind declarations:"+            , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}"             , line "Kind declarations may not refer to themselves in their own signatures."             ]     renderSimpleErrorMessage (NameIsUndefined ident) =@@ -953,7 +949,7 @@                 [ line (showQualified runProperName nm)                 , Box.vcat Box.left (map prettyTypeAtom ts)                 ]-            , line $ fold $+            , line $ fold                 [ "because the "                 , markCode (showQualified runProperName nm)                 , " type class has "@@ -989,11 +985,11 @@     renderSimpleErrorMessage (OverlappingArgNames ident) =       line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident     renderSimpleErrorMessage (MissingClassMember identsAndTypes) =-      paras $ [ line "The following type class members have not been implemented:"-              , Box.vcat Box.left-                [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> prettyType ty-                | (ident, ty) <- NEL.toList identsAndTypes ]-              ]+      paras [ line "The following type class members have not been implemented:"+            , Box.vcat Box.left+              [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> prettyType ty+              | (ident, ty) <- NEL.toList identsAndTypes ]+            ]     renderSimpleErrorMessage (ExtraneousClassMember ident className) =       line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)     renderSimpleErrorMessage (ExpectedType ty kind) =@@ -1035,7 +1031,7 @@                 ]       where         modulesToList = S.toList $ S.delete (moduleNameFromString "Prim") nonOrphanModules-        formattedModules = T.intercalate " or " ((markCode . runModuleName) <$> modulesToList)+        formattedModules = T.intercalate " or " (markCode . runModuleName <$> modulesToList)     renderSimpleErrorMessage (InvalidNewtype name) =       paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid."             , line "Newtypes must define a single constructor with a single argument."@@ -1081,7 +1077,7 @@       let         maxTSResults = 15         tsResult = case ts of-          Just (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) ->+          Just TSAfter{tsAfterIdentifiers=idents} | not (null idents) ->             let               formatTS (names, types) =                 let@@ -1111,7 +1107,7 @@     renderSimpleErrorMessage (MissingKindDeclaration sig name ty) =       let sigKw = prettyPrintKindSignatureFor sig in       paras [ line $ "The inferred kind for the " <> sigKw <> " declaration " <> markCode (runProperName name) <> " contains polymorphic kinds."-            , line $ "Consider adding a top-level kind signature as a form of documentation."+            , line "Consider adding a top-level kind signature as a form of documentation."             , markCodeBox $ indent $ Box.hsep 1 Box.left                 [ line $ sigKw <> " " <> runProperName name <> " ::"                 , prettyTypeWithDepth maxBound ty@@ -1177,7 +1173,7 @@             ]     renderSimpleErrorMessage msg@(ImplicitQualifiedImportReExport importedModule asModule _) =       paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports."-            , line $ "As this module is being re-exported, consider using the explicit form:"+            , line "As this module is being re-exported, consider using the explicit form:"             , indent $ line $ markCode $ showSuggestion msg             ] @@ -1256,9 +1252,9 @@             ]      renderSimpleErrorMessage (CannotDefinePrimModules mn) =-      paras $+      paras         [ line $ "The module name " <> markCode (runModuleName mn) <> " is in the Prim namespace."-        , line $ "The Prim namespace is reserved for compiler-defined terms."+        , line "The Prim namespace is reserved for compiler-defined terms."         ]      renderSimpleErrorMessage (MixedAssociativityError opsWithAssoc) =@@ -1304,7 +1300,7 @@     renderSimpleErrorMessage (VisibleQuantificationCheckFailureInType var) =       paras         [ line $ "Visible dependent quantification of type variable " <> markCode var <> " is not supported."-        , line $ "If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre)."+        , line "If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre)."         ]      renderSimpleErrorMessage (UnsupportedTypeInKind ty) =@@ -1334,7 +1330,7 @@         ]      renderSimpleErrorMessage UnsupportedRoleDeclaration =-      line $ "Role declarations are only supported for data types, not for type synonyms nor type classes."+      line "Role declarations are only supported for data types, not for type synonyms nor type classes."      renderSimpleErrorMessage (RoleDeclarationArityMismatch name expected actual) =       line $ T.intercalate " "@@ -1532,7 +1528,7 @@     -- Keep the unique labels only     filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a)     filterRows (s1, r1) (s2, r2) =-         let sort' = sortBy (comparing $ \(RowListItem _ name ty) -> (name, ty))+         let sort' = sortOn $ \(RowListItem _ name ty) -> (name, ty)              notElem' s (RowListItem _ name ty) = all (\(RowListItem _ name' ty') -> name /= name' || not (eqType ty ty')) s              unique1 = filter (notElem' s2) s1              unique2 = filter (notElem' s1) s2
src/Language/PureScript/Externs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- -- | -- This module generates code for \"externs\" files, i.e. files containing only -- foreign import declarations.@@ -30,6 +28,7 @@ import qualified Data.List.NonEmpty as NEL  import Language.PureScript.AST+import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Names@@ -150,7 +149,7 @@       , edInstanceKinds           :: [SourceType]       , edInstanceTypes           :: [SourceType]       , edInstanceConstraints     :: Maybe [SourceConstraint]-      , edInstanceChain           :: [Qualified Ident]+      , edInstanceChain           :: Maybe ChainId       , edInstanceChainIndex      :: Integer       }   deriving (Show, Generic)@@ -204,16 +203,13 @@    fixityDecl :: Declaration -> Maybe ExternsFixity   fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) =-    fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps)+    fmap (const (ExternsFixity assoc prec op name)) (find ((== Just op) . getValueOpRef) exps)   fixityDecl _ = Nothing    typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity   typeFixityDecl (TypeFixityDeclaration _ (Fixity assoc prec) name op) =-    fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps)+    fmap (const (ExternsTypeFixity assoc prec op name)) (find ((== Just op) . getTypeOpRef) exps)   typeFixityDecl _ = Nothing--  findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool-  findOp g op = maybe False (== op) . g    importDecl :: Declaration -> Maybe ExternsImport   importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn)
src/Language/PureScript/Ide.hs view
@@ -160,7 +160,7 @@ findAvailableExterns = do   oDir <- outputDirectory   unlessM (liftIO (doesDirectoryExist oDir))-    (throwError (GeneralError $ "Couldn't locate your output directory at: " <> (T.pack (normalise oDir))))+    (throwError (GeneralError $ "Couldn't locate your output directory at: " <> T.pack (normalise oDir)))   liftIO $ do     directories <- getDirectoryContents oDir     moduleNames <- filterM (containsExterns oDir) directories
src/Language/PureScript/Ide/Command.hs view
@@ -160,7 +160,7 @@       "usages" -> do         params <- o .: "params"         FindUsages-          <$> (map P.moduleNameFromString (params .: "module"))+          <$> map P.moduleNameFromString (params .: "module")           <*> params .: "identifier"           <*> params .: "namespace"       "import" -> do
src/Language/PureScript/Ide/Completion.hs view
@@ -54,8 +54,8 @@ matchesFromModules :: ModuleMap [IdeDeclarationAnn] -> [Match IdeDeclarationAnn] matchesFromModules = Map.foldMapWithKey completionFromModule   where-    completionFromModule moduleName decls =-      map (\x -> Match (moduleName, x)) decls+    completionFromModule moduleName =+      map $ \x -> Match (moduleName, x)  data CompletionOptions = CompletionOptions   { coMaxResults :: Maybe Int
src/Language/PureScript/Ide/Error.hs view
@@ -52,7 +52,7 @@     encodeRebuildError err = case err of       (P.ErrorMessage _        ((P.HoleInferredType name _ _-         (Just (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields}))))) ->+         (Just P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields})))) ->         insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error err))       _ ->         (toJSON . toJSONError False P.Error) err@@ -61,7 +61,7 @@       Aeson.Object         (HM.insert "pursIde"          (object [ "name" .= name-                 , "completions" .= (ordNub (map identCompletion idents ++ map fieldCompletion fields))+                 , "completions" .= ordNub (map identCompletion idents ++ map fieldCompletion fields)                  ]) value)     insertTSCompletions _ _ _ v = v @@ -73,13 +73,13 @@         , complExpandedType = prettyPrintTypeSingleLine ty         , complLocation = Nothing         , complDocumentation = Nothing-        , complExportedFrom = maybe [] (\x -> [x]) mn+        , complExportedFrom = toList mn         , complDeclarationType = Nothing         }     fieldCompletion (label, ty) =       Completion          { complModule = ""-        , complIdentifier = ("_." <> P.prettyPrintLabel label)+        , complIdentifier = "_." <> P.prettyPrintLabel label         , complType = prettyPrintTypeSingleLine ty         , complExpandedType = prettyPrintTypeSingleLine ty         , complLocation = Nothing
src/Language/PureScript/Ide/Filter.hs view
@@ -12,8 +12,6 @@ -- Filters for psc-ide commands ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Language.PureScript.Ide.Filter        ( Filter        , moduleFilter@@ -104,7 +102,7 @@  namespaceFilter' :: Set IdeNamespace -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] namespaceFilter' namespaces =-  filter (\decl -> elem (namespaceForDeclaration (discardAnn decl)) namespaces)+  filter (\decl -> namespaceForDeclaration (discardAnn decl) `elem` namespaces)  exactFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] exactFilter' search =
src/Language/PureScript/Ide/Filter/Declaration.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Language.PureScript.Ide.Filter.Declaration        ( DeclarationType(..)        ) where@@ -21,20 +19,19 @@   deriving (Show, Eq, Ord)  instance FromJSON DeclarationType where-  parseJSON = withText "Declaration type tag" $ \str ->-    case str of-      "value"             -> pure Value-      "type"              -> pure Type-      "synonym"           -> pure Synonym-      "dataconstructor"   -> pure DataConstructor-      "typeclass"         -> pure TypeClass-      "valueoperator"     -> pure ValueOperator-      "typeoperator"      -> pure TypeOperator-      "module"            -> pure Module-      s                   -> fail ("Unknown declaration type: " <> show s)+  parseJSON = withText "Declaration type tag" $ \case+    "value"             -> pure Value+    "type"              -> pure Type+    "synonym"           -> pure Synonym+    "dataconstructor"   -> pure DataConstructor+    "typeclass"         -> pure TypeClass+    "valueoperator"     -> pure ValueOperator+    "typeoperator"      -> pure TypeOperator+    "module"            -> pure Module+    s                   -> fail ("Unknown declaration type: " <> show s)  instance ToJSON DeclarationType where-  toJSON dt = toJSON $ case dt of+  toJSON = toJSON . \case     Value           -> "value" :: Text     Type            -> "type"     Synonym         -> "synonym"
src/Language/PureScript/Ide/Logging.hs view
@@ -22,7 +22,7 @@                                          LogAll -> True                                          LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)                                          LogNone -> False-                                         LogDebug -> not (logLevel == LevelOther "perf")+                                         LogDebug -> logLevel /= LevelOther "perf"                                          LogPerf -> logLevel == LevelOther "perf")  labelTimespec :: Text -> TimeSpec -> Text
src/Language/PureScript/Ide/Matcher.hs view
@@ -12,9 +12,6 @@ -- Matchers for psc-ide commands ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Language.PureScript.Ide.Matcher        ( Matcher        , runMatcher@@ -83,7 +80,7 @@ runMatcher (Matcher m)= appEndo m  sortCompletions :: [ScoredMatch a] -> [ScoredMatch a]-sortCompletions = sortBy (flip compare `on` snd)+sortCompletions = sortOn (Down . snd)  flexMatch :: Text -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn] flexMatch = mapMaybe . flexRate
src/Language/PureScript/Ide/Reexports.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- -- Module      : Language.PureScript.Ide.Reexports
src/Language/PureScript/Ide/State.hs view
@@ -13,9 +13,6 @@ -----------------------------------------------------------------------------  {-# LANGUAGE PackageImports #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-}  module Language.PureScript.Ide.State@@ -252,8 +249,8 @@   :: (DefinitionSites P.SourceSpan, TypeAnnotations)   -> [IdeDeclarationAnn]   -> [IdeDeclarationAnn]-resolveLocationsForModule (defs, types) decls =-  map convertDeclaration decls+resolveLocationsForModule (defs, types) =+  map convertDeclaration   where     convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn     convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration'@@ -313,8 +310,8 @@   :: P.Module     -> [IdeDeclarationAnn]     -> [IdeDeclarationAnn]-resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls =-  map convertDecl decls+resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) =+  map convertDecl   where   extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])]   extractDeclComments = \case
src/Language/PureScript/Ide/Types.hs view
@@ -228,7 +228,7 @@   } deriving (Show, Eq, Ord)  instance ToJSON Completion where-  toJSON (Completion {..}) =+  toJSON Completion {..} =     Aeson.object       [ "module" .= complModule       , "identifier" .= complIdentifier
src/Language/PureScript/Ide/Util.hs view
@@ -77,13 +77,13 @@  valueOperatorAliasT   :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text-valueOperatorAliasT i =-  P.showQualified (either P.runIdent P.runProperName) i+valueOperatorAliasT =+  P.showQualified $ either P.runIdent P.runProperName  typeOperatorAliasT   :: P.Qualified (P.ProperName 'P.TypeName) -> Text-typeOperatorAliasT i =-  P.showQualified P.runProperName i+typeOperatorAliasT =+  P.showQualified P.runProperName  encodeT :: (ToJSON a) => a -> Text encodeT = TL.toStrict . TLE.decodeUtf8 . encode
src/Language/PureScript/Interactive/Directive.hs view
@@ -42,7 +42,7 @@ directiveStrings' :: [(String, Directive)] directiveStrings' = concatMap go directiveStrings   where-  go (dir, strs) = map (\s -> (s, dir)) strs+  go (dir, strs) = map (, dir) strs  -- | -- List of all directive strings.
src/Language/PureScript/Interactive/Module.hs view
@@ -17,7 +17,7 @@  -- | Checks if the Console module is defined supportModuleIsDefined :: [P.ModuleName] -> Bool-supportModuleIsDefined = any ((== supportModuleName))+supportModuleIsDefined = elem supportModuleName  -- * Module Management
src/Language/PureScript/Interactive/Printer.hs view
@@ -122,7 +122,7 @@                     Box.moveRight 2 $                     Box.vcat Box.left $                     mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $-                    map (\(cons,idents) -> (textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt+                    map (\(cons,idents) -> textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents)) pt                  prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox maxBound t
src/Language/PureScript/Linter.hs view
@@ -174,11 +174,10 @@     where      goDecl :: Declaration -> (S.Set Ident, MultipleErrors)-    goDecl d@(ValueDeclaration vd) =+    goDecl (ValueDeclaration vd) =         let allExprs = concatMap unguard $ valdeclExpression vd-            bindNewNames = S.fromList (concatMap binderNames $ valdeclBinders vd)-            ss = declSourceSpan d-            (vars, errs) = removeAndWarn ss bindNewNames $ mconcat $ map (go ss) allExprs+            bindNewNames = S.fromList (concatMap binderNamesWithSpans $ valdeclBinders vd)+            (vars, errs) = removeAndWarn bindNewNames $ mconcat $ map go allExprs             errs' = addHint (ErrorInValueDeclaration $ valdeclIdent vd) errs         in           (vars, errs')@@ -186,101 +185,105 @@     goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls     goDecl _ = mempty -    go :: SourceSpan -> Expr -> (S.Set Ident, MultipleErrors)-    go _ (Var _ (Qualified Nothing v)) = (S.singleton v, mempty)-    go _ (Var _ _) = (S.empty, mempty)+    go :: Expr -> (S.Set Ident, MultipleErrors)+    go (Var _ (Qualified Nothing v)) = (S.singleton v, mempty)+    go (Var _ _) = (S.empty, mempty) -    go ss (Let _ ds e) =-      let letNames = S.fromList $ concatMap declIdents ds-      in removeAndWarn ss letNames $ mconcat (go ss e : map underDecl ds)-    go ss (Abs binder v1) =-      let newNames = S.fromList (binderNames binder)+    go (Let _ ds e) =+      let (letNames, letNamesRec) = foldMap declIdents ds+      in removeAndWarn letNamesRec $+            removeAndWarn letNames (go e)+            <> mconcat (map underDecl ds)+    go (Abs binder v1) =+      let newNames = S.fromList (binderNamesWithSpans binder)       in-      removeAndWarn ss newNames $ go ss v1+      removeAndWarn newNames $ go v1 -    go ss (UnaryMinus _ v1) = go ss v1-    go ss (BinaryNoParens v0 v1 v2) = go ss v0 <> go ss v1 <> go ss v2-    go ss (Parens v1) = go ss v1-    go ss (TypeClassDictionaryConstructorApp _ v1) = go ss v1-    go ss (Accessor _ v1) = go ss v1+    go (UnaryMinus _ v1) = go v1+    go (BinaryNoParens v0 v1 v2) = go v0 <> go v1 <> go v2+    go (Parens v1) = go v1+    go (TypeClassDictionaryConstructorApp _ v1) = go v1+    go (Accessor _ v1) = go v1 -    go ss (ObjectUpdate obj vs) = mconcat (go ss obj : map (go ss . snd) vs)-    go ss (ObjectUpdateNested obj vs) = go ss obj <> goTree vs+    go (ObjectUpdate obj vs) = mconcat (go obj : map (go . snd) vs)+    go (ObjectUpdateNested obj vs) = go obj <> goTree vs       where         goTree (PathTree tree) = mconcat $ map (goNode . snd) (runAssocList tree)-        goNode (Leaf val) = go ss val+        goNode (Leaf val) = go val         goNode (Branch val) = goTree val -    go ss (App v1 v2) = go ss v1 <> go ss v2-    go ss (Unused v) = go ss v-    go ss (IfThenElse v1 v2 v3) = go ss v1 <> go ss v2 <> go ss v3-    go ss (Case vs alts) =+    go (App v1 v2) = go v1 <> go v2+    go (Unused v) = go v+    go (IfThenElse v1 v2 v3) = go v1 <> go v2 <> go v3+    go (Case vs alts) =       let f (CaseAlternative binders gexprs) =-            let bindNewNames = S.fromList (concatMap binderNames binders)+            let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders)                 allExprs = concatMap unguard gexprs             in-                removeAndWarn ss bindNewNames $ mconcat $ map (go ss) allExprs+                removeAndWarn bindNewNames $ mconcat $ map go allExprs       in-      mconcat $ map (go ss) vs ++ map f alts+      mconcat $ map go vs ++ map f alts -    go ss (TypedValue _ v1 _) = go ss v1-    go ss (Do _ es) = doElts ss es Nothing-    go ss (Ado _ es v1) = doElts ss es (Just v1)+    go (TypedValue _ v1 _) = go v1+    go (Do _ es) = doElts es Nothing+    go (Ado _ es v1) = doElts es (Just v1) -    go ss (Literal _ (ArrayLiteral es)) = mconcat $ map (go ss) es-    go ss (Literal _ (ObjectLiteral oo)) = mconcat $ map (go ss . snd) oo+    go (Literal _ (ArrayLiteral es)) = mconcat $ map go es+    go (Literal _ (ObjectLiteral oo)) = mconcat $ map (go . snd) oo -    go _ (PositionedValue ss' _ v1) = go ss' v1+    go (PositionedValue _ _ v1) = go v1 -    go _ (Literal _ _) = mempty-    go _ (Op _ _) = mempty-    go _ (Constructor _ _) = mempty-    go _ (TypeClassDictionary _ _ _) = mempty-    go _ (TypeClassDictionaryAccessor _ _) = mempty-    go _ (DeferredDictionary _ _) = mempty-    go _ AnonymousArgument = mempty-    go _ (Hole _) = mempty+    go (Literal _ _) = mempty+    go (Op _ _) = mempty+    go (Constructor _ _) = mempty+    go (TypeClassDictionary _ _ _) = mempty+    go (TypeClassDictionaryAccessor _ _) = mempty+    go (DeferredDictionary _ _) = mempty+    go AnonymousArgument = mempty+    go (Hole _) = mempty  -    doElts :: SourceSpan -> [DoNotationElement] -> Maybe Expr -> (S.Set Ident, MultipleErrors)-    doElts ss' (DoNotationValue e : rest) v = go ss' e <> doElts ss' rest v-    doElts ss' (DoNotationBind binder e : rest) v =-      let bindNewNames = S.fromList (binderNames binder)-      in go ss' e <> removeAndWarn ss' bindNewNames (doElts ss' rest v)+    doElts :: [DoNotationElement] -> Maybe Expr -> (S.Set Ident, MultipleErrors)+    doElts (DoNotationValue e : rest) v = go e <> doElts rest v+    doElts (DoNotationBind binder e : rest) v =+      let bindNewNames = S.fromList (binderNamesWithSpans binder)+      in go e <> removeAndWarn bindNewNames (doElts rest v) -    doElts ss' (DoNotationLet ds : rest) v =-      let letNewNames = S.fromList $ concatMap declIdents ds-          declRes = foldr1 (<>) (map underDecl ds)-      in removeAndWarn ss' letNewNames $ declRes <> doElts ss' rest v-    doElts _ (PositionedDoNotationElement ss'' _ e : rest) v = doElts ss'' (e : rest) v-    doElts ss' [] (Just e) = go ss' e <> (rebindable, mempty)-    doElts _ [] Nothing = (rebindable, mempty)+    doElts (DoNotationLet ds : rest) v =+      let (letNewNames, letNewNamesRec) = foldMap declIdents ds+      in removeAndWarn letNewNamesRec $+            mconcat (map underDecl ds)+            <> removeAndWarn letNewNames (doElts rest v)+    doElts (PositionedDoNotationElement _ _ e : rest) v = doElts (e : rest) v+    doElts [] (Just e) = go e <> (rebindable, mempty)+    doElts [] Nothing = (rebindable, mempty) -    declIdents :: Declaration -> [Ident]-    declIdents (ValueDecl _ ident _ _ _) = [ident]-    declIdents (BoundValueDeclaration _ binders _) = binderNames binders-    declIdents _ = []+    -- (non-recursively, recursively) bound idents in decl+    declIdents :: Declaration -> (S.Set (SourceSpan, Ident), S.Set (SourceSpan, Ident))+    declIdents (ValueDecl (ss,_) ident _ _ _) = (S.empty, S.singleton (ss, ident))+    declIdents (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans binders, S.empty)+    declIdents _ = (S.empty, S.empty)      -- let f x = e  -- check the x in e (but not the f)-    underDecl d@(ValueDecl _ _ _ binders gexprs) =-      let bindNewNames = S.fromList (concatMap binderNames binders)+    underDecl (ValueDecl _ _ _ binders gexprs) =+      let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders)           allExprs = concatMap unguard gexprs-          ss = declSourceSpan d       in-          removeAndWarn ss bindNewNames $ foldr1 (<>) $ map (go ss) allExprs+          removeAndWarn bindNewNames $ foldr1 (<>) $ map go allExprs     -- let {x} = e  -- no binding to check inside e-    underDecl d@(BoundValueDeclaration _ _ expr) =-      go (declSourceSpan d) expr+    underDecl (BoundValueDeclaration _ _ expr) = go expr     underDecl _ = (mempty, mempty)      unguard (GuardedExpr guards expr) = map unguard' guards ++ [expr]     unguard' (ConditionGuard ee) = ee     unguard' (PatternGuard _ ee) = ee -    removeAndWarn :: SourceSpan -> S.Set Ident -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors)-    removeAndWarn ss newNames (used, errors) =-      let filteredUsed = used `S.difference` newNames+    removeAndWarn :: S.Set (SourceSpan, Ident) -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors)+    removeAndWarn newNamesWithSpans (used, errors) =+      let newNames = S.map snd newNamesWithSpans+          filteredUsed = used `S.difference` newNames           warnUnused = S.filter (not . Text.isPrefixOf "_" . runIdent) (newNames `S.difference` used)-          combinedErrors = if not $ S.null warnUnused then errors <> (mconcat $ map (errorMessage' ss . UnusedName) $ S.toList warnUnused) else errors+          warnUnusedSpans = S.filter (\(_,ident) -> ident `elem` warnUnused) newNamesWithSpans +          combinedErrors = if not $ S.null warnUnusedSpans then errors <> mconcat (map (\(ss,ident) -> errorMessage' ss $ UnusedName ident) $ S.toList warnUnusedSpans) else errors       in         (filteredUsed, combinedErrors)
src/Language/PureScript/Linter/Exhaustive.hs view
@@ -17,8 +17,7 @@ import Control.Monad.Writer.Class import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) -import Data.Function (on)-import Data.List (foldl', sortBy)+import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) import qualified Data.Map as M import Data.Text (Text)@@ -133,7 +132,7 @@   where   (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders) -  sortNames = sortBy (compare `on` fst)+  sortNames = sortOn fst    (sbs, sbs') = (sortNames bs, sortNames bs') @@ -294,7 +293,7 @@     where       partial :: Text -> Text -> Declaration       partial var tyVar =-        ValueDecl (ss, []) UnusedIdent Private [] $+        ValueDecl (ss, []) UnusedIdent Private []         [MkUnguarded           (TypedValue            True
src/Language/PureScript/Linter/Imports.hs view
@@ -12,7 +12,7 @@  import Data.Function (on) import Data.Foldable (for_)-import Data.List (find, intersect, groupBy, sort, sortBy, (\\))+import Data.List (find, intersect, groupBy, sort, sortOn, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM)@@ -94,7 +94,7 @@           . map tail           . filter ((> 1) . length)           . groupBy ((==) `on` defQual)-          . sortBy (compare `on` defQual)+          . sortOn defQual           $ unwarned      for_ duplicates $ \(pos, _, _) ->
src/Language/PureScript/Make.hs view
@@ -2,6 +2,7 @@   (   -- * Make API   rebuildModule+  , rebuildModule'   , make   , inferForeignModules   , module Monad@@ -21,7 +22,7 @@ import           Control.Monad.Writer.Strict (runWriterT) import           Data.Function (on) import           Data.Foldable (fold, for_)-import           Data.List (foldl', sortBy)+import           Data.List (foldl', sortOn) import qualified Data.List.NonEmpty as NEL import           Data.Maybe (fromMaybe) import qualified Data.Map as M@@ -199,7 +200,7 @@   -- Find all groups of duplicate values in a list based on a projection.   findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a]   findDuplicates f xs =-    case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of+    case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortOn f $ xs of       [] -> Nothing       xss -> Just xss
src/Language/PureScript/Make/Cache.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Language.PureScript.Make.Cache   ( ContentHash   , hash@@ -131,7 +129,7 @@ -- | Remove any modules from the given set from the cache database; used when -- they failed to build. removeModules :: Set ModuleName -> CacheDb -> CacheDb-removeModules moduleNames = flip Map.withoutKeys moduleNames+removeModules = flip Map.withoutKeys  -- | 1. Any path that is beneath our current working directory will be -- stored as a normalised relative path
src/Language/PureScript/Make/Monad.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.PureScript.Make.Monad   ( -- * Implementation of Make API using files on disk     Make(..)
src/Language/PureScript/Pretty/Common.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- -- | -- Common pretty-printing utility functions --
src/Language/PureScript/Pretty/Types.hs view
@@ -1,3 +1,6 @@+-- HLint is confused by the identifier `pattern` if PatternSynonyms is enabled.+{-# LANGUAGE NoPatternSynonyms #-}+ -- | -- Pretty printer for Types --@@ -22,6 +25,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA +import Data.Bifunctor (first) import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import qualified Data.Text as T@@ -176,11 +180,11 @@  matchTypeAtom :: TypeRenderOptions -> Pattern () PrettyPrintType Box matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =-    typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro)+    typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) (matchType tro)   where     typeLiterals :: Pattern () PrettyPrintType Box     typeLiterals = mkPattern match where-      match (PPTypeWildcard name) = Just $ maybe (text "_") (text . ('?' :) . T.unpack) name+      match (PPTypeWildcard name) = Just $ text $ maybe "_" (('?' :) . T.unpack) name       match (PPTypeVar var) = Just $ text $ T.unpack var       match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s       match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor@@ -228,7 +232,7 @@ forall_ :: Pattern () PrettyPrintType ([(String, Maybe PrettyPrintType)], PrettyPrintType) forall_ = mkPattern match   where-  match (PPForAll idents ty) = Just (map (\(v, mbK) -> (T.unpack v, mbK)) idents, ty)+  match (PPForAll idents ty) = Just (map (first T.unpack) idents, ty)   match _ = Nothing  typeAtomAsBox' :: PrettyPrintType -> Box
src/Language/PureScript/Pretty/Values.hs view
@@ -226,7 +226,7 @@ -- prettyPrintBinder :: Binder -> Text prettyPrintBinder (ConstructorBinder _ ctor []) = runProperName (disqualify ctor)-prettyPrintBinder (ConstructorBinder _ ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args)+prettyPrintBinder (ConstructorBinder _ ctor args) = runProperName (disqualify ctor) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b
src/Language/PureScript/Publish.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Language.PureScript.Publish   ( preparePackage   , preparePackage'@@ -164,7 +162,7 @@   (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths)    (modules, moduleMap) <--    (liftIO (runExceptT (D.collectDocs (publishCompileOutputDir opts) inputFiles depsFiles)))+    liftIO (runExceptT (D.collectDocs (publishCompileOutputDir opts) inputFiles depsFiles))     >>= either (userError . CompileError) return    pure (map snd modules, moduleMap)@@ -214,7 +212,7 @@     Nothing -> do       giturl <- catchError (Just . T.strip . T.pack <$> readProcess' "git" ["config", "remote.origin.url"] "")                   (const (return Nothing))-      userError (BadRepositoryField (RepositoryFieldMissing (giturl >>= extractGithub >>= return . format)))+      userError (BadRepositoryField (RepositoryFieldMissing (giturl >>= extractGithub <&> format)))     Just Repository{..} -> do       unless (repositoryType == "git")         (userError (BadRepositoryField (BadRepositoryType repositoryType)))
src/Language/PureScript/Publish/ErrorsWarnings.hs view
@@ -44,7 +44,7 @@ data PackageWarning   = NoResolvedVersion PackageName   | UnacceptableVersion (PackageName, Text)-  | DirtyWorkingTree_Warn+  | DirtyWorkingTreeWarn   deriving (Show)  -- | An error that should be fixed by the user.@@ -174,20 +174,17 @@       , spacer       ] ++ spdxExamples ++       [ spacer-      , para $ concat-          [ "See https://spdx.org/licenses/ for a full list of licenses. For more "-          , "information on SPDX license expressions, see https://spdx.org/ids-how"-          ]+      , para $+          "See https://spdx.org/licenses/ for a full list of licenses. For more " +++          "information on SPDX license expressions, see https://spdx.org/ids-how"       , spacer-      , para $ concat-          [ "Note that distributing code without a license means that nobody will "-          , "(legally) be able to use it."-          ]+      , para $+          "Note that distributing code without a license means that nobody will " +++          "(legally) be able to use it."       , spacer-      , para $ concat-          [ "It is also recommended to add a LICENSE file to the repository, "-          , "including your name and the current year, although this is not necessary."-          ]+      , para $+          "It is also recommended to add a LICENSE file to the repository, " +++          "including your name and the current year, although this is not necessary."       ]   InvalidLicense ->     vcat $@@ -206,12 +203,11 @@         do_          = pl "do" "does"         dependencies = pl "dependencies" "dependency"     in vcat $-      [ para (concat+      para (concat         [ "The following ", dependencies, " ", do_, " not appear to be "         , "installed:"-        ])-      ] ++-        bulletedListT runPackageName (NonEmpty.toList pkgs)+        ]) :+      bulletedListT runPackageName (NonEmpty.toList pkgs)   CompileError err ->     vcat       [ para "Compile error:"@@ -224,8 +220,8 @@         )   ResolutionsFileError path err ->     successivelyIndented $-      [ "Error in resolutions file (" ++ path ++ "):" ]-      ++ map T.unpack (displayError D.displayPackageError err)+      ("Error in resolutions file (" ++ path ++ "):") :+      map T.unpack (displayError D.displayPackageError err)  spdxExamples :: [Box] spdxExamples =@@ -318,7 +314,7 @@       mempty { noResolvedVersions = [pn] }     UnacceptableVersion t ->       mempty { unacceptableVersions = [t] }-    DirtyWorkingTree_Warn ->+    DirtyWorkingTreeWarn ->       mempty { dirtyWorkingTree = Any True }  renderWarnings :: [PackageWarning] -> Box
src/Language/PureScript/Renamer.hs view
@@ -134,7 +134,7 @@     name' <- if isTopLevel then return name else updateScope name     return ((a, name'), val)   updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)-  updateValues (aname, val) = (,) aname <$> renameInValue val+  updateValues (aname, val) = (aname, ) <$> renameInValue val  -- | -- Renames within a value.@@ -146,7 +146,7 @@ renameInValue (Accessor ann prop v) =   Accessor ann prop <$> renameInValue v renameInValue (ObjectUpdate ann obj vs) =-  ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (,) name <$> renameInValue v) vs+  ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e renameInValue (Abs ann name v) =   newScope $ Abs ann <$> updateScope name <*> renameInValue v
src/Language/PureScript/Sugar.hs view
@@ -30,6 +30,7 @@ import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.TypeClasses.Deriving as S+import Language.PureScript.Sugar.TypeClasses.Instances as S import Language.PureScript.Sugar.TypeDeclarations as S import Language.PureScript.TypeChecker.Synonyms (SynonymMap) @@ -48,6 +49,8 @@ -- --  * Desugar top-level case declarations into explicit case expressions --+--  * Generate type class instance names for those not defined in source code+-- --  * Desugar type declarations into value declarations with explicit type annotations -- --  * Qualify any unqualified names and types@@ -85,6 +88,7 @@       -- knowing their kinds but they're not available yet.           kinds = mempty        in deriveInstances externs syns kinds m+      >>= desugarTypeClassInstanceNames       >>= desugarTypeClasses externs syns kinds)     >=> createBindingGroupsModule
src/Language/PureScript/Sugar/AdoNotation.hs view
@@ -1,8 +1,6 @@ -- | This module implements the desugaring pass which replaces ado-notation statements with -- appropriate calls to pure and apply. -{-# LANGUAGE PatternGuards #-}- module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where  import           Prelude.Compat hiding (abs)
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -73,13 +73,13 @@   handleDecls :: [Declaration] -> m [Declaration]   handleDecls ds = do     let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds-        kindDecls = fmap (,VertexKindSignature) $ filter isKindDecl ds-        dataDecls = fmap (,VertexDefinition) $ filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds-        kindSigs = fmap (declTypeName . fst) kindDecls-        typeSyns = fmap declTypeName $ filter isTypeSynonymDecl ds+        kindDecls = (,VertexKindSignature) <$> filter isKindDecl ds+        dataDecls = (,VertexDefinition) <$> filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds+        kindSigs = declTypeName . fst <$> kindDecls+        typeSyns = declTypeName <$> filter isTypeSynonymDecl ds         nonTypeSynKindSigs = kindSigs \\ typeSyns         allDecls = kindDecls ++ dataDecls-        allProperNames = fmap (declTypeName . fst) allDecls+        allProperNames = declTypeName . fst <$> allDecls         mkVert (d, vty) =           let names = usedTypeNames moduleName d `intersect` allProperNames               name = declTypeName d
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -58,7 +58,7 @@   -> Expr   -> m Expr desugarGuardedExprs ss (Case scrut alternatives)-  | any (not . isTrivialExpr) scrut = do+  | not $ all isTrivialExpr scrut = do     -- in case the scrutinee is non trivial (e.g. not a Var or Literal)     -- we may evaluate the scrutinee more than once when a guard occurs.     -- We bind the scrutinee to Vars here to mitigate this case.@@ -186,7 +186,7 @@           --         in Case scrut             (CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)]-              : (alt_fail' (length scrut)))+              : alt_fail' (length scrut))        return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]]
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -1,8 +1,6 @@ -- | This module implements the desugaring pass which replaces do-notation statements with -- appropriate calls to bind. -{-# LANGUAGE PatternGuards #-}- module Language.PureScript.Sugar.DoNotation (desugarDoModule) where  import           Prelude.Compat
src/Language/PureScript/Sugar/Names.hs view
@@ -10,7 +10,7 @@   ) where  import Prelude.Compat-import Protolude (ordNub, sortBy, on)+import Protolude (ordNub, sortOn)  import Control.Arrow (first, second) import Control.Monad@@ -149,7 +149,7 @@ -- their order in the source file. reorderExports :: [Declaration] -> Maybe [DeclarationRef] -> [DeclarationRef] -> [DeclarationRef] reorderExports decls originalRefs =-  sortBy (compare `on` originalIndex)+  sortOn originalIndex   where   names =     maybe (mapMaybe declName decls) (map declRefName) originalRefs@@ -257,15 +257,15 @@       throwError . errorMessage' pos $ OverlappingNamesInLet     return ((pos, args ++ bound), Let w ds val')   updateValue (_, bound) (Var ss name'@(Qualified Nothing ident)) | ident `notElem` bound =-    (,) (ss, bound) <$> (Var ss <$> updateValueName name' ss)+    ((ss, bound), ) <$> (Var ss <$> updateValueName name' ss)   updateValue (_, bound) (Var ss name'@(Qualified (Just _) _)) =-    (,) (ss, bound) <$> (Var ss <$> updateValueName name' ss)+    ((ss, bound), ) <$> (Var ss <$> updateValueName name' ss)   updateValue (_, bound) (Op ss op) =-    (,) (ss, bound) <$> (Op ss <$> updateValueOpName op ss)+    ((ss, bound), ) <$> (Op ss <$> updateValueOpName op ss)   updateValue (_, bound) (Constructor ss name) =-    (,) (ss, bound) <$> (Constructor ss <$> updateDataConstructorName name ss)+    ((ss, bound), ) <$> (Constructor ss <$> updateDataConstructorName name ss)   updateValue s (TypedValue check val ty) =-    (,) s <$> (TypedValue check val <$> updateTypesEverywhere ty)+    (s, ) <$> (TypedValue check val <$> updateTypesEverywhere ty)   updateValue s v = return (s, v)    updateBinder@@ -275,9 +275,9 @@   updateBinder (_, bound) v@(PositionedBinder pos _ _) =     return ((pos, bound), v)   updateBinder (_, bound) (ConstructorBinder ss name b) =-    (,) (ss, bound) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b)+    ((ss, bound), ) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b)   updateBinder (_, bound) (OpBinder ss op) =-    (,) (ss, bound) <$> (OpBinder ss <$> updateValueOpName op ss)+    ((ss, bound), ) <$> (OpBinder ss <$> updateValueOpName op ss)   updateBinder s (TypedBinder t b) = do     t' <- updateTypesEverywhere t     return (s, TypedBinder t' b)
src/Language/PureScript/Sugar/Names/Common.hs view
@@ -54,7 +54,7 @@   extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)]   extractCtors pos' (TypeRef _ _ (Just dctors)) =     let dupes = dctors \\ ordNub dctors-    in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes+    in if null dupes then Nothing else Just $ (pos',) . DctorName <$> dupes   extractCtors _ _ = Nothing    -- Converts a DeclarationRef into a name for an error message.
src/Language/PureScript/Sugar/Names/Env.hs view
@@ -29,7 +29,7 @@  import Data.Function (on) import Data.Foldable (find)-import Data.List (groupBy, sortBy, delete)+import Data.List (groupBy, sortOn, delete) import Data.Maybe (fromJust, mapMaybe) import Safe (headMay) import qualified Data.Map as M@@ -490,7 +490,7 @@   -> m (ModuleName, ModuleName) checkImportConflicts ss currentModule toName xs =   let-    byOrig = sortBy (compare `on` importSourceModule) xs+    byOrig = sortOn importSourceModule xs     groups = groupBy ((==) `on` importSourceModule) byOrig     nonImplicit = filter ((/= FromImplicit) . importProvenance) xs     name = toName . disqualify . importName $ head xs
src/Language/PureScript/Sugar/Names/Exports.hs view
@@ -11,7 +11,7 @@  import Data.Function (on) import Data.Foldable (traverse_)-import Data.List (intersect, groupBy, sortBy)+import Data.List (intersect, groupBy, sortOn) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M @@ -217,7 +217,7 @@   resolve f (Qualified (Just mn'') a) = do     exps' <- envModuleExports <$> mn'' `M.lookup` env     src <- a `M.lookup` f exps'-    return $ (a, src { exportSourceImportedFrom = Just mn'' })+    return (a, src { exportSourceImportedFrom = Just mn'' })   resolve _ _ = internalError "Unqualified value in resolve"  -- |@@ -256,7 +256,7 @@     = fmap (\(ss', (tc, dcs)) -> TypeRef ss' tc dcs)     . fmap (foldr1 $ \(ss, (tc, dcs1)) (_, (_, dcs2)) -> (ss, (tc, liftM2 (++) dcs1 dcs2)))     . groupBy ((==) `on` (fst . snd))-    . sortBy (compare `on` (fst . snd))+    . sortOn (fst . snd)     . mapMaybe (\ref -> (declRefSourceSpan ref,) <$> getTypeRef ref)    filterTypes
src/Language/PureScript/Sugar/Operators.hs view
@@ -31,10 +31,12 @@ import Data.Either (partitionEithers) import Data.Foldable (for_, traverse_) import Data.Function (on)+import Data.Functor (($>)) import Data.Functor.Identity (Identity(..), runIdentity)-import Data.List (groupBy, sortBy)+import Data.List (groupBy, sortOn) import Data.Maybe (mapMaybe, listToMaybe) import qualified Data.Map as M+import Data.Ord (Down(..))  import qualified Language.PureScript.Constants.Prelude as C @@ -277,7 +279,7 @@   => (a -> SimpleErrorMessage)   -> [(Qualified a, SourceSpan)]   -> m ()-ensureNoDuplicates toError m = go $ sortBy (compare `on` fst) m+ensureNoDuplicates toError m = go $ sortOn fst m   where   go [] = return ()   go [_] = return ()@@ -292,7 +294,7 @@ customOperatorTable fixities =   let     userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities-    sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps+    sorted = sortOn (Down . (\(_, p, _) -> p)) userOps     groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted   in     map (map (\(name, _, a) -> (name, a))) groups@@ -372,7 +374,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) =   rethrow (addHint (ErrorInModule mn))     $ rethrowWithPosition ss (traverse_ checkRef exps)-    *> return m+    $> m   where    checkRef :: DeclarationRef -> m ()
src/Language/PureScript/Sugar/Operators/Common.hs view
@@ -104,9 +104,9 @@       opInfo :: M.Map (Qualified (OpName nameType)) (Integer, Associativity)       opInfo = M.fromList $ concatMap (\(n, o) -> map (\(name, assoc) -> (name, (n, assoc))) o) (zip [0..] ops)       opPrec :: Qualified (OpName nameType) -> Integer-      opPrec = fromJust . fmap fst . flip M.lookup opInfo+      opPrec = fst . fromJust . flip M.lookup opInfo       opAssoc :: Qualified (OpName nameType) -> Associativity-      opAssoc = fromJust . fmap snd . flip M.lookup opInfo+      opAssoc = snd . fromJust . flip M.lookup opInfo       chainOpSpans :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan)       chainOpSpans = foldr (\(ss, name) -> M.alter (Just . maybe (pure ss) (NEL.cons ss)) name) M.empty . mapMaybe fromOp $ rights chain       opUsages :: Qualified (OpName nameType) -> Int@@ -118,7 +118,7 @@       mixedAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))]       mixedAssoc = fmap join . filter (\precGroup -> NEL.length precGroup > 1) $ assocGrouped       nonAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))]-      nonAssoc = join $ fmap (NEL.filter (\assocGroup -> opAssoc (NEL.head assocGroup) == Infix && sum (fmap opUsages assocGroup) > 1)) assocGrouped+      nonAssoc = NEL.filter (\assocGroup -> opAssoc (NEL.head assocGroup) == Infix && sum (fmap opUsages assocGroup) > 1) =<< assocGrouped     in       if null (nonAssoc ++ mixedAssoc)         then internalError "matchOperators: cannot reorder operators"@@ -141,4 +141,4 @@     -> ErrorMessage   mkPositionedError chainOpSpans grp =     ErrorMessage-      [PositionedError (join . fmap (fromJust . flip M.lookup chainOpSpans) $ grp)]+      [PositionedError (fromJust . flip M.lookup chainOpSpans =<< grp)]
src/Language/PureScript/Sugar/Operators/Types.hs view
@@ -31,4 +31,4 @@   fromOp _ = Nothing    reapply :: a -> Qualified (OpName 'TypeOpName) -> SourceType -> SourceType -> SourceType-  reapply _ op t1 t2 = srcTypeApp (srcTypeApp (TypeOp (ss, []) op) t1) t2+  reapply _ op = srcTypeApp . srcTypeApp (TypeOp (ss, []) op)
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -17,7 +17,7 @@ import           Data.Graph import           Data.List (find, partition) import qualified Data.Map as M-import           Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe)+import           Data.Maybe (catMaybes, mapMaybe, isJust) import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import           Data.Text (Text)@@ -214,16 +214,17 @@     modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False))     return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)   go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"-  go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members))+  go (TypeInstanceDeclaration _ _ _ (Left _) _ _ _ _) = internalError "instance names should have been desugared"+  go d@(TypeInstanceDeclaration sa _ _ (Right name) deps className tys (ExplicitInstance members))     | className == C.Coercible     = throwError . errorMessage' (fst sa) $ InvalidCoercibleInstanceDeclaration tys     | otherwise = do     desugared <- desugarCases members     dictDecl <- typeInstanceDictionaryDeclaration syns kinds sa name mn deps className tys desugared     return (expRef name className tys, [d, dictDecl])-  go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do+  go d@(TypeInstanceDeclaration sa _ _ (Right name) deps className tys (NewtypeInstanceWithDictionary dict)) = do     let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys-        constrainedTy = quantify (foldr (srcConstrainedType) dictTy deps)+        constrainedTy = quantify (foldr srcConstrainedType dictTy deps)     return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]])   go other = return (Nothing, [other]) @@ -287,7 +288,7 @@   -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) =   let className = Qualified (Just mn) name-  in ValueDecl sa ident Private [] $+  in ValueDecl sa ident Private []     [MkUnguarded (      TypedValue False (TypeClassDictionaryAccessor className ident) $        moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))@@ -361,7 +362,7 @@ declIdent _ = Nothing  typeClassMemberName :: Declaration -> Text-typeClassMemberName = fromMaybe (internalError "typeClassMemberName: Invalid declaration in type class definition") . fmap runIdent . declIdent+typeClassMemberName = maybe (internalError "typeClassMemberName: Invalid declaration in type class definition") runIdent . declIdent  superClassDictionaryNames :: [Constraint a] -> [Text] superClassDictionaryNames supers =
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs view
@@ -10,10 +10,9 @@ import           Control.Monad.Writer.Class (MonadWriter(..)) import           Control.Monad.Supply.Class (MonadSupply) import           Data.Foldable (for_)-import           Data.List (foldl', find, sortBy, unzip5)+import           Data.List (foldl', find, sortOn, unzip5) import qualified Data.Map as M import           Data.Maybe (fromMaybe)-import           Data.Ord (comparing) import qualified Data.Set as S import           Data.Text (Text) import           Language.PureScript.AST@@ -197,7 +196,7 @@     tyCon <- findTypeDecl ss tyConNm ds     go tyCon   where-    go (DataDeclaration _ Newtype _ tyArgNames [(DataConstructorDeclaration _ _ [(_, wrapped)])]) = do+    go (DataDeclaration _ Newtype _ tyArgNames [DataConstructorDeclaration _ _ [(_, wrapped)]]) = do       -- The newtype might not be applied to all type arguments.       -- This is okay as long as the newtype wraps something which ends with       -- sufficiently many type applications to variables.@@ -440,7 +439,7 @@       | Just rec <- objectType ty       , Just fields <- decomposeRec rec =           conjAll-          . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ)+          . map (\(Label str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)           $ fields       | isAppliedVar ty = preludeEq1 l r       | otherwise = preludeEq l r@@ -502,7 +501,7 @@     ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident Prelude.compare1)))      mkCtorClauses :: (DataConstructorDeclaration, Bool) -> m [CaseAlternative]-    mkCtorClauses ((DataConstructorDeclaration _ ctorName tys), isLast) = do+    mkCtorClauses (DataConstructorDeclaration _ ctorName tys, isLast) = do       identsL <- replicateM (length tys) (freshIdent "l")       identsR <- replicateM (length tys) (freshIdent "r")       tys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) tys@@ -542,7 +541,7 @@       | Just rec <- objectType ty       , Just fields <- decomposeRec rec =           appendAll-          . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ)+          . map (\(Label str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)           $ fields       | isAppliedVar ty = ordCompare1 l r       | otherwise = ordCompare l r@@ -616,13 +615,13 @@ objectType _ = Nothing  decomposeRec :: SourceType -> Maybe [(Label, SourceType)]-decomposeRec = fmap (sortBy (comparing fst)) . go+decomposeRec = fmap (sortOn fst) . go   where go (RCons _ str typ typs) = fmap ((str, typ) :) (go typs)         go (REmptyKinded _ _) = Just []         go _ = Nothing  decomposeRec' :: SourceType -> [(Label, SourceType)]-decomposeRec' = sortBy (comparing fst) . go+decomposeRec' = sortOn fst . go   where go (RCons _ str typ typs) = (str, typ) : go typs         go _ = [] @@ -686,7 +685,7 @@               buildRecord updates = do                 arg <- freshIdent "o"                 let argVar = mkVar ss arg-                    mkAssignment ((Label l), x) = (l, App x (Accessor l argVar))+                    mkAssignment (Label l, x) = (l, App x (Accessor l argVar))                 return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates)))            -- quantifiers
+ src/Language/PureScript/Sugar/TypeClasses/Instances.hs view
@@ -0,0 +1,40 @@+-- |+-- This module implements the desugaring pass which creates the compiler-generated+-- names for type class instances that do not have one defined in the source code.+--+module Language.PureScript.Sugar.TypeClasses.Instances+  ( desugarTypeClassInstanceNames+  ) where++import Prelude.Compat hiding (take)++import           Control.Monad.Error.Class (MonadError(..))+import           Control.Monad.Supply.Class+import           Data.Text (pack)+import           Language.PureScript.Errors+import           Language.PureScript.Names++-- |+-- Completes the name generation for type class instances that do not have+-- a unique name defined in source code. All `Left Text` values+-- will be converted to `Right Ident` values.+--+desugarTypeClassInstanceNames+  :: (MonadSupply m, MonadError MultipleErrors m)+  => Module+  -> m Module+desugarTypeClassInstanceNames (Module ss coms name decls exps) = do+  desugaredDecl <- parU decls desugarInstName+  pure $ Module ss coms name desugaredDecl exps++  where+  desugarInstName+    :: (MonadSupply m, MonadError MultipleErrors m)+    => Declaration+    -> m Declaration+  desugarInstName = \case+    TypeInstanceDeclaration sa chainId idx (Left genText) deps className tys bd -> do+      uniqueIdent <- fresh+      let finalName = Ident $ genText <> pack (show uniqueIdent)+      pure $ TypeInstanceDeclaration sa chainId idx (Right finalName) deps className tys bd+    a -> pure a
src/Language/PureScript/Sugar/TypeDeclarations.hs view
@@ -76,17 +76,17 @@   checkRoleDeclarations :: Maybe Declaration -> [Declaration] -> m ()   checkRoleDeclarations Nothing (RoleDeclaration RoleDeclarationData{..} : _) =     throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent-  checkRoleDeclarations (Just (RoleDeclaration (RoleDeclarationData _ name' _))) ((RoleDeclaration (RoleDeclarationData{..})) : _) | name' == rdeclIdent =+  checkRoleDeclarations (Just (RoleDeclaration (RoleDeclarationData _ name' _))) ((RoleDeclaration RoleDeclarationData{..}) : _) | name' == rdeclIdent =     throwError . errorMessage' (fst rdeclSourceAnn) $ DuplicateRoleDeclaration rdeclIdent-  checkRoleDeclarations (Just d) (rd@(RoleDeclaration (RoleDeclarationData{..})) : rest) = do+  checkRoleDeclarations (Just d) (rd@(RoleDeclaration RoleDeclarationData{..}) : rest) = do     unless (matchesDeclaration d) . throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent     unless (isSupported d) . throwError . errorMessage' (fst rdeclSourceAnn) $ UnsupportedRoleDeclaration     checkRoleDeclarationArity d     checkRoleDeclarations (Just rd) rest     where     isSupported :: Declaration -> Bool-    isSupported (DataDeclaration{}) = True-    isSupported (ExternDataDeclaration{}) = True+    isSupported DataDeclaration{} = True+    isSupported ExternDataDeclaration{} = True     isSupported _ = False     matchesDeclaration :: Declaration -> Bool     matchesDeclaration (DataDeclaration _ _ name' _ _) = rdeclIdent == name'
src/Language/PureScript/TypeChecker.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}- -- | -- The top-level type checker, which checks all declarations in a module. --@@ -12,7 +10,7 @@ import Prelude.Compat import Protolude (headMay, ordNub) -import Control.Monad (when, unless, void, forM,)+import Control.Monad (when, unless, void, forM, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply)@@ -29,6 +27,7 @@ import qualified Data.Text as T  import Language.PureScript.AST+import Language.PureScript.AST.Declarations.ChainId (ChainId) import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype import Language.PureScript.Crash@@ -61,7 +60,7 @@ addDataType moduleName dtype name args dctors ctorKind = do   env <- getEnv   let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars)-      qualName = (Qualified (Just moduleName) name)+      qualName = Qualified (Just moduleName) name       hasSig = qualName `M.member` types env   putEnv $ env { types = M.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) }   unless (hasSig || not (containsForAll ctorKind)) $ do@@ -110,7 +109,7 @@ addTypeSynonym moduleName name args ty kind = do   env <- getEnv   checkTypeSynonyms ty-  let qualName = (Qualified (Just moduleName) name)+  let qualName = Qualified (Just moduleName) name       hasSig = qualName `M.member` types env   unless (hasSig || isDictSynonym name || not (containsForAll kind)) $ do     tell . errorMessage $ MissingKindDeclaration TypeSynonymSig name kind@@ -287,12 +286,12 @@       let args'' = args' `withRoles` roles       addDataType moduleName dtype name args'' dataCtors ctorKind     return $ DataDeclaration sa dtype name args dctors-  go (d@(DataBindingGroupDeclaration tys)) = do+  go d@(DataBindingGroupDeclaration tys) = do     let tysList = NEL.toList tys         syns = mapMaybe toTypeSynonym tysList         dataDecls = mapMaybe toDataDecl tysList         clss = mapMaybe toClassDecl tysList-        bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ (fmap coerceProperName (clss^..traverse._2._2)))+        bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ fmap coerceProperName (clss^..traverse._2._2))         sss = fmap declSourceSpan tys     warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do       env <- getEnv@@ -370,7 +369,7 @@         addValue moduleName name ty nameKind         return (sai, nameKind, val)       return . BindingGroupDeclaration $ NEL.fromList vals''-  go (d@(ExternDataDeclaration _ name kind)) = do+  go d@(ExternDataDeclaration _ name kind) = do     elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind     env <- getEnv     let qualName = Qualified (Just moduleName) name@@ -378,7 +377,7 @@     let roles = fromMaybe (nominalRolesForKind elabKind) $ M.lookup qualName (roleDeclarations env)     putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) }     return d-  go (d@(ExternDeclaration (ss, _) name ty)) = do+  go d@(ExternDeclaration (ss, _) name ty) = do     warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do       env <- getEnv       (elabTy, kind) <- withFreshSubstitution $ do@@ -400,7 +399,8 @@       (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys)       addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind       return d-  go (d@(TypeInstanceDeclaration sa@(ss, _) ch idx dictName deps className tys body)) =+  go (TypeInstanceDeclaration _ _ _ (Left _) _ _ _ _) = internalError "typeCheckAll: type class instance generated name should have been desugared"+  go d@(TypeInstanceDeclaration sa@(ss, _) ch idx (Right dictName) deps className tys body) =     rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do       env <- getEnv       let qualifiedDictName = Qualified (Just moduleName) dictName@@ -413,14 +413,14 @@           checkInstanceArity dictName className typeClass tys           (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys)           tys'' <- traverse replaceAllTypeSynonyms tys'-          sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys'')+          zipWithM_ (checkTypeClassInstance typeClass) [0..] tys''           let nonOrphanModules = findNonOrphanModules className typeClass tys''           checkOrphanInstance dictName className tys'' nonOrphanModules-          let qualifiedChain = Qualified (Just moduleName) <$> ch-          checkOverlappingInstance qualifiedChain dictName className typeClass tys'' nonOrphanModules+          let chainId = Just ch+          checkOverlappingInstance chainId dictName className typeClass tys'' nonOrphanModules           _ <- traverseTypeInstanceBody checkInstanceMembers body           deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps'-          let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys'' (Just deps'')+          let dict = TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'')           addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict)           return d @@ -491,7 +491,7 @@   -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and   -- could live in different modules but won't be caught here.   checkOverlappingInstance-    :: [Qualified Ident]+    :: Maybe ChainId     -> Ident     -> Qualified (ProperName 'ClassName)     -> TypeClassData@@ -587,7 +587,7 @@   => ProperName 'TypeName   -> [DataConstructorDeclaration]   -> m ()-checkNewtype _ [(DataConstructorDeclaration _ _ [_])] = return ()+checkNewtype _ [DataConstructorDeclaration _ _ [_]] = return () checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name  -- |@@ -672,7 +672,7 @@      pure $ checkSuperClassExport superClassesFor transitiveSuperClassesFor   moduleClassExports :: S.Set (Qualified (ProperName 'ClassName))-  moduleClassExports = S.fromList $ mapMaybe (\x -> case x of+  moduleClassExports = S.fromList $ mapMaybe (\case      TypeClassRef _ name -> Just (qualify' name)      _ -> Nothing) exps
src/Language/PureScript/TypeChecker/Entailment.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-}- -- | -- Type class entailment --@@ -23,7 +21,7 @@ import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>))-import Data.List (findIndices, minimumBy, groupBy, nubBy, sortBy)+import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S@@ -167,8 +165,8 @@   where     forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict]     forClassNameM env ctx cn@C.Coercible kinds args =-      solveCoercible env ctx kinds args >>=-        pure . fromMaybe (forClassName env ctx cn kinds args)+      fromMaybe (forClassName env ctx cn kinds args) <$>+        solveCoercible env ctx kinds args     forClassNameM env ctx cn kinds args =       pure $ forClassName env ctx cn kinds args @@ -176,7 +174,7 @@     forClassName _ ctx cn@C.Warn _ [msg] =       -- Prefer a warning dictionary in scope if there is one available.       -- This allows us to defer a warning by propagating the constraint.-      findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing]+      findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing]     forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts     forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts     forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts@@ -204,11 +202,11 @@     valUndefined = Var nullSourceSpan (Qualified (Just C.Prim) (Ident C.undefined))      solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr-    solve con = go 0 hints con+    solve = go 0 hints       where         go :: Int -> [ErrorMessageHint] -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr         go work _ (Constraint _ className' _ tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'-        go work hints' con'@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do+        go work hints' con@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT . runWriterT $ do             -- We might have unified types by solving other constraints, so we need to             -- apply the latest substitution.             latestSubst <- lift . lift $ gets checkSubstitution@@ -233,7 +231,7 @@              let instances = do                   chain <- groupBy ((==) `on` tcdChain) $-                           sortBy (compare `on` (tcdChain &&& tcdIndex)) $+                           sortOn (tcdChain &&& tcdIndex)                            dicts                   -- process instances in a chain in index order                   let found = for chain $ \tcd ->@@ -265,7 +263,7 @@                 currentSubst' <- lift . lift $ gets checkSubstitution                 let subst'' = fmap (substituteType currentSubst') subst'                 -- Solve any necessary subgoals-                args <- solveSubgoals subst'' (ErrorSolvingConstraint con') (tcdDependencies tcd)+                args <- solveSubgoals subst'' (ErrorSolvingConstraint con) (tcdDependencies tcd)                  initDict <- lift . lift $ mkDictionary (tcdValue tcd) args @@ -409,13 +407,13 @@       -- We may have collected hints for the solving failure along the way, in       -- which case we decorate the error with the first one.       maybe id addHint (listToMaybe hints') `rethrow` case inertWanteds of-        [] -> pure $ Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing]+        [] -> pure $ Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing]         (k, a', b') : _ | a' == b && b' == a -> throwError $ insoluble k b' a'         (k, a', b') : _ -> throwError $ insoluble k a' b'     solveCoercible _ _ _ _ = pure Nothing      solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict]-    solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing]+    solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope Nothing 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing]     solveIsSymbol _ = Nothing      solveSymbolCompare :: [SourceType] -> Maybe [TypeClassDict]@@ -425,14 +423,14 @@                   EQ -> C.orderingEQ                   GT -> C.orderingGT           args' = [arg0, arg1, srcTypeConstructor ordering]-      in Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing]+      in Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing]     solveSymbolCompare _ = Nothing      solveSymbolAppend :: [SourceType] -> Maybe [TypeClassDict]     solveSymbolAppend [arg0, arg1, arg2] = do       (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2       let args' = [arg0', arg1', arg2']-      pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing]+      pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing]     solveSymbolAppend _ = Nothing      -- | Append type level symbols, or, run backwards, strip a prefix or suffix@@ -454,7 +452,7 @@     solveSymbolCons [arg0, arg1, arg2] = do       (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2       let args' = [arg0', arg1', arg2']-      pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCons [] [] args' Nothing]+      pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCons [] [] args' Nothing]     solveSymbolCons _ = Nothing      consSymbol :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType)@@ -472,7 +470,7 @@     solveUnion :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict]     solveUnion kinds [l, r, u] = do       (lOut, rOut, uOut, cst, vars) <- unionRows kinds l r u-      pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst ]+      pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst ]     solveUnion _ _ = Nothing      -- | Left biased union of two row types@@ -503,13 +501,13 @@      solveRowCons :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict]     solveRowCons kinds [TypeLevelString ann sym, ty, r, _] =-      Just [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ]+      Just [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ]     solveRowCons _ _ = Nothing      solveRowToList :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict]     solveRowToList [kind] [r, _] = do       entries <- rowToRowList kind r-      pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing ]+      pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing ]     solveRowToList _ _ = Nothing      -- | Convert a closed row to a sorted list of entries@@ -528,7 +526,7 @@     solveNub :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict]     solveNub kinds [r, _] = do       r' <- nubRows r-      pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowNub [] kinds [r, r'] Nothing ]+      pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowNub [] kinds [r, r'] Nothing ]     solveNub _ _ = Nothing      nubRows :: SourceType -> Maybe SourceType@@ -540,10 +538,10 @@      solveLacks :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict]     solveLacks kinds tys@[_, REmptyKinded _ _] =-      pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [] kinds tys Nothing ]+      pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds tys Nothing ]     solveLacks kinds [TypeLevelString ann sym, r] = do       (r', cst) <- rowLacks kinds sym r-      pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [] kinds [TypeLevelString ann sym, r'] cst ]+      pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds [TypeLevelString ann sym, r'] cst ]     solveLacks _ _ = Nothing      rowLacks :: [SourceType] -> PSString -> SourceType -> Maybe (SourceType, Maybe [SourceConstraint])@@ -553,7 +551,7 @@         (fixed, rest) = rowToList r          lacksSym =-          not $ sym `elem` (runLabel . rowListLabel <$> fixed)+          sym `notElem` (runLabel . rowListLabel <$> fixed)          (canMakeProgress, cst) = case rest of             REmptyKinded _ _ -> (True, Nothing)@@ -700,7 +698,7 @@                                                         (replaceAllTypeVars sub <$> supArgs)                                                         Nothing)                                   ) typeClassSuperclasses [0..]-    return (TypeClassDictionaryInScope [] 0 name path className [] instanceKinds instanceTy Nothing : supDicts)+    return (TypeClassDictionaryInScope Nothing 0 name path className [] instanceKinds instanceTy Nothing : supDicts)  mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where
src/Language/PureScript/TypeChecker/Entailment/Coercible.hs view
@@ -17,7 +17,7 @@  import Control.Applicative ((<|>), empty) import Control.Arrow ((&&&))-import Control.Monad ((<=<), guard, when)+import Control.Monad ((<=<), guard, unless, when) import Control.Monad.Error.Class (MonadError, catchError, throwError) import Control.Monad.State (MonadState, StateT, get, gets, modify, put) import Control.Monad.Trans.Class (lift)@@ -640,7 +640,7 @@         -- to canonicalize them yet and we'd rather try to make progress with         -- another rule.         , isMonoType wrappedTy -> do-            when (not inScope) $ do+            unless inScope $ do               tell [MissingConstructorImportForCoercible newtypeCtorName]               throwError CannotUnwrapConstructor             for_ fromModuleName $ flip addConstructorImportForCoercible newtypeCtorName
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -39,10 +39,9 @@ import Data.Function (on) import Data.Functor (($>)) import qualified Data.IntSet as IS-import Data.List (nubBy, sortBy, (\\))+import Data.List (nubBy, sortOn, (\\)) import qualified Data.Map as M-import Data.Maybe (fromJust)-import Data.Ord (comparing)+import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (for)@@ -147,7 +146,7 @@   :: forall m. (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack)   => [Unknown]   -> m [(Unknown, SourceType)]-unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortBy (comparing fst) . join) . traverse go+unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) . traverse go   where   go u = do     (lvl, ty) <- traverse apply =<< lookupUnsolved u@@ -191,7 +190,7 @@       kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName v)       pure (ty, kind $> ann)     ty@(Skolem ann _ mbK _ _) -> do-      kind <- apply $ maybe (internalError "Skolem has no kind") id mbK+      kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK       pure (ty, kind $> ann)     ty@(TUnknown ann u) -> do       kind <- apply . snd =<< lookupUnsolved u@@ -218,7 +217,7 @@           t2' <- checkKind t2 argKind           pure (KindApp ann t1' t2', replaceTypeVars arg t2' resKind)         _ ->-          internalError $ "inferKind: unkinded forall binder"+          internalError "inferKind: unkinded forall binder"     KindedType _ t1 t2 -> do       t2' <- replaceAllTypeSynonyms . fst =<< go t2       t1' <- checkKind t1 t2'@@ -499,7 +498,7 @@     kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName a)     pure (kind $> ann)   (Skolem ann _ mbK _ _) -> do-    kind <- apply $ maybe (internalError "Skolem has no kind") id mbK+    kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK     pure $ kind $> ann   TUnknown ann a' -> do     kind <- snd <$> lookupUnsolved a'@@ -618,8 +617,8 @@           tyCtor = foldl (\ty -> srcKindApp ty . srcTypeVar . fst . snd) tyCtorName sigBinders           tyCtor' = foldl (\ty -> srcTypeApp ty . srcTypeVar . fst) tyCtor tyArgs'           ctorBinders = fmap (fmap (fmap Just)) $ sigBinders <> fmap (nullSourceAnn,) tyArgs'-      for ctors $ \ctor ->-        fmap (mkForAll ctorBinders) <$> inferDataConstructor tyCtor' ctor+      for ctors $+        fmap (fmap (mkForAll ctorBinders)) . inferDataConstructor tyCtor'  inferDataConstructor   :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)@@ -679,8 +678,8 @@   :: forall m. (MonadError MultipleErrors m)   => SourceType   -> m ()-checkQuantification ty =-  collectErrors . go [] [] . fst . fromJust . completeBinderList $ ty+checkQuantification =+  collectErrors . go [] [] . fst . fromJust . completeBinderList   where   collectErrors vars =     unless (null vars)@@ -690,7 +689,7 @@    go acc _ [] = reverse acc   go acc sco ((_, (arg, k)) : rest)-    | any (not . flip elem sco) $ freeTypeVariables k = goDeps acc arg rest+    | not . all (flip elem sco) $ freeTypeVariables k = goDeps acc arg rest     | otherwise = go acc (arg : sco) rest    goDeps acc _ [] = acc@@ -919,8 +918,8 @@   -> [ClassDeclarationArgs]   -> m ([TypeDeclarationResult], [DataDeclarationResult], [ClassDeclarationResult]) kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do-  synDict <- for syns $ \(sa, synName, _, _) -> fmap (synName,) $ existingSignatureOrFreshKind moduleName (fst sa) synName-  datDict <- for dats $ \(sa, datName, _, _) -> fmap (datName,) $ existingSignatureOrFreshKind moduleName (fst sa) datName+  synDict <- for syns $ \(sa, synName, _, _) -> (synName,) <$> existingSignatureOrFreshKind moduleName (fst sa) synName+  datDict <- for dats $ \(sa, datName, _, _) -> (datName,) <$> existingSignatureOrFreshKind moduleName (fst sa) datName   clsDict <- for clss $ \(sa, clsName, _, _, _) -> fmap (coerceProperName clsName,) $ existingSignatureOrFreshKind moduleName (fst sa) $ coerceProperName clsName   let bindingGroup = synDict <> datDict <> clsDict   bindLocalTypeVariables moduleName bindingGroup $ do
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}  -- |@@ -13,7 +12,6 @@ import Control.Monad.State import Control.Monad.Writer.Class (MonadWriter(..), censor) -import Data.List (intercalate) import Data.Maybe import qualified Data.Map as M import qualified Data.Set as S@@ -197,14 +195,14 @@ getTypeClassDictionaries   :: (MonadState CheckState m)   => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))-getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get+getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv  -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries   :: (MonadState CheckState m)   => Maybe ModuleName   -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))-lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get+lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv  -- | Lookup type class dictionaries in a module. lookupTypeClassDictionariesForClass@@ -296,7 +294,7 @@  -- | Get the current @Environment@ getEnv :: (MonadState CheckState m) => m Environment-getEnv = checkEnv <$> get+getEnv = gets checkEnv  -- | Get locally-bound names in context, to create an error message. getLocalContext :: MonadState CheckState m => m Context@@ -363,7 +361,7 @@   :: forall m    . (MonadError MultipleErrors m, MonadState CheckState m)   => m ModuleName-unsafeCheckCurrentModule = checkCurrentModule <$> get >>= \case+unsafeCheckCurrentModule = gets checkCurrentModule >>= \case   Nothing -> internalError "No module name set in scope"   Just name -> pure name @@ -397,7 +395,7 @@         ExternData _      -> "extern"         LocalTypeVariable -> "local"         ScopedTypeVar     -> "scoped"-    guard (not (isPrefixOf "Prim" name))+    guard (not ("Prim" `isPrefixOf` name))     pure $ decl <> " " <> unpack name <> " :: " <> init ppTy  debugNames :: Environment -> [String]@@ -423,7 +421,7 @@   where   go (qual, (binders, subTy)) = do     let-      vars = intercalate " " $ flip fmap binders $ \case+      vars = unwords $ flip fmap binders $ \case                (v, Just k) -> "(" <> unpack v <> " :: " <> init (prettyPrintType 100 k) <> ")"                (v, Nothing) -> unpack v       ppTy = prettyPrintType 100 subTy@@ -441,8 +439,8 @@       moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") mbModuleName       className' = showQualified runProperName className       ident' = showQualified runIdent ident-      kds = intercalate " " $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts-      tys = intercalate " " $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts+      kds = unwords $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts+      tys = unwords $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts     pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys  debugTypeClasses :: Environment -> [String]@@ -451,7 +449,7 @@   go (className, tc) = do     let       className' = showQualified runProperName className-      args = intercalate " " $ fmap (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") $ typeClassArguments tc+      args = unwords $ (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") <$> typeClassArguments tc     "class " <> unpack className' <> " " <> args  debugValue :: Expr -> String
src/Language/PureScript/TypeChecker/Roles.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-}  -- |
src/Language/PureScript/TypeChecker/Subsumption.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}  -- | Subsumption checking module Language.PureScript.TypeChecker.Subsumption
src/Language/PureScript/TypeChecker/TypeSearch.hs view
@@ -36,7 +36,7 @@   . TC.runCheck' (st { TC.checkEnv = env })  evalWriterT :: Monad m => WriterT b m r -> m r-evalWriterT m = liftM fst (runWriterT m)+evalWriterT m = fmap fst (runWriterT m)  checkSubsume   :: Maybe [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)]
src/Language/PureScript/TypeChecker/Types.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-}- -- | -- This module implements the type checker --@@ -159,7 +157,7 @@         let constraintTypeVars = fold (conData >>= snd)         let solved = solveFrom determinedFromType         let unsolvedVars = S.difference constraintTypeVars solved-        when (not (S.null unsolvedVars)) .+        unless (S.null unsolvedVars) .           throwError             . onErrorMessages (replaceTypes currentSubst)             . errorMessage' ss@@ -174,7 +172,7 @@     finalState <- get     let replaceTypes' = replaceTypes (checkSubstitution finalState)         runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState-        raisePreviousWarnings gen = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes'))+        raisePreviousWarnings gen = escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')      raisePreviousWarnings False wInfer     forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) ->@@ -466,7 +464,7 @@   -> Expr   -> (Expr -> m TypedValue')   -> m ([Declaration], TypedValue')-inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)+inferLetBinding seen [] ret j = (seen, ) <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do   moduleName <- unsafeCheckCurrentModule   TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do
src/Language/PureScript/TypeChecker/Unify.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}- -- | -- Functions and instances relating to unification --
src/System/IO/UTF8.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TupleSections #-}- module System.IO.UTF8 where  import Prelude.Compat
stack.yaml view
@@ -2,13 +2,18 @@ pvp-bounds: both packages: - '.'-- lib/purescript-ast - lib/purescript-cst ghc-options:   # Build with advanced optimizations enabled by default   "$locals": -O2 -Werror extra-deps: - language-javascript-0.7.0.0+- git: https://github.com/hspec/hspec.git+  commit: 8f628c861d01ec8fc0a94ffdfe31e4399bd049d1+  subdirs:+    - .+    - hspec-core+    - hspec-discover nix:   enable: false   packages:@@ -22,3 +27,6 @@     lib-only: true   these:     assoc: false+  haskeline:+    # Avoids a libtinfo dynamic library dependency+    terminfo: false
tests/Language/PureScript/Ide/CompletionSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.CompletionSpec where  import Protolude@@ -47,49 +45,49 @@       reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])]    it "gets simple docs on definition itself" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpecDocs"]                   , typ "something"                   ]     result `shouldSatisfy` \res -> complDocumentation res == Just "Doc x\n"    it "gets multiline docs" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpecDocs"]                   , typ "multiline"                   ]     result `shouldSatisfy` \res -> complDocumentation res == Just "This is\na multi-line\ncomment\n"    it "gets simple docs on type annotation" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpecDocs"]                   , typ "withType"                   ]     result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n"    it "gets docs on module declaration" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpecDocs"]                   , typ "CompletionSpecDocs"                   ]     result `shouldSatisfy` \res -> complDocumentation res == Just "Module Documentation\n"    it "gets docs on type class declaration" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpecDocs"]                   , typ "DocClass"                   ]     result `shouldSatisfy` \res -> complDocumentation res == Just "Doc for class\n"    it "gets docs on type class members" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpecDocs"]                   , typ "member"                   ]     result `shouldSatisfy` \res -> complDocumentation res == Just "doc for member\n"    it "includes declarationType in completions for values" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpec"]                   , typ "exampleValue"                   ]@@ -97,7 +95,7 @@       complDeclarationType res == Just DeclarationType.Value    it "includes declarationType in completions for functions" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpec"]                   , typ "exampleFunction"                   ]@@ -105,7 +103,7 @@       complDeclarationType res == Just DeclarationType.Value    it "includes declarationType in completions for inferred values" $ do-    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpec"]                   , typ "exampleInferredString"                   ]@@ -113,7 +111,7 @@       complDeclarationType res == Just DeclarationType.Value    it "includes declarationType in completions for operators" $ do-    ([_, (Right (CompletionResult results))], _) <- Test.inProject $+    ([_, Right (CompletionResult results)], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpec"]                   , typ "\\°/"                   ]@@ -125,7 +123,7 @@    it "includes declarationType in completions for type constructors with \       \conflicting names" $ do-    ([_, (Right (CompletionResult results))], _) <- Test.inProject $+    ([_, Right (CompletionResult results)], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpec"]                   , typ "ExampleTypeConstructor"                   ]@@ -136,7 +134,7 @@         complDeclarationType res == Just DeclarationType.Type)    it "includes declarationType in completions for type classes" $ do-    ([_, (Right (CompletionResult [result]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [result])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpec"]                   , typ "ExampleClass"                   ]@@ -144,7 +142,7 @@       complDeclarationType res == Just DeclarationType.TypeClass    it "includes declarationType in completions for type class members" $ do-    ([_, (Right (CompletionResult [result]))], _) <- Test.inProject $+    ([_, Right (CompletionResult [result])], _) <- Test.inProject $       Test.runIde [ load ["CompletionSpec"]                   , typ "exampleMember"                   ]
tests/Language/PureScript/Ide/FilterSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.FilterSpec where  import           Protolude
tests/Language/PureScript/Ide/ImportsSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ImportsSpec where  import           Protolude hiding (moduleName)@@ -288,7 +286,7 @@   describe "explicit import sorting" $ do     -- given some basic import skeleton     let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"]-        moduleName = (P.moduleNameFromString "Control.Monad")+        moduleName = P.moduleNameFromString "Control.Monad"         addImport imports import' = addExplicitImport' import' moduleName Nothing imports         valueImport ident = _idaDeclaration (Test.ideValue ident Nothing)         typeImport name = _idaDeclaration (Test.ideType name Nothing [])@@ -308,11 +306,11 @@         ["import Prelude", "", "import Control.Monad (ap, unless, where)"]     it "sorts type, value" $       expectSorted-        ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]))+        (map valueImport ["unless", "where"] ++ map typeImport ["Foo", "Bar"])         ["import Prelude", "", "import Control.Monad (Bar, Foo, ap, unless, where)"]     it "sorts class, type, value" $       expectSorted-        ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"]))+        (map valueImport ["unless", "where"] ++ map typeImport ["Foo", "Bar"] ++ map classImport ["Applicative", "Bind"])         ["import Prelude", "", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"]     it "sorts types with constructors, using open imports for the constructors" $       expectSorted
tests/Language/PureScript/Ide/MatcherSpec.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}- module Language.PureScript.Ide.MatcherSpec where  import           Protolude
tests/Language/PureScript/Ide/RebuildSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.RebuildSpec where  import           Protolude@@ -63,12 +61,12 @@         Test.runIde [ rebuild "RebuildSpecWithMissingForeign.fail" ]       result `shouldSatisfy` isLeft     it "completes a hidden identifier after rebuilding" $ do-      ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+      ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $         Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs"                     , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions]       complIdentifier result `shouldBe` "hidden"     it "uses the specified `actualFile` for location information" $ do-      ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $+      ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $         Test.runIde'           Test.defConfig           emptyIdeState
tests/Language/PureScript/Ide/ReexportsSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ReexportsSpec where  import           Protolude
tests/Language/PureScript/Ide/SourceFileSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.SourceFileSpec where  import           Protolude@@ -80,7 +78,7 @@       r `shouldBe` synonymSS     it "finds a data declaration and its constructors" $ do       rs <- traverse getLocation ["SFData", "SFOne", "SFTwo", "SFThree"]-      traverse_ (`shouldBe` (Just typeSS)) rs+      traverse_ (`shouldBe` Just typeSS) rs     it "finds a class declaration" $ do       Just r <- getLocation "SFClass"       r `shouldBe` classSS
tests/Language/PureScript/Ide/StateSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.StateSpec where  import           Protolude@@ -67,7 +65,7 @@       -- , edInstanceConstraints =       mempty       -- , edInstanceChain =-      mempty+      Nothing       -- , edInstanceChainIndex =       0  --     }
tests/Language/PureScript/Ide/Test.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports    #-}-{-# LANGUAGE DataKinds         #-} module Language.PureScript.Ide.Test where  import           Control.Concurrent.STM@@ -85,7 +82,7 @@        (IdeValueOperator         (P.OpName opName)         (bimap P.Ident P.ProperName <$> ident)-        (precedence)+        precedence         (fromMaybe P.Infix assoc)         t)) @@ -95,7 +92,7 @@        (IdeTypeOperator         (P.OpName opName)         (P.ProperName <$> ident)-        (precedence)+        precedence         (fromMaybe P.Infix assoc)         k)) @@ -137,9 +134,9 @@ compileTestProject :: IO Bool compileTestProject = inProject $ do   (_, _, _, procHandle) <--    createProcess $ (shell $ "purs compile \"src/**/*.purs\"")+    createProcess $ shell "purs compile \"src/**/*.purs\""   r <- tryNTimes 10 (getProcessExitCode procHandle)-  pure (fromMaybe False (isSuccess <$> r))+  pure (maybe False isSuccess r)  isSuccess :: ExitCode -> Bool isSuccess ExitSuccess = True
tests/Language/PureScript/Ide/UsageSpec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.UsageSpec where  import           Protolude@@ -17,7 +15,7 @@ load = LoadSync . map Test.mn  usage :: P.ModuleName -> Text -> IdeNamespace -> Command-usage mn ident ns = FindUsages mn ident ns+usage = FindUsages  shouldBeUsage :: P.SourceSpan -> (FilePath, Text) -> Expectation shouldBeUsage usage' (fp, range) =
tests/Main.hs view
@@ -1,17 +1,15 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}  module Main (main) where  import Prelude () import Prelude.Compat -import Test.Tasty+import Test.Hspec  import qualified TestCompiler import qualified TestCoreFn+import qualified TestCst import qualified TestDocs import qualified TestHierarchy import qualified TestPrimDocs@@ -30,41 +28,19 @@   hSetEncoding stdout utf8   hSetEncoding stderr utf8 -  heading "Updating support code"   TestUtils.updateSupportCode -  ideTests <- TestIde.main-  compilerTests <- TestCompiler.main-  makeTests <- TestMake.main-  psciTests <- TestPsci.main-  pscBundleTests <- TestBundle.main-  coreFnTests <- TestCoreFn.main-  docsTests <- TestDocs.main-  primDocsTests <- TestPrimDocs.main-  publishTests <- TestPscPublish.main-  hierarchyTests <- TestHierarchy.main-  graphTests <- TestGraph.main--  defaultMain $-    testGroup-      "Tests"-      [ compilerTests-      , makeTests-      , psciTests-      , pscBundleTests-      , ideTests-      , coreFnTests-      , docsTests-      , primDocsTests-      , publishTests-      , hierarchyTests-      , graphTests-      ]--  where-  heading msg = do-    putStrLn ""-    putStrLn $ replicate 79 '#'-    putStrLn $ "# " ++ msg-    putStrLn $ replicate 79 '#'-    putStrLn ""+  hspec $ do+    describe "cst" TestCst.spec+    describe "ide" TestIde.spec+    beforeAll TestUtils.setupSupportModules $ do+      describe "compiler" TestCompiler.spec+      describe "bundle" TestBundle.spec+    describe "make" TestMake.spec+    describe "psci" TestPsci.spec+    describe "corefn" TestCoreFn.spec+    describe "docs" TestDocs.spec+    describe "prim-docs" TestPrimDocs.spec+    describe "publish" TestPscPublish.spec+    describe "hierarchy" TestHierarchy.spec+    describe "graph" TestGraph.spec
tests/TestBundle.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}  module TestBundle where @@ -10,13 +6,11 @@ import Prelude.Compat  import qualified Language.PureScript as P-import Language.PureScript.Bundle +import Language.PureScript.Bundle  import Data.Function (on) import Data.List (minimumBy) -import qualified Data.Map as M- import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except@@ -29,24 +23,18 @@ import qualified System.FilePath.Glob as Glob  import TestUtils-import Test.Tasty-import Test.Tasty.Hspec--main :: IO TestTree-main = testSpec "bundle" spec--spec :: Spec-spec = do-  (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules-  bundleTestCases <- runIO $ getTestFiles "bundle"-  outputFile <- runIO $ createOutputFile logfile +import Test.Hspec +spec :: SpecWith SupportModules+spec =   context "Bundle examples" $-    forM_ bundleTestCases $ \testPurs -> do-      it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $-        assertBundles supportModules supportExterns supportForeigns testPurs outputFile+    beforeAllWith ((<$> createOutputFile logfile) . (,)) $ do+      bundleTestCases <- runIO $ getTestFiles "bundle"+      forM_ bundleTestCases $ \testPurs -> do+        it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $ \(support, outputFile) ->+          assertBundles support testPurs outputFile   where-  +   -- Takes the test entry point from a group of purs files - this is determined   -- by the file with the shortest path name, as everything but the main file   -- will be under a subdirectory.@@ -54,42 +42,38 @@   getTestMain = minimumBy (compare `on` length)  assertBundles-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath+  :: SupportModules   -> [FilePath]   -> Handle   -> Expectation-assertBundles supportModules supportExterns supportForeigns inputFiles outputFile =-  assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e ->-    case e of-      Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs-      Right _ -> do-        process <- findNodeProcess-        jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir-        let entryPoint = modulesDir </> "index.js"-        let entryModule = map (`ModuleIdentifier` Regular) ["Main"] -        bundled <- runExceptT $ do-          input <- forM jsFiles $ \filename -> do-            js <- liftIO $ readUTF8File filename-            mid <- guessModuleIdentifier filename-            length js `seq` return (mid, Just filename, js) -          bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) Nothing-        case bundled of-            Right (_, js) -> do-              writeUTF8File entryPoint js-              result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process-              hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"-              case result of-                Just (ExitSuccess, out, err)-                 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err-                 | not (null out) && trim (last (lines out)) == "Done" -> do-                     hPutStr outputFile out-                     return Nothing-                 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out-                Just (ExitFailure _, _, err) -> return $ Just err-                Nothing -> return $ Just "Couldn't find node.js executable"-            Left err -> return . Just $ "Coud not bundle: " ++ show err+assertBundles support inputFiles outputFile = do+  (result, _) <- compile support inputFiles+  case result of+    Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs+    Right _ -> do+      process <- findNodeProcess+      jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir+      let entryPoint = modulesDir </> "index.js"+      let entryModule = map (`ModuleIdentifier` Regular) ["Main"]+      bundled <- runExceptT $ do+        input <- forM jsFiles $ \filename -> do+          js <- liftIO $ readUTF8File filename+          mid <- guessModuleIdentifier filename+          length js `seq` return (mid, Just filename, js)+        bundleSM input entryModule (Just "Main") "PS" (Just entryPoint) Nothing+      case bundled of+          Right (_, js) -> do+            writeUTF8File entryPoint js+            nodeResult <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process+            hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"+            case nodeResult of+              Just (ExitSuccess, out, err)+               | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err+               | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out+               | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out+              Just (ExitFailure _, _, err) -> expectationFailure err+              Nothing -> expectationFailure "Couldn't find node.js executable"+          Left err -> expectationFailure $ "Could not bundle: " ++ show err  logfile :: FilePath logfile = "bundle-tests.out"
tests/TestCompiler.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}  module TestCompiler where @@ -21,9 +17,10 @@ --   -- @shouldFailWith TypesDoNotUnify --   -- @shouldFailWith TransitiveExportError ----- Failing tests also check their output against the relative golden files (`.out`).--- The golden files are generated automatically when missing, and can be updated--- by passing `--accept` to `--test-arguments.`+-- Warning and failing tests also check their output against the relative+-- golden files (`.out`). The golden files are generated automatically when+-- missing, and can be updated by setting the "HSPEC_ACCEPT" environment+-- variable, e.g. by running `HSPEC_ACCEPT=true stack test`.  import Prelude () import Prelude.Compat@@ -32,15 +29,12 @@  import Control.Arrow ((>>>)) import Data.Function (on)-import Data.List (sort, stripPrefix, intercalate, minimumBy)+import Data.List (sort, stripPrefix, minimumBy) import Data.Maybe (mapMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Map as M -import qualified Data.ByteString.Lazy as BS- import Control.Monad  import System.Exit@@ -53,95 +47,68 @@ import Text.Regex.TDFA (Regex)  import TestUtils-import Test.Tasty-import Test.Tasty.Hspec-import Test.Tasty.Golden (goldenVsString)+import Test.Hspec -main :: IO TestTree-main = do-  (supportModules, supportExterns, supportForeigns) <- setupSupportModules-  passing <- passingTests supportModules supportExterns supportForeigns-  warning <- warningTests supportModules supportExterns supportForeigns-  failing <- failingTests supportModules supportExterns supportForeigns-  return . testGroup "compiler" $ [passing, warning, failing]+spec :: SpecWith SupportModules+spec = do+  passingTests+  warningTests+  failingTests -passingTests-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath-  -> IO TestTree-passingTests supportModules supportExterns supportForeigns = do-  passingTestCases <- getTestFiles "passing"+passingTests :: SpecWith SupportModules+passingTests = do+  passingTestCases <- runIO $ getTestFiles "passing" -  outputFile <- createOutputFile logfile+  describe "Passing examples" $+    beforeAllWith ((<$> createOutputFile logfile) . (,)) $+      forM_ passingTestCases $ \testPurs ->+        it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ \(support, outputFile) ->+          assertCompiles support testPurs outputFile -  testSpec "Passing examples" $-    forM_ passingTestCases $ \testPurs ->-      it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $-        assertCompiles supportModules supportExterns supportForeigns testPurs outputFile+warningTests :: SpecWith SupportModules+warningTests = do+  warningTestCases <- runIO $ getTestFiles "warning" -warningTests-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath-  -> IO TestTree-warningTests supportModules supportExterns supportForeigns = do-  warningTestCases <- getTestFiles "warning"-  tests <- forM warningTestCases $ \testPurs -> do-    let mainPath = getTestMain testPurs-    expectedWarnings <- getShouldWarnWith mainPath-    wTc <- testSpecs $-      it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $-        assertCompilesWithWarnings supportModules supportExterns supportForeigns testPurs expectedWarnings-    return $ wTc ++ [ goldenVsString-                      ("'" <> takeFileName mainPath <> "' golden test")-                      (replaceExtension mainPath ".out")-                      (BS.fromStrict . T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs)-                    ]-  return $ testGroup "Warning examples" $ concat tests+  describe "Warning examples" $+    forM_ warningTestCases $ \testPurs -> do+      let mainPath = getTestMain testPurs+      it ("'" <> takeFileName mainPath <> "' should compile with expected warning(s)") $ \support -> do+        expectedWarnings <- getShouldWarnWith mainPath+        assertCompilesWithWarnings support testPurs expectedWarnings -failingTests-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath-  -> IO TestTree-failingTests supportModules supportExterns supportForeigns = do-  failingTestCases <- getTestFiles "failing"-  tests <- forM failingTestCases $ \testPurs -> do-    let mainPath = getTestMain testPurs-    expectedFailures <- getShouldFailWith mainPath-    fTc <- testSpecs $-      it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $-        assertDoesNotCompile supportModules supportExterns supportForeigns testPurs expectedFailures-    return $ fTc ++ [ goldenVsString-                    ("'" <> takeFileName mainPath <> "' golden test")-                    (replaceExtension mainPath ".out")-                    (BS.fromStrict . T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs)-                  ]-  return $ testGroup "Failing examples" $ concat tests+failingTests :: SpecWith SupportModules+failingTests = do+  failingTestCases <- runIO $ getTestFiles "failing" -checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Maybe String+  describe "Failing examples" $ do+    forM_ failingTestCases $ \testPurs -> do+      let mainPath = getTestMain testPurs+      it ("'" <> takeFileName mainPath <> "' should fail to compile") $ \support -> do+        expectedFailures <- getShouldFailWith mainPath+        assertDoesNotCompile support testPurs expectedFailures++checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Expectation checkShouldReport expected prettyPrintDiagnostics errs =   let actual = map P.errorCode $ P.runMultipleErrors errs   in if sort expected == sort (map T.unpack actual)     then checkPositioned errs-    else Just $ "Expected these diagnostics: " ++ show expected ++ ", but got these: "+    else expectationFailure $ "Expected these diagnostics: " ++ show expected ++ ", but got these: "       ++ show actual ++ ", full diagnostic messages: \n"       ++ prettyPrintDiagnostics errs -checkPositioned :: P.MultipleErrors -> Maybe String+checkPositioned :: P.MultipleErrors -> Expectation checkPositioned errs =   case mapMaybe guardSpans (P.runMultipleErrors errs) of     [] ->-      Nothing+      pure ()     errs' ->-      Just+      expectationFailure         $ "Found diagnostics with missing source spans:\n"         ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) errs')   where   guardSpans :: P.ErrorMessage -> Maybe P.ErrorMessage   guardSpans err = case P.errorSpan err of-    Just ss | any (not . isNonsenseSpan) ss -> Nothing+    Just ss | not $ all isNonsenseSpan ss -> Nothing     _ -> Just err    isNonsenseSpan :: P.SourceSpan -> Bool@@ -152,85 +119,75 @@   emptyPos = P.SourcePos 0 0  assertCompiles-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath+  :: SupportModules   -> [FilePath]   -> Handle   -> Expectation-assertCompiles supportModules supportExterns supportForeigns inputFiles outputFile =-  assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e ->-    case e of-      Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs-      Right _ -> do-        process <- findNodeProcess-        let entryPoint = modulesDir </> "index.js"-        writeFile entryPoint "require('Main').main()"-        result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process-        hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"-        case result of-          Just (ExitSuccess, out, err)-            | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err-            | not (null out) && trim (last (lines out)) == "Done" -> do-                hPutStr outputFile out-                return Nothing-            | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out-          Just (ExitFailure _, _, err) -> return $ Just err-          Nothing -> return $ Just "Couldn't find node.js executable"+assertCompiles support inputFiles outputFile = do+  (result, _) <- compile support inputFiles+  case result of+    Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs+    Right _ -> do+      process <- findNodeProcess+      let entryPoint = modulesDir </> "index.js"+      writeFile entryPoint "require('Main').main()"+      nodeResult <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process+      hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"+      case nodeResult of+        Just (ExitSuccess, out, err)+          | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err+          | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out+          | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out+        Just (ExitFailure _, _, err) -> expectationFailure err+        Nothing -> expectationFailure "Couldn't find node.js executable"  assertCompilesWithWarnings-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath+  :: SupportModules   -> [FilePath]   -> [String]   -> Expectation-assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFiles shouldWarnWith =-  assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e ->-    case e of-      Left errs ->-        return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs-      Right warnings ->-        return $ checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings P.defaultPPEOptions) warnings+assertCompilesWithWarnings support inputFiles shouldWarnWith = do+  result'@(result, warnings) <- compile support inputFiles+  case result of+    Left errs ->+      expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs+    Right _ -> do+      checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings P.defaultPPEOptions) warnings+      goldenVsString+        (replaceExtension (getTestMain inputFiles) ".out")+        (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result')  assertDoesNotCompile-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath+  :: SupportModules   -> [FilePath]   -> [String]   -> Expectation-assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles shouldFailWith =-  assert supportModules supportExterns supportForeigns inputFiles noPreCheck $ \e ->-    case e of-      Left errs ->-        return $ if null shouldFailWith-          then Just $ "shouldFailWith declaration is missing (errors were: "-                      ++ show (map P.errorCode (P.runMultipleErrors errs))-                      ++ ")"-          else checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors P.defaultPPEOptions) errs-      Right _ ->-        return $ Just "Should not have compiled"--  where-  noPreCheck = const (return ())+assertDoesNotCompile support inputFiles shouldFailWith = do+  result <- compile support inputFiles+  case fst result of+    Left errs -> do+      when (null shouldFailWith)+        (expectationFailure $+          "shouldFailWith declaration is missing (errors were: "+          ++ show (map P.errorCode (P.runMultipleErrors errs))+          ++ ")")+      checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors P.defaultPPEOptions) errs+      goldenVsString+        (replaceExtension (getTestMain inputFiles) ".out")+        (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result)+    Right _ ->+      expectationFailure "Should not have compiled" -printErrorOrWarning-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath-  -> [FilePath]-  -> IO String-printErrorOrWarning supportModules supportExterns supportForeigns inputFiles = do-  -- Sorting the input files makes some messages (e.g., duplicate module) deterministic-  (res, warnings) <- compile supportModules supportExterns supportForeigns (sort inputFiles) noPreCheck-  return . normalizePaths $ case res of+-- Prints a set of diagnostics (i.e. errors or warnings) as a string, in order+-- to compare it to the contents of a golden test file.+printDiagnosticsForGoldenTest :: (Either P.MultipleErrors a, P.MultipleErrors) -> String+printDiagnosticsForGoldenTest (result, warnings) =+  normalizePaths $ case result of     Left errs ->+      -- TODO: should probably include warnings when failing?       P.prettyPrintMultipleErrors P.defaultPPEOptions errs     Right _ ->       P.prettyPrintMultipleWarnings P.defaultPPEOptions warnings-  where-    noPreCheck = const (return ())  -- Replaces Windows-style paths in an error or warning with POSIX paths normalizePaths :: String -> String
tests/TestCoreFn.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-} -module TestCoreFn (main) where+module TestCoreFn (spec) where  import Prelude () import Prelude.Compat@@ -22,11 +19,7 @@ import Language.PureScript.Names import Language.PureScript.PSString -import Test.Tasty-import Test.Tasty.Hspec--main :: IO TestTree-main = testSpec "corefn" spec+import Test.Hspec  parseModule :: Value -> Result (Version, Module Ann) parseModule = parse moduleFromJSON@@ -42,7 +35,7 @@ isSuccess _           = False  spec :: Spec-spec = context "CoreFnFromJsonTest" $ do+spec = context "CoreFnFromJson" $ do   let mn = ModuleName "Example.Main"       mp = "src/Example/Main.purs"       ss = SourceSpan mp (SourcePos 0 0) (SourcePos 0 0)
+ tests/TestCst.hs view
@@ -0,0 +1,222 @@+module TestCst where++import Prelude++import Control.Monad (when, forM_)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.IO as Text+import Test.Hspec+import Test.QuickCheck+import TestUtils+import Text.Read (readMaybe)+import Language.PureScript.CST.Errors as CST+import Language.PureScript.CST.Lexer as CST+import Language.PureScript.CST.Print as CST+import Language.PureScript.CST.Types+import System.FilePath (takeBaseName, replaceExtension)++spec :: Spec+spec = do+  layoutSpec+  literalsSpec++layoutSpec :: Spec+layoutSpec = do+  pursFiles <- runIO $ concat <$> getTestFiles "layout"+  describe "Layout golden tests" $ do+    forM_ pursFiles $ \file ->+      it (takeBaseName file) $+        goldenVsString+          (replaceExtension file ".out")+          (Text.encodeUtf8 <$> runLexer file)+  where+  runLexer file = do+    src <- Text.readFile file+    case sequence $ CST.lex src of+      Left (_, err) ->+        pure $ Text.pack $ CST.prettyPrintError err+      Right toks -> do+        pure $ CST.printTokens toks++literalsSpec :: Spec+literalsSpec = describe "Literals" $ do+  testProperty "Integer" $+    checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unInt+  testProperty "Hex" $+    checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unHex+  testProperty "Number" $+    checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unFloat+  testProperty "Exponent" $+    checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unExponent++  testProperty "Integer (round trip)" $ roundTripTok . unInt+  testProperty "Hex (round trip)" $ roundTripTok . unHex+  testProperty "Number (round trip)" $ roundTripTok . unFloat+  testProperty "Exponent (round trip)" $ roundTripTok . unExponent+  testProperty "Char (round trip)" $ roundTripTok . unChar+  testProperty "String (round trip)" $ roundTripTok . unString+  testProperty "Raw String (round trip)" $ roundTripTok . unRawString++  where+  testProperty name test = specify name (property test)++readTok' :: String -> Text -> Gen SourceToken+readTok' failMsg t = case CST.lex t of+  Right tok : _ ->+    pure tok+  Left (_, err) : _ ->+    error $ failMsg <> ": " <> CST.prettyPrintError err+  [] ->+    error "Empty token stream"++readTok :: Text -> Gen SourceToken+readTok = readTok' "Failed to parse"++checkTok+  :: (Text -> a -> Gen Bool)+  -> (Token -> Maybe a)+  -> Text+  -> Gen Bool+checkTok p f t = do+  SourceToken _ tok <- readTok t+  case f tok of+    Just a  -> p t a+    Nothing -> error $ "Failed to lex correctly: " <> show tok++roundTripTok :: Text -> Gen Bool+roundTripTok t = do+  tok <- readTok t+  let t' = CST.printTokens [tok]+  tok' <- readTok' "Failed to re-parse" t'+  pure $ tok == tok'++checkReadNum :: (Eq a, Read a) => Text -> a -> Gen Bool+checkReadNum t a = do+  let+    chs = case Text.unpack $ Text.replace ".e" ".0e" $ Text.replace "_" "" t of+      chs' | last chs' == '.' -> chs' <> "0"+      chs' -> chs'+  case (== a) <$> readMaybe chs of+    Just a' -> pure a'+    Nothing -> error "Failed to `read`"++newtype PSSourceInt = PSSourceInt { unInt :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceInt where+  arbitrary = resize 16 genInt++newtype PSSourceFloat = PSSourceFloat { unFloat :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceFloat where+  arbitrary = resize 16 genFloat++newtype PSSourceExponent = PSSourceExponent { unExponent :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceExponent where+  arbitrary = PSSourceExponent <$> do+    floatPart <- unFloat <$> resize 5 genFloat+    signPart <- fromMaybe "" <$> elements [ Just "+", Just "-", Nothing ]+    expPart <- unInt <$> resize 1 genInt+    pure $ floatPart <> "e" <> signPart <> expPart++newtype PSSourceHex = PSSourceHex { unHex :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceHex where+  arbitrary = resize 16 genHex++newtype PSSourceChar = PSSourceChar { unChar :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceChar where+  arbitrary = genChar++newtype PSSourceString = PSSourceString { unString :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceString where+  arbitrary = resize 256 genString++newtype PSSourceRawString = PSSourceRawString { unRawString :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceRawString where+  arbitrary = resize 256 genRawString++genInt :: Gen PSSourceInt+genInt = PSSourceInt . Text.pack <$> do+  (:) <$> nonZeroChar+      <*> listOf numChar++genFloat :: Gen PSSourceFloat+genFloat = PSSourceFloat <$> do+  intPart <- unInt <$> genInt+  floatPart <- Text.pack <$> listOf1 numChar+  pure $ intPart <> "." <> floatPart++genHex :: Gen PSSourceHex+genHex = PSSourceHex <$> do+  nums <- listOf1 hexDigit+  pure $ "0x" <> Text.pack nums++genChar :: Gen PSSourceChar+genChar = PSSourceChar <$> do+  ch <- resize 0xFFFF arbitrarySizedNatural >>= (genStringChar '\'' . toEnum)+  pure $ "'" <> ch <> "'"++genString :: Gen PSSourceString+genString = PSSourceString <$> do+  chs <- listOf $ arbitraryUnicodeChar >>= genStringChar '"'+  pure $ "\"" <> Text.concat chs <> "\""++genStringChar :: Char -> Char -> Gen Text+genStringChar delimiter ch = frequency+  [ (1, genCharEscape)+  , (10, if ch `elem` [delimiter, '\n', '\r', '\\']+           then discard+           else pure $ Text.singleton ch+    )+  ]++genRawString :: Gen PSSourceRawString+genRawString = PSSourceRawString <$> do+  chs <- listOf arbitraryUnicodeChar+  let+    k1 acc qs cs = do+      let (cs', q) = span (/= '"') cs+      k2 (acc <> cs') qs q+    k2 acc qs [] = acc <> qs+    k2 acc qs cs = do+      let (q, cs') = span (== '"') cs+      k1 (acc <> take 2 q) (qs <> drop 2 q) cs'+    chs' = k1 [] [] chs+  when (all (== '"') chs') discard+  pure $ "\"\"\"" <> Text.pack chs' <> "\"\"\""++genCharEscape :: Gen Text+genCharEscape = oneof+  [ pure "\\t"+  , pure "\\r"+  , pure "\\n"+  , pure "\\\""+  , pure "\\'"+  , pure "\\\\"+  , do+      chs <- resize 4 $ listOf1 hexDigit+      pure $ "\\x" <> Text.pack chs+  ]++numChar :: Gen Char+numChar = elements "0123456789_"++nonZeroChar :: Gen Char+nonZeroChar = elements "123456789"++hexDigit :: Gen Char+hexDigit = elements $ ['a'..'f'] <> ['A'..'F'] <> ['0'..'9']
tests/TestDocs.hs view
@@ -1,15 +1,9 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}- module TestDocs where  import Prelude () import Prelude.Compat -import Control.Arrow (first)+import Data.Bifunctor (first) import Data.List (findIndex) import Data.Foldable import Safe (headMay)@@ -29,77 +23,40 @@  import TestPscPublish (preparePackage) -import Test.Tasty-import Test.Tasty.Hspec (Spec, it, context, expectationFailure, runIO, testSpec)--main :: IO TestTree-main = testSpec "docs" spec+import Test.Hspec  spec :: Spec-spec = do-  packageResult <- runIO (preparePackage "tests/purs/docs" "resolutions.json")--  case packageResult of-    Left e ->-      it "failed to produce docs" $ do-        expectationFailure (Boxes.render (Publish.renderError e))-    Right pkg ->-      mkSpec pkg--mkSpec :: Docs.Package Docs.NotYetKnown -> Spec-mkSpec pkg@Docs.Package{..} = do-  let linksCtx = Docs.getLinksContext pkg-+spec = beforeAll (handleDocPrepFailure <$> preparePackage "tests/purs/docs" "resolutions.json") $   context "Language.PureScript.Docs" $ do     context "Doc generation tests:" $-      forM_ testCases $ \(mnString, assertions) -> do-        let mn = P.moduleNameFromString mnString-            mdl = find ((==) mn . Docs.modName) pkgModules--        context ("in module " ++ T.unpack mnString) $-          case mdl of-            Nothing ->-              it "exists in docs output" $-                expectationFailure ("module not found in docs: " ++ T.unpack mnString)-            Just mdl' ->-              toHspec linksCtx mdl' assertions--    context "Tag generation tests:" $-      forM_ testTagsCases $ \(mnString, assertions) -> do-        let mn = P.moduleNameFromString mnString-            mdl = find ((==) mn . Docs.modName) pkgModules-        context ("in module " ++ T.unpack mnString) $-          case mdl of-            Nothing ->-              it "exists in docs output" $-                expectationFailure ("module not found in docs: " ++ T.unpack mnString)-            Just mdl' ->-              tagAssertionsToHspec mdl' assertions--  where-  toHspec :: Docs.LinksContext -> Docs.Module -> [DocsAssertion] -> Spec-  toHspec linksCtx mdl assertions =-    forM_ assertions $ \a ->-      it (T.unpack (displayAssertion a)) $ do-        case runAssertion a linksCtx mdl of+      mkSpec testCases displayAssertion $ \a pkg mdl ->+        case runAssertion a (Docs.getLinksContext pkg) mdl of           Pass ->             pure ()           Fail reason ->             expectationFailure (T.unpack (displayAssertionFailure reason)) -  tagAssertionsToHspec :: Docs.Module -> [TagsAssertion] -> Spec-  tagAssertionsToHspec mdl assertions =-    let tags = Map.fromList $ Docs.tags mdl-    in forM_ assertions $ \a ->-      it (T.unpack (displayTagsAssertion a)) $ do-        case runTagsAssertion a tags of+    context "Tag generation tests:" $+      mkSpec testTagsCases displayTagsAssertion $ \a _ mdl ->+        case runTagsAssertion a (Map.fromList $ Docs.tags mdl) of           TagsPass ->             pure ()           TagsFail reason ->             expectationFailure (T.unpack (displayTagsAssertionFailure reason))+  where+  handleDocPrepFailure = first (expectationFailure . ("failed to produce docs: " <>) . Boxes.render . Publish.renderError) -takeJust :: String -> Maybe a -> a-takeJust msg = fromMaybe (error msg)+  mkSpec cases displayAssertion' runner =+    forM_ cases $ \(mnString, assertions) -> do+      let mn = P.moduleNameFromString mnString+      context ("in module " ++ T.unpack mnString) $+        forM_ assertions $ \a ->+          it (T.unpack (displayAssertion' a)) . either id $ \pkg@Docs.Package{..} ->+            case find ((==) mn . Docs.modName) pkgModules of+              Nothing ->+                expectationFailure ("module not found in docs: " ++ T.unpack mnString)+              Just mdl ->+                runner a pkg mdl  data DocsAssertion   -- | Assert that a particular declaration is documented with the given@@ -306,8 +263,8 @@     "in rendered code for " <> decl <> ", bad link location for " <> target <>     ": expected " <> T.pack (show expected) <>     " got " <> T.pack (show actual)-  WrongOrder _ before after' ->-    "expected to see " <> before <> " before " <> after'+  WrongOrder _ before' after' ->+    "expected to see " <> before' <> " before " <> after'  displayTagsAssertionFailure :: TagsAssertionFailure -> Text displayTagsAssertionFailure = \case@@ -462,20 +419,20 @@             Nothing ->               Fail (LinkedDeclarationMissing mn decl destTitle) -    ShouldComeBefore mn before after' ->+    ShouldComeBefore mn before' after' ->       let         decls = declarationsFor mn          indexOf :: Text -> Maybe Int         indexOf title = findIndex ((==) title . Docs.declTitle) decls       in-        case (indexOf before, indexOf after') of+        case (indexOf before', indexOf after') of           (Just i, Just j) ->             if i < j               then Pass-              else Fail (WrongOrder mn before after')+              else Fail (WrongOrder mn before' after')           (Nothing, _) ->-            Fail (NotDocumented mn before)+            Fail (NotDocumented mn before')           (_, Nothing) ->             Fail (NotDocumented mn after')
tests/TestGraph.hs view
@@ -3,8 +3,7 @@ import Prelude () import Prelude.Compat -import Test.Tasty-import Test.Tasty.Hspec+import Test.Hspec import System.IO.UTF8 (readUTF8FileT) import Data.Either (isLeft) @@ -12,10 +11,6 @@ import qualified Data.Text.Encoding as Text import qualified Data.Aeson as Json import qualified Language.PureScript as P---main :: IO TestTree-main = testSpec "graph" spec  spec :: Spec spec = do
tests/TestHierarchy.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module TestHierarchy where  import Prelude@@ -6,11 +5,10 @@ import Language.PureScript.Hierarchy import qualified Language.PureScript as P -import Test.Tasty-import Test.Tasty.Hspec (describe, it, shouldBe, testSpec)+import Test.Hspec -main :: IO TestTree-main = testSpec "hierarchy" $ do+spec :: Spec+spec = describe "hierarchy" $ do   describe "Language.PureScript.Hierarchy" $ do     describe "prettyPrint" $ do       it "creates just the node when there is no relation" $ do@@ -21,7 +19,7 @@         prettyPrinted `shouldBe` "  A;"        it "creates a relation when there is one" $ do-        let superMap = SuperMap (Right $ (P.ProperName "A", P.ProperName "B"))+        let superMap = SuperMap (Right (P.ProperName "A", P.ProperName "B"))          let prettyPrinted = prettyPrint superMap
tests/TestIde.hs view
@@ -5,12 +5,11 @@ import           Control.Monad (unless) import           Language.PureScript.Ide.Test import qualified PscIdeSpec-import           Test.Tasty-import           Test.Tasty.Hspec+import           Test.Hspec -main :: IO TestTree-main =-  testSpec "ide" (beforeAll_ setup PscIdeSpec.spec)+spec :: Spec+spec =+  beforeAll_ setup PscIdeSpec.spec   where     setup = do       deleteOutputFolder
tests/TestMake.hs view
@@ -26,8 +26,7 @@ import System.IO.Error (isDoesNotExistError) import System.IO.UTF8 (readUTF8FilesT, writeUTF8FileT) -import Test.Tasty-import Test.Tasty.Hspec+import Test.Hspec  utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime utcMidnightOnDate year month day = UTCTime (fromGregorian year month day) (secondsToDiffTime 0)@@ -39,9 +38,6 @@ timestampD = utcMidnightOnDate 2019 1 4 timestampE = utcMidnightOnDate 2019 1 5 timestampF = utcMidnightOnDate 2019 1 6--main :: IO TestTree-main = testSpec "make" spec  spec :: Spec spec = do
tests/TestPrimDocs.hs view
@@ -10,12 +10,7 @@ import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D -import Test.Tasty-import Test.Tasty.Hspec (Spec, testSpec, it)-import Test.Hspec (shouldBe)--main :: IO TestTree-main = testSpec "prim docs" spec+import Test.Hspec  spec :: Spec spec = do@@ -26,7 +21,7 @@   it "all Prim modules are fully documented" $ do     let actualPrimNames =           -- note that prim type classes are listed in P.primTypes-          (filter (not . Text.any (== '$')) . map (P.runProperName . P.disqualify . fst) $ Map.toList+          filter (not . Text.any (== '$')) . map (P.runProperName . P.disqualify . fst) $ Map.toList             ( P.primTypes <>               P.primBooleanTypes <>               P.primCoerceTypes <>@@ -34,7 +29,7 @@               P.primRowTypes <>               P.primRowListTypes <>               P.primTypeErrorTypes <>-              P.primSymbolTypes ))+              P.primSymbolTypes )     let documentedPrimNames =           map D.declTitle (concatMap D.modDeclarations D.primModules)
tests/TestPscPublish.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}- module TestPscPublish where  import Prelude@@ -24,13 +20,9 @@ import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish -import Test.Tasty-import Test.Tasty.Hspec (Spec, Expectation, runIO, context, it, expectationFailure, testSpec)+import Test.Hspec import TestUtils hiding (inferForeignModules, makeActions) -main :: IO TestTree-main = testSpec "publish" spec- spec :: Spec spec = do   context "preparePackage with json roundtrips" $ do@@ -67,14 +59,14 @@  roundTrip :: UploadedPackage -> TestResult roundTrip pkg =-  let before = A.encode pkg-  in case A.eitherDecode before of+  let before' = A.encode pkg+  in case A.eitherDecode before' of        Left err -> ParseFailed err        Right parsed -> do          let after' = A.encode (parsed :: UploadedPackage)-         if before == after'-           then Pass before-           else Mismatch before after'+         if before' == after'+           then Pass before'+           else Mismatch before' after'  testRunOptions :: FilePath -> PublishOptions testRunOptions resolutionsFile = defaultPublishOptions
tests/TestPsci.hs view
@@ -1,17 +1,15 @@ module TestPsci where  import Prelude ()-import Prelude.Compat  import TestPsci.CommandTest (commandTests) import TestPsci.CompletionTest (completionTests) import TestPsci.EvalTest (evalTests) -import Test.Tasty-import Test.Tasty.Hspec+import Test.Hspec -main :: IO TestTree-main = testSpec "repl" $ do+spec :: Spec+spec = do   completionTests   commandTests   evalTests
tests/TestPsci/CommandTest.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module TestPsci.CommandTest where  import Prelude ()@@ -69,7 +67,7 @@   specPSCi ":print" $ do     let failMsg = "Unable to set the repl's printing function"     let interactivePrintModuleShouldBe modName = do-          modName' <- (fst . psciInteractivePrint) <$> get+          modName' <- fst . psciInteractivePrint <$> get           modName' `equalsTo` modName      run "import Prelude"
tests/TestPsci/CompletionTest.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module TestPsci.CompletionTest where  import Prelude ()@@ -7,6 +6,7 @@ import Test.Hspec  import           Control.Monad.Trans.State.Strict (evalStateT)+import           Data.Functor ((<&>)) import           Data.List (sort) import qualified Data.Text as T import qualified Language.PureScript as P@@ -15,93 +15,93 @@ import           TestUtils (getSupportModuleNames)  completionTests :: Spec-completionTests = context "completionTests" $ do-  mns       <- runIO getSupportModuleNames-  psciState <- runIO getPSCiStateForCompletion-  mapM_ (assertCompletedOk psciState) (completionTestData mns)+completionTests = context "completionTests" $+  beforeAll getPSCiStateForCompletion $+    mapM_ assertCompletedOk completionTestData  -- If the cursor is at the right end of the line, with the 1st element of the -- pair as the text in the line, then pressing tab should offer all the -- elements of the list (which is the 2nd element) as completions.-completionTestData :: [T.Text] -> [(String, [String])]-completionTestData supportModuleNames =+completionTestData :: [(String, IO [String])]+completionTestData =   -- basic directives-  [ (":h",  [":help"])-  , (":r",  [":reload"])-  , (":c",  [":clear", ":complete"])-  , (":q",  [":quit"])-  , (":b",  [":browse"])+  [ (":h",  pure [":help"])+  , (":r",  pure [":reload"])+  , (":c",  pure [":clear", ":complete"])+  , (":q",  pure [":quit"])+  , (":b",  pure [":browse"])    -- :browse should complete module names-  , (":b Eff",    map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])-  , (":b Effect.", map (":b Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])+  , (":b Eff",    pure $ map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])+  , (":b Effect.", pure $ map (":b Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])    -- import should complete module names-  , ("import Eff",    map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])-  , ("import Effect.", map ("import Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])+  , ("import Eff",    pure $ map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])+  , ("import Effect.", pure $ map ("import Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])    -- :quit, :help, :reload, :clear should not complete-  , (":help ", [])-  , (":quit ", [])-  , (":reload ", [])-  , (":clear ", [])+  , (":help ", pure [])+  , (":quit ", pure [])+  , (":reload ", pure [])+  , (":clear ", pure [])    -- :show should complete its available arguments-  , (":show ", [":show import", ":show loaded", ":show print"])-  , (":show a", [])+  , (":show ", pure [":show import", ":show loaded", ":show print"])+  , (":show a", pure [])    -- :type should complete next word from values and constructors in scope-  , (":type uni", [":type unit"])-  , (":type E", [":type EQ"])-  , (":type P.", map (":type P." ++) ["EQ", "GT", "LT", "unit"]) -- import Prelude (unit, Ordering(..)) as P-  , (":type Effect.Console.lo", [])-  , (":type voi", [])+  , (":type uni", pure [":type unit"])+  , (":type E", pure [":type EQ"])+  , (":type P.", pure $ map (":type P." ++) ["EQ", "GT", "LT", "unit"]) -- import Prelude (unit, Ordering(..)) as P+  , (":type Effect.Console.lo", pure [])+  , (":type voi", pure [])    -- :kind should complete next word from types in scope-  , (":kind Str", [":kind String"])-  , (":kind ST.", [":kind ST.Region", ":kind ST.ST"]) -- import Control.Monad.ST as ST-  , (":kind STRef.", [":kind STRef.STRef"]) -- import Control.Monad.ST.Ref as STRef-  , (":kind Effect.", [])+  , (":kind Str", pure [":kind String"])+  , (":kind ST.", pure [":kind ST.Region", ":kind ST.ST"]) -- import Control.Monad.ST as ST+  , (":kind STRef.", pure [":kind STRef.STRef"]) -- import Control.Monad.ST.Ref as STRef+  , (":kind Effect.", pure [])    -- Only one argument for these directives should be completed-  , (":show import ", [])-  , (":browse Data.List ", [])+  , (":show import ", pure [])+  , (":browse Data.List ", pure [])    -- These directives take any number of completable terms-  , (":type const compa", [":type const compare", ":type const comparing"])-  , (":kind Array In", [":kind Array Int"])+  , (":type const compa", pure [":type const compare", ":type const comparing"])+  , (":kind Array In", pure [":kind Array Int"])    -- a few other import tests-  , ("impor", ["import"])-  , ("import ", map (T.unpack . mappend "import ") supportModuleNames)-  , ("import Prelude ", [])+  , ("impor", pure ["import"])+  , ("import ", getSupportModuleNames <&> map (T.unpack . mappend "import "))+  , ("import Prelude ", pure [])    -- String and number literals should not be completed-  , ("\"hi", [])-  , ("34", [])+  , ("\"hi", pure [])+  , ("34", pure [])    -- Identifiers and data constructors in scope should be completed-  , ("uni", ["unit"])-  , ("G", ["GT"])-  , ("P.G", ["P.GT"])-  , ("P.uni", ["P.unit"])-  , ("voi", []) -- import Prelude hiding (void)-  , ("Effect.Class.", [])+  , ("uni", pure ["unit"])+  , ("G", pure ["GT"])+  , ("P.G", pure ["P.GT"])+  , ("P.uni", pure ["P.unit"])+  , ("voi", pure []) -- import Prelude hiding (void)+  , ("Effect.Class.", pure [])    -- complete first name after type annotation symbol-  , ("1 :: I", ["1 :: Int"])-  , ("1 ::I",  ["1 ::Int"])-  , ("1:: I",  ["1:: Int"])-  , ("1::I",   ["1::Int"])-  , ("(1::Int) uni", ["(1::Int) unit"]) -- back to completing values+  , ("1 :: I", pure ["1 :: Int"])+  , ("1 ::I",  pure ["1 ::Int"])+  , ("1:: I",  pure ["1:: Int"])+  , ("1::I",   pure ["1::Int"])+  , ("(1::Int) uni", pure ["(1::Int) unit"]) -- back to completing values    -- Parens and brackets aren't considered part of the current identifier-  , ("map id [uni", ["map id [unit"])-  , ("map (cons", ["map (const"])+  , ("map id [uni", pure ["map id [unit"])+  , ("map (cons", pure ["map (const"])   ] -assertCompletedOk :: PSCiState -> (String, [String]) -> Spec-assertCompletedOk psciState (line, expecteds) = specify line $ do+assertCompletedOk :: (String, IO [String]) -> SpecWith PSCiState+assertCompletedOk (line, expectedsM) = specify line $ \psciState -> do+  expecteds <- expectedsM   results <- runCM psciState (completion' (reverse line, ""))   let actuals = formatCompletions results   sort actuals `shouldBe` sort expecteds
tests/TestPsci/EvalTest.hs view
@@ -46,8 +46,8 @@   case stripPrefix evalCommentPrefix line of     Just rest ->       case splitOn " " rest of-        "shouldEvaluateTo" : args -> Comment (ShouldEvaluateTo $ intercalate " " args)-        "paste" : [] -> Comment (Paste [])+        "shouldEvaluateTo" : args -> Comment (ShouldEvaluateTo $ unwords args)+        ["paste"] -> Comment (Paste [])         _ -> Invalid line     Nothing -> Line line
tests/TestPsci/TestEnv.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module TestPsci.TestEnv where  import Prelude ()@@ -75,7 +73,7 @@     Right commands ->       -- The JS result is ignored, as it's already written in a JS source file.       -- For the detail, please refer to Interactive.hs-      traverse_ (handleCommand (\_ -> jsOutputEval) (return ()) textOutputEval) commands+      traverse_ (handleCommand (const jsOutputEval) (return ()) textOutputEval) commands  -- | Run a PSCi command, evaluate compiled JS, and ignore evaluation output and printed output run :: String -> TestPSCi ()
tests/TestUtils.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-- module TestUtils where  import Prelude ()@@ -17,23 +13,27 @@ import Control.Monad.Trans.Maybe import Control.Monad.Writer.Class (tell) import Control.Exception+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Data.Char (isSpace) import Data.Function (on) import Data.List (sort, sortBy, stripPrefix, groupBy) import qualified Data.Map as M+import Data.Maybe (isJust) import qualified Data.Text as T-import Data.Time.Clock (UTCTime())+import qualified Data.Text.Encoding as T+import Data.Time.Clock (UTCTime(), diffUTCTime, getCurrentTime, nominalDay) import Data.Tuple (swap)-import System.Process hiding (cwd) import System.Directory-import System.Info-import System.IO.UTF8 (readUTF8FileT) import System.Exit (exitFailure)+import System.Environment (lookupEnv) import System.FilePath+import System.IO.Error (isDoesNotExistError)+import System.IO.UTF8 (readUTF8FileT)+import System.Process hiding (cwd) import qualified System.FilePath.Glob as Glob import System.IO-import Test.Tasty.Hspec-+import Test.Hspec  findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names@@ -49,24 +49,55 @@ -- updating. -- updateSupportCode :: IO ()-updateSupportCode = do-  setCurrentDirectory "tests/support"-  if System.Info.os == "mingw32"-    then callProcess "setup-win.cmd" []-    else do-      callProcess "npm" ["install"]-      -- bower uses shebang "/usr/bin/env node", but we might have nodejs-      node <- maybe cannotFindNode pure =<< findNodeProcess-      -- Sometimes we run as a root (e.g. in simple docker containers)-      -- And we are non-interactive: https://github.com/bower/bower/issues/1162-      callProcess node ["node_modules/.bin/bower", "--allow-root", "install", "--config.interactive=false"]-  setCurrentDirectory "../.."+updateSupportCode = withCurrentDirectory "tests/support" $ do+  let lastUpdatedFile = ".last_updated"+  skipUpdate <- fmap isJust . runMaybeT $ do+    -- We skip the update if: `.last_updated` exists,+    lastUpdated <- MaybeT $ getModificationTimeMaybe lastUpdatedFile++    -- ... and it was modified less than a day ago (no particular reason why+    -- "one day" specifically),+    now <- lift getCurrentTime+    guard $ now `diffUTCTime` lastUpdated < nominalDay++    -- ... and the needed directories exist,+    contents <- lift $ listDirectory "."+    guard $ "node_modules" `elem` contents && "bower_components" `elem` contents++    -- ... and everything else in `tests/support` is at least as old as+    -- `.last_updated`.+    modTimes <- lift $ traverse getModificationTime . filter (/= lastUpdatedFile) $ contents+    guard $ all (<= lastUpdated) modTimes++    pure ()++  unless skipUpdate $ do+    heading "Updating support code"+    callCommand "npm install"+    -- bower uses shebang "/usr/bin/env node", but we might have nodejs+    node <- maybe cannotFindNode pure =<< findNodeProcess+    -- Sometimes we run as a root (e.g. in simple docker containers)+    -- And we are non-interactive: https://github.com/bower/bower/issues/1162+    callProcess node ["node_modules/bower/bin/bower", "--allow-root", "install", "--config.interactive=false"]+    writeFile lastUpdatedFile ""   where   cannotFindNode :: IO a   cannotFindNode = do     hPutStrLn stderr "Cannot find node (or nodejs) executable"     exitFailure +  getModificationTimeMaybe :: FilePath -> IO (Maybe UTCTime)+  getModificationTimeMaybe f = catch (Just <$> getModificationTime f) $ \case+    e | isDoesNotExistError e -> pure Nothing+      | otherwise             -> throw e++  heading msg = do+    putStrLn ""+    putStrLn $ replicate 79 '#'+    putStrLn $ "# " ++ msg+    putStrLn $ replicate 79 '#'+    putStrLn ""+ readInput :: [FilePath] -> IO [(FilePath, T.Text)] readInput inputFiles = forM inputFiles $ \inputFile -> do   text <- readUTF8FileT inputFile@@ -107,7 +138,13 @@   createDirectoryIfMissing False (tmp </> logpath)   openFile (tmp </> logpath </> logfileName) WriteMode -setupSupportModules :: IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath)+data SupportModules = SupportModules+  { supportModules :: [P.Module]+  , supportExterns :: [P.ExternsFile]+  , supportForeigns :: M.Map P.ModuleName FilePath+  }++setupSupportModules :: IO SupportModules setupSupportModules = do   ms <- getSupportModuleTuples   let modules = map snd ms@@ -117,7 +154,7 @@     return (externs, foreigns)   case supportExterns of     Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)-    Right (externs, foreigns) -> return (modules, externs, foreigns)+    Right (externs, foreigns) -> return $ SupportModules modules externs foreigns  getTestFiles :: FilePath -> IO [[FilePath]] getTestFiles testDir = do@@ -162,43 +199,21 @@        else dir  compile-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath+  :: SupportModules   -> [FilePath]-  -> ([P.Module] -> IO ())   -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)-compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do-  fs <- liftIO $ readInput inputFiles+compile SupportModules{..} inputFiles = runTest $ do+  -- Sorting the input files makes some messages (e.g., duplicate module) deterministic+  fs <- liftIO $ readInput (sort inputFiles)   msWithWarnings <- CST.parseFromFiles id fs   tell $ foldMap (\(fp, (ws, _)) -> CST.toMultipleWarnings fp ws) msWithWarnings   let ms = fmap snd <$> msWithWarnings   foreigns <- inferForeignModules ms-  liftIO (check (map snd ms))   let actions = makeActions supportModules (foreigns `M.union` supportForeigns)   case ms of     [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule)     _ -> P.make actions (CST.pureResult <$> supportModules ++ map snd ms) -assert-  :: [P.Module]-  -> [P.ExternsFile]-  -> M.Map P.ModuleName FilePath-  -> [FilePath]-  -> ([P.Module] -> IO ())-  -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))-  -> Expectation-assert supportModules supportExterns supportForeigns inputFiles check f = do-  (e, w) <- compile supportModules supportExterns supportForeigns inputFiles check-  maybeErr <- f (const w <$> e)-  maybe (return ()) expectationFailure maybeErr--checkMain :: [P.Module] -> IO ()-checkMain ms =-  unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)-    (fail "Main module missing")-- makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)                                { P.getInputTimestampsAndHashes = getInputTimestampsAndHashes@@ -240,3 +255,41 @@  logpath :: FilePath logpath = "purescript-output"++-- | Assert that the contents of the provided file path match the result of the+-- provided action. If the "HSPEC_ACCEPT" environment variable is set, or if the+-- file does not already exist, we write the resulting ByteString out to the+-- provided file path instead. However, if the "CI" environment variable is+-- set, "HSPEC_ACCEPT" is ignored and we require that the file does exist with+-- the correct contents (see #3808). Based (very loosely) on the tasty-golden+-- package.+goldenVsString+  :: HasCallStack -- For expectationFailure; use the call site for better failure locations+  => FilePath+  -> IO ByteString+  -> Expectation+goldenVsString goldenFile testAction = do+  accept <- isJust <$> lookupEnv "HSPEC_ACCEPT"+  ci <- isJust <$> lookupEnv "CI"+  goldenContents <- tryJust (guard . isDoesNotExistError) (BS.readFile goldenFile)+  case goldenContents of+    Left () ->+      -- The golden file does not exist+      if ci+        then expectationFailure $ "Missing golden file: " ++ goldenFile+        else createOrReplaceGoldenFile++    Right _ | not ci && accept ->+      createOrReplaceGoldenFile++    Right expected -> do+      actual <- testAction+      if expected == actual+        then pure ()+        else expectationFailure $+          "Test output differed from '" ++ goldenFile ++ "'; got:\n" +++          T.unpack (T.decodeUtf8With (\_ _ -> Just '\xFFFD') actual)+  where+  createOrReplaceGoldenFile = do+    testAction >>= BS.writeFile goldenFile+    pendingWith "Accepting new output"
+ tests/purs/failing/InstanceNamedWithoutSeparator.out view
@@ -0,0 +1,10 @@+Error found:+at tests/purs/failing/InstanceNamedWithoutSeparator.purs:9:23 - 9:26 (line 9, column 23 - line 9, column 26)++  Unable to parse module:+  Unexpected token 'Foo'+++See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information,+or to contribute content related to this error.+
+ tests/purs/failing/InstanceNamedWithoutSeparator.purs view
@@ -0,0 +1,12 @@+-- @shouldFailWith ErrorParsingModule+module Main where++import Effect.Console (log)++class Foo a+-- the "::" separator between the name and class name+-- needs to be added.+instance instanceName Foo x+-- else instance Foo x++main = log "Done"
+ tests/purs/layout/AdoIn.out view
@@ -0,0 +1,20 @@+module Test where{++test = ado{+  baz;+  let {foo = bar}}+   in bar;++test = ado {}in foo;++test = ado{+  foo <- bar $ let {a = 42 }in a;+  baz <- b}+  in bar;++test = ado{+  foo;+  let {bar = let {a = 42 }in a};+  let {baz = 42}}+  in bar}+<eof>
+ tests/purs/layout/AdoIn.purs view
@@ -0,0 +1,19 @@+module Test where++test = ado+  baz+  let foo = bar+   in bar++test = ado in foo++test = ado+  foo <- bar $ let a = 42 in a+  baz <- b+  in bar++test = ado+  foo+  let bar = let a = 42 in a+  let baz = 42+  in bar
+ tests/purs/layout/CaseGuards.out view
@@ -0,0 +1,54 @@+module Test where{++-- Including data because of `|` masking+data Foo+ = Foo+ | Bar+ | Baz;++test =+  case foo of{+    a | b, c ->+      d;+    a | b, c -> d};++test = case a, b of{+  c, d+   | e ->+     case e of{+       f | true -> bar+         | false -> baz}+   | f -> g};++test a+  | false =+      case false of{+        true | a > 12 -> true}+  | otherwise = true;++test = case a of {foo | foo \a -> a -> true};++test = a `case _ of {x | unit # \_ -> true, true -> const}` b;++test = case a of{+  12 | do {that;+          that   }-> this+     | otherwise -> this};++test a b = [ case _ of{+  12 | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b -> true+     | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b -> true}, false ];++test a+  | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b = true+  | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b = true}++<eof>
+ tests/purs/layout/CaseGuards.purs view
@@ -0,0 +1,53 @@+module Test where++-- Including data because of `|` masking+data Foo+ = Foo+ | Bar+ | Baz++test =+  case foo of+    a | b, c ->+      d+    a | b, c -> d++test = case a, b of+  c, d+   | e ->+     case e of+       f | true -> bar+         | false -> baz+   | f -> g++test a+  | false =+      case false of+        true | a > 12 -> true+  | otherwise = true++test = case a of foo | foo \a -> a -> true++test = a `case _ of x | unit # \_ -> true, true -> const` b++test = case a of+  12 | do that+          that   -> this+     | otherwise -> this++test a b = [ case _ of+  12 | case a, b of+         _, 42 -> b+         _, 12 -> false, b -> true+     | case a, b of+         _, 42 -> b+         _, 12 -> false, b -> true, false ]++test a+  | case a, b of+         _, 42 -> b+         _, 12 -> false, b = true+  | case a, b of+         _, 42 -> b+         _, 12 -> false, b = true+
+ tests/purs/layout/CaseWhere.out view
@@ -0,0 +1,13 @@+module Test where{++test = case foo of{+  Nothing -> a+    where {a = 12};+  Just a -> do{+    what}}+  where{+    foo = bar};++test = case f of {Foo -> do {that}+                        where {foo = 12}}}+<eof>
+ tests/purs/layout/CaseWhere.purs view
@@ -0,0 +1,12 @@+module Test where++test = case foo of+  Nothing -> a+    where a = 12+  Just a -> do+    what+  where+    foo = bar++test = case f of Foo -> do that+                        where foo = 12
+ tests/purs/layout/ClassHead.out view
@@ -0,0 +1,11 @@+module Test where{++import Foo (class Foo);++class Foo a b c d | a -> b, c -> d where{+  foo :: Foo};++class Foo a b c d | a -> b, c -> d;++instance foo :: Foo}+<eof>
+ tests/purs/layout/ClassHead.purs view
@@ -0,0 +1,10 @@+module Test where++import Foo (class Foo)++class Foo a b c d | a -> b, c -> d where+  foo :: Foo++class Foo a b c d | a -> b, c -> d++instance foo :: Foo
+ tests/purs/layout/Commas.out view
@@ -0,0 +1,23 @@+module Test where{++test =+  [ case do {foo}, bar of{+      a | b, c -> d}, bar+    ];++test =+  [ case do {foo}, bar of {a | b, c -> d}, bar ];++test =+  [ do {do {do {foo}}}, bar ];++test =+  [ \foo -> foo, bar ];++test = foo where{+  bar =+    case a, b of{+      c, d | d == [case true, w of {1, a -> true}, false ] -> d;+      e, d | do {what}, do {that }-> d}}}++<eof>
+ tests/purs/layout/Commas.purs view
@@ -0,0 +1,22 @@+module Test where++test =+  [ case do foo, bar of+      a | b, c -> d, bar+    ]++test =+  [ case do foo, bar of a | b, c -> d, bar ]++test =+  [ do do do foo, bar ]++test =+  [ \foo -> foo, bar ]++test = foo where+  bar =+    case a, b of+      c, d | d == [case true, w of 1, a -> true, false ] -> d+      e, d | do what, do that -> d+
+ tests/purs/layout/Delimiter.out view
@@ -0,0 +1,14 @@+module Test where{++test1 = a;+test2 = {+  b+};+test3 = do{+  foo;+  bar (+    baz+  ) == 12;+  baz};+test4 = c}+<eof>
+ tests/purs/layout/Delimiter.purs view
@@ -0,0 +1,13 @@+module Test where++test1 = a+test2 = {+  b+}+test3 = do+  foo+  bar (+    baz+  ) == 12+  baz+test4 = c
+ tests/purs/layout/DoLet.out view
@@ -0,0 +1,16 @@+module Test where{++test = do{+  let {foo = bar};+  foo};++test = do{+  let {foo = bar};+  in baz;+  foo};++test = do{+  let {foo = bar}+    in baz;+  foo}}+<eof>
+ tests/purs/layout/DoLet.purs view
@@ -0,0 +1,15 @@+module Test where++test = do+  let foo = bar+  foo++test = do+  let foo = bar+  in baz+  foo++test = do+  let foo = bar+    in baz+  foo
+ tests/purs/layout/DoOperator.out view
@@ -0,0 +1,9 @@+module Test where{++test = do{+  foo;+  foo do{+    bar}}+  <|> bar}++<eof>
+ tests/purs/layout/DoOperator.purs view
@@ -0,0 +1,8 @@+module Test where++test = do+  foo+  foo do+    bar+  <|> bar+
+ tests/purs/layout/DoWhere.out view
@@ -0,0 +1,7 @@+module Test where{++test =+  do{+    do {do{+        foo }}}where {bar = baz}}+<eof>
+ tests/purs/layout/DoWhere.purs view
@@ -0,0 +1,6 @@+module Test where++test =+  do+    do do+        foo where bar = baz
+ tests/purs/layout/IfThenElseDo.out view
@@ -0,0 +1,11 @@+module Test where{++foo = do{+  if true then+    false+  else if false then do{+    that}+    else do{+     what};+  that}}+<eof>
+ tests/purs/layout/IfThenElseDo.purs view
@@ -0,0 +1,10 @@+module Test where++foo = do+  if true then+    false+  else if false then do+    that+    else do+     what+  that
+ tests/purs/layout/InstanceChainElse.out view
@@ -0,0 +1,5 @@+module Test where{++instance foo :: Foo Int else bar :: Foo String+else baz :: Foo Boolean}+<eof>
+ tests/purs/layout/InstanceChainElse.purs view
@@ -0,0 +1,4 @@+module Test where++instance foo :: Foo Int else bar :: Foo String+else baz :: Foo Boolean
+ tests/purs/layout/LetGuards.out view
@@ -0,0 +1,30 @@+module Test where{++test =+  let{+    foo+      | bar+      , baz =+        42+      | otherwise = 100}+  in+    foo;++test = do{+  let{+    foo+      | bar+      , baz =+        42+      | otherwise = 100};+  foo};++test = ado{+  let{+    foo+      | bar+      , baz =+        42+      | otherwise = 100};+  foo}}+<eof>
+ tests/purs/layout/LetGuards.purs view
@@ -0,0 +1,29 @@+module Test where++test =+  let+    foo+      | bar+      , baz =+        42+      | otherwise = 100+  in+    foo++test = do+  let+    foo+      | bar+      , baz =+        42+      | otherwise = 100+  foo++test = ado+  let+    foo+      | bar+      , baz =+        42+      | otherwise = 100+  foo
+ tests/purs/passing/InstanceNamesGenerated.purs view
@@ -0,0 +1,92 @@+module Main where++import Effect.Console (log)+import Data.Generic.Rep (class Generic)++-- This file verifies that unnamed instances will produce+-- completely-generated instance names without problems.++class NoTypeParams+instance NoTypeParams+++class OneTypeParam a+instance OneTypeParam Boolean+++class OneTypeParamChain a+instance OneTypeParamChain Boolean+else instance OneTypeParamChain String+++class MultipleTypeParams :: Type -> Type -> Type -> Type -> Type -> Constraint+class MultipleTypeParams a b c d e++instance MultipleTypeParams Boolean Int Number Char String+++class MultipleTypeParamsChain :: Type -> Type -> Type -> Type -> Type -> Constraint+class MultipleTypeParamsChain a b c d e++instance MultipleTypeParamsChain Boolean Int Number Char Boolean+else instance MultipleTypeParamsChain Boolean Int Number Char Int+else instance MultipleTypeParamsChain Boolean Int Number Char Number+else instance MultipleTypeParamsChain Boolean Int Number Char Char+else instance MultipleTypeParamsChain Boolean Int Number Char String+++class HigherKindedTypeParams :: (Type -> Type) -> (Type -> Type) -> Constraint+class HigherKindedTypeParams f g where+  hktp :: f Int -> g Int -> Int++instance HigherKindedTypeParams Array (Either Int) where+  hktp _ _ = 0+++class HigherKindedTypeParamsChain :: (Type -> Type) -> (Type -> Type) -> Constraint+class HigherKindedTypeParamsChain f g where+  hktpChain :: f Int -> g Int -> Int++instance HigherKindedTypeParamsChain Array (Either Int) where+  hktpChain _ _ = 0+else instance HigherKindedTypeParamsChain (Either Int) Array where+  hktpChain _ _ = 0+++data CustomKind+foreign import data Constructor1 :: CustomKind+foreign import data Constructor2 :: CustomKind+foreign import data Constructor3 :: CustomKind++class MultipleKindParams :: CustomKind -> Constraint+class MultipleKindParams customKind++instance MultipleKindParams Constructor1+++class MultipleKindParamsChain :: CustomKind -> Constraint+class MultipleKindParamsChain customKind++instance MultipleKindParamsChain Constructor1+else instance MultipleKindParamsChain Constructor2+else instance MultipleKindParamsChain Constructor3+++data Arrow a b = Foo a b+class ReservedWord a+instance ReservedWord (Arrow a b)+instance ReservedWord ((->) a b)+++data GenericFoo = GenericFoo+derive instance Generic GenericFoo _+++class OverlappingStillCompiles a+instance OverlappingStillCompiles x+else instance OverlappingStillCompiles x+++main = log "Done"++data Either l r = Left l | Right r
+ tests/purs/passing/InstanceUnnamedSimilarClassName.purs view
@@ -0,0 +1,16 @@+module Main where++import Effect.Console (log)+import ImportedClassName as I++data Foo = Foo++class ClassName a where+  foo :: a -> Int++instance ClassName Foo where+  foo _ = 0+instance I.ClassName Foo where+  foo _ = 0++main = log "Done"
+ tests/purs/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs view
@@ -0,0 +1,4 @@+module ImportedClassName where++class ClassName a where+  foo :: a -> Int
tests/purs/warning/UnusedVar.out view
@@ -1,7 +1,7 @@-Warning 1 of 5:+Warning 1 of 8:    in module [33mMain[0m-  at tests/purs/warning/UnusedVar.purs:12:19 - 12:37 (line 12, column 19 - line 12, column 37)+  at tests/purs/warning/UnusedVar.purs:15:20 - 15:32 (line 15, column 20 - line 15, column 32)      Name [33mlambdaUnused[0m was introduced but not used. @@ -10,10 +10,10 @@   See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information,   or to contribute content related to this warning. -Warning 2 of 5:+Warning 2 of 8:    in module [33mMain[0m-  at tests/purs/warning/UnusedVar.purs:16:3 - 17:4 (line 16, column 3 - line 17, column 4)+  at tests/purs/warning/UnusedVar.purs:19:7 - 19:20 (line 19, column 7 - line 19, column 20)      Name [33mletUnused[0m was introduced but not used. @@ -22,10 +22,10 @@   See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information,   or to contribute content related to this warning. -Warning 3 of 5:+Warning 3 of 8:    in module [33mMain[0m-  at tests/purs/warning/UnusedVar.purs:21:3 - 21:4 (line 21, column 3 - line 21, column 4)+  at tests/purs/warning/UnusedVar.purs:25:9 - 25:24 (line 25, column 9 - line 25, column 24)      Name [33mwhereUnused[0m was introduced but not used. @@ -34,10 +34,10 @@   See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information,   or to contribute content related to this warning. -Warning 4 of 5:+Warning 4 of 8:    in module [33mMain[0m-  at tests/purs/warning/UnusedVar.purs:26:7 - 26:27 (line 26, column 7 - line 26, column 27)+  at tests/purs/warning/UnusedVar.purs:29:11 - 29:23 (line 29, column 11 - line 29, column 23)      Name [33mletArgUnused[0m was introduced but not used. @@ -46,15 +46,51 @@   See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information,   or to contribute content related to this warning. -Warning 5 of 5:+Warning 5 of 8:    in module [33mMain[0m-  at tests/purs/warning/UnusedVar.purs:39:3 - 40:20 (line 39, column 3 - line 40, column 20)+  at tests/purs/warning/UnusedVar.purs:43:5 - 43:15 (line 43, column 5 - line 43, column 15)      Name [33mcaseUnused[0m was introduced but not used.    in value declaration [33munusedCaseBinder[0m    See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information,+  or to contribute content related to this warning.++Warning 6 of 8:++  in module [33mMain[0m+  at tests/purs/warning/UnusedVar.purs:61:34 - 61:35 (line 61, column 34 - line 61, column 35)++    Name [33mx[0m was introduced but not used.++  in value declaration [33munusedShadowedByRecursiveBinding[0m++  See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information,+  or to contribute content related to this warning.++Warning 7 of 8:++  in module [33mMain[0m+  at tests/purs/warning/UnusedVar.purs:68:8 - 68:9 (line 68, column 8 - line 68, column 9)++    Name [33mx[0m was introduced but not used.++  in value declaration [33munusedShadowingLet[0m++  See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information,+  or to contribute content related to this warning.++Warning 8 of 8:++  in module [33mMain[0m+  at tests/purs/warning/UnusedVar.purs:62:7 - 62:16 (line 62, column 7 - line 62, column 16)++    Name [33mx[0m was shadowed.++  in value declaration [33munusedShadowedByRecursiveBinding[0m++  See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information,   or to contribute content related to this warning.
tests/purs/warning/UnusedVar.purs view
@@ -3,6 +3,9 @@ -- @shouldWarnWith UnusedName -- @shouldWarnWith UnusedName -- @shouldWarnWith UnusedName+-- @shouldWarnWith UnusedName+-- @shouldWarnWith UnusedName+-- @shouldWarnWith ShadowedName module Main where  data X = X@@ -45,3 +48,22 @@       obj = { foo: X }   in   obj { foo = x }++-- The outer x is used in the let-bound expression, the let-binding variable is used in the body+notUnusedNonRecursiveBinding :: X -> X+notUnusedNonRecursiveBinding x = +  let {x} = {x}+  in x++-- Almost like above but the outer x is not used, as x is bound recursively (Can also be true if there are no +-- arguments to x but in most cases this will error due to being cyclic)+unusedShadowedByRecursiveBinding :: X -> X+unusedShadowedByRecursiveBinding x = +  let x _ = x X+  in x X++-- In this case the outer x is used but the new x binding is not+unusedShadowingLet :: X -> X+unusedShadowingLet x = +  let (x) = x+  in X
tests/purs/warning/UnusedVarDecls.out view
@@ -1,7 +1,7 @@ Warning 1 of 2:    in module [33mMain[0m-  at tests/purs/warning/UnusedVarDecls.purs:13:1 - 13:28 (line 13, column 1 - line 13, column 28)+  at tests/purs/warning/UnusedVarDecls.purs:13:15 - 13:24 (line 13, column 15 - line 13, column 24)      Name [33munusedArg[0m was introduced but not used.
tests/purs/warning/UnusedVarDo.out view
@@ -1,7 +1,7 @@ Warning 1 of 4:    in module [33mMain[0m-  at tests/purs/warning/UnusedVarDo.purs:12:3 - 12:26 (line 12, column 3 - line 12, column 26)+  at tests/purs/warning/UnusedVarDo.purs:12:3 - 12:15 (line 12, column 3 - line 12, column 15)      Name [33munusedDoBind[0m was introduced but not used. @@ -13,7 +13,7 @@ Warning 2 of 4:    in module [33mMain[0m-  at tests/purs/warning/UnusedVarDo.purs:24:3 - 24:23 (line 24, column 3 - line 24, column 23)+  at tests/purs/warning/UnusedVarDo.purs:24:7 - 24:23 (line 24, column 7 - line 24, column 23)      Name [33munusedDoLet[0m was introduced but not used. @@ -25,7 +25,7 @@ Warning 3 of 4:    in module [33mMain[0m-  at tests/purs/warning/UnusedVarDo.purs:29:3 - 29:27 (line 29, column 3 - line 29, column 27)+  at tests/purs/warning/UnusedVarDo.purs:29:3 - 29:16 (line 29, column 3 - line 29, column 16)      Name [33munusedAdoBind[0m was introduced but not used. @@ -37,7 +37,7 @@ Warning 4 of 4:    in module [33mMain[0m-  at tests/purs/warning/UnusedVarDo.purs:34:3 - 34:24 (line 34, column 3 - line 34, column 24)+  at tests/purs/warning/UnusedVarDo.purs:34:7 - 34:24 (line 34, column 7 - line 34, column 24)      Name [33munusedAdoLet[0m was introduced but not used.
tests/purs/warning/UnusedVarDo.purs view
@@ -33,3 +33,8 @@ unusedAdoLetBinding = ado   let unusedAdoLet = 42   in 17++notUnusedNonRecursiveBinding :: Int -> Maybe Int+notUnusedNonRecursiveBinding x = do+  let {x} = {x}+  pure x
− tests/support/setup-win.cmd 
@@ -1,3 +0,0 @@-@echo off-call npm install-call node_modules\.bin\bower install --config.interactive=false