purescript 0.12.0 → 0.12.1
raw patch · 105 files changed
+656/−637 lines, 105 filesdep +Cabaldep +microlens-platformdep −lensdep −spdxdep ~aesondep ~base
Dependencies added: Cabal, microlens-platform
Dependencies removed: lens, spdx
Dependency ranges changed: aeson, base
Files
- CONTRIBUTING.md +1/−1
- CONTRIBUTORS.md +2/−1
- README.md +1/−3
- app/Command/Bundle.hs +2/−4
- app/Command/Compile.hs +4/−13
- app/Command/Hierarchy.hs +0/−1
- app/Command/Publish.hs +0/−1
- app/Command/REPL.hs +4/−5
- app/Main.hs +0/−1
- purescript.cabal +23/−19
- src/Language/PureScript/AST/Binders.hs +0/−2
- src/Language/PureScript/AST/Declarations.hs +1/−1
- src/Language/PureScript/AST/SourcePos.hs +0/−1
- src/Language/PureScript/AST/Traversals.hs +72/−75
- src/Language/PureScript/CodeGen/JS.hs +0/−1
- src/Language/PureScript/CodeGen/JS/Common.hs +0/−1
- src/Language/PureScript/CodeGen/JS/Printer.hs +0/−1
- src/Language/PureScript/Constants.hs +21/−12
- src/Language/PureScript/CoreFn/Traversals.hs +15/−15
- src/Language/PureScript/CoreImp/AST.hs +20/−20
- src/Language/PureScript/CoreImp/Optimizer.hs +3/−2
- src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +0/−1
- src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +17/−14
- src/Language/PureScript/CoreImp/Optimizer/TCO.hs +0/−1
- src/Language/PureScript/Docs/AsHtml.hs +0/−1
- src/Language/PureScript/Docs/AsMarkdown.hs +0/−1
- src/Language/PureScript/Docs/Convert/ReExports.hs +4/−4
- src/Language/PureScript/Docs/Convert/Single.hs +1/−1
- src/Language/PureScript/Docs/Prim.hs +11/−2
- src/Language/PureScript/Docs/Render.hs +0/−1
- src/Language/PureScript/Docs/RenderedCode/RenderKind.hs +0/−1
- src/Language/PureScript/Docs/RenderedCode/RenderType.hs +0/−1
- src/Language/PureScript/Docs/RenderedCode/Types.hs +1/−2
- src/Language/PureScript/Docs/Utils/MonoidExtras.hs +0/−1
- src/Language/PureScript/Environment.hs +1/−0
- src/Language/PureScript/Errors.hs +9/−3
- src/Language/PureScript/Errors/JSON.hs +0/−1
- src/Language/PureScript/Hierarchy.hs +0/−1
- src/Language/PureScript/Ide.hs +4/−4
- src/Language/PureScript/Ide/Command.hs +8/−2
- src/Language/PureScript/Ide/Completion.hs +1/−1
- src/Language/PureScript/Ide/Externs.hs +1/−1
- src/Language/PureScript/Ide/Filter.hs +1/−1
- src/Language/PureScript/Ide/Imports.hs +1/−1
- src/Language/PureScript/Ide/Matcher.hs +1/−1
- src/Language/PureScript/Ide/Rebuild.hs +12/−9
- src/Language/PureScript/Ide/Reexports.hs +1/−1
- src/Language/PureScript/Ide/State.hs +2/−2
- src/Language/PureScript/Ide/Types.hs +36/−2
- src/Language/PureScript/Ide/Usage.hs +1/−1
- src/Language/PureScript/Ide/Util.hs +8/−8
- src/Language/PureScript/Interactive.hs +1/−2
- src/Language/PureScript/Interactive/Printer.hs +0/−1
- src/Language/PureScript/Interactive/Types.hs +9/−4
- src/Language/PureScript/Kinds.hs +3/−3
- src/Language/PureScript/Label.hs +1/−1
- src/Language/PureScript/Linter.hs +0/−1
- src/Language/PureScript/Linter/Exhaustive.hs +0/−1
- src/Language/PureScript/Make.hs +1/−0
- src/Language/PureScript/Make/Actions.hs +28/−14
- src/Language/PureScript/Names.hs +0/−1
- src/Language/PureScript/Options.hs +9/−0
- src/Language/PureScript/PSString.hs +1/−2
- src/Language/PureScript/Parser/Common.hs +0/−1
- src/Language/PureScript/Parser/Declarations.hs +0/−1
- src/Language/PureScript/Parser/Lexer.hs +0/−1
- src/Language/PureScript/Pretty/Common.hs +4/−4
- src/Language/PureScript/Pretty/Kinds.hs +0/−1
- src/Language/PureScript/Pretty/Types.hs +1/−1
- src/Language/PureScript/Pretty/Values.hs +1/−1
- src/Language/PureScript/Publish.hs +7/−2
- src/Language/PureScript/Publish/ErrorsWarnings.hs +4/−3
- src/Language/PureScript/Renamer.hs +0/−1
- src/Language/PureScript/Sugar/DoNotation.hs +29/−28
- src/Language/PureScript/Sugar/Names/Env.hs +3/−1
- src/Language/PureScript/Sugar/Names/Exports.hs +1/−0
- src/Language/PureScript/Sugar/TypeClasses.hs +10/−6
- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +14/−12
- src/Language/PureScript/TypeChecker.hs +2/−2
- src/Language/PureScript/TypeChecker/Entailment.hs +6/−5
- src/Language/PureScript/TypeChecker/Skolems.hs +0/−1
- src/Language/PureScript/TypeChecker/Types.hs +0/−1
- src/Language/PureScript/TypeClassDictionaries.hs +0/−1
- src/Language/PureScript/Types.hs +0/−1
- stack.yaml +5/−1
- tests/Language/PureScript/Ide/CompletionSpec.hs +3/−2
- tests/Language/PureScript/Ide/RebuildSpec.hs +23/−3
- tests/Language/PureScript/Ide/StateSpec.hs +2/−2
- tests/TestCompiler.hs +13/−2
- tests/TestCoreFn.hs +8/−8
- tests/TestPrimDocs.hs +0/−1
- tests/TestPsci/CommandTest.hs +21/−0
- tests/TestPsci/CompletionTest.hs +4/−4
- tests/TestPsci/TestEnv.hs +42/−11
- tests/TestUtils.hs +6/−4
- tests/purs/failing/3405.purs +8/−0
- tests/purs/failing/MissingClassMember.purs +1/−2
- tests/purs/passing/3388.purs +10/−0
- tests/purs/passing/3410.purs +11/−0
- tests/purs/warning/CustomWarning4.purs +31/−0
- tests/support/bower.json +35/−72
- tests/support/package-lock.json +0/−171
- tests/support/psci/Reload.edit +4/−0
- tests/support/psci/Reload.purs +4/−0
- tests/support/psci/Sample.purs +0/−0
CONTRIBUTING.md view
@@ -23,7 +23,7 @@ To build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/`, add test arguments like so: -`stack test --fast --test-arguments="-p compiler/**1110.purs*"`+`stack test --fast --test-arguments="-p 1110.purs"` This will run whatever test uses the example file `1110.purs`.
CONTRIBUTORS.md view
@@ -93,7 +93,7 @@ | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | | [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) |-| [@rndnoise](https://github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) |+| [@rndnoise](https://www.github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | | [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license](https://opensource.org/licenses/MIT) |@@ -126,6 +126,7 @@ | [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license](http://opensource.org/licenses/MIT) | | [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license](http://opensource.org/licenses/MIT) | | [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) |+| [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms
README.md view
@@ -20,7 +20,5 @@ ## Help! - [#purescript @ FP Slack](https://functionalprogramming.slack.com/)-- [PureScript Language Forum](https://purescript-users.ml/)+- [PureScript Language Forum](https://discourse.purescript.org/) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript)-- [Google Group](https://groups.google.com/forum/#!forum/purescript)-- [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
app/Command/Bundle.hs view
@@ -7,7 +7,6 @@ module Command.Bundle (command) where import Data.Traversable (for)-import Data.Monoid ((<>)) import Data.Aeson (encode) import Data.Maybe (isNothing) import Control.Applicative@@ -21,8 +20,7 @@ import System.IO (stderr, hPutStr, hPutStrLn) import System.IO.UTF8 (readUTF8File, writeUTF8File) import System.Directory (createDirectoryIfMissing, getCurrentDirectory)-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString.UTF8 as BU8+import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Language.PureScript.Bundle import Options.Applicative (Parser) import qualified Options.Applicative as Opts@@ -124,6 +122,6 @@ case sourcemap of Just sm -> do writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n"- writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm+ writeUTF8File (outputFile <.> "map") $ LBU8.toString . encode $ generate sm Nothing -> writeUTF8File outputFile js Nothing -> putStrLn js
app/Command/Compile.hs view
@@ -8,11 +8,9 @@ import Control.Applicative import Control.Monad-import Control.Monad.Writer.Strict import qualified Data.Aeson as A import Data.Bool (bool)-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString.UTF8 as BU8+import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Data.List (intercalate) import qualified Data.Map as M import qualified Data.Set as S@@ -52,7 +50,7 @@ exitFailure Right _ -> return () printWarningsAndErrors verbose True warnings errors = do- hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $+ hPutStrLn stderr . LBU8.toString . A.encode $ JSONResult (toJSONErrors verbose P.Warning warnings) (either (toJSONErrors verbose P.Error) (const []) errors) either (const exitFailure) (const (return ())) errors@@ -137,22 +135,15 @@ <> " The default target is 'js', but if this option is used only the targets specified will be used." ) -targets :: M.Map String P.CodegenTarget-targets = M.fromList- [ ("js", P.JS)- , ("sourcemaps", P.JSSourceMap)- , ("corefn", P.CoreFn)- ]- targetsMessage :: String-targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys targets) <> "'."+targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'." targetParser :: Opts.ReadM [P.CodegenTarget] targetParser = Opts.str >>= \s -> for (T.split (== ',') s) $ maybe (Opts.readerError targetsMessage) pure- . flip M.lookup targets+ . flip M.lookup P.codegenTargets . T.unpack . T.strip
app/Command/Hierarchy.hs view
@@ -22,7 +22,6 @@ import Control.Applicative (optional) import Data.Foldable (for_)-import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.IO as T import Options.Applicative (Parser)
app/Command/Publish.hs view
@@ -5,7 +5,6 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL-import Data.Monoid ((<>)) import Data.Time.Clock (getCurrentTime) import Data.Version (Version(..)) import Language.PureScript.Publish
app/Command/REPL.hs view
@@ -31,7 +31,6 @@ import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.FileEmbed (embedStringFile) import Data.Foldable (for_)-import Data.Monoid ((<>)) import Data.String (IsString(..)) import Data.Text (Text, unpack) import Data.Traversable (for)@@ -319,19 +318,19 @@ unless (supportModuleIsDefined (map snd modules)) . liftIO $ do putStr supportModuleMessage exitFailure- (externs, env) <- ExceptT . runMake . make $ modules- return (modules, externs, env)+ (externs, _) <- ExceptT . runMake . make $ modules+ return (modules, externs) case psciBackend of Backend setup eval reload (shutdown :: state -> IO ()) -> case e of Left errs -> do pwd <- getCurrentDirectory putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs) >> exitFailure- Right (modules, externs, env) -> do+ Right (modules, externs) -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } initialState = updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState- config = PSCiConfig psciInputGlob env+ config = PSCiConfig psciInputGlob runner = flip runReaderT config . flip evalStateT initialState . runInputT (setComplete completion settings)
app/Main.hs view
@@ -15,7 +15,6 @@ import qualified Command.Publish as Publish import qualified Command.REPL as REPL import Data.Foldable (fold)-import Data.Monoid ((<>)) import qualified Options.Applicative as Opts import System.Environment (getArgs) import qualified System.IO as IO
purescript.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: ed9acbb7111e989600e6d412bddce7d96a240dabdfa42338b1d3a2434ac6c976+-- hash: 628bcaed9683521da81533454c6e643bda4bea5445007164d4783767f98f0173 name: purescript-version: 0.12.0+version: 0.12.1 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language@@ -108,6 +108,7 @@ tests/purs/failing/3275-BindingGroupErrorPos.purs tests/purs/failing/3275-DataBindingGroupErrorPos.purs tests/purs/failing/3335-TypeOpAssociativityError.purs+ tests/purs/failing/3405.purs tests/purs/failing/365.purs tests/purs/failing/438.purs tests/purs/failing/881.purs@@ -366,6 +367,8 @@ tests/purs/passing/3114/VendoredVariant.purs tests/purs/passing/3125.purs tests/purs/passing/3187-UnusedNameClash.purs+ tests/purs/passing/3388.purs+ tests/purs/passing/3410.purs tests/purs/passing/652.purs tests/purs/passing/810.purs tests/purs/passing/862.purs@@ -659,6 +662,7 @@ tests/purs/warning/CustomWarning.purs tests/purs/warning/CustomWarning2.purs tests/purs/warning/CustomWarning3.purs+ tests/purs/warning/CustomWarning4.purs tests/purs/warning/DuplicateExportRef.purs tests/purs/warning/DuplicateImport.purs tests/purs/warning/DuplicateImportRef.purs@@ -693,10 +697,10 @@ tests/purs/warning/UnusedTypeVar.purs tests/purs/warning/WildcardInferredType.purs tests/support/bower.json- tests/support/package-lock.json tests/support/package.json tests/support/prelude-resolutions.json- tests/support/psci/Sample.purs+ tests/support/psci/Reload.edit+ tests/support/psci/Reload.purs tests/support/pscide/src/CompletionSpecDocs.purs tests/support/pscide/src/FindUsage.purs tests/support/pscide/src/FindUsage/Definition.purs@@ -732,11 +736,12 @@ default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns ghc-options: -Wall -O2 build-depends:- Glob >=0.9 && <0.10- , aeson >=1.0 && <1.3+ Cabal >=2.2+ , Glob >=0.9 && <0.10+ , aeson >=1.0 && <1.4 , aeson-better-errors >=0.8 , ansi-terminal >=0.7.1 && <0.9- , base >=4.8 && <4.11+ , base >=4.8 && <4.12 , base-compat >=0.6.0 , blaze-html >=0.8.1 && <0.10 , bower-json >=1.0.0.1 && <1.1@@ -755,8 +760,8 @@ , fsnotify >=0.2.1 , haskeline >=0.7.0.0 , language-javascript >=0.6.0.9 && <0.7- , lens ==4.* , lifted-base >=0.2.3 && <0.2.4+ , microlens-platform >=0.3.9.0 && <0.4 , monad-control >=1.0.0.0 && <1.1 , monad-logger >=0.3 && <0.4 , mtl >=2.1.0 && <2.3.0@@ -770,7 +775,6 @@ , scientific >=0.3.4.9 && <0.4 , semigroups >=0.16.2 && <0.19 , sourcemap >=0.1.6- , spdx ==0.2.* , split , stm >=0.2.4.0 , stringsearch@@ -949,12 +953,13 @@ app ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N build-depends:- Glob >=0.9 && <0.10- , aeson >=1.0 && <1.3+ Cabal >=2.2+ , Glob >=0.9 && <0.10+ , aeson >=1.0 && <1.4 , aeson-better-errors >=0.8 , ansi-terminal >=0.7.1 && <0.9 , ansi-wl-pprint- , base >=4.8 && <4.11+ , base >=4.8 && <4.12 , base-compat >=0.6.0 , blaze-html >=0.8.1 && <0.10 , bower-json >=1.0.0.1 && <1.1@@ -974,8 +979,8 @@ , haskeline >=0.7.0.0 , http-types , language-javascript >=0.6.0.9 && <0.7- , lens ==4.* , lifted-base >=0.2.3 && <0.2.4+ , microlens-platform >=0.3.9.0 && <0.4 , monad-control >=1.0.0.0 && <1.1 , monad-logger >=0.3 && <0.4 , mtl >=2.1.0 && <2.3.0@@ -992,7 +997,6 @@ , scientific >=0.3.4.9 && <0.4 , semigroups >=0.16.2 && <0.19 , sourcemap >=0.1.6- , spdx ==0.2.* , split , stm >=0.2.4.0 , stringsearch@@ -1035,12 +1039,13 @@ default-extensions: NoImplicitPrelude ghc-options: -Wall build-depends:- Glob >=0.9 && <0.10+ Cabal >=2.2+ , Glob >=0.9 && <0.10 , HUnit- , aeson >=1.0 && <1.3+ , aeson >=1.0 && <1.4 , aeson-better-errors >=0.8 , ansi-terminal >=0.7.1 && <0.9- , base >=4.8 && <4.11+ , base >=4.8 && <4.12 , base-compat >=0.6.0 , blaze-html >=0.8.1 && <0.10 , bower-json >=1.0.0.1 && <1.1@@ -1061,8 +1066,8 @@ , hspec , hspec-discover , language-javascript >=0.6.0.9 && <0.7- , lens ==4.* , lifted-base >=0.2.3 && <0.2.4+ , microlens-platform >=0.3.9.0 && <0.4 , monad-control >=1.0.0.0 && <1.1 , monad-logger >=0.3 && <0.4 , mtl >=2.1.0 && <2.3.0@@ -1077,7 +1082,6 @@ , scientific >=0.3.4.9 && <0.4 , semigroups >=0.16.2 && <0.19 , sourcemap >=0.1.6- , spdx ==0.2.* , split , stm >=0.2.4.0 , stringsearch
src/Language/PureScript/AST/Binders.hs view
@@ -5,8 +5,6 @@ import Prelude.Compat -import Data.Semigroup- import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Literals import Language.PureScript.Names
src/Language/PureScript/AST/Declarations.hs view
@@ -124,7 +124,7 @@ | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident)- | MissingClassMember Ident+ | MissingClassMember (NEL.NonEmpty (Ident, Type)) | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) | ExpectedType Type Kind -- | constructor name, expected argument count, actual argument count
src/Language/PureScript/AST/SourcePos.hs view
@@ -8,7 +8,6 @@ import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:))-import Data.Monoid import Data.Text (Text) import GHC.Generics (Generic) import Language.PureScript.Comments
src/Language/PureScript/AST/Traversals.hs view
@@ -132,7 +132,7 @@ f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds- f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> h' b <*> g' expr+ f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> (h' <=< h) b <*> (g' <=< g) expr f' other = f other g' :: Expr -> m Expr@@ -264,66 +264,66 @@ , CaseAlternative -> r , DoNotationElement -> r )-everythingOnValues (<>) f g h i j = (f', g', h', i', j')+everythingOnValues (<>.) f g h i j = (f', g', h', i', j') where f' :: Declaration -> r- f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (fmap f' ds)- f' d@(ValueDeclaration vd) = foldl (<>) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd))- f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (fmap (\(_, _, val) -> g' val) ds)- f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) (f d) (fmap f' ds)- f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds)- f' d@(BoundValueDeclaration _ b expr) = f d <> h' b <> g' expr+ f' d@(DataBindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap f' ds)+ f' d@(ValueDeclaration vd) = foldl (<>.) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd))+ f' d@(BindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap (\(_, _, val) -> g' val) ds)+ f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) (f d) (fmap f' ds)+ f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) (f d) (fmap f' ds)+ f' d@(BoundValueDeclaration _ b expr) = f d <>. h' b <>. g' expr f' d = f d g' :: Expr -> r g' v@(Literal _ l) = lit (g v) g' l- g' v@(UnaryMinus _ v1) = g v <> g' v1- g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2- g' v@(Parens v1) = g v <> g' v1- g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1- g' v@(Accessor _ v1) = g v <> g' v1- g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (fmap (g' . snd) vs)- g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs)- g' v@(Abs b v1) = g v <> h' b <> g' v1- g' v@(App v1 v2) = g v <> g' v1 <> g' v2- g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3- g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (fmap g' vs)) (fmap i' alts)- g' v@(TypedValue _ v1 _) = g v <> g' v1- g' v@(Let _ ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1- g' v@(Do es) = foldl (<>) (g v) (fmap j' es)- g' v@(Ado es v1) = foldl (<>) (g v) (fmap j' es) <> g' v1- g' v@(PositionedValue _ _ v1) = g v <> g' v1+ g' v@(UnaryMinus _ v1) = g v <>. g' v1+ g' v@(BinaryNoParens op v1 v2) = g v <>. g' op <>. g' v1 <>. g' v2+ g' v@(Parens v1) = g v <>. g' v1+ g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <>. g' v1+ g' v@(Accessor _ v1) = g v <>. g' v1+ g' v@(ObjectUpdate obj vs) = foldl (<>.) (g v <>. g' obj) (fmap (g' . snd) vs)+ g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs)+ g' v@(Abs b v1) = g v <>. h' b <>. g' v1+ g' v@(App v1 v2) = g v <>. g' v1 <>. g' v2+ g' v@(IfThenElse v1 v2 v3) = g v <>. g' v1 <>. g' v2 <>. g' v3+ g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts)+ g' v@(TypedValue _ v1 _) = g v <>. g' v1+ g' v@(Let _ ds v1) = foldl (<>.) (g v) (fmap f' ds) <>. g' v1+ g' v@(Do es) = foldl (<>.) (g v) (fmap j' es)+ g' v@(Ado es v1) = foldl (<>.) (g v) (fmap j' es) <>. g' v1+ g' v@(PositionedValue _ _ v1) = g v <>. g' v1 g' v = g v h' :: Binder -> r h' b@(LiteralBinder _ l) = lit (h b) h' l- h' b@(ConstructorBinder _ _ bs) = foldl (<>) (h b) (fmap h' bs)- h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3- h' b@(ParensInBinder b1) = h b <> h' b1- h' b@(NamedBinder _ _ b1) = h b <> h' b1- h' b@(PositionedBinder _ _ b1) = h b <> h' b1- h' b@(TypedBinder _ b1) = h b <> h' b1+ h' b@(ConstructorBinder _ _ bs) = foldl (<>.) (h b) (fmap h' bs)+ h' b@(BinaryNoParensBinder b1 b2 b3) = h b <>. h' b1 <>. h' b2 <>. h' b3+ h' b@(ParensInBinder b1) = h b <>. h' b1+ h' b@(NamedBinder _ _ b1) = h b <>. h' b1+ h' b@(PositionedBinder _ _ b1) = h b <>. h' b1+ h' b@(TypedBinder _ b1) = h b <>. h' b1 h' b = h b lit :: r -> (a -> r) -> Literal a -> r- lit r go (ArrayLiteral as) = foldl (<>) r (fmap go as)- lit r go (ObjectLiteral as) = foldl (<>) r (fmap (go . snd) as)+ lit r go (ArrayLiteral as) = foldl (<>.) r (fmap go as)+ lit r go (ObjectLiteral as) = foldl (<>.) r (fmap (go . snd) as) lit r _ _ = r i' :: CaseAlternative -> r i' ca@(CaseAlternative bs gs) =- foldl (<>) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs)+ foldl (<>.) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs) j' :: DoNotationElement -> r- j' e@(DoNotationValue v) = j e <> g' v- j' e@(DoNotationBind b v) = j e <> h' b <> g' v- j' e@(DoNotationLet ds) = foldl (<>) (j e) (fmap f' ds)- j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1+ j' e@(DoNotationValue v) = j e <>. g' v+ j' e@(DoNotationBind b v) = j e <>. h' b <>. g' v+ j' e@(DoNotationLet ds) = foldl (<>.) (j e) (fmap f' ds)+ j' e@(PositionedDoNotationElement _ _ e1) = j e <>. j' e1 k' :: Guard -> r k' (ConditionGuard e) = g' e- k' (PatternGuard b e) = h' b <> g' e+ k' (PatternGuard b e) = h' b <>. g' e everythingWithContextOnValues :: forall s r@@ -340,50 +340,50 @@ , Binder -> r , CaseAlternative -> r , DoNotationElement -> r)-everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)+everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) where f'' :: s -> Declaration -> r- f'' s d = let (s', r) = f s d in r <> f' s' d+ f'' s d = let (s', r) = f s d in r <>. f' s' d f' :: s -> Declaration -> r- f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (fmap (f'' s) ds)- f' s (ValueDeclaration vd) = foldl (<>) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd))- f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (fmap (\(_, _, val) -> g'' s val) ds)- f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) r0 (fmap (f'' s) ds)- f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds)+ f' s (DataBindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (f'' s) ds)+ f' s (ValueDeclaration vd) = foldl (<>.) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd))+ f' s (BindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (\(_, _, val) -> g'' s val) ds)+ f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) r0 (fmap (f'' s) ds)+ f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) r0 (fmap (f'' s) ds) f' _ _ = r0 g'' :: s -> Expr -> r- g'' s v = let (s', r) = g s v in r <> g' s' v+ g'' s v = let (s', r) = g s v in r <>. g' s' v g' :: s -> Expr -> r g' s (Literal _ l) = lit g'' s l g' s (UnaryMinus _ v1) = g'' s v1- g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2+ g' s (BinaryNoParens op v1 v2) = g'' s op <>. g'' s v1 <>. g'' s v2 g' s (Parens v1) = g'' s v1 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1- g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s . snd) vs)- g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs)- g' s (Abs binder v1) = h'' s binder <> g'' s v1- g' s (App v1 v2) = g'' s v1 <> g'' s v2- g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3- g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts)+ g' s (ObjectUpdate obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s . snd) vs)+ g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs)+ g' s (Abs binder v1) = h'' s binder <>. g'' s v1+ g' s (App v1 v2) = g'' s v1 <>. g'' s v2+ g' s (IfThenElse v1 v2 v3) = g'' s v1 <>. g'' s v2 <>. g'' s v3+ g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1- g' s (Let _ ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1- g' s (Do es) = foldl (<>) r0 (fmap (j'' s) es)- g' s (Ado es v1) = foldl (<>) r0 (fmap (j'' s) es) <> g'' s v1+ g' s (Let _ ds v1) = foldl (<>.) r0 (fmap (f'' s) ds) <>. g'' s v1+ g' s (Do es) = foldl (<>.) r0 (fmap (j'' s) es)+ g' s (Ado es v1) = foldl (<>.) r0 (fmap (j'' s) es) <>. g'' s v1 g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = r0 h'' :: s -> Binder -> r- h'' s b = let (s', r) = h s b in r <> h' s' b+ h'' s b = let (s', r) = h s b in r <>. h' s' b h' :: s -> Binder -> r h' s (LiteralBinder _ l) = lit h'' s l- h' s (ConstructorBinder _ _ bs) = foldl (<>) r0 (fmap (h'' s) bs)- h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3+ h' s (ConstructorBinder _ _ bs) = foldl (<>.) r0 (fmap (h'' s) bs)+ h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <>. h'' s b2 <>. h'' s b3 h' s (ParensInBinder b) = h'' s b h' s (NamedBinder _ _ b1) = h'' s b1 h' s (PositionedBinder _ _ b1) = h'' s b1@@ -391,28 +391,28 @@ h' _ _ = r0 lit :: (s -> a -> r) -> s -> Literal a -> r- lit go s (ArrayLiteral as) = foldl (<>) r0 (fmap (go s) as)- lit go s (ObjectLiteral as) = foldl (<>) r0 (fmap (go s . snd) as)+ lit go s (ArrayLiteral as) = foldl (<>.) r0 (fmap (go s) as)+ lit go s (ObjectLiteral as) = foldl (<>.) r0 (fmap (go s . snd) as) lit _ _ _ = r0 i'' :: s -> CaseAlternative -> r- i'' s ca = let (s', r) = i s ca in r <> i' s' ca+ i'' s ca = let (s', r) = i s ca in r <>. i' s' ca i' :: s -> CaseAlternative -> r- i' s (CaseAlternative bs gs) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs)+ i' s (CaseAlternative bs gs) = foldl (<>.) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs) j'' :: s -> DoNotationElement -> r- j'' s e = let (s', r) = j s e in r <> j' s' e+ j'' s e = let (s', r) = j s e in r <>. j' s' e j' :: s -> DoNotationElement -> r j' s (DoNotationValue v) = g'' s v- j' s (DoNotationBind b v) = h'' s b <> g'' s v- j' s (DoNotationLet ds) = foldl (<>) r0 (fmap (f'' s) ds)+ j' s (DoNotationBind b v) = h'' s b <>. g'' s v+ j' s (DoNotationLet ds) = foldl (<>.) r0 (fmap (f'' s) ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 k' :: s -> Guard -> r k' s (ConditionGuard e) = g'' s e- k' s (PatternGuard b e) = h'' s b <> g'' s e+ k' s (PatternGuard b e) = h'' s b <>. g'' s e everywhereWithContextOnValuesM :: forall m s@@ -514,9 +514,6 @@ ) everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) where- -- Avoid importing Data.Monoid and getting shadowed names above- (<>) = mappend- f'' :: S.Set ScopedIdent -> Declaration -> r f'' s a = f s a <> f' s a @@ -635,7 +632,7 @@ forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap f . snd) dctors) forDecls (ExternDeclaration _ _ ty) = f ty forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies)- forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys)+ forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) <> mconcat (fmap f tys) forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty forDecls (TypeDeclaration td) = f (tydeclType td) forDecls _ = mempty@@ -657,16 +654,16 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where forDecls (DataDeclaration _ _ _ args dctors) =- foldMap (foldMap f . snd) args `mappend`+ foldMap (foldMap f . snd) args <> foldMap (foldMap forTypes . snd) dctors forDecls (TypeClassDeclaration _ _ args implies _ _) =- foldMap (foldMap f . snd) args `mappend`+ foldMap (foldMap f . snd) args <> foldMap (foldMap forTypes . constraintArgs) implies forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) =- foldMap (foldMap forTypes . constraintArgs) cs `mappend`+ foldMap (foldMap forTypes . constraintArgs) cs <> foldMap forTypes tys forDecls (TypeSynonymDeclaration _ _ args ty) =- foldMap (foldMap f . snd) args `mappend`+ foldMap (foldMap f . snd) args <> forTypes ty forDecls (TypeDeclaration td) = forTypes (tydeclType td) forDecls (ExternDeclaration _ _ ty) = forTypes ty
src/Language/PureScript/CodeGen/JS.hs view
@@ -19,7 +19,6 @@ import qualified Data.Foldable as F import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing)-import Data.Monoid ((<>)) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/CodeGen/JS/Common.hs view
@@ -4,7 +4,6 @@ import Prelude.Compat import Data.Char-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/CodeGen/JS/Printer.hs view
@@ -13,7 +13,6 @@ import qualified Control.Arrow as A import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/Constants.hs view
@@ -204,29 +204,23 @@ -- Core lib values -untilE :: forall a. (IsString a) => a-untilE = "untilE"--whileE :: forall a. (IsString a) => a-whileE = "whileE"- runST :: forall a. (IsString a) => a-runST = "runST"+runST = "run" stRefValue :: forall a. (IsString a) => a stRefValue = "value" newSTRef :: forall a. (IsString a) => a-newSTRef = "newSTRef"+newSTRef = "new" readSTRef :: forall a. (IsString a) => a-readSTRef = "readSTRef"+readSTRef = "read" writeSTRef :: forall a. (IsString a) => a-writeSTRef = "writeSTRef"+writeSTRef = "write" modifySTRef :: forall a. (IsString a) => a-modifySTRef = "modifySTRef"+modifySTRef = "modify" mkFn :: forall a. (IsString a) => a mkFn = "mkFn"@@ -257,6 +251,8 @@ { edApplicativeDict :: PSString , edBindDict :: PSString , edMonadDict :: PSString+ , edWhile :: PSString+ , edUntil :: PSString } effDictionaries :: EffectDictionaries@@ -264,6 +260,8 @@ { edApplicativeDict = "applicativeEff" , edBindDict = "bindEff" , edMonadDict = "monadEff"+ , edWhile = "whileE"+ , edUntil = "untilE" } effectDictionaries :: EffectDictionaries@@ -271,8 +269,19 @@ { edApplicativeDict = "applicativeEffect" , edBindDict = "bindEffect" , edMonadDict = "monadEffect"+ , edWhile = "whileE"+ , edUntil = "untilE" } +stDictionaries :: EffectDictionaries+stDictionaries = EffectDictionaries+ { edApplicativeDict = "applicativeST"+ , edBindDict = "bindST"+ , edMonadDict = "monadST"+ , edWhile = "while"+ , edUntil = "until"+ }+ discardUnitDictionary :: forall a. (IsString a) => a discardUnitDictionary = "discardUnit" @@ -507,7 +516,7 @@ effect = "Effect" st :: forall a. (IsString a) => a-st = "Control_Monad_ST"+st = "Control_Monad_ST_Internal" controlApplicative :: forall a. (IsString a) => a controlApplicative = "Control_Applicative"
src/Language/PureScript/CoreFn/Traversals.hs view
@@ -50,27 +50,27 @@ (Binder a -> r) -> (CaseAlternative a -> r) -> (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)-everythingOnValues (<>) f g h i = (f', g', h', i')+everythingOnValues (<>.) f g h i = (f', g', h', i') where- f' b@(NonRec _ _ e) = f b <> g' e- f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)+ f' b@(NonRec _ _ e) = f b <>. g' e+ f' b@(Rec es) = foldl (<>.) (f b) (map (g' . snd) es) - g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))- g' v@(Accessor _ _ e1) = g v <> g' e1- g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)- g' v@(Abs _ _ e1) = g v <> g' e1- g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2- g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)- g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1+ g' v@(Literal _ l) = foldl (<>.) (g v) (map g' (extractLiteral l))+ g' v@(Accessor _ _ e1) = g v <>. g' e1+ g' v@(ObjectUpdate _ obj vs) = foldl (<>.) (g v <>. g' obj) (map (g' . snd) vs)+ g' v@(Abs _ _ e1) = g v <>. g' e1+ g' v@(App _ e1 e2) = g v <>. g' e1 <>. g' e2+ g' v@(Case _ vs alts) = foldl (<>.) (foldl (<>.) (g v) (map g' vs)) (map i' alts)+ g' v@(Let _ ds e1) = foldl (<>.) (g v) (map f' ds) <>. g' e1 g' v = g v - h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))- h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)- h' b@(NamedBinder _ _ b1) = h b <> h' b1+ h' b@(LiteralBinder _ l) = foldl (<>.) (h b) (map h' (extractLiteral l))+ h' b@(ConstructorBinder _ _ _ bs) = foldl (<>.) (h b) (map h' bs)+ h' b@(NamedBinder _ _ b1) = h b <>. h' b1 h' b = h b - i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val- i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>.) (i ca) (map h' bs) <>. g' val+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>.) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) extractLiteral (ArrayLiteral xs) = xs extractLiteral (ObjectLiteral xs) = map snd xs
src/Language/PureScript/CoreImp/AST.hs view
@@ -201,24 +201,24 @@ go other = f other everything :: (r -> r -> r) -> (AST -> r) -> AST -> r-everything (<>) f = go where- go j@(Unary _ _ j1) = f j <> go j1- go j@(Binary _ _ j1 j2) = f j <> go j1 <> go j2- go j@(ArrayLiteral _ js) = foldl (<>) (f j) (map go js)- go j@(Indexer _ j1 j2) = f j <> go j1 <> go j2- go j@(ObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)- go j@(Function _ _ _ j1) = f j <> go j1- go j@(App _ j1 js) = foldl (<>) (f j <> go j1) (map go js)- go j@(Block _ js) = foldl (<>) (f j) (map go js)- go j@(VariableIntroduction _ _ (Just j1)) = f j <> go j1- go j@(Assignment _ j1 j2) = f j <> go j1 <> go j2- go j@(While _ j1 j2) = f j <> go j1 <> go j2- go j@(For _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3- go j@(ForIn _ _ j1 j2) = f j <> go j1 <> go j2- go j@(IfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2- go j@(IfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3- go j@(Return _ j1) = f j <> go j1- go j@(Throw _ j1) = f j <> go j1- go j@(InstanceOf _ j1 j2) = f j <> go j1 <> go j2- go j@(Comment _ _ j1) = f j <> go j1+everything (<>.) f = go where+ go j@(Unary _ _ j1) = f j <>. go j1+ go j@(Binary _ _ j1 j2) = f j <>. go j1 <>. go j2+ go j@(ArrayLiteral _ js) = foldl (<>.) (f j) (map go js)+ go j@(Indexer _ j1 j2) = f j <>. go j1 <>. go j2+ go j@(ObjectLiteral _ js) = foldl (<>.) (f j) (map (go . snd) js)+ go j@(Function _ _ _ j1) = f j <>. go j1+ go j@(App _ j1 js) = foldl (<>.) (f j <>. go j1) (map go js)+ go j@(Block _ js) = foldl (<>.) (f j) (map go js)+ go j@(VariableIntroduction _ _ (Just j1)) = f j <>. go j1+ go j@(Assignment _ j1 j2) = f j <>. go j1 <>. go j2+ go j@(While _ j1 j2) = f j <>. go j1 <>. go j2+ go j@(For _ _ j1 j2 j3) = f j <>. go j1 <>. go j2 <>. go j3+ go j@(ForIn _ _ j1 j2) = f j <>. go j1 <>. go j2+ go j@(IfElse _ j1 j2 Nothing) = f j <>. go j1 <>. go j2+ go j@(IfElse _ j1 j2 (Just j3)) = f j <>. go j1 <>. go j2 <>. go j3+ go j@(Return _ j1) = f j <>. go j1+ go j@(Throw _ j1) = f j <>. go j1+ go j@(InstanceOf _ j1 j2) = f j <>. go j1 <>. go j2+ go j@(Comment _ _ j1) = f j <>. go j1 go other = f other
src/Language/PureScript/CoreImp/Optimizer.hs view
@@ -38,8 +38,9 @@ , inlineCommonOperators ]) js untilFixedPoint (return . tidyUp) . tco . inlineST- =<< untilFixedPoint (return . magicDo')- =<< untilFixedPoint (return . magicDo) js'+ =<< untilFixedPoint (return . magicDoST)+ =<< untilFixedPoint (return . magicDoEff)+ =<< untilFixedPoint (return . magicDoEffect) js' where tidyUp :: AST -> AST tidyUp = applyAll
src/Language/PureScript/CoreImp/Optimizer/Inliner.hs view
@@ -16,7 +16,6 @@ import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs view
@@ -1,6 +1,6 @@ -- | This module implements the "Magic Do" optimization, which inlines calls to return -- and bind for the Eff monad, as well as some of its actions.-module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDo, magicDo', inlineST) where+module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where import Prelude.Compat import Protolude (ordNub)@@ -27,14 +27,17 @@ -- var x = m1(); -- ... -- }-magicDo :: AST -> AST-magicDo = magicDo'' C.eff C.effDictionaries+magicDoEff :: AST -> AST+magicDoEff = magicDo C.eff C.effDictionaries -magicDo' :: AST -> AST-magicDo' = magicDo'' C.effect C.effectDictionaries+magicDoEffect :: AST -> AST+magicDoEffect = magicDo C.effect C.effectDictionaries -magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST-magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert+magicDoST :: AST -> AST+magicDoST = magicDo C.st C.stDictionaries++magicDo :: Text -> C.EffectDictionaries -> AST -> AST+magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert where -- The name of the function block which is added to denote a do block fnName = "__do"@@ -49,10 +52,10 @@ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind = Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js) -- Desugar untilE- convert (App s1 (App _ f [arg]) []) | isEffFunc C.untilE f =+ convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f = App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) [] -- Desugar whileE- convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =+ convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f = App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) [] -- Inline __do returns convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body@@ -98,12 +101,12 @@ -- Look for runST blocks and inline the STRefs there. -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then -- we can be more aggressive about inlining, and actually turn STRefs into local variables.- convertBlock (App _ f [arg]) | isSTFunc C.runST f =+ convertBlock (App s1 f [arg]) | isSTFunc C.runST f = let refs = ordNub . findSTRefsIn $ arg usages = findAllSTUsagesIn arg allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs- in everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg+ in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) [] convertBlock other = other -- Convert a block in a safe way, preserving object wrappers of references, -- or in a more aggressive way, turning wrappers into local variables depending on the@@ -112,9 +115,9 @@ Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]]) convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f = if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref- convert agg (App _ (App _ (App s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =+ convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f = if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg- convert agg (App _ (App _ (App s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =+ convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f = if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref]) convert _ other = other -- Check if an expression represents a function in the ST module@@ -129,7 +132,7 @@ findAllSTUsagesIn = everything (++) isSTUsage where isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]- isSTUsage (App _ (App _ (App _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]+ isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] isSTUsage _ = [] -- Find all uses of a variable appearingIn ref = everything (++) isVar
src/Language/PureScript/CoreImp/Optimizer/TCO.hs view
@@ -4,7 +4,6 @@ import Prelude.Compat import Data.Text (Text)-import Data.Monoid ((<>)) import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe)
src/Language/PureScript/Docs/AsHtml.hs view
@@ -20,7 +20,6 @@ import Data.Char (isUpper) import Data.Either (isRight) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Foldable (for_) import Data.String (fromString)
src/Language/PureScript/Docs/AsMarkdown.hs view
@@ -13,7 +13,6 @@ import Control.Monad.Writer (Writer, tell, execWriter) import Data.Foldable (for_)-import Data.Monoid ((<>)) import Data.List (partition) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/Docs/Convert/ReExports.hs view
@@ -14,7 +14,6 @@ import Data.Either import Data.Map (Map) import Data.Maybe (mapMaybe)-import Data.Monoid ((<>)) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T@@ -415,12 +414,13 @@ } deriving (Show) +instance Semigroup TypeClassEnv where+ (TypeClassEnv a1 b1 c1) <> (TypeClassEnv a2 b2 c2) =+ TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)+ instance Monoid TypeClassEnv where mempty = TypeClassEnv mempty mempty mempty- mappend (TypeClassEnv a1 b1 c1)- (TypeClassEnv a2 b2 c2) =- TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2) -- | -- Take a TypeClassEnv and handle all of the type class members in it, either
src/Language/PureScript/Docs/Convert/Single.hs view
@@ -114,7 +114,7 @@ convertDeclaration (P.ValueDecl sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking.- basicDeclaration sa title (ValueDeclaration P.TypeWildcard{})+ basicDeclaration sa title (ValueDeclaration (P.TypeWildcard (fst sa))) convertDeclaration (P.ExternDeclaration sa _ ty) title = basicDeclaration sa title (ValueDeclaration ty) convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title =
src/Language/PureScript/Docs/Prim.hs view
@@ -7,7 +7,6 @@ ) where import Prelude.Compat hiding (fail)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as Map@@ -106,6 +105,7 @@ , kindDoc , textDoc , quoteDoc+ , quoteLabelDoc , besideDoc , aboveDoc ]@@ -442,7 +442,7 @@ [ "`Doc` is the kind of type-level documents." , "" , "This kind is used with the `Fail` and `Warn` type clases."- , "Build up a `Doc` with `Text`, `Quote`, `Beside`, and `Above`."+ , "Build up a `Doc` with `Text`, `Quote`, `QuoteLabel`, `Beside`, and `Above`." ] textDoc :: Declaration@@ -458,6 +458,15 @@ quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines [ "The Quote type constructor renders any concrete type as a Doc" , "to be used in a custom type error."+ , ""+ , "For more information, see"+ , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."+ ]++quoteLabelDoc :: Declaration+quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines+ [ "The `QuoteLabel` type constructor will produce a `Doc` when given a `Symbol`. When the resulting `Doc` is rendered"+ , "for a `Warn` or `Fail` constraint, a syntactically valid label will be produced, escaping with quotes as needed." , "" , "For more information, see" , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
src/Language/PureScript/Docs/Render.hs view
@@ -12,7 +12,6 @@ import Prelude.Compat import Data.Maybe (maybeToList)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/Docs/RenderedCode/RenderKind.hs view
@@ -12,7 +12,6 @@ import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows as PA -import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import qualified Data.Text as T
src/Language/PureScript/Docs/RenderedCode/RenderType.hs view
@@ -13,7 +13,6 @@ import Prelude.Compat import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Text (Text) import Control.Arrow ((<+>))
src/Language/PureScript/Docs/RenderedCode/Types.hs view
@@ -49,7 +49,6 @@ import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) -import Data.Monoid ((<>)) import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray) import qualified Data.Aeson as A import Data.Text (Text)@@ -248,7 +247,7 @@ -- newtype RenderedCode = RC { unRC :: [RenderedCodeElement] }- deriving (Show, Eq, Ord, Monoid)+ deriving (Show, Eq, Ord, Semigroup, Monoid) instance A.ToJSON RenderedCode where toJSON (RC elems) = A.toJSON elems
src/Language/PureScript/Docs/Utils/MonoidExtras.hs view
@@ -6,4 +6,3 @@ mintersperse _ [] = mempty mintersperse _ [x] = x mintersperse sep (x:xs) = x <> sep <> mintersperse sep xs-
src/Language/PureScript/Environment.hs view
@@ -449,6 +449,7 @@ , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData)) , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData)) , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData))+ , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData)) , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) ]
src/Language/PureScript/Errors.hs view
@@ -186,7 +186,7 @@ -- | A stack trace for an error newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage]- } deriving (Show, Monoid)+ } deriving (Show, Semigroup, Monoid) -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool@@ -753,8 +753,12 @@ line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident) renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident- renderSimpleErrorMessage (MissingClassMember ident) =- line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented."+ 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.<> typeAsBox 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) =@@ -1405,6 +1409,8 @@ | f == primSubName C.typeError "Text" = toTypelevelString x toTypelevelString (TypeApp (TypeConstructor f) x) | f == primSubName C.typeError "Quote" = Just (typeAsBox x)+toTypelevelString (TypeApp (TypeConstructor f) (TypeLevelString x))+ | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) | f == primSubName C.typeError "Beside" = (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret
src/Language/PureScript/Errors/JSON.hs view
@@ -6,7 +6,6 @@ import qualified Data.Aeson.TH as A import qualified Data.List.NonEmpty as NEL-import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text)
src/Language/PureScript/Hierarchy.hs view
@@ -19,7 +19,6 @@ import Protolude (ordNub) import Data.List (sort)-import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Language.PureScript as P
src/Language/PureScript/Ide.hs view
@@ -94,10 +94,10 @@ Right rs' -> answerRequest outfp rs' Left question -> pure (CompletionResult (map (completionFromMatch . simpleExport . map withEmptyAnn) question))- Rebuild file actualFile ->- rebuildFileAsync file actualFile- RebuildSync file actualFile ->- rebuildFileSync file actualFile+ Rebuild file actualFile targets ->+ rebuildFileAsync file actualFile targets+ RebuildSync file actualFile targets ->+ rebuildFileSync file actualFile targets Cwd -> TextResult . T.pack <$> liftIO getCurrentDirectory Reset ->
src/Language/PureScript/Ide/Command.hs view
@@ -17,6 +17,8 @@ import Protolude import Data.Aeson+import qualified Data.Map as Map+import qualified Data.Set as Set import qualified Language.PureScript as P import Language.PureScript.Ide.CaseSplit import Language.PureScript.Ide.Completion@@ -57,8 +59,8 @@ -- Import InputFile OutputFile | Import FilePath (Maybe FilePath) [Filter] ImportCommand | List { listType :: ListType }- | Rebuild FilePath (Maybe FilePath)- | RebuildSync FilePath (Maybe FilePath)+ | Rebuild FilePath (Maybe FilePath) (Set P.CodegenTarget)+ | RebuildSync FilePath (Maybe FilePath) (Set P.CodegenTarget) | Cwd | Reset | Quit@@ -172,7 +174,11 @@ Rebuild <$> params .: "file" <*> params .:? "actualFile"+ <*> (parseCodegenTargets =<< params .:? "codegen" .!= [ "js" ]) _ -> mzero where+ parseCodegenTargets =+ maybe mzero (pure . Set.fromList) . traverse (flip Map.lookup P.codegenTargets)+ mkAnnotations True = explicitAnnotations mkAnnotations False = noAnnotations
src/Language/PureScript/Ide/Completion.hs view
@@ -11,7 +11,6 @@ import Protolude hiding ((<&>), moduleName) -import Control.Lens hiding ((&), op) import Data.Aeson import qualified Data.Map as Map import qualified Data.Text as T@@ -21,6 +20,7 @@ import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util+import Lens.Micro.Platform hiding ((&)) type Module = (P.ModuleName, [IdeDeclarationAnn])
src/Language/PureScript/Ide/Externs.hs view
@@ -21,7 +21,6 @@ import Protolude hiding (to, from, (&)) -import Control.Lens import "monad-logger" Control.Monad.Logger import Data.Aeson (decodeStrict) import Data.Aeson.Types (withObject, parseMaybe, (.:))@@ -29,6 +28,7 @@ import Data.Version (showVersion) import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types+import Lens.Micro.Platform import qualified Language.PureScript as P
src/Language/PureScript/Ide/Filter.hs view
@@ -35,7 +35,7 @@ import qualified Language.PureScript as P newtype Filter = Filter (Endo [Module])- deriving (Monoid)+ deriving (Semigroup, Monoid) type Module = (P.ModuleName, [IdeDeclarationAnn])
src/Language/PureScript/Ide/Imports.hs view
@@ -32,7 +32,6 @@ import Protolude hiding (moduleName) -import Control.Lens ((^.), (%~), ix) import Data.List (findIndex, nubBy, partition) import qualified Data.Map as Map import qualified Data.Text as T@@ -45,6 +44,7 @@ import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util+import Lens.Micro.Platform ((^.), (%~), ix) import System.IO.UTF8 (writeUTF8FileT) import qualified Text.Parsec as Parsec
src/Language/PureScript/Ide/Matcher.hs view
@@ -35,7 +35,7 @@ type ScoredMatch a = (Match a, Double) -newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid)+newtype Matcher a = Matcher (Endo [Match a]) deriving (Semigroup, Monoid) instance FromJSON (Matcher IdeDeclarationAnn) where parseJSON = withObject "matcher" $ \o -> do
src/Language/PureScript/Ide/Rebuild.hs view
@@ -42,10 +42,12 @@ -- ^ The file to rebuild -> Maybe FilePath -- ^ The file to use as the location for parsing and errors+ -> Set P.CodegenTarget+ -- ^ The targets to codegen -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ()) -- ^ A runner for the second build with open exports -> m Success-rebuildFile file actualFile runOpenBuild = do+rebuildFile file actualFile codegenTargets runOpenBuild = do input <- ideReadFile file @@ -69,7 +71,7 @@ -- Rebuild the single module using the cached externs (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ liftIO- . P.runMake P.defaultOptions+ . P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) . P.rebuildModule (buildMakeActions >>= shushProgress $ makeEnv) externs $ m case result of@@ -87,8 +89,8 @@ rebuildFileAsync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)- => FilePath -> Maybe FilePath -> m Success-rebuildFileAsync fp fp' = rebuildFile fp fp' asyncRun+ => FilePath -> Maybe FilePath -> Set P.CodegenTarget -> m Success+rebuildFileAsync fp fp' ts = rebuildFile fp fp' ts asyncRun where asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () asyncRun action = do@@ -98,8 +100,8 @@ rebuildFileSync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)- => FilePath -> Maybe FilePath -> m Success-rebuildFileSync fp fp' = rebuildFile fp fp' syncRun+ => FilePath -> Maybe FilePath -> Set P.CodegenTarget -> m Success+rebuildFileSync fp fp' ts = rebuildFile fp fp' ts syncRun where syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () syncRun action = do@@ -154,11 +156,12 @@ shushProgress ma _ = ma { P.progress = \_ -> pure () } --- | Stops any kind of codegen (also silences errors about missing or unused FFI--- files though)+-- | Stops any kind of codegen shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make shushCodegen ma MakeActionsEnv{..} =- ma { P.codegen = \_ _ _ -> pure () }+ ma { P.codegen = \_ _ _ -> pure ()+ , P.ffiCodegen = \_ -> pure ()+ } -- | Returns a topologically sorted list of dependent ExternsFiles for the given -- module. Throws an error if there is a cyclic dependency within the
src/Language/PureScript/Ide/Reexports.hs view
@@ -25,11 +25,11 @@ import Protolude hiding (moduleName) -import Control.Lens hiding ((&)) import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util+import Lens.Micro.Platform hiding ((&)) -- | Contains the module with resolved reexports, and possible failures data ReexportResult a
src/Language/PureScript/Ide/State.hs view
@@ -41,7 +41,6 @@ import Control.Arrow import Control.Concurrent.STM-import Control.Lens hiding (op, (&)) import "monad-logger" Control.Monad.Logger import qualified Data.Map.Lazy as Map import qualified Language.PureScript as P@@ -52,6 +51,7 @@ import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util+import Lens.Micro.Platform hiding ((&)) -- | Resets all State inside psc-ide resetIdeState :: Ide m => m ()@@ -329,7 +329,7 @@ mapIf matchTC (idaDeclaration . _IdeDeclTypeClass . ideTCInstances- %~ cons ideInstance)+ %~ (ideInstance :)) in acc' & ix classModule %~ updateDeclaration
src/Language/PureScript/Ide/Types.hs view
@@ -22,11 +22,11 @@ import Protolude hiding (moduleName) import Control.Concurrent.STM-import Control.Lens.TH import Data.Aeson import qualified Data.Map.Lazy as M import qualified Language.PureScript as P import qualified Language.PureScript.Errors.JSON as P+import Lens.Micro.Platform hiding ((.=)) type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a@@ -94,7 +94,41 @@ , _ideTypeOpKind :: Maybe P.Kind } deriving (Show, Eq, Ord, Generic, NFData) -makePrisms ''IdeDeclaration+_IdeDeclValue :: Traversal' IdeDeclaration IdeValue+_IdeDeclValue f (IdeDeclValue x) = map IdeDeclValue (f x)+_IdeDeclValue _ x = pure x++_IdeDeclType :: Traversal' IdeDeclaration IdeType+_IdeDeclType f (IdeDeclType x) = map IdeDeclType (f x)+_IdeDeclType _ x = pure x++_IdeDeclTypeSynonym :: Traversal' IdeDeclaration IdeTypeSynonym+_IdeDeclTypeSynonym f (IdeDeclTypeSynonym x) = map IdeDeclTypeSynonym (f x)+_IdeDeclTypeSynonym _ x = pure x++_IdeDeclDataConstructor :: Traversal' IdeDeclaration IdeDataConstructor+_IdeDeclDataConstructor f (IdeDeclDataConstructor x) = map IdeDeclDataConstructor (f x)+_IdeDeclDataConstructor _ x = pure x++_IdeDeclTypeClass :: Traversal' IdeDeclaration IdeTypeClass+_IdeDeclTypeClass f (IdeDeclTypeClass x) = map IdeDeclTypeClass (f x)+_IdeDeclTypeClass _ x = pure x++_IdeDeclValueOperator :: Traversal' IdeDeclaration IdeValueOperator+_IdeDeclValueOperator f (IdeDeclValueOperator x) = map IdeDeclValueOperator (f x)+_IdeDeclValueOperator _ x = pure x++_IdeDeclTypeOperator :: Traversal' IdeDeclaration IdeTypeOperator+_IdeDeclTypeOperator f (IdeDeclTypeOperator x) = map IdeDeclTypeOperator (f x)+_IdeDeclTypeOperator _ x = pure x++_IdeDeclKind :: Traversal' IdeDeclaration (P.ProperName 'P.KindName)+_IdeDeclKind f (IdeDeclKind x) = map IdeDeclKind (f x)+_IdeDeclKind _ x = pure x++anyOf :: Getting Any s a -> (a -> Bool) -> s -> Bool+anyOf g p = getAny . getConst . g (Const . Any . p)+ makeLenses ''IdeValue makeLenses ''IdeType makeLenses ''IdeTypeSynonym
src/Language/PureScript/Ide/Usage.hs view
@@ -8,13 +8,13 @@ import Protolude hiding (moduleName) -import Control.Lens (preview) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Language.PureScript as P import Language.PureScript.Ide.State (getAllModules, getFileState) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util+import Lens.Micro.Platform (preview) -- | -- How we find usages, given an IdeDeclaration and the module it was defined in:
src/Language/PureScript/Ide/Util.hs view
@@ -30,9 +30,8 @@ ) where import Protolude hiding (decodeUtf8,- encodeUtf8)+ encodeUtf8, to) -import Control.Lens hiding ((&), op) import Data.Aeson import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding as TLE@@ -40,6 +39,7 @@ import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types+import Lens.Micro.Platform hiding ((&)) import System.IO.UTF8 (readUTF8FileT) import System.Directory (makeAbsolute) @@ -90,14 +90,14 @@ decodeT :: (FromJSON a) => Text -> Maybe a decodeT = decode . TLE.encodeUtf8 . TL.fromStrict -properNameT :: Iso' (P.ProperName a) Text-properNameT = iso P.runProperName P.ProperName+properNameT :: Getting r (P.ProperName a) Text+properNameT = to P.runProperName -identT :: Iso' P.Ident Text-identT = iso P.runIdent P.Ident+identT :: Getting r P.Ident Text+identT = to P.runIdent -opNameT :: Iso' (P.OpName a) Text-opNameT = iso P.runOpName P.OpName+opNameT :: Getting r (P.OpName a) Text+opNameT = to P.runOpName ideReadFile' :: (MonadIO m, MonadError IdeError m)
src/Language/PureScript/Interactive.hs view
@@ -16,7 +16,6 @@ import Data.List (sort, find, foldl') import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M-import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T@@ -292,7 +291,7 @@ -> m () handleBrowse print' moduleName = do st <- get- env <- asks psciEnvironment+ let env = psciEnvironment st case findMod moduleName (psciLoadedExterns st) (psciImportedModules st) of Just qualName -> print' $ printModuleSignatures qualName env Nothing -> failNotInEnv moduleName
src/Language/PureScript/Interactive/Printer.hs view
@@ -5,7 +5,6 @@ import Data.List (intersperse) import qualified Data.Map as M import Data.Maybe (mapMaybe)-import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text) import qualified Language.PureScript as P
src/Language/PureScript/Interactive/Types.hs view
@@ -3,6 +3,7 @@ -- module Language.PureScript.Interactive.Types ( PSCiConfig(..)+ , psciEnvironment , PSCiState -- constructor is not exported, to prevent psciImports and psciExports from -- becoming inconsistent with importedModules, letBindings and loadedExterns , ImportedModule@@ -29,6 +30,7 @@ import qualified Language.PureScript as P import qualified Data.Map as M+import Data.List (foldl') import Language.PureScript.Sugar.Names.Env (nullImports, primExports) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Writer.Strict (runWriterT)@@ -38,9 +40,8 @@ -- -- These configuration values do not change during execution. ---data PSCiConfig = PSCiConfig- { psciFileGlobs :: [String]- , psciEnvironment :: P.Environment+newtype PSCiConfig = PSCiConfig+ { psciFileGlobs :: [String] } deriving Show -- | The PSCI state.@@ -78,6 +79,10 @@ initialPSCiState :: PSCiState initialPSCiState = PSCiState [] [] [] nullImports primExports +psciEnvironment :: PSCiState -> P.Environment+psciEnvironment st = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs+ where externs = map snd (psciLoadedExterns st)+ -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: --@@ -137,7 +142,7 @@ -- | Updates the loaded externs files in the state record. updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState updateLoadedExterns f (PSCiState a b x c d) =- PSCiState a b (f x) c d+ updateImportExports (PSCiState a b (f x) c d) -- | Updates the let bindings in the state record. updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState
src/Language/PureScript/Kinds.hs view
@@ -102,8 +102,8 @@ go other = f other everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r-everythingOnKinds (<>) f = go+everythingOnKinds (<>.) f = go where- go k@(Row k1) = f k <> go k1- go k@(FunKind k1 k2) = f k <> go k1 <> go k2+ go k@(Row k1) = f k <>. go k1+ go k@(FunKind k1 k2) = f k <>. go k1 <>. go k2 go other = f other
src/Language/PureScript/Label.hs view
@@ -17,6 +17,6 @@ -- because records are indexable by PureScript strings at runtime. -- newtype Label = Label { runLabel :: PSString }- deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON, Generic)+ deriving (Show, Eq, Ord, IsString, Semigroup, Monoid, A.ToJSON, A.FromJSON, Generic) instance NFData Label
src/Language/PureScript/Linter.hs view
@@ -10,7 +10,6 @@ import Data.List ((\\)) import Data.Maybe (mapMaybe)-import Data.Monoid import qualified Data.Set as S import Data.Text (Text)
src/Language/PureScript/Linter/Exhaustive.hs view
@@ -20,7 +20,6 @@ import Data.Function (on) import Data.List (foldl', sortBy) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/Make.hs view
@@ -75,6 +75,7 @@ optimized = CF.optimizeCoreFn corefn [renamed] = renameInModules [optimized] exts = moduleToExternsFile mod' env'+ ffiCodegen renamed evalSupplyT nextVar' . codegen renamed env' . encode $ exts return exts
src/Language/PureScript/Make/Actions.hs view
@@ -4,6 +4,7 @@ , Externs() , ProgressMessage(..) , buildMakeActions+ , checkForeignDecls ) where import Prelude@@ -18,13 +19,12 @@ import Data.Aeson (encode) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as LB-import qualified Data.ByteString.UTF8 as BU8+import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Data.Either (partitionEithers) import Data.Foldable (for_, minimum) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -44,7 +44,7 @@ import Language.PureScript.Make.Monad import Language.PureScript.Names import Language.PureScript.Names (runModuleName, ModuleName)-import Language.PureScript.Options+import Language.PureScript.Options hiding (codegenTargets) import qualified Language.PureScript.Parser as PSParser import Language.PureScript.Pretty.Common (SMap(..)) import qualified Paths_purescript as Paths@@ -96,6 +96,8 @@ -- path for the file. , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () -- ^ Run the code generator for the module and write any required output files.+ , ffiCodegen :: CF.Module CF.Ann -> m ()+ -- ^ Check ffi and print it in the output directory. , progress :: ProgressMessage -> m () -- ^ Respond to a progress update. }@@ -112,7 +114,7 @@ -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix =- MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen ffiCodegen progress where getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))@@ -156,12 +158,10 @@ lift $ writeTextFile coreFnFile (encode json) when (S.member JS codegenTargets) $ do foreignInclude <- case mn `M.lookup` foreigns of- Just path+ Just _ | not $ requiresForeign m -> do- tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path return Nothing | otherwise -> do- checkForeignDecls m path return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing@@ -169,7 +169,6 @@ dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory let sourceMaps = S.member JSSourceMap codegenTargets (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])- foreignFile = outputFilename mn "foreign.js" jsFile = targetFilename mn JS mapFile = targetFilename mn JSSourceMap prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]@@ -177,9 +176,24 @@ mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" lift $ do writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)- for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + ffiCodegen :: CF.Module CF.Ann -> Make ()+ ffiCodegen m = do+ codegenTargets <- asks optionsCodegenTargets+ when (S.member JS codegenTargets) $ do+ let mn = CF.moduleName m+ foreignFile = outputFilename mn "foreign.js"+ case mn `M.lookup` foreigns of+ Just path+ | not $ requiresForeign m ->+ tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path+ | otherwise ->+ checkForeignDecls m path+ Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn+ | otherwise -> return ()+ for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)+ genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)@@ -227,10 +241,10 @@ -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module.-checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()+checkForeignDecls :: CF.Module ann -> FilePath -> Make () checkForeignDecls m path = do- jsStr <- lift $ readTextFile path- js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path+ jsStr <- readTextFile path+ js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (LBU8.toString jsStr) path foreignIdentsStrs <- either errorParsingModule pure $ getExps js foreignIdents <- either@@ -253,13 +267,13 @@ mname = CF.moduleName m modSS = CF.moduleSourceSpan m - errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a+ errorParsingModule :: Bundle.ErrorMessage -> Make a errorParsingModule = throwError . errorMessage' modSS . ErrorParsingFFIModule path . Just getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) - errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a+ errorInvalidForeignIdentifiers :: [String] -> Make a errorInvalidForeignIdentifiers = throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)
src/Language/PureScript/Names.hs view
@@ -16,7 +16,6 @@ import GHC.Generics (Generic) import Data.Aeson import Data.Aeson.TH-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/Options.hs view
@@ -3,6 +3,8 @@ import Prelude.Compat import qualified Data.Set as S+import Data.Map (Map)+import qualified Data.Map as Map -- | The data type of compiler options data Options = Options@@ -20,3 +22,10 @@ data CodegenTarget = JS | JSSourceMap | CoreFn deriving (Eq, Ord, Show)++codegenTargets :: Map String CodegenTarget+codegenTargets = Map.fromList+ [ ("js", JS)+ , ("sourcemaps", JSSourceMap)+ , ("corefn", CoreFn)+ ]
src/Language/PureScript/PSString.hs view
@@ -21,7 +21,6 @@ import Data.Char (chr) import Data.Bits (shiftR) import Data.List (unfoldr)-import Data.Monoid ((<>)) import Data.Scientific (toBoundedInteger) import Data.String (IsString(..)) import Data.ByteString (ByteString)@@ -52,7 +51,7 @@ -- and arrays of UTF-16 code units (integers) otherwise. -- newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }- deriving (Eq, Ord, Monoid, Generic)+ deriving (Eq, Ord, Semigroup, Monoid, Generic) instance NFData PSString
src/Language/PureScript/Parser/Common.hs view
@@ -6,7 +6,6 @@ import Control.Applicative ((<|>)) import Control.Monad (guard) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.SourcePos
src/Language/PureScript/Parser/Declarations.hs view
@@ -25,7 +25,6 @@ import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST
src/Language/PureScript/Parser/Lexer.hs view
@@ -70,7 +70,6 @@ import Control.Monad (void, guard) import Control.Monad.Identity (Identity) import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)-import Data.Monoid ((<>)) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T
src/Language/PureScript/Pretty/Common.hs view
@@ -10,7 +10,6 @@ import Control.Monad.State (StateT, modify, get) import Data.List (elemIndices, intersperse)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.Char (isUpper)@@ -55,11 +54,12 @@ -- appropriately and advancing source mappings on the right hand side to account for -- the length of the left. --+instance Semigroup StrPos where+ StrPos (a,b,c) <> StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c'))+ instance Monoid StrPos where mempty = StrPos (SourcePos 0 0, "", []) - StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c'))- mconcat ms = let s' = foldMap (\(StrPos(_, s, _)) -> s) ms (p, maps) = foldl plus (SourcePos 0 0, []) ms@@ -88,7 +88,7 @@ mapping = SMap (T.pack file) startPos zeroPos zeroPos = SourcePos 0 0 -newtype PlainString = PlainString Text deriving Monoid+newtype PlainString = PlainString Text deriving (Semigroup, Monoid) runPlainString :: PlainString -> Text runPlainString (PlainString s) = s
src/Language/PureScript/Pretty/Kinds.hs view
@@ -10,7 +10,6 @@ import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows as PA -import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Text (Text)
src/Language/PureScript/Pretty/Types.hs view
@@ -14,7 +14,7 @@ , prettyPrintObjectKey ) where -import Prelude.Compat+import Prelude.Compat hiding ((<>)) import Control.Arrow ((<+>)) import Control.PatternArrows as PA
src/Language/PureScript/Pretty/Values.hs view
@@ -7,7 +7,7 @@ , prettyPrintBinderAtom ) where -import Prelude.Compat+import Prelude.Compat hiding ((<>)) import Control.Arrow (second)
src/Language/PureScript/Publish.hs view
@@ -36,7 +36,8 @@ import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Version-import qualified Data.SPDX as SPDX+import qualified Distribution.SPDX as SPDX+import qualified Distribution.Parsec.Class as CabalParsec import System.Directory (doesFileExist) import System.FilePath.Glob (globDir1)@@ -230,7 +231,11 @@ -- Check if a string is a valid SPDX license expression. -- isValidSPDX :: String -> Bool-isValidSPDX = (== 1) . length . SPDX.parseExpression+isValidSPDX input = case CabalParsec.simpleParsec input of+ Nothing -> False+ Just SPDX.NONE -> False+ Just _ -> True+ extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo) extractGithub = stripGitHubPrefixes
src/Language/PureScript/Publish/ErrorsWarnings.hs view
@@ -311,11 +311,12 @@ } deriving (Show, Eq, Ord) +instance Semigroup CollectedWarnings where+ (CollectedWarnings as bs cs d es) <> (CollectedWarnings as' bs' cs' d' es') =+ CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es')+ instance Monoid CollectedWarnings where mempty = CollectedWarnings mempty mempty mempty mempty mempty- mappend (CollectedWarnings as bs cs d es)- (CollectedWarnings as' bs' cs' d' es') =- CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es') collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular
src/Language/PureScript/Renamer.hs view
@@ -10,7 +10,6 @@ import Data.List (find) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M-import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -25,46 +25,47 @@ -- | Desugar a single do statement desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration desugarDo d =- let (f, _, _) = everywhereOnValuesM return replace return- in rethrowWithPosition (declSourceSpan d) $ f d+ let ss = declSourceSpan d+ (f, _, _) = everywhereOnValuesM return (replace ss) return+ in rethrowWithPosition ss $ f d where- bind :: Expr- bind = Var nullSourceSpan (Qualified Nothing (Ident C.bind))+ bind :: SourceSpan -> Expr+ bind = flip Var (Qualified Nothing (Ident C.bind)) - discard :: Expr- discard = Var nullSourceSpan (Qualified Nothing (Ident C.discard))+ discard :: SourceSpan -> Expr+ discard = flip Var (Qualified Nothing (Ident C.discard)) - replace :: Expr -> m Expr- replace (Do els) = go els- replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)- replace other = return other+ replace :: SourceSpan -> Expr -> m Expr+ replace pos (Do els) = go pos els+ replace _ (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace pos v)+ replace _ other = return other - go :: [DoNotationElement] -> m Expr- go [] = internalError "The impossible happened in desugarDo"- go [DoNotationValue val] = return val- go (DoNotationValue val : rest) = do- rest' <- go rest- return $ App (App discard val) (Abs (VarBinder nullSourceSpan UnusedIdent) rest')- go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind- go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) =+ go :: SourceSpan -> [DoNotationElement] -> m Expr+ go _ [] = internalError "The impossible happened in desugarDo"+ go _ [DoNotationValue val] = return val+ go pos (DoNotationValue val : rest) = do+ rest' <- go pos rest+ return $ App (App (discard pos) val) (Abs (VarBinder pos UnusedIdent) rest')+ go _ [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind+ go _ (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) where fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) fromIdent _ = mempty- go (DoNotationBind (VarBinder ss ident) val : rest) = do- rest' <- go rest- return $ App (App bind val) (Abs (VarBinder ss ident) rest')- go (DoNotationBind binder val : rest) = do- rest' <- go rest+ go pos (DoNotationBind (VarBinder ss ident) val : rest) = do+ rest' <- go pos rest+ return $ App (App (bind pos) val) (Abs (VarBinder ss ident) rest')+ go pos (DoNotationBind binder val : rest) = do+ rest' <- go pos rest ident <- freshIdent'- return $ App (App bind val) (Abs (VarBinder nullSourceSpan ident) (Case [Var nullSourceSpan (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']]))- go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet- go (DoNotationLet ds : rest) = do+ return $ App (App (bind pos) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']]))+ go _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet+ go pos (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _) | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds- rest' <- go rest+ rest' <- go pos rest return $ Let FromLet ds rest'- go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)+ go _ (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go pos (el : rest)
src/Language/PureScript/Sugar/Names/Env.hs view
@@ -32,6 +32,7 @@ import Data.Foldable (find) import Data.List (groupBy, sortBy, delete) import Data.Maybe (fromJust, mapMaybe)+import Safe (headMay) import qualified Data.Map as M import qualified Data.Set as S @@ -469,8 +470,9 @@ in if length groups > 1 then case nonImplicit of- [ImportRecord (Qualified (Just mnNew) _) mnOrig ss' _] -> do+ [ImportRecord (Qualified (Just mnNew) _) mnOrig _ _] -> do let warningModule = if mnNew == currentModule then Nothing else Just mnNew+ ss' = maybe nullSourceSpan importSourceSpan . headMay . filter ((== FromImplicit) . importProvenance) $ xs tell . errorMessage' ss' $ ScopeShadowing name warningModule $ delete mnNew conflictModules return (mnNew, mnOrig) _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules
src/Language/PureScript/Sugar/Names/Exports.hs view
@@ -147,6 +147,7 @@ -- values if that fails to see whether the value has been imported at all. testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool testQuals f mn' = any (isQualifiedWith mn') (f (importedTypes imps))+ || any (isQualifiedWith mn') (f (importedTypeOps imps)) || any (isQualifiedWith mn') (f (importedDataConstructors imps)) || any (isQualifiedWith mn') (f (importedTypeClasses imps)) || any (isQualifiedWith mn') (f (importedValues imps))
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -14,9 +14,11 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class-import Data.List ((\\), find, sortBy)+import Data.List (find, sortBy) import qualified Data.Map as M import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe)+import qualified Data.List.NonEmpty as NEL+import qualified Data.Set as S import Data.Text (Text) import qualified Language.PureScript.Constants as C import Language.PureScript.Crash@@ -285,12 +287,14 @@ maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m - case map fst typeClassMembers \\ mapMaybe declIdent decls of- member : _ -> throwError . errorMessage' ss $ MissingClassMember member- [] -> do- -- Replace the type arguments with the appropriate types in the member types- let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers+ -- Replace the type arguments with the appropriate types in the member types+ let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers + let declaredMembers = S.fromList $ mapMaybe declIdent decls++ case filter (\(ident, _) -> not $ S.member ident declaredMembers) memberTypes of+ hd : tl -> throwError . errorMessage' ss $ MissingClassMember (hd NEL.:| tl)+ [] -> do -- Create values for the type instance members members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs view
@@ -12,7 +12,6 @@ import Data.Foldable (for_) import Data.List (foldl', find, sortBy, unzip5) import qualified Data.Map as M-import Data.Monoid ((<>)) import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (comparing) import qualified Data.Set as S@@ -42,13 +41,15 @@ -- ^ A list of newtype instances which were derived in this module. } deriving Show -instance Monoid NewtypeDerivedInstances where- mempty = NewtypeDerivedInstances mempty mempty- mappend x y =+instance Semigroup NewtypeDerivedInstances where+ x <> y = NewtypeDerivedInstances { ndiClasses = ndiClasses x <> ndiClasses y , ndiDerivedInstances = ndiDerivedInstances x <> ndiDerivedInstances y } +instance Monoid NewtypeDerivedInstances where+ mempty = NewtypeDerivedInstances mempty mempty+ -- | Extract the name of the newtype appearing in the last type argument of -- a derived newtype instance. --@@ -201,7 +202,7 @@ -> m Expr deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do verifySuperclasses- tyCon <- findTypeDecl tyConNm ds+ tyCon <- findTypeDecl ss tyConNm ds go tyCon where go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) = do@@ -287,7 +288,7 @@ -> m ([Declaration], Type) deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do checkIsWildcard ss tyConNm repTy- go =<< findTypeDecl tyConNm ds+ go =<< findTypeDecl ss tyConNm ds where go :: Declaration -> m ([Declaration], Type) go (DataDeclaration (ss', _) _ _ args dctors) = do@@ -440,7 +441,7 @@ -> ProperName 'TypeName -> m [Declaration] deriveEq ss mn syns ds tyConNm = do- tyCon <- findTypeDecl tyConNm ds+ tyCon <- findTypeDecl ss tyConNm ds eqFun <- mkEqFunction tyCon return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] where@@ -508,7 +509,7 @@ -> ProperName 'TypeName -> m [Declaration] deriveOrd ss mn syns ds tyConNm = do- tyCon <- findTypeDecl tyConNm ds+ tyCon <- findTypeDecl ss tyConNm ds compareFun <- mkCompareFunction tyCon return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] where@@ -612,7 +613,7 @@ -> m ([Declaration], Type) deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do checkIsWildcard ss tyConNm unwrappedTy- go =<< findTypeDecl tyConNm ds+ go =<< findTypeDecl ss tyConNm ds where go :: Declaration -> m ([Declaration], Type) go (DataDeclaration (ss', _) Data name _ _) =@@ -639,10 +640,11 @@ findTypeDecl :: (MonadError MultipleErrors m)- => ProperName 'TypeName+ => SourceSpan+ -> ProperName 'TypeName -> [Declaration] -> m Declaration-findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl+findTypeDecl ss tyConNm = maybe (throwError . errorMessage' ss $ CannotFindDerivingType tyConNm) return . find isTypeDecl where isTypeDecl :: Declaration -> Bool isTypeDecl (DataDeclaration _ _ nm _ _) | nm == tyConNm = True@@ -692,7 +694,7 @@ -> ProperName 'TypeName -> m [Declaration] deriveFunctor ss mn syns ds tyConNm = do- tyCon <- findTypeDecl tyConNm ds+ tyCon <- findTypeDecl ss tyConNm ds mapFun <- mkMapFunction tyCon return [ ValueDecl (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] where
src/Language/PureScript/TypeChecker.hs view
@@ -17,12 +17,10 @@ import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..))-import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_, toList) import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M@@ -42,6 +40,8 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types++import Lens.Micro.Platform ((^..), _1, _2) addDataType :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
src/Language/PureScript/TypeChecker/Entailment.hs view
@@ -135,13 +135,14 @@ | Unknown deriving (Eq, Show, Functor) +instance Semigroup t => Semigroup (Matched t) where+ (Match l) <> (Match r) = Match (l <> r)+ Apart <> _ = Apart+ _ <> Apart = Apart+ _ <> _ = Unknown+ instance Monoid t => Monoid (Matched t) where mempty = Match mempty-- mappend (Match l) (Match r) = Match (l <> r)- mappend Apart _ = Apart- mappend _ Apart = Apart- mappend _ _ = Unknown -- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference.
src/Language/PureScript/TypeChecker/Skolems.hs view
@@ -14,7 +14,6 @@ import Control.Monad.State.Class (MonadState(..), gets, modify) import Data.Foldable (traverse_) import Data.Functor.Identity (Identity(), runIdentity)-import Data.Monoid import Data.Set (Set, fromList, notMember) import Data.Text (Text) import Language.PureScript.AST
src/Language/PureScript/TypeChecker/Types.hs view
@@ -39,7 +39,6 @@ import Data.Functor (($>)) import Data.List (transpose, (\\), partition, delete) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Traversable (for) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M
src/Language/PureScript/TypeClassDictionaries.hs view
@@ -7,7 +7,6 @@ import GHC.Generics (Generic) import Control.DeepSeq (NFData)-import Data.Monoid ((<>)) import Data.Text (Text, pack) import Language.PureScript.Names
src/Language/PureScript/Types.hs view
@@ -18,7 +18,6 @@ import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic)
stack.yaml view
@@ -1,4 +1,8 @@-resolver: lts-11.7+resolver: lts-12.0 packages: - '.' extra-deps:+nix:+ enable: false+ packages:+ - zlib
tests/Language/PureScript/Ide/CompletionSpec.hs view
@@ -4,7 +4,8 @@ import Protolude -import Language.PureScript as P+import qualified Data.Set as Set+import qualified Language.PureScript as P import Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Completion@@ -30,7 +31,7 @@ load = LoadSync . map Test.mn rebuildSync :: FilePath -> Command-rebuildSync fp = RebuildSync ("src" </> fp) Nothing+rebuildSync fp = RebuildSync ("src" </> fp) Nothing (Set.singleton P.JS) spec :: Spec spec = describe "Applying completion options" $ do
tests/Language/PureScript/Ide/RebuildSpec.hs view
@@ -4,6 +4,8 @@ import Protolude +import qualified Data.Set as Set+import qualified Language.PureScript as P import Language.PureScript.AST.SourcePos (spanName) import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion@@ -11,16 +13,20 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript.Ide.Test as Test import System.FilePath+import System.Directory (doesFileExist, removePathForcibly) import Test.Hspec +defaultTarget :: Set P.CodegenTarget+defaultTarget = Set.singleton P.JS+ load :: [Text] -> Command load = LoadSync . map Test.mn rebuild :: FilePath -> Command-rebuild fp = Rebuild ("src" </> fp) Nothing+rebuild fp = Rebuild ("src" </> fp) Nothing defaultTarget rebuildSync :: FilePath -> Command-rebuildSync fp = RebuildSync ("src" </> fp) Nothing+rebuildSync fp = RebuildSync ("src" </> fp) Nothing defaultTarget spec :: Spec spec = describe "Rebuilding single modules" $ do@@ -67,6 +73,20 @@ Test.runIde' editorConfig emptyIdeState- [ RebuildSync ("src" </> "RebuildSpecWithHiddenIdent.purs") (Just "actualFile")+ [ RebuildSync ("src" </> "RebuildSpecWithHiddenIdent.purs") (Just "actualFile") defaultTarget , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] map spanName (complLocation result) `shouldBe` Just "actualFile"+ it "doesn't produce JS when an empty target list is supplied" $ do+ exists <- Test.inProject $ do+ let indexJs = "output" </> "RebuildSpecSingleModule" </> "index.js"+ removePathForcibly ("output" </> "RebuildSpecSingleModule")+ _ <- Test.runIde [ RebuildSync ("src" </> "RebuildSpecSingleModule.purs") Nothing Set.empty ]+ doesFileExist indexJs+ exists `shouldBe` False+ it "does produce corefn if it's a codegen target" $ do+ exists <- Test.inProject $ do+ let corefn = "output" </> "RebuildSpecSingleModule" </> "corefn.json"+ removePathForcibly ("output" </> "RebuildSpecSingleModule")+ _ <- Test.runIde [ RebuildSync ("src" </> "RebuildSpecSingleModule.purs") Nothing (Set.singleton P.CoreFn) ]+ doesFileExist corefn+ exists `shouldBe` True
tests/Language/PureScript/Ide/StateSpec.hs view
@@ -3,11 +3,11 @@ module Language.PureScript.Ide.StateSpec where import Protolude-import Control.Lens hiding ((&)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.State import Language.PureScript.Ide.Test import qualified Language.PureScript as P+import Lens.Micro.Platform hiding ((&)) import Test.Hspec import qualified Data.Map as Map @@ -91,7 +91,7 @@ it "resolves an instance for an existing type class" $ do resolveInstances (Map.singleton (mn "InstanceModule") ef) moduleMap `shouldSatisfy`- elemOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) ideInstance+ anyOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) (ideInstance ==) describe "resolving data constructors" $ do it "resolves a constructor" $ do resolveDataConstructorsForModule (snd testModule)
tests/TestCompiler.hs view
@@ -40,7 +40,6 @@ import Control.Arrow ((***), (>>>)) import Control.Monad.Reader-import Control.Monad.Writer.Strict import Control.Monad.Trans.Except import System.Exit@@ -234,13 +233,25 @@ checkPositioned :: P.MultipleErrors -> Maybe String checkPositioned errs =- case mapMaybe (\err -> maybe (Just err) (const Nothing) (P.errorSpan err)) (P.runMultipleErrors errs) of+ case mapMaybe guardSpans (P.runMultipleErrors errs) of [] -> Nothing errs' -> Just $ "Found errors 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 err++ isNonsenseSpan :: P.SourceSpan -> Bool+ isNonsenseSpan (P.SourceSpan spanName spanStart spanEnd) =+ spanName == "" || spanName == "<module>" || (spanStart == emptyPos && spanEnd == emptyPos)++ emptyPos :: P.SourcePos+ emptyPos = P.SourcePos 0 0 assertCompiles :: [P.Module]
tests/TestCoreFn.hs view
@@ -9,7 +9,7 @@ import Prelude.Compat import Data.Aeson-import Data.Aeson.Types+import Data.Aeson.Types as Aeson import Data.Version import Language.PureScript.AST.Literals@@ -37,7 +37,7 @@ in snd <$> parseModule (moduleToJSON v m) isSuccess :: Result a -> Bool-isSuccess (Success _) = True+isSuccess (Aeson.Success _) = True isSuccess _ = False spec :: Spec@@ -52,42 +52,42 @@ r `shouldSatisfy` isSuccess case r of Error _ -> return ()- Success m -> moduleName m `shouldBe` mn+ Aeson.Success m -> moduleName m `shouldBe` mn specify "should parse source span" $ do let r = parseMod $ Module ss [] mn mp [] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return ()- Success m -> moduleSourceSpan m `shouldBe` ss+ Aeson.Success m -> moduleSourceSpan m `shouldBe` ss specify "should parse module path" $ do let r = parseMod $ Module ss [] mn mp [] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return ()- Success m -> modulePath m `shouldBe` mp+ Aeson.Success m -> modulePath m `shouldBe` mp specify "should parse imports" $ do let r = parseMod $ Module ss [] mn mp [(ann, mn)] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return ()- Success m -> moduleImports m `shouldBe` [(ann, mn)]+ Aeson.Success m -> moduleImports m `shouldBe` [(ann, mn)] specify "should parse exports" $ do let r = parseMod $ Module ss [] mn mp [] [Ident "exp"] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return ()- Success m -> moduleExports m `shouldBe` [Ident "exp"]+ Aeson.Success m -> moduleExports m `shouldBe` [Ident "exp"] specify "should parse foreign" $ do let r = parseMod $ Module ss [] mn mp [] [] [Ident "exp"] [] r `shouldSatisfy` isSuccess case r of Error _ -> return ()- Success m -> moduleForeign m `shouldBe` [Ident "exp"]+ Aeson.Success m -> moduleForeign m `shouldBe` [Ident "exp"] context "Expr" $ do specify "should parse literals" $ do
tests/TestPrimDocs.hs view
@@ -3,7 +3,6 @@ import Prelude import Control.Monad-import Data.Monoid ((<>)) import Data.List ((\\)) import qualified Data.Map as Map import qualified Data.Set as Set
tests/TestPsci/CommandTest.hs view
@@ -1,10 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+ module TestPsci.CommandTest where import Prelude () import Prelude.Compat +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (get)+import Language.PureScript (moduleNameFromString) import Language.PureScript.Interactive+import System.FilePath ((</>))+import System.Directory (getCurrentDirectory) import Test.Hspec import TestPsci.TestEnv @@ -42,5 +48,20 @@ ":complete M.a" `prints` unlines ["M.ap", "M.apply"] specPSCi ":browse" $ do+ ":browse Data.Void" `printed` flip shouldContain "data Void"+ ":browse Data.Void" `printed` flip shouldContain "absurd ::"++ specPSCi ":reload, :browse" $ do+ cwd <- liftIO getCurrentDirectory+ let new = cwd </> "tests" </> "support" </> "psci" </> "Reload.edit"++ ":browse Reload" `printed` flip shouldContain "reload ::"+ ":browse Reload" `printed` flip shouldNotContain "edited ::"++ simulateModuleEdit (moduleNameFromString "Reload") new $ do+ run ":reload"+ ":browse Reload" `printed` flip shouldNotContain "reload ::"+ ":browse Reload" `printed` flip shouldContain "edited ::"+ ":browse Mirp" `printed` flip shouldContain "is not valid" ":browse Prim" `printed` flip shouldContain "class Partial"
tests/TestPsci/CompletionTest.hs view
@@ -34,12 +34,12 @@ , (":b", [":browse"]) -- :browse should complete module names- , (":b Eff", map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"])- , (":b Effect.", map (":b Effect" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"])+ , (":b Eff", map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])+ , (":b Effect.", map (":b Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) -- import should complete module names- , ("import Eff", map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"])- , ("import Effect.", map ("import Effect" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"])+ , ("import Eff", map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"])+ , ("import Effect.", map ("import Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) -- :quit, :help, :reload, :clear should not complete , (":help ", [])
tests/TestPsci/TestEnv.hs view
@@ -1,16 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+ module TestPsci.TestEnv where import Prelude () import Prelude.Compat -import Control.Monad (void)+import Control.Exception.Lifted (bracket_)+import Control.Monad (void, when) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS.Strict (evalRWST, RWST)+import Control.Monad.Trans.RWS.Strict (evalRWST, asks, local, RWST)+import Data.List (isSuffixOf)+import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.Interactive-import System.Directory (getCurrentDirectory)+import System.Directory (getCurrentDirectory, doesPathExist, removeFile) import System.Exit-import System.FilePath ((</>))+import System.FilePath ((</>), pathSeparator) import qualified System.FilePath.Glob as Glob import System.Process (readProcessWithExitCode) import Test.Hspec (shouldBe, Expectation)@@ -23,9 +28,10 @@ initTestPSCiEnv = do -- Load test support packages cwd <- getCurrentDirectory- let supportDir = cwd </> "tests" </> "support" </> "bower_components"- let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir- pursFiles <- supportFiles "purs"+ let supportDir = cwd </> "tests" </> "support"+ psciFiles <- Glob.globDir1 (Glob.compile "**/*.purs") (supportDir </> "psci")+ libraries <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") (supportDir </> "bower_components")+ let pursFiles = psciFiles ++ libraries modulesOrError <- loadAllModules pursFiles case modulesOrError of Left err ->@@ -35,8 +41,8 @@ makeResultOrError <- runMake . make $ modules case makeResultOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure- Right (externs, env) ->- return (updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState, PSCiConfig pursFiles env)+ Right (externs, _) ->+ return (updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState, PSCiConfig pursFiles) -- | Execute a TestPSCi, returning IO execTestPSCi :: TestPSCi a -> IO a@@ -71,9 +77,8 @@ -- | Run a PSCi command, evaluate compiled JS, and ignore evaluation output and printed output run :: String -> TestPSCi ()-run comm = runAndEval comm evalJsAndIgnore ignorePrinted+run comm = runAndEval comm (void jsEval) ignorePrinted where- evalJsAndIgnore = jsEval *> return () ignorePrinted _ = return () -- | A lifted evaluation of Hspec 'shouldBe' for the TestPSCi@@ -95,3 +100,29 @@ printed :: String -> (String -> Expectation) -> TestPSCi () printed command f = runAndEval command (void jsEval) (liftIO . f)++simulateModuleEdit :: P.ModuleName -> FilePath -> TestPSCi a -> TestPSCi a+simulateModuleEdit mn newPath action = do+ ms <- asks psciFileGlobs+ case replacePath ms of+ Nothing -> fail $ "Did not find " ++ inputPath ++ " in psciFileGlobs"+ Just xs' -> local (\c -> c { psciFileGlobs = xs' }) temporarily <* rebuild++ where+ outputPath = modulesDir </> T.unpack (P.runModuleName mn) </> "index.js"+ inputPath = T.unpack (T.replace "." slash (P.runModuleName mn)) ++ ".purs"+ slash = T.singleton pathSeparator++ replacePath :: [String] -> Maybe [String]+ replacePath (x:xs)+ | inputPath `isSuffixOf` x = Just (newPath : xs)+ | otherwise = fmap (x:) (replacePath xs)+ replacePath [] = Nothing++ -- Simply adding the file to `PSCiConfig.fileGlobs` isn't sufficient; running+ -- ":reload" might not rebuild because the compiled JS artifact has a more+ -- recent timestamp than the "new" source file `newPath`.+ temporarily = bracket_ enableRebuild enableRebuild action+ enableRebuild = liftIO $ do { b <- doesPathExist outputPath; when b (removeFile outputPath) }+ rebuild = handleCommand discard (return ()) discard ReloadState+ discard _ = return ()
tests/TestUtils.hs view
@@ -66,10 +66,12 @@ getSupportModuleTuples :: IO [(FilePath, P.Module)] getSupportModuleTuples = do cd <- getCurrentDirectory- let supportDir = cd </> "tests" </> "support" </> "bower_components"- supportPurs <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") supportDir- supportPursFiles <- readInput supportPurs- modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id supportPursFiles+ let supportDir = cd </> "tests" </> "support"+ psciFiles <- Glob.globDir1 (Glob.compile "**/*.purs") (supportDir </> "psci")+ libraries <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") (supportDir </> "bower_components")+ let pursFiles = psciFiles ++ libraries+ fileContents <- readInput pursFiles+ modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id fileContents case modules of Right ms -> return ms Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
+ tests/purs/failing/3405.purs view
@@ -0,0 +1,8 @@+-- @shouldFailWith CannotFindDerivingType+module Main where++import Prelude++type Something = Int++derive instance eqSomething ∷ Eq Something
tests/purs/failing/MissingClassMember.purs view
@@ -1,11 +1,10 @@ -- @shouldFailWith MissingClassMember module Main where -import Prelude- class A a where a :: a -> String b :: a -> Number+ c :: forall f. a -> f a instance aString :: A String where a s = s
+ tests/purs/passing/3388.purs view
@@ -0,0 +1,10 @@+module Main where++import Prelude+import Effect.Console (log)++main = do+ let+ x = { a: 42, b: "foo" }+ { a, b } = x { a = 43 }+ log "Done"
+ tests/purs/passing/3410.purs view
@@ -0,0 +1,11 @@+module Main+ ( module Prelude+ , module DEN+ , main+ ) where++import Prelude+import Data.Either.Nested (type (\/)) as DEN+import Effect.Console (log)++main = log "Done"
+ tests/purs/warning/CustomWarning4.purs view
@@ -0,0 +1,31 @@+-- @shouldWarnWith UserDefinedWarning+-- @shouldWarnWith UserDefinedWarning+-- @shouldWarnWith UserDefinedWarning+-- @shouldWarnWith UserDefinedWarning+module Main where++import Prim.TypeError (class Warn, Beside, QuoteLabel, Text)+import Prim+import Type.Row (class RowToList, Cons, Nil)++data Label (l :: Symbol) = Label++baz ::+ forall row label typ.+ RowToList row (Cons label typ Nil) =>+ Warn (Beside (Text "Custom label ") (QuoteLabel label)) =>+ Record row ->+ String+baz _ = ""++baz' :: String+baz' = baz { hello: 1 }++baz'' :: String+baz'' = baz { "hello": 1 }++baz''' :: String+baz''' = baz { "h e l l o": 1 }++baz'''' :: String+baz'''' = baz { "hel\"lo": 1 }
tests/support/bower.json view
@@ -1,77 +1,40 @@ { "name": "purescript-test-suite-support", "dependencies": {- "purescript-arrays": "purescript/purescript-arrays#compiler/0.12",- "purescript-assert": "purescript/purescript-assert#compiler/0.12",- "purescript-bifunctors": "purescript/purescript-bifunctors#compiler/0.12",- "purescript-console": "purescript/purescript-console#compiler/0.12",- "purescript-control": "purescript/purescript-control#compiler/0.12",- "purescript-distributive": "purescript/purescript-distributive#compiler/0.12",- "purescript-effect": "purescript/purescript-effect#compiler/0.12",- "purescript-either": "purescript/purescript-either#compiler/0.12",- "purescript-foldable-traversable": "purescript/purescript-foldable-traversable#compiler/0.12",- "purescript-functions": "purescript/purescript-functions#compiler/0.12",- "purescript-gen": "purescript/purescript-gen#compiler/0.12",- "purescript-generics-rep": "purescript/purescript-generics-rep#compiler/0.12",- "purescript-globals": "purescript/purescript-globals#compiler/0.12",- "purescript-identity": "purescript/purescript-identity#compiler/0.12",- "purescript-integers": "purescript/purescript-integers#compiler/0.12",- "purescript-invariant": "purescript/purescript-invariant#compiler/0.12",- "purescript-lazy": "purescript/purescript-lazy#compiler/0.12",- "purescript-lists": "purescript/purescript-lists#compiler/0.12",- "purescript-math": "purescript/purescript-math#compiler/0.12",- "purescript-maybe": "purescript/purescript-maybe#compiler/0.12",- "purescript-newtype": "purescript/purescript-newtype#compiler/0.12",- "purescript-nonempty": "purescript/purescript-nonempty#compiler/0.12",- "purescript-partial": "purescript/purescript-partial#compiler/0.12",- "purescript-prelude": "purescript/purescript-prelude#compiler/0.12",- "purescript-proxy": "purescript/purescript-proxy#compiler/0.12",- "purescript-psci-support": "purescript/purescript-psci-support#compiler/0.12",- "purescript-refs": "purescript/purescript-refs#compiler/0.12",- "purescript-st": "purescript/purescript-st#compiler/0.12",- "purescript-strings": "purescript/purescript-strings#compiler/0.12",- "purescript-tailrec": "purescript/purescript-tailrec#compiler/0.12",- "purescript-tuples": "purescript/purescript-tuples#compiler/0.12",- "purescript-type-equality": "purescript/purescript-type-equality#compiler/0.12",- "purescript-typelevel-prelude": "purescript/purescript-typelevel-prelude#compiler/0.12",- "purescript-unfoldable": "purescript/purescript-unfoldable#compiler/0.12",- "purescript-unsafe-coerce": "purescript/purescript-unsafe-coerce#compiler/0.12"- },- "resolutions": {- "purescript-arrays": "compiler/0.12",- "purescript-assert": "compiler/0.12",- "purescript-bifunctors": "compiler/0.12",- "purescript-console": "compiler/0.12",- "purescript-control": "compiler/0.12",- "purescript-distributive": "compiler/0.12",- "purescript-effect": "compiler/0.12",- "purescript-either": "compiler/0.12",- "purescript-foldable-traversable": "compiler/0.12",- "purescript-functions": "compiler/0.12",- "purescript-gen": "compiler/0.12",- "purescript-generics-rep": "compiler/0.12",- "purescript-globals": "compiler/0.12",- "purescript-identity": "compiler/0.12",- "purescript-integers": "compiler/0.12",- "purescript-invariant": "compiler/0.12",- "purescript-lazy": "compiler/0.12",- "purescript-lists": "compiler/0.12",- "purescript-math": "compiler/0.12",- "purescript-maybe": "compiler/0.12",- "purescript-newtype": "compiler/0.12",- "purescript-nonempty": "compiler/0.12",- "purescript-partial": "compiler/0.12",- "purescript-prelude": "compiler/0.12",- "purescript-proxy": "compiler/0.12",- "purescript-psci-support": "compiler/0.12",- "purescript-refs": "compiler/0.12",- "purescript-st": "compiler/0.12",- "purescript-strings": "compiler/0.12",- "purescript-tailrec": "compiler/0.12",- "purescript-tuples": "compiler/0.12",- "purescript-type-equality": "compiler/0.12",- "purescript-typelevel-prelude": "compiler/0.12",- "purescript-unfoldable": "compiler/0.12",- "purescript-unsafe-coerce": "compiler/0.12"+ "purescript-arrays": "5.0.0",+ "purescript-assert": "4.0.0",+ "purescript-bifunctors": "4.0.0",+ "purescript-console": "4.1.0",+ "purescript-control": "4.0.0",+ "purescript-distributive": "4.0.0",+ "purescript-effect": "2.0.0",+ "purescript-either": "4.0.0",+ "purescript-foldable-traversable": "4.0.0",+ "purescript-functions": "4.0.0",+ "purescript-gen": "2.0.0",+ "purescript-generics-rep": "6.0.0",+ "purescript-globals": "4.0.0",+ "purescript-identity": "4.0.0",+ "purescript-integers": "4.0.0",+ "purescript-invariant": "4.0.0",+ "purescript-lazy": "4.0.0",+ "purescript-lists": "5.0.0",+ "purescript-math": "2.1.1",+ "purescript-maybe": "4.0.0",+ "purescript-newtype": "3.0.0",+ "purescript-nonempty": "5.0.0",+ "purescript-partial": "2.0.0",+ "purescript-prelude": "4.0.0",+ "purescript-proxy": "3.0.0",+ "purescript-psci-support": "4.0.0",+ "purescript-refs": "4.1.0",+ "purescript-st": "4.0.0",+ "purescript-strings": "4.0.0",+ "purescript-tailrec": "4.0.0",+ "purescript-tuples": "5.0.0",+ "purescript-type-equality": "3.0.0",+ "purescript-typelevel-prelude": "3.0.0",+ "purescript-unfoldable": "4.0.0",+ "purescript-unsafe-coerce": "4.0.0" } }
− tests/support/package-lock.json
@@ -1,171 +0,0 @@-{- "requires": true,- "lockfileVersion": 1,- "dependencies": {- "bower": {- "version": "1.8.2",- "resolved": "https://registry.npmjs.org/bower/-/bower-1.8.2.tgz",- "integrity": "sha1-rfU1KcjUrwLvJPuNU0HBQZ0z4vc="- },- "fs.realpath": {- "version": "1.0.0",- "resolved": "https://registry.npmjs.org/fs.realpath/-/fs.realpath-1.0.0.tgz",- "integrity": "sha1-FQStJSMVjKpA20onh8sBQRmU6k8="- },- "glob": {- "version": "5.0.15",- "resolved": "https://registry.npmjs.org/glob/-/glob-5.0.15.tgz",- "integrity": "sha1-G8k2ueAvSmA/zCIuz3Yz0wuLk7E=",- "requires": {- "inflight": "1.0.6",- "inherits": "2.0.3",- "minimatch": "3.0.4",- "once": "1.4.0",- "path-is-absolute": "1.0.1"- },- "dependencies": {- "balanced-match": {- "version": "1.0.0",- "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.0.tgz",- "integrity": "sha1-ibTRmasr7kneFk6gK4nORi1xt2c="- },- "brace-expansion": {- "version": "1.1.11",- "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-1.1.11.tgz",- "integrity": "sha512-iCuPHDFgrHX7H2vEI/5xpz07zSHB00TpugqhmYtVmMO6518mCuRMoOYFldEBl0g187ufozdaHgWKcYFb61qGiA==",- "requires": {- "balanced-match": "1.0.0",- "concat-map": "0.0.1"- }- },- "concat-map": {- "version": "0.0.1",- "resolved": "https://registry.npmjs.org/concat-map/-/concat-map-0.0.1.tgz",- "integrity": "sha1-2Klr13/Wjfd5OnMDajug1UBdR3s="- },- "inflight": {- "version": "1.0.6",- "resolved": "https://registry.npmjs.org/inflight/-/inflight-1.0.6.tgz",- "integrity": "sha1-Sb1jMdfQLQwJvJEKEHW6gWW1bfk=",- "requires": {- "once": "1.4.0",- "wrappy": "1.0.2"- }- },- "inherits": {- "version": "2.0.3",- "resolved": "https://registry.npmjs.org/inherits/-/inherits-2.0.3.tgz",- "integrity": "sha1-Yzwsg+PaQqUC9SRmAiSA9CCCYd4="- },- "minimatch": {- "version": "3.0.4",- "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.0.4.tgz",- "integrity": "sha512-yJHVQEhyqPLUTgt9B83PXu6W3rx4MvvHvSUvToogpwoGDOUQ+yDrR0HRot+yOCdCO7u4hX3pWft6kWBBcqh0UA==",- "requires": {- "brace-expansion": "1.1.11"- }- },- "once": {- "version": "1.4.0",- "resolved": "https://registry.npmjs.org/once/-/once-1.4.0.tgz",- "integrity": "sha1-WDsap3WWHUsROsF9nFC6753Xa9E=",- "requires": {- "wrappy": "1.0.2"- }- },- "path-is-absolute": {- "version": "1.0.1",- "resolved": "https://registry.npmjs.org/path-is-absolute/-/path-is-absolute-1.0.1.tgz",- "integrity": "sha1-F0uSaHNVNP+8es5r9TpanhtcX18="- },- "wrappy": {- "version": "1.0.2",- "resolved": "https://registry.npmjs.org/wrappy/-/wrappy-1.0.2.tgz",- "integrity": "sha1-tSQ9jz7BqjXxNkYFvA0QNuMKtp8="- }- }- },- "rimraf": {- "version": "2.6.2",- "resolved": "https://registry.npmjs.org/rimraf/-/rimraf-2.6.2.tgz",- "integrity": "sha512-lreewLK/BlghmxtfH36YYVg1i8IAce4TI7oao75I1g245+6BctqTVQiBP3YUJ9C6DQOXJmkYR9X9fCLtCOJc5w==",- "requires": {- "glob": "7.1.2"- },- "dependencies": {- "balanced-match": {- "version": "1.0.0",- "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.0.tgz",- "integrity": "sha1-ibTRmasr7kneFk6gK4nORi1xt2c="- },- "brace-expansion": {- "version": "1.1.11",- "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-1.1.11.tgz",- "integrity": "sha512-iCuPHDFgrHX7H2vEI/5xpz07zSHB00TpugqhmYtVmMO6518mCuRMoOYFldEBl0g187ufozdaHgWKcYFb61qGiA==",- "requires": {- "balanced-match": "1.0.0",- "concat-map": "0.0.1"- }- },- "concat-map": {- "version": "0.0.1",- "resolved": "https://registry.npmjs.org/concat-map/-/concat-map-0.0.1.tgz",- "integrity": "sha1-2Klr13/Wjfd5OnMDajug1UBdR3s="- },- "glob": {- "version": "7.1.2",- "resolved": "https://registry.npmjs.org/glob/-/glob-7.1.2.tgz",- "integrity": "sha512-MJTUg1kjuLeQCJ+ccE4Vpa6kKVXkPYJ2mOCQyUuKLcLQsdrMCpBPUi8qVE6+YuaJkozeA9NusTAw3hLr8Xe5EQ==",- "requires": {- "fs.realpath": "1.0.0",- "inflight": "1.0.6",- "inherits": "2.0.3",- "minimatch": "3.0.4",- "once": "1.4.0",- "path-is-absolute": "1.0.1"- }- },- "inflight": {- "version": "1.0.6",- "resolved": "https://registry.npmjs.org/inflight/-/inflight-1.0.6.tgz",- "integrity": "sha1-Sb1jMdfQLQwJvJEKEHW6gWW1bfk=",- "requires": {- "once": "1.4.0",- "wrappy": "1.0.2"- }- },- "inherits": {- "version": "2.0.3",- "resolved": "https://registry.npmjs.org/inherits/-/inherits-2.0.3.tgz",- "integrity": "sha1-Yzwsg+PaQqUC9SRmAiSA9CCCYd4="- },- "minimatch": {- "version": "3.0.4",- "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.0.4.tgz",- "integrity": "sha512-yJHVQEhyqPLUTgt9B83PXu6W3rx4MvvHvSUvToogpwoGDOUQ+yDrR0HRot+yOCdCO7u4hX3pWft6kWBBcqh0UA==",- "requires": {- "brace-expansion": "1.1.11"- }- },- "once": {- "version": "1.4.0",- "resolved": "https://registry.npmjs.org/once/-/once-1.4.0.tgz",- "integrity": "sha1-WDsap3WWHUsROsF9nFC6753Xa9E=",- "requires": {- "wrappy": "1.0.2"- }- },- "path-is-absolute": {- "version": "1.0.1",- "resolved": "https://registry.npmjs.org/path-is-absolute/-/path-is-absolute-1.0.1.tgz",- "integrity": "sha1-F0uSaHNVNP+8es5r9TpanhtcX18="- },- "wrappy": {- "version": "1.0.2",- "resolved": "https://registry.npmjs.org/wrappy/-/wrappy-1.0.2.tgz",- "integrity": "sha1-tSQ9jz7BqjXxNkYFvA0QNuMKtp8="- }- }- }- }-}
+ tests/support/psci/Reload.edit view
@@ -0,0 +1,4 @@+module Reload where++edited :: String+edited = "reload"
+ tests/support/psci/Reload.purs view
@@ -0,0 +1,4 @@+module Reload where++reload :: Int+reload = 0
− tests/support/psci/Sample.purs