summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-03-26 20:48:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-03-26 20:48:00 (GMT)
commit6bc83edfdc50ee74921ae3e0e751a764c8a618fa (patch)
treec7b64824ccb2279ce03f4b751e2e3656fa1a1937
parent0bdc658bac6649643d96d50c5803c123273de9af (diff)
version 0.8.3.00.8.3.0
-rw-r--r--CONTRIBUTORS.md2
-rw-r--r--INSTALL.md12
-rw-r--r--examples/docs/LICENSE1
-rw-r--r--examples/docs/bower.json3
-rw-r--r--examples/failing/ConstraintInference.purs10
-rw-r--r--examples/failing/OperatorSections.purs8
-rw-r--r--examples/passing/ConstraintInference.purs7
-rw-r--r--examples/passing/ContextSimplification.purs13
-rw-r--r--examples/passing/MonadState.purs51
-rw-r--r--psc-bundle/Main.hs9
-rw-r--r--psc-docs/Main.hs4
-rw-r--r--psc-ide-client/Main.hs13
-rw-r--r--psc-ide-server/Main.hs57
-rw-r--r--psc-publish/Main.hs4
-rw-r--r--psc/Main.hs4
-rw-r--r--psci/PSCi.hs4
-rw-r--r--purescript.cabal28
-rw-r--r--src/Control/Monad/Supply.hs2
-rw-r--r--src/Control/Monad/Supply/Class.hs2
-rw-r--r--src/Language/PureScript/AST.hs18
-rw-r--r--src/Language/PureScript/AST/Binders.hs31
-rw-r--r--src/Language/PureScript/AST/Declarations.hs28
-rw-r--r--src/Language/PureScript/AST/Literals.hs (renamed from src/Language/PureScript/CoreFn/Literals.hs)4
-rw-r--r--src/Language/PureScript/AST/Traversals.hs300
-rw-r--r--src/Language/PureScript/Bundle.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs10
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS/Common.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs4
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs8
-rw-r--r--src/Language/PureScript/CoreFn.hs17
-rw-r--r--src/Language/PureScript/CoreFn/Binders.hs2
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs34
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs2
-rw-r--r--src/Language/PureScript/CoreFn/Traversals.hs17
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs3
-rw-r--r--src/Language/PureScript/Docs/Convert.hs14
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs41
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs7
-rw-r--r--src/Language/PureScript/Docs/ParseAndBookmark.hs4
-rw-r--r--src/Language/PureScript/Errors.hs54
-rw-r--r--src/Language/PureScript/Ide.hs6
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs30
-rw-r--r--src/Language/PureScript/Ide/Completion.hs8
-rw-r--r--src/Language/PureScript/Ide/Error.hs23
-rw-r--r--src/Language/PureScript/Ide/Externs.hs2
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs32
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs22
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs40
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs80
-rw-r--r--src/Language/PureScript/Ide/State.hs25
-rw-r--r--src/Language/PureScript/Ide/Types.hs155
-rw-r--r--src/Language/PureScript/Kinds.hs2
-rw-r--r--src/Language/PureScript/Linter.hs2
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs25
-rw-r--r--src/Language/PureScript/Linter/Imports.hs6
-rw-r--r--src/Language/PureScript/Make.hs10
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs66
-rw-r--r--src/Language/PureScript/Parser/JS.hs2
-rw-r--r--src/Language/PureScript/Pretty/Common.hs2
-rw-r--r--src/Language/PureScript/Pretty/JS.hs3
-rw-r--r--src/Language/PureScript/Pretty/Values.hs67
-rw-r--r--src/Language/PureScript/Publish.hs34
-rw-r--r--src/Language/PureScript/Publish/BoxesHelpers.hs3
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs21
-rw-r--r--src/Language/PureScript/Sugar.hs2
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs6
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs12
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs4
-rw-r--r--src/Language/PureScript/Sugar/Names.hs8
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs8
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs8
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs8
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs17
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs10
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses/Deriving.hs90
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs24
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs113
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs22
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs34
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs162
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs11
-rw-r--r--src/Language/PureScript/Types.hs4
-rw-r--r--stack-lts-2.yaml13
-rw-r--r--stack-lts-5.yaml (renamed from stack-lts-3.yaml)4
-rw-r--r--stack-nightly.yaml2
-rw-r--r--stack.yaml3
-rw-r--r--tests/TestDocs.hs24
-rw-r--r--tests/TestPscPublish.hs26
94 files changed, 1137 insertions, 998 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 46867ac..700c3c8 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -9,6 +9,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@aspidites](https://github.com/aspidites) (Edwin Marshall) My existing contributions and all future contributions until further notice are Copyright Edwin Marshall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
@@ -23,6 +24,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@epost](https://github.com/epost) (Erik Post) - My existing contributions and all future contributions until further notice are Copyright Erik Post, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
- [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
diff --git a/INSTALL.md b/INSTALL.md
index c58652f..4414a13 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -6,8 +6,8 @@ alternatively Stack Overflow.
## Using prebuilt binaries
-The prebuilt binaries are compiled with GHC 7.8.4, and therefore they should
-run on any operating system supported by GHC 7.8.4, such as:
+The prebuilt binaries are compiled with GHC 7.10.3, and therefore they should
+run on any operating system supported by GHC 7.10.3, such as:
* Windows 2000 or later,
* OS X 10.7 or later,
@@ -23,11 +23,11 @@ requirements.
## Compiling from source
-GHC 7.6.1 or newer is required to compile from source. The easiest way is to
+GHC 7.10.1 or newer is required to compile from source. The easiest way is to
use stack:
```
-$ stack install --resolver lts purescript
+$ stack install --resolver=nightly purescript
```
This will then copy the compiler and utilities into `~/.local/bin`.
@@ -39,10 +39,6 @@ If you don't have stack installed yet there are install instructions
If you don't have ghc installed yet, stack will prompt you to run `stack setup`
which will install ghc for you.
-The PureScript compiler has been known to run on OS X 10.6 when built with GHC
-7.6.
-
-
## The "curses" library
`psci` depends on the `curses` library (via the Haskell package `terminfo`). If
diff --git a/examples/docs/LICENSE b/examples/docs/LICENSE
new file mode 100644
index 0000000..c993dba
--- /dev/null
+++ b/examples/docs/LICENSE
@@ -0,0 +1 @@
+This isn't a real license, it's just here for the sake of the tests.
diff --git a/examples/docs/bower.json b/examples/docs/bower.json
index f4f13d5..fea039d 100644
--- a/examples/docs/bower.json
+++ b/examples/docs/bower.json
@@ -15,5 +15,6 @@
"output"
],
"dependencies": {
- }
+ },
+ "license": "replaceme"
}
diff --git a/examples/failing/ConstraintInference.purs b/examples/failing/ConstraintInference.purs
new file mode 100644
index 0000000..f451fa0
--- /dev/null
+++ b/examples/failing/ConstraintInference.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith NoInstanceFound
+
+module Main where
+
+import Prelude
+
+spin :: forall a b. a -> b
+spin x = spin x
+
+test = show <<< spin
diff --git a/examples/failing/OperatorSections.purs b/examples/failing/OperatorSections.purs
new file mode 100644
index 0000000..7be5b3f
--- /dev/null
+++ b/examples/failing/OperatorSections.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith CannotApplyFunction
+module Main where
+
+import Prelude
+
+main = do
+ (true `not` _)
+
diff --git a/examples/passing/ConstraintInference.purs b/examples/passing/ConstraintInference.purs
new file mode 100644
index 0000000..1c97c66
--- /dev/null
+++ b/examples/passing/ConstraintInference.purs
@@ -0,0 +1,7 @@
+module Main where
+
+import Prelude
+
+shout = Control.Monad.Eff.Console.log <<< (<> "!") <<< show
+
+main = shout "Done"
diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs
new file mode 100644
index 0000000..88c5835
--- /dev/null
+++ b/examples/passing/ContextSimplification.purs
@@ -0,0 +1,13 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+shout = log <<< (<> "!") <<< show
+
+-- Here, we should simplify the context so that only one Show
+-- constraint is added.
+usesShowTwice true = shout
+usesShowTwice false = print
+
+main = usesShowTwice true "Done"
diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs
index c2cd0e7..8d64394 100644
--- a/examples/passing/MonadState.purs
+++ b/examples/passing/MonadState.purs
@@ -1,12 +1,16 @@
module Main where
import Prelude
+import Control.Monad.Eff.Console
data Tuple a b = Tuple a b
-class MonadState s m where
+instance showTuple :: (Show a, Show b) => Show (Tuple a b) where
+ show (Tuple a b) = "(" <> show a <> ", " <> show b <> ")"
+
+class Monad m <= MonadState s m where
get :: m s
- put :: s -> m {}
+ put :: s -> m Unit
data State s a = State (s -> Tuple s a)
@@ -29,20 +33,29 @@ instance monadState :: Monad (State s)
instance monadStateState :: MonadState s (State s) where
get = State (\s -> Tuple s s)
- put s = State (\_ -> Tuple s {})
-
-modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}
-modify f = do
- s <- get
- put (f s)
-
-test :: Tuple String String
-test = runState "" $ do
- modify $ (++) "World!"
- modify $ (++) "Hello, "
- get
-
-main = do
- let t1 = test
- Control.Monad.Eff.Console.log "Done"
-
+ put s = State (\_ -> Tuple s unit)
+
+-- Without the call to same, the following strange (but correct, in the absence of
+-- functional dependencies) type:
+--
+-- forall m t1 t2.
+-- ( Bind m
+-- , MonadState t1 m
+-- , MonadState t2 m
+-- ) => (t1 -> t2) -> m Unit
+--
+-- With the type hint, the inferred type is more sensible:
+--
+-- forall m t.
+-- ( Bind m
+-- , MonadState t m
+-- ) => (t -> t) -> m Unit
+modify f =
+ do
+ s <- get
+ put (same f s)
+ where
+ same :: forall a. (a -> a) -> (a -> a)
+ same = id
+
+main = print $ runState 0 (modify (+ 1))
diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs
index 5a4201b..f97e36f 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -19,6 +19,7 @@
module Main (main) where
+import Data.Maybe
import Data.Traversable (for)
import Data.Version (showVersion)
@@ -51,7 +52,7 @@ data Options = Options
} deriving Show
-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.
-guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier
+guessModuleIdentifier :: (MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier
guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)
where
guessModuleType "index.js" = pure Regular
@@ -61,7 +62,7 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f
-- | The main application function.
-- This function parses the input files, performs dead code elimination, filters empty modules
-- and generates and prints the final Javascript bundle.
-app :: (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String
+app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m String
app Options{..} = do
inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles
when (null inputFiles) . liftIO $ do
@@ -119,13 +120,13 @@ options = Options <$> some inputFile
requirePath = strOption $
short 'r'
<> long "require-path"
- <> Opts.value ""
- <> help "The path prefix used in require() calls in the generated JavaScript"
+ <> help "The path prefix used in require() calls in the generated JavaScript [deprecated]"
-- | Make it go.
main :: IO ()
main = do
opts <- execParser (info (version <*> helper <*> options) infoModList)
+ when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9."
output <- runExceptT (app opts)
case output of
Left err -> do
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index 6374dff..70650c8 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -32,7 +32,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import System.Exit (exitFailure)
-import System.IO (hPutStrLn, stderr)
+import System.IO (hPutStrLn, hPrint, stderr)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.FilePath.Glob (glob)
@@ -139,7 +139,7 @@ dumpTags input renderTags = do
e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
case e of
Left err -> do
- hPutStrLn stderr (show err)
+ hPrint stderr err
exitFailure
Right ms ->
ldump (renderTags (pairs ms))
diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs
index 7007815..17c0596 100644
--- a/psc-ide-client/Main.hs
+++ b/psc-ide-client/Main.hs
@@ -5,7 +5,6 @@ import Prelude ()
import Prelude.Compat
import Control.Exception
-import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
@@ -18,19 +17,19 @@ import System.IO
import qualified Paths_purescript as Paths
data Options = Options
- { optionsPort :: Maybe Int
- }
+ { optionsPort :: PortID
+ }
main :: IO ()
main = do
Options port <- execParser opts
- let port' = PortNumber . fromIntegral $ fromMaybe 4242 port
- client port'
+ client port
where
parser =
Options <$>
- optional (option auto (long "port" <> short 'p'))
- opts = info (version <*> parser) mempty
+ (PortNumber . fromIntegral <$>
+ option auto (long "port" <> short 'p' <> value (4242 :: Integer)))
+ opts = info (version <*> helper <*> parser) mempty
version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
client :: PortID -> IO ()
diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs
index 6188c49..77f2243 100644
--- a/psc-ide-server/Main.hs
+++ b/psc-ide-server/Main.hs
@@ -11,8 +11,9 @@ import Prelude.Compat
import Control.Concurrent (forkFinally)
import Control.Concurrent.STM
-import Control.Exception (bracketOnError)
+import Control.Exception (bracketOnError, catchJust)
import Control.Monad
+import Control.Monad.Error.Class
import "monad-logger" Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Except
@@ -32,6 +33,7 @@ import Options.Applicative
import System.Directory
import System.FilePath
import System.IO
+import System.IO.Error (isEOFError)
import qualified Paths_purescript as Paths
@@ -87,7 +89,7 @@ main = do
(PortNumber . fromIntegral <$>
option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*>
switch (long "debug")
- opts = info (version <*> parser) mempty
+ opts = info (version <*> helper <*> parser) mempty
version = abortOption
(InfoMsg (showVersion Paths.version))
(long "version" <> help "Show the version number")
@@ -101,32 +103,43 @@ startServer port env = withSocketsDo $ do
loop :: (PscIde m, MonadLogger m) => Socket -> m ()
loop sock = do
- (cmd,h) <- acceptCommand sock
- case decodeT cmd of
- Just cmd' -> do
- result <- runExceptT (handleCommand cmd')
- $(logDebug) ("Answer was: " <> T.pack (show result))
- liftIO (hFlush stdout)
- case result of
- -- What function can I use to clean this up?
- Right r -> liftIO $ T.hPutStrLn h (encodeT r)
- Left err -> liftIO $ T.hPutStrLn h (encodeT err)
- Nothing -> do
- $(logDebug) ("Parsing the command failed. Command: " <> cmd)
- liftIO $ do
- T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))
- hFlush stdout
- liftIO (hClose h)
+ accepted <- runExceptT $ acceptCommand sock
+ case accepted of
+ Left err -> $(logDebug) err
+ Right (cmd, h) -> do
+ case decodeT cmd of
+ Just cmd' -> do
+ result <- runExceptT (handleCommand cmd')
+ $(logDebug) ("Answer was: " <> T.pack (show result))
+ liftIO (hFlush stdout)
+ case result of
+ -- What function can I use to clean this up?
+ Right r -> liftIO $ T.hPutStrLn h (encodeT r)
+ Left err -> liftIO $ T.hPutStrLn h (encodeT err)
+ Nothing -> do
+ $(logDebug) ("Parsing the command failed. Command: " <> cmd)
+ liftIO $ do
+ T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))
+ hFlush stdout
+ liftIO (hClose h)
-acceptCommand :: (Applicative m, MonadIO m, MonadLogger m)
+acceptCommand :: (MonadIO m, MonadLogger m, MonadError T.Text m)
=> Socket -> m (T.Text, Handle)
acceptCommand sock = do
h <- acceptConnection
$(logDebug) "Accepted a connection"
- cmd <- liftIO (T.hGetLine h)
- $(logDebug) cmd
- pure (cmd, h)
+ cmd' <- liftIO (catchJust
+ -- this means that the connection was
+ -- terminated without receiving any input
+ (\e -> if isEOFError e then Just () else Nothing)
+ (Just <$> T.hGetLine h)
+ (const (pure Nothing)))
+ case cmd' of
+ Nothing -> throwError "Connection was closed before any input arrived"
+ Just cmd -> do
+ $(logDebug) cmd
+ pure (cmd, h)
where
acceptConnection = liftIO $ do
(h,_,_) <- accept sock
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
index 912f460..d7d397c 100644
--- a/psc-publish/Main.hs
+++ b/psc-publish/Main.hs
@@ -38,8 +38,8 @@ publish :: Bool -> IO ()
publish isDryRun =
if isDryRun
then do
- _ <- preparePackage dryRunOptions
+ _ <- unsafePreparePackage dryRunOptions
putStrLn "Dry run completed, no errors."
else do
- pkg <- preparePackage defaultPublishOptions
+ pkg <- unsafePreparePackage defaultPublishOptions
BL.putStrLn (A.encode pkg)
diff --git a/psc/Main.hs b/psc/Main.hs
index 8639346..fc90127 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -107,7 +107,7 @@ globWarningOnMisses warn = concatMapM globWithWarning
readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile
-parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
+parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
=> [(Either P.RebuildPolicy FilePath, String)]
-> [(FilePath, P.ForeignJS)]
-> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)
@@ -138,7 +138,7 @@ requirePath :: Parser (Maybe FilePath)
requirePath = optional $ strOption $
short 'r'
<> long "require-path"
- <> help "The path prefix to use for require() calls in the generated JavaScript"
+ <> help "The path prefix to use for require() calls in the generated JavaScript [deprecated]"
noTco :: Parser Bool
noTco = switch $
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
index ea119c5..7561494 100644
--- a/psci/PSCi.hs
+++ b/psci/PSCi.hs
@@ -214,7 +214,7 @@ handleDecls :: [P.Declaration] -> PSCI ()
handleDecls ds = do
st <- PSCI $ lift get
let st' = updateLets ds st
- let m = createTemporaryModule False st' (P.ObjectLiteral [])
+ let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral []))
e <- psciIO . runMake $ make st' [m]
case e of
Left err -> PSCI $ printErrors err
@@ -337,7 +337,7 @@ handleKindOf typ = do
k = check (P.kindOf typ') chk
check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
- check sew cs = fst . runWriter . runExceptT . runStateT sew $ cs
+ check sew = fst . runWriter . runExceptT . runStateT sew
case k of
Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack
Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
diff --git a/purescript.cabal b/purescript.cabal
index e2da1cf..9c0040d 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.8.2.0
+version: 0.8.3.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -17,12 +17,13 @@ author: Phil Freeman <paf31@cantab.net>,
Harry Garrood <harry@garrood.me>,
Christoph Hegemann <christoph.hegemann1337@gmail.com>
-tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1
+tested-with: GHC==7.10.3
extra-source-files: examples/passing/*.purs
, examples/failing/*.purs
, examples/docs/bower_components/purescript-prelude/src/*.purs
, examples/docs/bower.json
+ , examples/docs/LICENSE
, examples/docs/src/*.purs
, tests/support/setup.js
, tests/support/package.json
@@ -36,8 +37,7 @@ extra-source-files: examples/passing/*.purs
, tests/support/flattened/*.js
, tests/support/psci/*.purs
, stack.yaml
- , stack-lts-2.yaml
- , stack-lts-3.yaml
+ , stack-lts-5.yaml
, stack-nightly.yaml
, README.md
, INSTALL.md
@@ -49,7 +49,7 @@ source-repository head
location: https://github.com/purescript/purescript.git
library
- build-depends: base >=4.6 && <5,
+ build-depends: base >=4.8 && <5,
base-compat >=0.6.0,
lifted-base >= 0.2.3 && < 0.2.4,
monad-control >= 1.0.0.0 && < 1.1,
@@ -69,7 +69,7 @@ library
boxes >= 0.1.4 && < 0.2.0,
aeson >= 0.8 && < 0.12,
vector -any,
- bower-json >= 0.7,
+ bower-json >= 0.8,
aeson-better-errors >= 0.8,
bytestring -any,
text -any,
@@ -96,6 +96,7 @@ library
Language.PureScript.AST.Binders
Language.PureScript.AST.Declarations
Language.PureScript.AST.Operators
+ Language.PureScript.AST.Literals
Language.PureScript.AST.SourcePos
Language.PureScript.AST.Traversals
Language.PureScript.AST.Exported
@@ -119,7 +120,6 @@ library
Language.PureScript.CoreFn.Binders
Language.PureScript.CoreFn.Desugar
Language.PureScript.CoreFn.Expr
- Language.PureScript.CoreFn.Literals
Language.PureScript.CoreFn.Meta
Language.PureScript.CoreFn.Module
Language.PureScript.CoreFn.Traversals
@@ -229,7 +229,7 @@ library
executable psc
build-depends: base >=4 && <5, base-compat >=0.6.0,
containers -any, directory -any, filepath -any,
- mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
+ mtl -any, optparse-applicative >= 0.12.1, parsec -any, purescript -any,
time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,
aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2
main-is: Main.hs
@@ -240,7 +240,7 @@ executable psc
executable psci
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
- mtl -any, optparse-applicative >= 0.10.0, parsec -any,
+ mtl -any, optparse-applicative >= 0.12.1, parsec -any,
haskeline >= 0.7.0.0, purescript -any, transformers -any,
transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0,
boxes >= 0.1.4 && < 0.2.0
@@ -263,7 +263,7 @@ executable psci
executable psc-docs
build-depends: base >=4 && <5, purescript -any,
- optparse-applicative >= 0.10.0, process -any, mtl -any,
+ optparse-applicative >= 0.12.1, process -any, mtl -any,
split -any, ansi-wl-pprint -any, directory -any,
filepath -any, Glob -any, transformers -any,
transformers-compat -any
@@ -285,7 +285,7 @@ executable psc-publish
ghc-options: -Wall -O2
executable psc-hierarchy
- build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
+ build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1,
process -any, mtl -any, parsec -any, filepath -any, directory -any,
Glob -any
main-is: Main.hs
@@ -306,7 +306,7 @@ executable psc-bundle
mtl -any,
transformers -any,
transformers-compat -any,
- optparse-applicative >= 0.10.0,
+ optparse-applicative >= 0.12.1,
Glob -any
ghc-options: -Wall -O2
hs-source-dirs: psc-bundle
@@ -324,7 +324,7 @@ executable psc-ide-server
, transformers -any
, transformers-compat -any
, network -any
- , optparse-applicative >= 0.10.0
+ , optparse-applicative >= 0.12.1
, stm -any
, text -any
, base-compat >=0.6.0
@@ -338,7 +338,7 @@ executable psc-ide-client
build-depends: base >=4 && <5
, mtl -any
, text -any
- , optparse-applicative >= 0.10.0
+ , optparse-applicative >= 0.12.1
, network -any
, base-compat >=0.6.0
ghc-options: -Wall -O2
diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs
index 1ae1e72..0b002e4 100644
--- a/src/Control/Monad/Supply.hs
+++ b/src/Control/Monad/Supply.hs
@@ -27,7 +27,7 @@ import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Reader
import Control.Monad.Writer
-newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)
runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
index 02c185a..8621e2e 100644
--- a/src/Control/Monad/Supply/Class.hs
+++ b/src/Control/Monad/Supply/Class.hs
@@ -21,4 +21,4 @@ instance (MonadSupply m) => MonadSupply (StateT s m) where
fresh = lift fresh
freshName :: (MonadSupply m) => m String
-freshName = liftM (('$' :) . show) fresh
+freshName = fmap (('$' :) . show) fresh
diff --git a/src/Language/PureScript/AST.hs b/src/Language/PureScript/AST.hs
index 417ec41..fe82e27 100644
--- a/src/Language/PureScript/AST.hs
+++ b/src/Language/PureScript/AST.hs
@@ -1,24 +1,14 @@
------------------------------------------------------------------------------
+-- |
+-- The initial PureScript AST
--
--- Module : Language.PureScript.AST
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | The initial PureScript AST
---
------------------------------------------------------------------------------
-
module Language.PureScript.AST (
module AST
) where
import Language.PureScript.AST.Binders as AST
import Language.PureScript.AST.Declarations as AST
+import Language.PureScript.AST.Exported as AST
+import Language.PureScript.AST.Literals as AST
import Language.PureScript.AST.Operators as AST
import Language.PureScript.AST.SourcePos as AST
import Language.PureScript.AST.Traversals as AST
-import Language.PureScript.AST.Exported as AST
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 2ff3fe4..21ef3ca 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -4,6 +4,7 @@
module Language.PureScript.AST.Binders where
import Language.PureScript.AST.SourcePos
+import Language.PureScript.AST.Literals
import Language.PureScript.Names
import Language.PureScript.Comments
import Language.PureScript.Types
@@ -17,21 +18,9 @@ data Binder
--
= NullBinder
-- |
- -- A binder which matches a boolean literal
+ -- A binder which matches a literal
--
- | BooleanBinder Bool
- -- |
- -- A binder which matches a string literal
- --
- | StringBinder String
- -- |
- -- A binder which matches a character literal
- --
- | CharBinder Char
- -- |
- -- A binder which matches a numeric literal
- --
- | NumberBinder (Either Integer Double)
+ | LiteralBinder (Literal Binder)
-- |
-- A binder which binds an identifier
--
@@ -59,14 +48,6 @@ data Binder
--
| ParensInBinder Binder
-- |
- -- A binder which matches a record and binds its properties
- --
- | ObjectBinder [(String, Binder)]
- -- |
- -- A binder which matches an array and binds its elements
- --
- | ArrayBinder [Binder]
- -- |
-- A binder which binds its input to an identifier
--
| NamedBinder Ident Binder
@@ -86,13 +67,15 @@ data Binder
binderNames :: Binder -> [Ident]
binderNames = go []
where
+ go ns (LiteralBinder b) = lit ns b
go ns (VarBinder name) = name : ns
go ns (ConstructorBinder _ bs) = foldl go ns bs
go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]
go ns (ParensInBinder b) = go ns b
- go ns (ObjectBinder bs) = foldl go ns (map snd bs)
- go ns (ArrayBinder bs) = foldl go ns bs
go ns (NamedBinder name b) = go (name : ns) b
go ns (PositionedBinder _ _ b) = go ns b
go ns (TypedBinder _ b) = go ns b
go ns _ = ns
+ lit ns (ObjectLiteral bs) = foldl go ns (map snd bs)
+ lit ns (ArrayLiteral bs) = foldl go ns bs
+ lit ns _ = ns
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 2b92a04..f4e999c 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -19,6 +19,7 @@ import qualified Data.Map as M
import Control.Monad.Identity
import Language.PureScript.AST.Binders
+import Language.PureScript.AST.Literals
import Language.PureScript.AST.Operators
import Language.PureScript.AST.SourcePos
import Language.PureScript.Types
@@ -309,21 +310,9 @@ type Guard = Expr
--
data Expr
-- |
- -- A numeric literal
+ -- A literal value
--
- = NumericLiteral (Either Integer Double)
- -- |
- -- A string literal
- --
- | StringLiteral String
- -- |
- -- A character literal
- --
- | CharLiteral Char
- -- |
- -- A boolean literal
- --
- | BooleanLiteral Bool
+ = Literal (Literal Expr)
-- |
-- A prefix -, will be desugared
--
@@ -342,19 +331,10 @@ data Expr
--
| Parens Expr
-- |
- -- Operator section. This will be removed during desugaring and replaced with a partially applied
- -- operator or lambda to flip the arguments.
+ -- Operator section. This will be removed during desugaring and replaced with lambda.
--
| OperatorSection Expr (Either Expr Expr)
-- |
- -- An array literal
- --
- | ArrayLiteral [Expr]
- -- |
- -- An object literal
- --
- | ObjectLiteral [(String, Expr)]
- -- |
-- An object property getter (e.g. `_.x`). This will be removed during
-- desugaring and expanded into a lambda that reads a property from an object.
--
diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index cdc71b4..d14a36b 100644
--- a/src/Language/PureScript/CoreFn/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -3,7 +3,7 @@
-- |
-- The core functional representation for literal values.
--
-module Language.PureScript.CoreFn.Literals where
+module Language.PureScript.AST.Literals where
-- |
-- Data type for literal values. Parameterised so it can be used for Exprs and
@@ -34,4 +34,4 @@ data Literal a
-- An object literal
--
| ObjectLiteral [(String, a)]
- deriving (Show, Read, Functor)
+ deriving (Eq, Ord, Show, Read, Functor)
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index ce800a2..4ea8c5b 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -1,17 +1,8 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.AST.Traversals
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | AST traversal helpers
---
------------------------------------------------------------------------------
+{-# LANGUAGE ScopedTypeVariables #-}
+-- |
+-- AST traversal helpers
+--
module Language.PureScript.AST.Traversals where
import Prelude ()
@@ -26,15 +17,20 @@ import Control.Monad
import Control.Arrow ((***), (+++))
import Language.PureScript.AST.Binders
+import Language.PureScript.AST.Literals
import Language.PureScript.AST.Declarations
import Language.PureScript.Types
import Language.PureScript.Traversals
import Language.PureScript.Names
-everywhereOnValues :: (Declaration -> Declaration) ->
- (Expr -> Expr) ->
- (Binder -> Binder) ->
- (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
+everywhereOnValues
+ :: (Declaration -> Declaration)
+ -> (Expr -> Expr)
+ -> (Binder -> Binder)
+ -> ( Declaration -> Declaration
+ , Expr -> Expr
+ , Binder -> Binder
+ )
everywhereOnValues f g h = (f', g', h')
where
f' :: Declaration -> Declaration
@@ -47,13 +43,12 @@ everywhereOnValues f g h = (f', g', h')
f' other = f other
g' :: Expr -> Expr
+ g' (Literal l) = g (Literal (lit g' l))
g' (UnaryMinus v) = g (UnaryMinus (g' v))
g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
g' (Parens v) = g (Parens (g' v))
g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))
g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))
- g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
- g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
g' (Accessor prop v) = g (Accessor prop (g' v))
g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
@@ -71,13 +66,17 @@ everywhereOnValues f g h = (f', g', h')
h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
h' (ParensInBinder b) = h (ParensInBinder (h' b))
- h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
- h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
+ h' (LiteralBinder l) = h (LiteralBinder (lit h' l))
h' (NamedBinder name b) = h (NamedBinder name (h' b))
h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
h' (TypedBinder t b) = h (TypedBinder t (h' b))
h' other = h other
+ lit :: (a -> a) -> Literal a -> Literal a
+ lit go (ArrayLiteral as) = ArrayLiteral (map go as)
+ lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as)
+ lit _ other = other
+
handleCaseAlternative :: CaseAlternative -> CaseAlternative
handleCaseAlternative ca =
ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
@@ -90,13 +89,20 @@ everywhereOnValues f g h = (f', g', h')
handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
-everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
- (Declaration -> m Declaration) ->
- (Expr -> m Expr) ->
- (Binder -> m Binder) ->
- (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
+everywhereOnValuesTopDownM
+ :: forall m
+ . (Monad m)
+ => (Declaration -> m Declaration)
+ -> (Expr -> m Expr)
+ -> (Binder -> m Binder)
+ -> ( Declaration -> m Declaration
+ , Expr -> m Expr
+ , Binder -> m Binder
+ )
everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
where
+
+ f' :: Declaration -> m Declaration
f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
@@ -105,13 +111,13 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
f' other = f other
+ g' :: Expr -> m Expr
+ g' (Literal l) = Literal <$> lit (g >=> g') l
g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
g' (Parens v) = Parens <$> (g v >>= g')
g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))
g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
- g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs
- g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs
g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
@@ -125,31 +131,47 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
g' other = g other
+ h' :: Binder -> m Binder
+ h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l
h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs
h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
- h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs
- h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs
h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')
h' other = h other
- handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs
- <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
+ lit :: (a -> m a) -> Literal a -> m (Literal a)
+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as
+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as
+ lit _ other = pure other
+
+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative
+ handleCaseAlternative (CaseAlternative bs val) =
+ CaseAlternative
+ <$> traverse (h' <=< h) bs
+ <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
-everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
- (Declaration -> m Declaration) ->
- (Expr -> m Expr) ->
- (Binder -> m Binder) ->
- (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
+everywhereOnValuesM
+ :: forall m
+ . (Monad m)
+ => (Declaration -> m Declaration)
+ -> (Expr -> m Expr)
+ -> (Binder -> m Binder)
+ -> ( Declaration -> m Declaration
+ , Expr -> m Expr
+ , Binder -> m Binder
+ )
everywhereOnValuesM f g h = (f', g', h')
where
+
+ f' :: Declaration -> m Declaration
f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
@@ -158,13 +180,13 @@ everywhereOnValuesM f g h = (f', g', h')
f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
f' other = f other
+ g' :: Expr -> m Expr
+ g' (Literal l) = (Literal <$> lit g' l) >>= g
g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
g' (Parens v) = (Parens <$> g' v) >>= g
g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g
g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
- g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g
- g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g
g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g
@@ -178,33 +200,51 @@ everywhereOnValuesM f g h = (f', g', h')
g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
g' other = g other
+ h' :: Binder -> m Binder
+ h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h
h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h
h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
- h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h
- h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h
h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h
h' other = h other
- handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs
- <*> eitherM (traverse (pairM g' g')) g' val
+ lit :: (a -> m a) -> Literal a -> m (Literal a)
+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as
+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as
+ lit _ other = pure other
+
+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative
+ handleCaseAlternative (CaseAlternative bs val) =
+ CaseAlternative
+ <$> traverse h' bs
+ <*> eitherM (traverse (pairM g' g')) g' val
+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
-everythingOnValues :: (r -> r -> r) ->
- (Declaration -> r) ->
- (Expr -> r) ->
- (Binder -> r) ->
- (CaseAlternative -> r) ->
- (DoNotationElement -> r) ->
- (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
+everythingOnValues
+ :: forall r
+ . (r -> r -> r)
+ -> (Declaration -> r)
+ -> (Expr -> r)
+ -> (Binder -> r)
+ -> (CaseAlternative -> r)
+ -> (DoNotationElement -> r)
+ -> ( Declaration -> r
+ , Expr -> r
+ , Binder -> r
+ , CaseAlternative -> r
+ , DoNotationElement -> r
+ )
everythingOnValues (<>) f g h i j = (f', g', h', i', j')
where
+
+ f' :: Declaration -> r
f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
@@ -214,13 +254,13 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
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@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1
g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1
- g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
- g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
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) (map (g' . snd) vs)
@@ -234,42 +274,53 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
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) (map 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@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
- h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
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 (map go as)
+ lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as)
+ lit r _ _ = r
+
+ i' :: CaseAlternative -> r
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)
+ 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) (map f' ds)
j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
-everythingWithContextOnValues ::
- s ->
- r ->
- (r -> r -> r) ->
- (s -> Declaration -> (s, r)) ->
- (s -> Expr -> (s, r)) ->
- (s -> Binder -> (s, r)) ->
- (s -> CaseAlternative -> (s, r)) ->
- (s -> DoNotationElement -> (s, r)) ->
- ( Declaration -> r
- , Expr -> r
- , Binder -> r
- , CaseAlternative -> r
- , DoNotationElement -> r)
+everythingWithContextOnValues
+ :: forall s r
+ . s
+ -> r
+ -> (r -> r -> r)
+ -> (s -> Declaration -> (s, r))
+ -> (s -> Expr -> (s, r))
+ -> (s -> Binder -> (s, r))
+ -> (s -> CaseAlternative -> (s, r))
+ -> (s -> DoNotationElement -> (s, r))
+ -> ( Declaration -> r
+ , Expr -> r
+ , Binder -> r
+ , CaseAlternative -> r
+ , DoNotationElement -> r)
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 -> Declaration -> r
f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
@@ -279,15 +330,16 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
f' s (PositionedDeclaration _ _ d1) = f'' s d1
f' _ _ = r0
+ g'' :: s -> Expr -> r
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 (Parens v1) = g'' s v1
g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
- g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
- g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
g' s (Accessor _ v1) = g'' s v1
g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
@@ -301,42 +353,54 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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 -> Binder -> r
+ h' s (LiteralBinder l) = lit h'' s l
h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (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 (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
- h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
h' s (NamedBinder _ b1) = h'' s b1
h' s (PositionedBinder _ _ b1) = h'' s b1
h' s (TypedBinder _ b1) = h'' s b1
h' _ _ = r0
+ lit :: (s -> a -> r) -> s -> Literal a -> r
+ lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as)
+ lit go s (ObjectLiteral as) = foldl (<>) r0 (map (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 -> CaseAlternative -> r
i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' 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 -> 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 (map (f'' s) ds)
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
-everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
- s ->
- (s -> Declaration -> m (s, Declaration)) ->
- (s -> Expr -> m (s, Expr)) ->
- (s -> Binder -> m (s, Binder)) ->
- (s -> CaseAlternative -> m (s, CaseAlternative)) ->
- (s -> DoNotationElement -> m (s, DoNotationElement)) ->
- ( Declaration -> m Declaration
- , Expr -> m Expr
- , Binder -> m Binder
- , CaseAlternative -> m CaseAlternative
- , DoNotationElement -> m DoNotationElement)
+everywhereWithContextOnValuesM
+ :: forall m s
+ . (Monad m)
+ => s
+ -> (s -> Declaration -> m (s, Declaration))
+ -> (s -> Expr -> m (s, Expr))
+ -> (s -> Binder -> m (s, Binder))
+ -> (s -> CaseAlternative -> m (s, CaseAlternative))
+ -> (s -> DoNotationElement -> m (s, DoNotationElement))
+ -> ( Declaration -> m Declaration
+ , Expr -> m Expr
+ , Binder -> m Binder
+ , CaseAlternative -> m CaseAlternative
+ , DoNotationElement -> m DoNotationElement)
everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
where
f'' s = uncurry f' <=< f s
@@ -351,13 +415,12 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g'' s = uncurry g' <=< g s
+ g' s (Literal l) = Literal <$> lit g'' s l
g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
g' s (Parens v) = Parens <$> g'' s v
g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)
g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
- g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs
- g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs
g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
g' s (Accessor prop v) = Accessor prop <$> g'' s v
g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs
@@ -373,16 +436,20 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
h'' s = uncurry h' <=< h s
+ h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l
h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs
h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
- h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs
- h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs
h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
h' s (TypedBinder t b) = TypedBinder t <$> h'' s b
h' _ other = return other
+ lit :: (s -> a -> m a) -> s -> Literal a -> m (Literal a)
+ lit go s (ArrayLiteral as) = ArrayLiteral <$> traverse (go s) as
+ lit go s (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM (go s)) as
+ lit _ _ other = return other
+
i'' s = uncurry i' <=< i s
i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
@@ -394,25 +461,29 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds
j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
-everythingWithScope ::
- (Monoid r) =>
- (S.Set Ident -> Declaration -> r) ->
- (S.Set Ident -> Expr -> r) ->
- (S.Set Ident -> Binder -> r) ->
- (S.Set Ident -> CaseAlternative -> r) ->
- (S.Set Ident -> DoNotationElement -> r) ->
- ( S.Set Ident -> Declaration -> r
- , S.Set Ident -> Expr -> r
- , S.Set Ident -> Binder -> r
- , S.Set Ident -> CaseAlternative -> r
- , S.Set Ident -> DoNotationElement -> r)
+everythingWithScope
+ :: forall r
+ . (Monoid r)
+ => (S.Set Ident -> Declaration -> r)
+ -> (S.Set Ident -> Expr -> r)
+ -> (S.Set Ident -> Binder -> r)
+ -> (S.Set Ident -> CaseAlternative -> r)
+ -> (S.Set Ident -> DoNotationElement -> r)
+ -> ( S.Set Ident -> Declaration -> r
+ , S.Set Ident -> Expr -> r
+ , S.Set Ident -> Binder -> r
+ , S.Set Ident -> CaseAlternative -> r
+ , S.Set Ident -> DoNotationElement -> r
+ )
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 Ident -> Declaration -> r
f'' s a = f s a <> f' s a
+ f' :: S.Set Ident -> Declaration -> r
f' s (DataBindingGroupDeclaration ds) =
let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
in foldMap (f'' s') ds
@@ -431,15 +502,16 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
f' s (PositionedDeclaration _ _ d) = f'' s d
f' _ _ = mempty
+ g'' :: S.Set Ident -> Expr -> r
g'' s a = g s a <> g' s a
+ g' :: S.Set Ident -> 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 (Parens v1) = g'' s v1
g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
- g' s (ArrayLiteral vs) = foldMap (g'' s) vs
- g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
g' s (Accessor _ v1) = g'' s v1
g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
@@ -460,20 +532,28 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
g' s (PositionedValue _ _ v1) = g'' s v1
g' _ _ = mempty
+ h'' :: S.Set Ident -> Binder -> r
h'' s a = h s a <> h' s a
+ h' :: S.Set Ident -> Binder -> r
+ h' s (LiteralBinder l) = lit h'' s l
h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
h' s (ParensInBinder b) = h'' s b
- h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs
- h' s (ArrayBinder bs) = foldMap (h'' s) bs
h' s (NamedBinder name b1) = h'' (S.insert name s) b1
h' s (PositionedBinder _ _ b1) = h'' s b1
h' s (TypedBinder _ b1) = h'' s b1
h' _ _ = mempty
+ lit :: (S.Set Ident -> a -> r) -> S.Set Ident -> Literal a -> r
+ lit go s (ArrayLiteral as) = foldMap (go s) as
+ lit go s (ObjectLiteral as) = foldMap (go s . snd) as
+ lit _ _ _ = mempty
+
+ i'' :: S.Set Ident -> CaseAlternative -> r
i'' s a = i s a <> i' s a
+ i' :: S.Set Ident -> CaseAlternative -> r
i' s (CaseAlternative bs (Right val)) =
let s' = S.union s (S.fromList (concatMap binderNames bs))
in foldMap (h'' s) bs <> g'' s' val
@@ -481,8 +561,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
let s' = S.union s (S.fromList (concatMap binderNames bs))
in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs
+ j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
j'' s a = let (s', r) = j' s a in (s', j s a <> r)
+ j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
j' s (DoNotationValue v) = (s, g'' s v)
j' s (DoNotationBind b v) =
let s' = S.union (S.fromList (binderNames b)) s
@@ -498,7 +580,15 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
getDeclIdent (TypeDeclaration ident _) = Just ident
getDeclIdent _ = Nothing
-accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
+accumTypes
+ :: (Monoid r)
+ => (Type -> r)
+ -> ( Declaration -> r
+ , Expr -> r
+ , Binder -> r
+ , CaseAlternative -> r
+ , DoNotationElement -> r
+ )
accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
where
forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 3efa43f..38caa2d 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -141,7 +141,7 @@ checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String
checkImportPath _ "./foreign" m _ =
Right (ModuleIdentifier (moduleName m) Foreign)
checkImportPath requirePath name _ names
- | Just name' <- stripPrefix (fromMaybe "" requirePath) name
+ | Just name' <- stripPrefix (fromMaybe "../" requirePath) name
, name' `S.member` names = Right (ModuleIdentifier name' Regular)
checkImportPath _ name _ _ = Left name
@@ -209,7 +209,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
--
-- Each type of module element is matched using pattern guards, and everything else is bundled into the
-- Other constructor.
-toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module
+toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module
toModule requirePath mids mid top
| JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns
| otherwise = err InvalidTopLevel
@@ -533,7 +533,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem
-- | The bundling function.
-- This function performs dead code elimination, filters empty modules
-- and generates and prints the final Javascript bundle.
-bundle :: (Applicative m, MonadError ErrorMessage m)
+bundle :: (MonadError ErrorMessage m)
=> [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
-> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
-> Maybe String -- ^ An optional main module.
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 3b2de22..d4a1e8f 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -47,7 +47,7 @@ import System.FilePath.Posix ((</>))
--
moduleToJs
:: forall m
- . (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
+ . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
=> Module Ann
-> Maybe JS
-> m [JS]
@@ -55,7 +55,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
rethrow (addHint (ErrorInModule mn)) $ do
let usedNames = concatMap getNames decls
let mnLookup = renameImports usedNames imps
- jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps
+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd imps
let decls' = renameModules mnLookup decls
jsDecls <- mapM bindToJs decls'
optimized <- T.traverse (T.traverse optimize) jsDecls
@@ -67,7 +67,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
let foreignExps = exps `intersect` (fst `map` foreigns)
let standardExps = exps \\ foreignExps
- let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps
+ let exps' = JSObjectLiteral Nothing $ map (runIdent &&& JSVar Nothing . identToJs) standardExps
++ map (runIdent &&& foreignIdent) foreignExps
return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']
@@ -85,7 +85,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- with declaration names.
--
renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
- renameImports ids mns = go M.empty ids mns
+ renameImports = go M.empty
where
go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
go acc used ((ann, mn') : mns') =
@@ -111,7 +111,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
importToJs mnLookup mn' = do
path <- asks optionsRequirePath
let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
- let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]
+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromMaybe ".." path </> runModuleName mn')]
withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
-- |
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 59f7bc1..dd9a69a 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -347,7 +347,7 @@ everywhereOnJS f = go
everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)
-everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS
+everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS
everywhereOnJSTopDownM f = f >=> go
where
f' = f >=> go
diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs
index 8c004b3..720d829 100644
--- a/src/Language/PureScript/CodeGen/JS/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -78,7 +78,7 @@ nameIsJsReserved name =
--
nameIsJsBuiltIn :: String -> Bool
nameIsJsBuiltIn name =
- elem name
+ name `elem`
[ "arguments"
, "Array"
, "ArrayBuffer"
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index 5836b46..d270949 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -43,12 +43,12 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks
-- |
-- Apply a series of optimizer passes to simplified Javascript code
--
-optimize :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS
+optimize :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS
optimize js = do
noOpt <- asks optionsNoOptimizations
if noOpt then return js else optimize' js
-optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS
+optimize' :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS
optimize' js = do
opts <- ask
js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index 6b9f4e7..bcc2b39 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -96,9 +96,9 @@ inlineCommonValues = everywhereOnJS convert
fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]
fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]
fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]
- fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]
- fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]
- fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]
+ fnAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, (C.+)), (C.dataSemiring, C.add)]
+ fnDivide = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)]
+ fnMultiply = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, (C.*)), (C.dataSemiring, C.mul)]
fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]
intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
@@ -235,7 +235,7 @@ inlineCommonOperators = applyAll $
-- (f <<< g $ x) = f (g x)
-- (f <<< g) = \x -> f (g x)
-inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS
+inlineFnComposition :: (MonadSupply m) => JS -> m JS
inlineFnComposition = everywhereOnJSTopDownM convert
where
convert :: (MonadSupply m) => JS -> m JS
diff --git a/src/Language/PureScript/CoreFn.hs b/src/Language/PureScript/CoreFn.hs
index a06840e..ffebd2e 100644
--- a/src/Language/PureScript/CoreFn.hs
+++ b/src/Language/PureScript/CoreFn.hs
@@ -1,17 +1,6 @@
------------------------------------------------------------------------------
+-- |
+-- The core functional representation
--
--- Module : Language.PureScript.CoreFn
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- | The core functional representation
---
------------------------------------------------------------------------------
-
module Language.PureScript.CoreFn (
module C
) where
@@ -20,7 +9,7 @@ import Language.PureScript.CoreFn.Ann as C
import Language.PureScript.CoreFn.Binders as C
import Language.PureScript.CoreFn.Desugar as C
import Language.PureScript.CoreFn.Expr as C
-import Language.PureScript.CoreFn.Literals as C
+import Language.PureScript.AST.Literals as C
import Language.PureScript.CoreFn.Meta as C
import Language.PureScript.CoreFn.Module as C
import Language.PureScript.CoreFn.Traversals as C
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
index ae8a014..7f6623b 100644
--- a/src/Language/PureScript/CoreFn/Binders.hs
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -5,7 +5,7 @@
--
module Language.PureScript.CoreFn.Binders where
-import Language.PureScript.CoreFn.Literals
+import Language.PureScript.AST.Literals
import Language.PureScript.Names
-- |
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 9816bc0..0c86329 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -17,7 +17,7 @@ import Language.PureScript.AST.Traversals
import Language.PureScript.CoreFn.Ann
import Language.PureScript.CoreFn.Binders
import Language.PureScript.CoreFn.Expr
-import Language.PureScript.CoreFn.Literals
+import Language.PureScript.AST.Literals
import Language.PureScript.CoreFn.Meta
import Language.PureScript.CoreFn.Module
import Language.PureScript.Environment
@@ -88,18 +88,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
-- Desugars expressions from AST to CoreFn representation.
--
exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
- exprToCoreFn ss com ty (A.NumericLiteral v) =
- Literal (ss, com, ty, Nothing) (NumericLiteral v)
- exprToCoreFn ss com ty (A.StringLiteral v) =
- Literal (ss, com, ty, Nothing) (StringLiteral v)
- exprToCoreFn ss com ty (A.CharLiteral v) =
- Literal (ss, com, ty, Nothing) (CharLiteral v)
- exprToCoreFn ss com ty (A.BooleanLiteral v) =
- Literal (ss, com, ty, Nothing) (BooleanLiteral v)
- exprToCoreFn ss com ty (A.ArrayLiteral vs) =
- Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)
- exprToCoreFn ss com ty (A.ObjectLiteral vs) =
- Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)
+ exprToCoreFn ss com ty (A.Literal lit) =
+ Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit)
exprToCoreFn ss com ty (A.Accessor name v) =
Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
@@ -126,7 +116,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
exprToCoreFn ss com (Just ty) v
exprToCoreFn ss com ty (A.Let ds v) =
Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)
- exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) =
let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
in foldl (App (ss, com, Nothing, Nothing)) ctor args
@@ -152,25 +142,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
-- Desugars case binders from AST to CoreFn representation.
--
binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
- binderToCoreFn ss com (A.NullBinder) =
+ binderToCoreFn ss com (A.LiteralBinder lit) =
+ LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)
+ binderToCoreFn ss com A.NullBinder =
NullBinder (ss, com, Nothing, Nothing)
- binderToCoreFn ss com (A.BooleanBinder b) =
- LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
- binderToCoreFn ss com (A.StringBinder s) =
- LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
- binderToCoreFn ss com (A.CharBinder c) =
- LiteralBinder (ss, com, Nothing, Nothing) (CharLiteral c)
- binderToCoreFn ss com (A.NumberBinder n) =
- LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
binderToCoreFn ss com (A.VarBinder name) =
VarBinder (ss, com, Nothing, Nothing) name
binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
let (_, tctor, _, _) = lookupConstructor env dctor
in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)
- binderToCoreFn ss com (A.ObjectBinder bs) =
- LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)
- binderToCoreFn ss com (A.ArrayBinder bs) =
- LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)
binderToCoreFn ss com (A.NamedBinder name b) =
NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index c4117d7..961c70b 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -8,7 +8,7 @@ module Language.PureScript.CoreFn.Expr where
import Control.Arrow ((***))
import Language.PureScript.CoreFn.Binders
-import Language.PureScript.CoreFn.Literals
+import Language.PureScript.AST.Literals
import Language.PureScript.Names
-- |
diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs
index 91a077e..613062e 100644
--- a/src/Language/PureScript/CoreFn/Traversals.hs
+++ b/src/Language/PureScript/CoreFn/Traversals.hs
@@ -1,24 +1,13 @@
------------------------------------------------------------------------------
+-- |
+-- CoreFn traversal helpers
--
--- Module : Language.PureScript.CoreFn.Traversals
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- | CoreFn traversal helpers
---
------------------------------------------------------------------------------
-
module Language.PureScript.CoreFn.Traversals where
import Control.Arrow (second, (***), (+++))
import Language.PureScript.CoreFn.Binders
import Language.PureScript.CoreFn.Expr
-import Language.PureScript.CoreFn.Literals
+import Language.PureScript.AST.Literals
everywhereOnValues :: (Bind a -> Bind a) ->
(Expr a -> Expr a) ->
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 9d1f0a6..b2de1d6 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -29,8 +29,7 @@ import qualified Language.PureScript.Docs.Render as Render
-- Markdown-formatted String.
--
renderModulesAsMarkdown ::
- (Functor m, Applicative m,
- MonadError P.MultipleErrors m) =>
+ (MonadError P.MultipleErrors m) =>
[P.Module] ->
m String
renderModulesAsMarkdown =
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index 3b98889..2cb83cb 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Functions for converting PureScript ASTs into values of the data types
@@ -38,7 +36,7 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports)
-- documentation.
--
convertModulesInPackage ::
- (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ (MonadError P.MultipleErrors m) =>
[InPackage P.Module] ->
m [Module]
convertModulesInPackage modules =
@@ -66,7 +64,7 @@ convertModulesInPackage modules =
-- types.
--
convertModules ::
- (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ (MonadError P.MultipleErrors m) =>
[P.Module] ->
m [Module]
convertModules =
@@ -81,7 +79,7 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
-- Convert a sorted list of modules.
--
convertSorted ::
- (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ (MonadError P.MultipleErrors m) =>
[P.Module] ->
m [Module]
convertSorted modules = do
@@ -99,7 +97,7 @@ convertSorted modules = do
-- types.
--
typeCheckIfNecessary ::
- (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ (MonadError P.MultipleErrors m) =>
[P.Module] ->
[Module] ->
m [Module]
@@ -122,7 +120,7 @@ typeCheckIfNecessary modules convertedModules =
-- were not provided.
--
typeCheck ::
- (Functor m, MonadError P.MultipleErrors m) =>
+ (MonadError P.MultipleErrors m) =>
[P.Module] ->
m ([P.Module], P.Environment)
typeCheck =
@@ -182,7 +180,7 @@ runParser p s = either (Left . show) Right $ do
-- documentation information from.
--
partiallyDesugar ::
- (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ (MonadError P.MultipleErrors m) =>
[P.Module]
-> m (P.Env, [P.Module])
partiallyDesugar = P.evalSupplyT 0 . desugar'
diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
index a9330f9..0c67f88 100644
--- a/src/Language/PureScript/Docs/Convert/ReExports.hs
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -69,8 +68,7 @@ updateReExports env order modules =
-- have already been converted.
--
getReExports ::
- (Functor m, Applicative m,
- MonadState (Map P.ModuleName Module) m) =>
+ (MonadState (Map P.ModuleName Module) m) =>
P.Env ->
P.ModuleName ->
m [(P.ModuleName, [Declaration])]
@@ -105,9 +103,7 @@ getReExports env mn =
-- class members are listed.
--
collectDeclarations ::
- (Functor m, Applicative m,
- MonadState (Map P.ModuleName Module) m,
- MonadReader P.ModuleName m) =>
+ (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>
P.Imports ->
P.Exports ->
m [(P.ModuleName, [Declaration])]
@@ -154,7 +150,7 @@ collectDeclarations imports exports = do
-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.
--
findImport ::
- (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>
+ (Show name, Eq name, MonadReader P.ModuleName m) =>
[P.ImportRecord name] ->
(name, P.ModuleName) ->
m (P.ModuleName, name)
@@ -174,9 +170,8 @@ findImport imps (name, orig) =
internalErrorInModule ("findImport: not found: " ++ show (name, orig))
lookupValueDeclaration ::
- (Applicative m,
- MonadState (Map P.ModuleName Module) m,
- MonadReader P.ModuleName m) =>
+ (MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
P.ModuleName ->
P.Ident ->
m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
@@ -221,8 +216,7 @@ lookupValueDeclaration importedFrom ident = do
pure (importedFrom, [Left r'])
other ->
errOther other
- other -> do
- errOther other
+ other -> errOther other
where
thd :: (a, b, c) -> c
@@ -233,9 +227,8 @@ lookupValueDeclaration importedFrom ident = do
-- are only included in the output if they are listed in the arguments.
--
lookupTypeDeclaration ::
- (Applicative m,
- MonadState (Map P.ModuleName Module) m,
- MonadReader P.ModuleName m) =>
+ (MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
P.ModuleName ->
P.ProperName 'P.TypeName ->
m (P.ModuleName, [Declaration])
@@ -251,9 +244,8 @@ lookupTypeDeclaration importedFrom ty = do
("lookupTypeDeclaration: unexpected result: " ++ show other)
lookupTypeClassDeclaration ::
- (Applicative m,
- MonadState (Map P.ModuleName Module) m,
- MonadReader P.ModuleName m) =>
+ (MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
P.ModuleName ->
P.ProperName 'P.ClassName ->
m (P.ModuleName, [Declaration])
@@ -276,9 +268,8 @@ lookupTypeClassDeclaration importedFrom tyClass = do
-- state, or raise an internal error if it is not there.
--
lookupModuleDeclarations ::
- (Applicative m,
- MonadState (Map P.ModuleName Module) m,
- MonadReader P.ModuleName m) =>
+ (MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
String ->
P.ModuleName ->
m [Declaration]
@@ -293,8 +284,7 @@ lookupModuleDeclarations definedIn moduleName = do
pure (allDeclarations mdl)
handleTypeClassMembers ::
- (Functor m, Applicative m,
- MonadReader P.ModuleName m) =>
+ (MonadReader P.ModuleName m) =>
Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
Map P.ModuleName [Declaration] ->
m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
@@ -364,8 +354,7 @@ instance Monoid TypeClassEnv where
-- Returns a tuple of (values, type classes).
--
handleEnv ::
- (Functor m, Applicative m,
- MonadReader P.ModuleName m) =>
+ (MonadReader P.ModuleName m) =>
TypeClassEnv ->
m ([Declaration], [Declaration])
handleEnv TypeClassEnv{..} =
@@ -390,7 +379,7 @@ handleEnv TypeClassEnv{..} =
promoteChild constraint ChildDeclaration{..} =
case cdeclInfo of
ChildTypeClassMember typ ->
- pure $ Declaration
+ pure Declaration
{ declTitle = cdeclTitle
, declComments = cdeclComments
, declSourceSpan = cdeclSourceSpan
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index cade0ec..fd9845c 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -11,11 +11,10 @@ module Language.PureScript.Docs.Convert.Single
import Prelude ()
import Prelude.Compat
-import Data.Maybe (catMaybes)
+import Data.Maybe (mapMaybe, isNothing)
import Control.Monad
import Control.Category ((>>>))
-import Data.Maybe (mapMaybe, isNothing)
import Data.Either
import Data.List (nub, isPrefixOf, isSuffixOf)
@@ -137,7 +136,7 @@ basicDeclaration title info = Just $ Right $ mkDeclaration title info
convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =
basicDeclaration title (ValueDeclaration ty)
-convertDeclaration (P.ValueDeclaration _ _ _ _) title =
+convertDeclaration (P.ValueDeclaration {}) title =
-- If no explicit type declaration was provided, insert a wildcard, so that
-- the actual type will be added during type checking.
basicDeclaration title (ValueDeclaration P.TypeWildcard)
@@ -205,7 +204,7 @@ convertDeclaration _ _ = Nothing
convertComments :: [P.Comment] -> Maybe String
convertComments cs = do
let raw = concatMap toLines cs
- let docs = catMaybes (map stripPipe raw)
+ let docs = mapMaybe stripPipe raw
guard (not (null docs))
pure (unlines docs)
diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs
index ed94820..cfb32d5 100644
--- a/src/Language/PureScript/Docs/ParseAndBookmark.hs
+++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs
@@ -35,7 +35,7 @@ import Language.PureScript.Docs.Convert (collectBookmarks)
-- * Collect a list of bookmarks from the whole set of source files
-- * Return the parsed modules and the bookmarks
parseAndBookmark ::
- (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>
+ (MonadError P.MultipleErrors m, MonadIO m) =>
[FilePath]
-> [(PackageName, FilePath)]
-> m ([InPackage P.Module], [Bookmark])
@@ -82,7 +82,7 @@ fileInfoToString (FromDep _ fn) = fn
parseFile :: FilePath -> IO (FilePath, String)
parseFile input' = (,) input' <$> readFile input'
-parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)
+parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)
parseAs g = fmap (first g) . liftIO . parseFile
getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 9c5d2d6..c6bdb14 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -148,6 +148,7 @@ data SimpleErrorMessage
| CaseBinderLengthDiffers Int [Binder]
| IncorrectAnonymousArgument
| InvalidOperatorInBinder Ident Ident
+ | DeprecatedRequirePath
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -328,6 +329,7 @@ errorCode em = case unwrapErrorMessage em of
CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"
InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
+ DeprecatedRequirePath{} -> "DeprecatedRequirePath"
-- |
-- A stack trace for an error
@@ -447,6 +449,7 @@ errorSuggestion err = case err of
UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
+ HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
_ -> Nothing
where
@@ -634,7 +637,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
renderSimpleErrorMessage (CycleInDeclaration nm) =
line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."
renderSimpleErrorMessage (CycleInModules mns) =
- paras [ line $ "There is a cycle in module dependencies in these modules: "
+ paras [ line "There is a cycle in module dependencies in these modules: "
, indent $ paras (map (line . runModuleName) mns)
]
renderSimpleErrorMessage (CycleInTypeSynonym name) =
@@ -668,7 +671,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type)
sortRows' (s1, r1) (s2, r2) =
let common :: [(String, (Type, Type))]
- common = sortBy (comparing fst) $ [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
+ common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
sd1, sd2 :: [(String, Type)]
sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
@@ -837,8 +840,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
paras [ line "A case expression could not be determined to cover all inputs."
, line "The following additional cases are required to cover all inputs:\n"
, indent $ paras $
- [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
- ++ [ line "..." | not b ]
+ Box.hsep 1 Box.left
+ (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
+ : [line "..." | not b]
, line "Or alternatively, add a Partial constraint to the type of the enclosing value."
, line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."
]
@@ -955,9 +959,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
, indent $ line $ showSuggestion msg
]
- renderSimpleErrorMessage (HidingImport mn refs) =
+ renderSimpleErrorMessage msg@(HidingImport mn _) =
paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "
- , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
+ , indent $ line $ showSuggestion msg
]
renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
@@ -970,10 +974,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
line "An anonymous function argument appears in an invalid context."
renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =
- paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."
+ paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."
, line "Only aliases for data constructors may be used in patterns."
]
+ renderSimpleErrorMessage DeprecatedRequirePath =
+ line "The require-path option is deprecated and will be removed in PureScript 0.9."
+
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
renderHint (ErrorUnifyingTypes t1 t2) detail =
paras [ detail
@@ -1181,31 +1188,32 @@ prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
-- Pretty print multiple errors
--
prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
-prettyPrintMultipleErrors full = renderBox . prettyPrintMultipleErrorsBox full
+prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full
-- |
-- Pretty print multiple warnings
--
-prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
-prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox full
+prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
+prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full
-- | Pretty print warnings as a Box
-prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
-prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
+prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]
+prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning"
-- | Pretty print errors as a Box
-prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
-prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
+prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]
+prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"
-prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box
+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]
prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =
let result = prettyPrintSingleError full level True e
- in Box.vcat Box.left [ Box.text intro
- , result
- ]
+ in [ Box.vcat Box.left [ Box.text intro
+ , result
+ ]
+ ]
prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =
let result = map (prettyPrintSingleError full level True) es
- in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result
+ in concat $ zipWith withIntro [1 :: Int ..] result
where
withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")
, Box.moveRight 2 err
@@ -1283,7 +1291,7 @@ renderBox = unlines
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)
-reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a)
+reifyErrors :: (MonadError e m) => m a -> m (Either e a)
reifyErrors ma = catchError (fmap Right ma) (return . Left)
reflectErrors :: (MonadError e m) => m (Either e a) -> m a
@@ -1310,13 +1318,13 @@ withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : h
-- |
-- Collect errors in in parallel
--
-parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
+parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]
parU xs f = forM xs (withError . f) >>= collectErrors
where
- withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
+ withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a)
withError u = catchError (Right <$> u) (return . Left)
- collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
+ collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]
collectErrors es = case lefts es of
[] -> return $ rights es
errs -> throwError $ fold errs
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 3d9a45a..a77734e 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -74,12 +74,12 @@ findType :: (PscIde m, MonadLogger m) =>
findType search filters =
CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports
-findPursuitCompletions :: (Applicative m, MonadIO m, MonadLogger m) =>
+findPursuitCompletions :: (MonadIO m, MonadLogger m) =>
PursuitQuery -> m Success
findPursuitCompletions (PursuitQuery q) =
PursuitResult <$> liftIO (searchPursuitForDeclarations q)
-findPursuitPackages :: (Applicative m, MonadIO m, MonadLogger m) =>
+findPursuitPackages :: (MonadIO m, MonadLogger m) =>
PursuitQuery -> m Success
findPursuitPackages (PursuitQuery q) =
PursuitResult <$> liftIO (findPackagesForModuleIdent q)
@@ -118,7 +118,7 @@ caseSplit l b e csa t = do
addClause :: Text -> CS.WildcardAnnotations -> Success
addClause t wca = MultilineTextResult (CS.addClause t wca)
-importsForFile :: (Applicative m, MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
+importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
FilePath -> m Success
importsForFile fp = do
imports <- getImportsForFile fp
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index 83dbeab..0e4d089 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -19,6 +19,7 @@ module Language.PureScript.Ide.CaseSplit
import Prelude ()
import Prelude.Compat hiding (lex)
+import Control.Arrow (second)
import Control.Monad.Error.Class
import "monad-logger" Control.Monad.Logger
import Data.List (find)
@@ -54,21 +55,13 @@ noAnnotations = WildcardAnnotations False
caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
Text -> m [Constructor]
caseSplit q = do
- (tc, args) <- splitTypeConstructor (parseType' (T.unpack q))
+ type' <- parseType' (T.unpack q)
+ (tc, args) <- splitTypeConstructor type'
(EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc
let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))
- let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors
+ let appliedCtors = map (second (map applyTypeVars)) ctors
pure appliedCtors
-{- ["EDType {
- edTypeName = ProperName {runProperName = \"Either\"}
- , edTypeKind = FunKind Star (FunKind Star Star)
- , edTypeDeclarationKind =
- DataType [(\"a\",Just Star),(\"b\",Just Star)]
- [(ProperName {runProperName = \"Left\"},[TypeVar \"a\"])
- ,(ProperName {runProperName = \"Right\"},[TypeVar \"b\"])]}"]
--}
-
findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
ProperName 'TypeName -> m ExternsDeclaration
findTypeDeclaration q = do
@@ -87,7 +80,7 @@ findTypeDeclaration' t ExternsFile{..} =
EDType tn _ _ -> tn == t
_ -> False) efDeclarations
-splitTypeConstructor :: (Applicative m, MonadError PscIdeError m) =>
+splitTypeConstructor :: (MonadError PscIdeError m) =>
Type -> m (ProperName 'TypeName, [Type])
splitTypeConstructor = go []
where
@@ -128,11 +121,14 @@ addClause s wca =
" = ?" <> (T.strip . T.pack . runIdent $ fName)
in [s, template]
-parseType' :: String -> Type
-parseType' s = let (Right t) = do
- ts <- lex "" s
- runTokenParser "" (parseType <* P.eof) ts
- in t
+parseType' :: (MonadError PscIdeError m) =>
+ String -> m Type
+parseType' s =
+ case lex "<psc-ide>" s >>= runTokenParser "<psc-ide>" (parseType <* P.eof) of
+ Right type' -> pure type'
+ Left err ->
+ throwError (GeneralError ("Parsing the splittype failed with:"
+ ++ show err))
parseTypeDeclaration' :: String -> (Ident, Type)
parseTypeDeclaration' s =
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index d0430ad..c813066 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -24,12 +24,12 @@ getExactMatches search filters modules =
completionsFromModules :: [Module] -> [Completion]
completionsFromModules = foldMap completionFromModule
- where
- completionFromModule :: Module -> [Completion]
- completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls
+ where
+ completionFromModule :: Module -> [Completion]
+ completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls
completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion
completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type'))
completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind))
-completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module"))
+completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module"))
completionFromDecl _ _ = Nothing
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 9b5d1fb..0281211 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -21,21 +21,20 @@ data PscIdeError
instance ToJSON PscIdeError where
toJSON err = object
- [
- "resultType" .= ("error" :: Text),
- "result" .= textError err
- ]
+ [ "resultType" .= ("error" :: Text)
+ , "result" .= textError err
+ ]
textError :: PscIdeError -> Text
-textError (GeneralError msg) = pack msg
-textError (NotFound ident) = "Symbol '" <> ident <> "' not found."
-textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."
-textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"
-textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError)
- where
+textError (GeneralError msg) = pack msg
+textError (NotFound ident) = "Symbol '" <> ident <> "' not found."
+textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."
+textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"
+textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError)
+ where
-- escape newlines and other special chars so we can send the error over the socket as a single line
- escape :: P.ParseError -> String
- escape = show
+ escape :: P.ParseError -> String
+ escape = show
-- | Specialized version of `first` from `Data.Bifunctors`
first :: (a -> b) -> Either a r -> Either b r
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 67e9cd7..0ce7a8e 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -34,7 +34,7 @@ import Language.PureScript.Ide.Types
import qualified Language.PureScript.Names as N
import qualified Language.PureScript.Pretty as PP
-readExternFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>
+readExternFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m PE.ExternsFile
readExternFile fp = do
parseResult <- liftIO (decodeT <$> T.readFile fp)
diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs
index cb92cc3..65244a6 100644
--- a/src/Language/PureScript/Ide/Matcher.hs
+++ b/src/Language/PureScript/Ide/Matcher.hs
@@ -76,8 +76,8 @@ flexMatch pattern = mapMaybe (flexRate pattern)
flexRate :: Text -> Completion -> Maybe ScoredCompletion
flexRate pattern c@(Completion (_,ident,_)) = do
- score <- flexScore pattern ident
- return (c, score)
+ score <- flexScore pattern ident
+ return (c, score)
-- FlexMatching ala Sublime.
-- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/
@@ -86,15 +86,25 @@ flexRate pattern c@(Completion (_,ident,_)) = do
-- the matchas a (start, length) tuple if there's a match.
-- If match fails then it would be (-1,0)
flexScore :: Text -> DeclIdent -> Maybe Double
-flexScore "" _ = Nothing
flexScore pat str =
- case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of
+ case T.uncons pat of
+ Nothing -> Nothing
+ Just (first, pattern) ->
+ case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of
(-1,0) -> Nothing
(start,len) -> Just $ calcScore start (start + len)
- where
- Just (first,pattern) = T.uncons pat
- -- This just interleaves the search string with .*
- -- abcd -> a.*b.*c.*d
- pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern
- calcScore start end =
- 100.0 / fromIntegral ((1 + start) * (end - start + 1))
+ where
+ escapedPattern :: [Text]
+ escapedPattern = map escape (T.unpack pattern)
+
+ -- escape prepends a backslash to "regexy" characters to prevent the
+ -- matcher from crashing when trying to build the regex
+ escape :: Char -> Text
+ escape c = if c `elem` ("[\\^$.|?*+(){}" :: String)
+ then T.pack ['\\', c]
+ else T.singleton c
+ -- This just interleaves the search pattern with .*
+ -- abcd[*] -> a.*b.*c.*d.*[*]
+ pat' = escape first <> foldMap (<> ".*") escapedPattern
+ calcScore start end =
+ 100.0 / fromIntegral ((1 + start) * (end - start + 1))
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
index 8a6987d..ed401f4 100644
--- a/src/Language/PureScript/Ide/Pursuit.hs
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -10,9 +10,9 @@ import qualified Control.Exception as E
import Data.Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict)
-import Data.Foldable (toList)
+import Data.Foldable (toList)
+import Data.Maybe (mapMaybe)
import Data.Monoid ((<>))
-import Data.Maybe (mapMaybe)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
@@ -33,12 +33,12 @@ queryPursuit q = do
}
m <- newManager tlsManagerSettings
withHTTP req m $ \resp ->
- P.fold (\x a -> x <> a) "" id $ responseBody resp
+ P.fold (<>) "" id $ responseBody resp
handler :: HttpException -> IO [a]
-handler StatusCodeException{} = return []
-handler _ = return []
+handler StatusCodeException{} = pure []
+handler _ = pure []
searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
searchPursuitForDeclarations query =
@@ -54,12 +54,12 @@ searchPursuitForDeclarations query =
findPackagesForModuleIdent :: Text -> IO [PursuitResponse]
findPackagesForModuleIdent query =
- (do r <- queryPursuit query
- let results' = decode (fromStrict r) :: Maybe Array
- case results' of
- Nothing -> pure []
- Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch`
- handler
+ (do r <- queryPursuit query
+ let results' = decode (fromStrict r) :: Maybe Array
+ case results' of
+ Nothing -> pure []
+ Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch`
+ handler
where
isModuleResponse (Success a@ModuleResponse{}) = Just a
isModuleResponse _ = Nothing
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index 8831e77..fa00f56 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -15,10 +15,10 @@ import Language.PureScript.Ide.Types
getReexports :: Module -> [ExternDecl]
getReexports (mn, decls)= concatMap getExport decls
- where getExport d
- | (Export mn') <- d
- , mn /= mn' = replaceExportWithAliases decls mn'
- | otherwise = []
+ where getExport d
+ | (Export mn') <- d
+ , mn /= mn' = replaceExportWithAliases decls mn'
+ | otherwise = []
dependencyToExport :: ExternDecl -> ExternDecl
dependencyToExport (Dependency m _ _) = Export m
@@ -51,23 +51,25 @@ removeExportDecls = fmap (filter (not . isExport))
replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module
replaceReexports m db = result
- where reexports = getReexports m
- result = foldl go (removeExportDecls m) reexports
+ where
+ reexports = getReexports m
+ result = foldl go (removeExportDecls m) reexports
- go :: Module -> ExternDecl -> Module
- go m' re@(Export name) = replaceReexport re m' (getModule name)
- go _ _ = error "partiality! woohoo"
+ go :: Module -> ExternDecl -> Module
+ go m' re@(Export name) = replaceReexport re m' (getModule name)
+ go _ _ = error "partiality! woohoo"
- getModule :: ModuleIdent -> Module
- getModule name = clean res
- where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db
- -- we have to do this because keeping self exports in will result in
- -- infinite loops
- clean (mn, decls) = (mn,) (filter (/= Export mn) decls)
+ getModule :: ModuleIdent -> Module
+ getModule name = clean res
+ where
+ res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db
+ -- we have to do this because keeping self exports in will result in
+ -- infinite loops
+ clean (mn, decls) = (mn,) (filter (/= Export mn) decls)
resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module
-resolveReexports modules m = do
+resolveReexports modules m =
let replaced = replaceReexports m modules
- if null . getReexports $ replaced
- then replaced
- else resolveReexports modules replaced
+ in if null (getReexports replaced)
+ then replaced
+ else resolveReexports modules replaced
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index ab22ba2..846a8fa 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -3,8 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Ide.SourceFile where
-import Prelude ()
-import Prelude.Compat
+import Prelude
import Control.Monad.Error.Class
import Control.Monad.IO.Class
@@ -22,7 +21,7 @@ import qualified Language.PureScript.Names as N
import qualified Language.PureScript.Parser as P
import System.Directory
-parseModuleFromFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>
+parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m D.Module
parseModuleFromFile fp = do
exists <- liftIO (doesFileExist fp)
@@ -46,24 +45,25 @@ getImports (D.Module _ _ _ declarations _) =
isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i
isImport _ = Nothing
-getImportsForFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>
+getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m [ModuleImport]
getImportsForFile fp = do
module' <- parseModuleFromFile fp
let imports = getImports module'
pure (mkModuleImport . unwrapPositionedImport <$> imports)
- where mkModuleImport (D.ImportDeclaration mn importType' qualifier _) =
- ModuleImport
- (T.pack (N.runModuleName mn))
- importType'
- (T.pack . N.runModuleName <$> qualifier)
- mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"
- unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) =
- D.ImportDeclaration mn (unwrapImportType importType') qualifier b
- unwrapPositionedImport x = x
- unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)
- unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls)
- unwrapImportType D.Implicit = D.Implicit
+ where
+ mkModuleImport (D.ImportDeclaration mn importType' qualifier _) =
+ ModuleImport
+ (T.pack (N.runModuleName mn))
+ importType'
+ (T.pack . N.runModuleName <$> qualifier)
+ mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"
+ unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) =
+ D.ImportDeclaration mn (unwrapImportType importType') qualifier b
+ unwrapPositionedImport x = x
+ unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)
+ unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls)
+ unwrapImportType D.Implicit = D.Implicit
getPositionedImports :: D.Module -> [D.Declaration]
getPositionedImports (D.Module _ _ _ declarations _) =
@@ -73,34 +73,34 @@ getPositionedImports (D.Module _ _ _ declarations _) =
isImport _ = Nothing
getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan
-getDeclPosition m ident =
- let decls = getDeclarations m
- in getFirst (foldMap (match ident) decls)
- where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl
- then Just ss
- else Nothing)
- match _ _ = First Nothing
+getDeclPosition m ident = getFirst (foldMap (match ident) decls)
+ where
+ decls = getDeclarations m
+ match q (D.PositionedDeclaration ss _ decl) = First (if go q decl
+ then Just ss
+ else Nothing)
+ match _ _ = First Nothing
- go q (D.DataDeclaration _ name _ constructors) =
- properEqual name q || any (\(x,_) -> properEqual x q) constructors
- go q (D.DataBindingGroupDeclaration decls) = any (go q) decls
- go q (D.TypeSynonymDeclaration name _ _) = properEqual name q
- go q (D.TypeDeclaration ident' _) = identEqual ident' q
- go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q
- go q (D.ExternDeclaration ident' _) = identEqual ident' q
- go q (D.ExternDataDeclaration name _) = properEqual name q
- go q (D.TypeClassDeclaration name _ _ members) =
- properEqual name q || any (go q . unwrapPositioned) members
- go q (D.TypeInstanceDeclaration ident' _ _ _ _) =
- identEqual ident' q
- go _ _ = False
+ go q (D.DataDeclaration _ name _ constructors) =
+ properEqual name q || any (\(x,_) -> properEqual x q) constructors
+ go q (D.DataBindingGroupDeclaration decls') = any (go q) decls'
+ go q (D.TypeSynonymDeclaration name _ _) = properEqual name q
+ go q (D.TypeDeclaration ident' _) = identEqual ident' q
+ go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q
+ go q (D.ExternDeclaration ident' _) = identEqual ident' q
+ go q (D.ExternDataDeclaration name _) = properEqual name q
+ go q (D.TypeClassDeclaration name _ _ members) =
+ properEqual name q || any (go q . unwrapPositioned) members
+ go q (D.TypeInstanceDeclaration ident' _ _ _ _) =
+ identEqual ident' q
+ go _ _ = False
- properEqual x q = N.runProperName x == q
- identEqual x q = N.runIdent x == q
+ properEqual x q = N.runProperName x == q
+ identEqual x q = N.runIdent x == q
goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)
goToDefinition q fp = do
m <- runExceptT (parseModuleFromFile fp)
case m of
- Right module' -> return $ getDeclPosition module' q
- Left _ -> return Nothing
+ Right module' -> pure (getDeclPosition module' q)
+ Left _ -> pure Nothing
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index dc015cb..80791c2 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -25,38 +25,38 @@ import Language.PureScript.Ide.Reexports
import Language.PureScript.Ide.Types
import Language.PureScript.Names
-getPscIdeState :: (PscIde m, Functor m) =>
+getPscIdeState :: (PscIde m) =>
m (M.Map ModuleIdent [ExternDecl])
getPscIdeState = do
stateVar <- envStateVar <$> ask
liftIO $ pscStateModules <$> readTVarIO stateVar
-getExternFiles :: (PscIde m, Functor m) =>
+getExternFiles :: (PscIde m) =>
m (M.Map ModuleName ExternsFile)
getExternFiles = do
stateVar <- envStateVar <$> ask
liftIO (externsFiles <$> readTVarIO stateVar)
-getAllDecls :: (PscIde m, Functor m) => m [ExternDecl]
+getAllDecls :: (PscIde m) => m [ExternDecl]
getAllDecls = concat <$> getPscIdeState
-getAllModules :: (PscIde m, Functor m) => m [Module]
+getAllModules :: (PscIde m) => m [Module]
getAllModules = M.toList <$> getPscIdeState
-getAllModulesWithReexports :: (PscIde m, MonadLogger m, Applicative m) =>
+getAllModulesWithReexports :: (PscIde m, MonadLogger m) =>
m [Module]
getAllModulesWithReexports = do
mis <- M.keys <$> getPscIdeState
ms <- traverse getModuleWithReexports mis
pure (catMaybes ms)
-getModule :: (PscIde m, MonadLogger m, Applicative m) =>
+getModule :: (PscIde m, MonadLogger m) =>
ModuleIdent -> m (Maybe Module)
getModule m = do
modules <- getPscIdeState
pure ((m,) <$> M.lookup m modules)
-getModuleWithReexports :: (PscIde m, MonadLogger m, Applicative m) =>
+getModuleWithReexports :: (PscIde m, MonadLogger m) =>
ModuleIdent -> m (Maybe Module)
getModuleWithReexports mi = do
m <- getModule mi
@@ -72,9 +72,8 @@ insertModule externsFile = do
liftIO . atomically $ insertModule' (envStateVar env) externsFile
insertModule' :: TVar PscIdeState -> ExternsFile -> STM ()
-insertModule' st ef = do
- modifyTVar (st) $ \x ->
- x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)
- , pscStateModules = let (mn, decls ) = convertExterns ef
- in M.insert mn decls (pscStateModules x)
- }
+insertModule' st ef = modifyTVar st $ \x ->
+ x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)
+ , pscStateModules = let (mn, decls) = convertExterns ef
+ in M.insert mn decls (pscStateModules x)
+ }
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 0d8d429..8692e69 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -2,7 +2,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Ide.Types where
@@ -33,21 +32,26 @@ type Type = Text
data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)
data ExternDecl
- = FunctionDecl { functionName :: DeclIdent
- , functionType :: Type
- }
- | FixityDeclaration Fixity
- Int
- DeclIdent
- | Dependency { dependencyModule :: ModuleIdent
- , dependencyNames :: [Text]
- , dependencyAlias :: Maybe Text
- }
- | ModuleDecl ModuleIdent
- [DeclIdent]
- | DataDecl DeclIdent
- Text
- | Export ModuleIdent
+ -- | A function/value declaration
+ = FunctionDecl
+ DeclIdent -- The functions name
+ Type -- The functions type
+ | FixityDeclaration Fixity Int DeclIdent
+ -- | A Dependency onto another Module
+ | Dependency
+ ModuleIdent -- name of the dependency
+ [Text] -- explicit imports
+ (Maybe Text) -- An eventual qualifier
+
+ -- | A module declaration
+ | ModuleDecl
+ ModuleIdent -- The modules name
+ [DeclIdent] -- The exported identifiers
+ -- | A data/newtype declaration
+ | DataDecl DeclIdent -- The type name
+ Text -- The "type"
+ -- | An exported module
+ | Export ModuleIdent -- The exported Modules name
deriving (Show,Eq,Ord)
instance ToJSON ExternDecl where
@@ -63,22 +67,22 @@ instance ToJSON ExternDecl where
type Module = (ModuleIdent, [ExternDecl])
data Configuration =
- Configuration {
- confOutputPath :: FilePath
+ Configuration
+ { confOutputPath :: FilePath
, confDebug :: Bool
}
data PscIdeEnvironment =
- PscIdeEnvironment {
- envStateVar :: TVar PscIdeState
+ PscIdeEnvironment
+ { envStateVar :: TVar PscIdeState
, envConfiguration :: Configuration
}
-type PscIde m = (Applicative m, MonadIO m, MonadReader PscIdeEnvironment m)
+type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m)
data PscIdeState =
- PscIdeState {
- pscStateModules :: M.Map Text [ExternDecl]
+ PscIdeState
+ { pscStateModules :: M.Map Text [ExternDecl]
, externsFiles :: M.Map ModuleName ExternsFile
} deriving Show
@@ -90,29 +94,32 @@ newtype Completion =
deriving (Show,Eq)
data ModuleImport =
- ModuleImport {
- importModuleName :: ModuleIdent
+ ModuleImport
+ { importModuleName :: ModuleIdent
, importType :: D.ImportDeclarationType
, importQualifier :: Maybe Text
} deriving(Show)
instance Eq ModuleImport where
- mi1 == mi2 = importModuleName mi1 == importModuleName mi2
- && importQualifier mi1 == importQualifier mi2
+ mi1 == mi2 =
+ importModuleName mi1 == importModuleName mi2
+ && importQualifier mi1 == importQualifier mi2
instance ToJSON ModuleImport where
toJSON (ModuleImport mn D.Implicit qualifier) =
- object $ ["module" .= mn
- , "importType" .= ("implicit" :: Text)
- ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
+ object $ [ "module" .= mn
+ , "importType" .= ("implicit" :: Text)
+ ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
toJSON (ModuleImport mn (D.Explicit refs) _) =
- object ["module" .= mn
+ object [ "module" .= mn
, "importType" .= ("explicit" :: Text)
- , "identifiers" .= (identifierFromDeclarationRef <$> refs)]
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
+ ]
toJSON (ModuleImport mn (D.Hiding refs) _) =
- object ["module" .= mn
+ object [ "module" .= mn
, "importType" .= ("hiding" :: Text)
- , "identifiers" .= (identifierFromDeclarationRef <$> refs)]
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
+ ]
identifierFromDeclarationRef :: D.DeclarationRef -> String
identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name
@@ -121,16 +128,16 @@ identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name
identifierFromDeclarationRef _ = ""
instance FromJSON Completion where
- parseJSON (Object o) = do
- m <- o .: "module"
- d <- o .: "identifier"
- t <- o .: "type"
- return $ Completion (m, d, t)
- parseJSON _ = mzero
+ parseJSON (Object o) = do
+ m <- o .: "module"
+ d <- o .: "identifier"
+ t <- o .: "type"
+ pure (Completion (m, d, t))
+ parseJSON _ = mzero
instance ToJSON Completion where
- toJSON (Completion (m,d,t)) =
- object ["module" .= m, "identifier" .= d, "type" .= t]
+ toJSON (Completion (m,d,t)) =
+ object ["module" .= m, "identifier" .= d, "type" .= t]
data Success =
CompletionResult [Completion]
@@ -161,23 +168,22 @@ data PursuitSearchType = Package | Identifier
instance FromJSON PursuitSearchType where
parseJSON (String t) = case t of
- "package" -> return Package
- "completion" -> return Identifier
+ "package" -> pure Package
+ "completion" -> pure Identifier
_ -> mzero
parseJSON _ = mzero
instance FromJSON PursuitQuery where
- parseJSON o = fmap PursuitQuery (parseJSON o)
-
-data PursuitResponse
- = ModuleResponse { moduleResponseName :: Text
- , moduleResponsePackage :: Text}
- | DeclarationResponse { declarationResponseType :: Text
- , declarationResponseModule :: Text
- , declarationResponseIdent :: Text
- , declarationResponsePackage :: Text
- }
- deriving (Show,Eq)
+ parseJSON o = PursuitQuery <$> (parseJSON o)
+
+data PursuitResponse =
+ -- | A Pursuit Response for a module. Consists of the modules name and the
+ -- package it belongs to
+ ModuleResponse ModuleIdent Text
+ -- | A Pursuit Response for a declaration. Consist of the declarations type,
+ -- module, name and package
+ | DeclarationResponse Type ModuleIdent DeclIdent Text
+ deriving (Show,Eq)
instance FromJSON PursuitResponse where
parseJSON (Object o) = do
@@ -186,22 +192,12 @@ instance FromJSON PursuitResponse where
(type' :: String) <- info .: "type"
case type' of
"module" -> do
- name <- info .: "module"
- return
- ModuleResponse
- { moduleResponseName = name
- , moduleResponsePackage = package
- }
+ name <- info .: "module"
+ pure (ModuleResponse name package)
"declaration" -> do
- moduleName <- info .: "module"
- Right (ident, declType) <- typeParse <$> o .: "text"
- return
- DeclarationResponse
- { declarationResponseType = declType
- , declarationResponseModule = moduleName
- , declarationResponseIdent = ident
- , declarationResponsePackage = package
- }
+ moduleName <- info .: "module"
+ Right (ident, declType) <- typeParse <$> o .: "text"
+ pure (DeclarationResponse declType moduleName ident package)
_ -> mzero
parseJSON _ = mzero
@@ -217,7 +213,7 @@ typeParse t = case parse parseType "" t of
_ <- string "::"
spaces
type' <- many1 anyChar
- return (unpack name, type')
+ pure (unpack name, type')
identifier :: Parser Text
identifier = do
@@ -227,14 +223,15 @@ identifier = do
between (char '(') (char ')') (many1 (noneOf ", )")) <|>
many1 (noneOf ", )")
spaces
- return (pack ident)
+ pure (pack ident)
instance ToJSON PursuitResponse where
- toJSON ModuleResponse{..} =
- object ["module" .= moduleResponseName, "package" .= moduleResponsePackage]
- toJSON DeclarationResponse{..} =
+ toJSON (ModuleResponse name package) =
+ object ["module" .= name, "package" .= package]
+ toJSON (DeclarationResponse module' ident type' package) =
object
- [ "module" .= declarationResponseModule
- , "ident" .= declarationResponseIdent
- , "type" .= declarationResponseType
- , "package" .= declarationResponsePackage]
+ [ "module" .= module'
+ , "ident" .= ident
+ , "type" .= type'
+ , "package" .= package
+ ]
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index c19c773..f9876b1 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -42,7 +42,7 @@ everywhereOnKinds f = go
go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
go other = f other
-everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind
+everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind
everywhereOnKindsM f = go
where
go (Row k1) = (Row <$> go k1) >>= f
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 3e554ef..c5de548 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -29,7 +29,7 @@ import Language.PureScript.Linter.Imports as L
-- | Lint the PureScript AST.
-- |
-- | Right now, this pass only performs a shadowing check.
-lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
+lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m ()
lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
where
moduleNames :: S.Set Ident
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 8ccfc6e..ce43a95 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -24,6 +24,7 @@ import Control.Monad.Writer.Class
import Language.PureScript.Crash
import Language.PureScript.AST.Binders
+import Language.PureScript.AST.Literals
import Language.PureScript.AST.Declarations
import Language.PureScript.Environment
import Language.PureScript.Names as P
@@ -119,12 +120,12 @@ missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =
missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')
| con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)
| otherwise = ([cb], return False)
-missingCasesSingle env mn NullBinder (ObjectBinder bs) =
- (map (ObjectBinder . zip (map fst bs)) allMisses, pr)
+missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) =
+ (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr)
where
(allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)
-missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
- (map (ObjectBinder . zip sortedNames) allMisses, pr)
+missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (ObjectLiteral bs')) =
+ (map (LiteralBinder . ObjectLiteral . zip sortedNames) allMisses, pr)
where
(allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)
@@ -141,10 +142,10 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
compBS e s b b' = (s, compB e b b')
(sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
-missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)
-missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)
+missingCasesSingle _ _ NullBinder (LiteralBinder (BooleanLiteral b)) = ([LiteralBinder . BooleanLiteral $ not b], return True)
+missingCasesSingle _ _ (LiteralBinder (BooleanLiteral bl)) (LiteralBinder (BooleanLiteral br))
| bl == br = ([], return True)
- | otherwise = ([BooleanBinder bl], return False)
+ | otherwise = ([LiteralBinder $ BooleanLiteral bl], return False)
missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb
missingCasesSingle _ _ b _ = ([b], Left Unknown)
@@ -201,7 +202,7 @@ isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool
isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
where
isOtherwise :: Expr -> Bool
- isOtherwise (BooleanLiteral True) = True
+ isOtherwise (Literal (BooleanLiteral True)) = True
isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
isOtherwise (TypedValue _ e _) = isOtherwise e
@@ -260,7 +261,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold
-- |
-- Exhaustivity checking over a list of declarations
--
-checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
+checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m ()
checkExhaustiveDecls env mn = mapM_ onDecl
where
onDecl :: Declaration -> m ()
@@ -274,8 +275,8 @@ checkExhaustiveDecls env mn = mapM_ onDecl
onExpr :: Bool -> Expr -> m ()
onExpr isP (UnaryMinus e) = onExpr isP e
- onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es
- onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es
+ onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es
+ onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es
onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e
onExpr isP (Accessor _ e) = onExpr isP e
onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es
@@ -309,5 +310,5 @@ checkExhaustiveDecls env mn = mapM_ onDecl
-- |
-- Exhaustivity checking over a single module
--
-checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
+checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m ()
checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index 63fccba..446ede2 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -70,7 +70,7 @@ type UsedImports = M.Map ModuleName [Name]
--
lintImports
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Module
-> Env
-> UsedImports
@@ -152,7 +152,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do
in foldr go used (classes ++ types ++ dctors ++ values)
where
go :: (ModuleName, Name) -> UsedImports -> UsedImports
- go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc
+ go (q, name) = M.alter (Just . maybe [name] (name :)) q
extractByQual
:: (Eq a)
@@ -170,7 +170,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do
lintImportDecl
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Env
-> ModuleName
-> Maybe ModuleName
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index c1d327c..ddc0d10 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -40,7 +40,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Concurrent.Lifted as C
import Data.List (foldl', sort)
-import Data.Maybe (fromMaybe, catMaybes)
+import Data.Maybe (fromMaybe, catMaybes, isJust)
import Data.Time.Clock
import Data.String (fromString)
import Data.Foldable (for_)
@@ -145,11 +145,14 @@ data RebuildPolicy
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
--
-make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [Module]
-> m Environment
make MakeActions{..} ms = do
+ requirePath <- asks optionsRequirePath
+ when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath
+
checkModuleNamesAreUnique
(sorted, graph) <- sortModules ms
@@ -361,8 +364,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
, mapSourceFile = sourceFile
, mapGenerated = convertPos $ add (extraLines+1) 0 gen
, mapName = Nothing
- }) $
- mappings
+ }) mappings
}
let mapping = generate rawMapping
writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index c6e9ad4..42d2253 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -184,7 +184,6 @@ parseTypeClassDeclaration = do
indented *> reserved "where"
indented *> mark (P.many (same *> positioned parseTypeDeclaration))
return $ TypeClassDeclaration className idents implies members
- where
parseConstraint :: TokenParser Constraint
parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)
@@ -260,7 +259,7 @@ parseModule = do
return $ Module ss comments name decls exports
-- | Parse a collection of modules in parallel
-parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>
+parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m) =>
(k -> FilePath) -> [(k, String)] -> m [(k, Module)]
parseModulesFromFiles toFilePath input = do
modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do
@@ -299,23 +298,23 @@ parseModules = mark (P.many (same *> parseModule)) <* P.eof
booleanLiteral :: TokenParser Bool
booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
-parseNumericLiteral :: TokenParser Expr
+parseNumericLiteral :: TokenParser (Literal a)
parseNumericLiteral = NumericLiteral <$> number
-parseCharLiteral :: TokenParser Expr
+parseCharLiteral :: TokenParser (Literal a)
parseCharLiteral = CharLiteral <$> charLiteral
-parseStringLiteral :: TokenParser Expr
+parseStringLiteral :: TokenParser (Literal a)
parseStringLiteral = StringLiteral <$> stringLiteral
-parseBooleanLiteral :: TokenParser Expr
+parseBooleanLiteral :: TokenParser (Literal a)
parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
-parseArrayLiteral :: TokenParser Expr
-parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
+parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)
+parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)
-parseObjectLiteral :: TokenParser Expr
-parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)
+parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)
+parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)
parseIdentifierAndValue :: TokenParser (String, Expr)
parseIdentifierAndValue =
@@ -376,12 +375,12 @@ parseLet = do
parseValueAtom :: TokenParser Expr
parseValueAtom = P.choice
[ parseAnonymousArgument
- , parseNumericLiteral
- , parseCharLiteral
- , parseStringLiteral
- , parseBooleanLiteral
- , parseArrayLiteral
- , P.try parseObjectLiteral
+ , Literal <$> parseNumericLiteral
+ , Literal <$> parseCharLiteral
+ , Literal <$> parseStringLiteral
+ , Literal <$> parseBooleanLiteral
+ , Literal <$> parseArrayLiteral parseValue
+ , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue)
, parseAbs
, P.try parseConstructor
, P.try parseVar
@@ -469,17 +468,8 @@ parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.inde
parseAnonymousArgument :: TokenParser Expr
parseAnonymousArgument = underscore *> pure AnonymousArgument
-parseStringBinder :: TokenParser Binder
-parseStringBinder = StringBinder <$> stringLiteral
-
-parseCharBinder :: TokenParser Binder
-parseCharBinder = CharBinder <$> charLiteral
-
-parseBooleanBinder :: TokenParser Binder
-parseBooleanBinder = BooleanBinder <$> booleanLiteral
-
-parseNumberBinder :: TokenParser Binder
-parseNumberBinder = NumberBinder <$> (sign <*> number)
+parseNumberLiteral :: TokenParser Binder
+parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)
where
sign :: TokenParser (Either Integer Double -> Either Integer Double)
sign = (symbol' "-" >> return (negate +++ negate))
@@ -492,11 +482,11 @@ parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properN
parseConstructorBinder :: TokenParser Binder
parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
-parseObjectBinder :: TokenParser Binder
-parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
+parseObjectBinder:: TokenParser Binder
+parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)
parseArrayBinder :: TokenParser Binder
-parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)
parseVarOrNamedBinder :: TokenParser Binder
parseVarOrNamedBinder = do
@@ -541,10 +531,10 @@ parseBinder =
parseBinderAtom :: TokenParser Binder
parseBinderAtom = P.choice
[ parseNullBinder
- , parseCharBinder
- , parseStringBinder
- , parseBooleanBinder
- , parseNumberBinder
+ , LiteralBinder <$> parseCharLiteral
+ , LiteralBinder <$> parseStringLiteral
+ , LiteralBinder <$> parseBooleanLiteral
+ , parseNumberLiteral
, parseVarOrNamedBinder
, parseConstructorBinder
, parseObjectBinder
@@ -561,10 +551,10 @@ parseBinder =
parseBinderNoParens :: TokenParser Binder
parseBinderNoParens = P.choice
[ parseNullBinder
- , parseCharBinder
- , parseStringBinder
- , parseBooleanBinder
- , parseNumberBinder
+ , LiteralBinder <$> parseCharLiteral
+ , LiteralBinder <$> parseStringLiteral
+ , LiteralBinder <$> parseBooleanLiteral
+ , parseNumberLiteral
, parseVarOrNamedBinder
, parseNullaryConstructorBinder
, parseObjectBinder
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
index a25f7d8..9defab4 100644
--- a/src/Language/PureScript/Parser/JS.hs
+++ b/src/Language/PureScript/Parser/JS.hs
@@ -36,7 +36,7 @@ import qualified Text.Parsec as PS
type ForeignJS = String
-parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> [(FilePath, ForeignJS)]
-> m (M.Map ModuleName FilePath)
parseForeignModulesFromFiles files = do
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 58aa9b2..c2ff4d4 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -148,7 +148,7 @@ prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] ->
prettyPrintMany f xs = do
ss <- mapM f xs
indentString <- currentIndent
- return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss
+ return $ intercalate (emit "\n") $ map (mappend indentString) ss
-- |
-- Prints an object key, escaping reserved names.
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 5e8a654..5477361 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -274,8 +274,7 @@ prettyPrintJSWithSourceMaps js =
in (s, mp)
prettyPrintJS :: [JS] -> String
-prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . fmap runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
-
+prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
-- |
-- Generate an indented, pretty-printed string representing a Javascript expression
--
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index b1ab730..e5a04e8 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -1,18 +1,6 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Pretty.Values
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- Pretty printer for values
--
------------------------------------------------------------------------------
-
module Language.PureScript.Pretty.Values (
prettyPrintValue,
prettyPrintBinder,
@@ -75,12 +63,7 @@ prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val
prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val
-prettyPrintValue d expr@NumericLiteral{} = prettyPrintValueAtom d expr
-prettyPrintValue d expr@StringLiteral{} = prettyPrintValueAtom d expr
-prettyPrintValue d expr@CharLiteral{} = prettyPrintValueAtom d expr
-prettyPrintValue d expr@BooleanLiteral{} = prettyPrintValueAtom d expr
-prettyPrintValue d expr@ArrayLiteral{} = prettyPrintValueAtom d expr
-prettyPrintValue d expr@ObjectLiteral{} = prettyPrintValueAtom d expr
+prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l
prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr
prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr
prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr
@@ -92,13 +75,7 @@ prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr
-- | Pretty-print an atomic expression, adding parentheses if necessary.
prettyPrintValueAtom :: Int -> Expr -> Box
-prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n
-prettyPrintValueAtom _ (StringLiteral s) = text $ show s
-prettyPrintValueAtom _ (CharLiteral c) = text $ show c
-prettyPrintValueAtom _ (BooleanLiteral True) = text "true"
-prettyPrintValueAtom _ (BooleanLiteral False) = text "false"
-prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs
-prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps
+prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l
prettyPrintValueAtom _ AnonymousArgument = text "_"
prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)
prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)
@@ -116,6 +93,15 @@ prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr
prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field
prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"
+prettyPrintLiteralValue :: Int -> Literal Expr -> Box
+prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n
+prettyPrintLiteralValue _ (StringLiteral s) = text $ show s
+prettyPrintLiteralValue _ (CharLiteral c) = text $ show c
+prettyPrintLiteralValue _ (BooleanLiteral True) = text "true"
+prettyPrintLiteralValue _ (BooleanLiteral False) = text "false"
+prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs
+prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps
+
prettyPrintDeclaration :: Int -> Declaration -> Box
prettyPrintDeclaration d _ | d < 0 = ellipsis
prettyPrintDeclaration _ (TypeDeclaration ident ty) =
@@ -160,32 +146,35 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin
prettyPrintBinderAtom :: Binder -> String
prettyPrintBinderAtom NullBinder = "_"
-prettyPrintBinderAtom (StringBinder str) = show str
-prettyPrintBinderAtom (CharBinder c) = show c
-prettyPrintBinderAtom (NumberBinder num) = either show show num
-prettyPrintBinderAtom (BooleanBinder True) = "true"
-prettyPrintBinderAtom (BooleanBinder False) = "false"
+prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l
prettyPrintBinderAtom (VarBinder ident) = showIdent ident
prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)
prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)
-prettyPrintBinderAtom (ObjectBinder bs) =
+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder
+prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder
+prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)
+prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =
+ prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2
+prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)
+
+prettyPrintLiteralBinder :: Literal Binder -> String
+prettyPrintLiteralBinder (StringLiteral str) = show str
+prettyPrintLiteralBinder (CharLiteral c) = show c
+prettyPrintLiteralBinder (NumericLiteral num) = either show show num
+prettyPrintLiteralBinder (BooleanLiteral True) = "true"
+prettyPrintLiteralBinder (BooleanLiteral False) = "false"
+prettyPrintLiteralBinder (ObjectLiteral bs) =
"{ "
++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)
++ " }"
where
prettyPrintObjectPropertyBinder :: (String, Binder) -> String
prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder
-prettyPrintBinderAtom (ArrayBinder bs) =
+prettyPrintLiteralBinder (ArrayLiteral bs) =
"[ "
++ intercalate ", " (map prettyPrintBinder bs)
++ " ]"
-prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder
-prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
-prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder
-prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)
-prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =
- prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2
-prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)
-- |
-- Generate a pretty-printed string representing a Binder
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 7666d8b..90a90f6 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -6,6 +6,7 @@
module Language.PureScript.Publish
( preparePackage
, preparePackage'
+ , unsafePreparePackage
, PrepareM()
, runPrepareM
, warn
@@ -17,7 +18,7 @@ module Language.PureScript.Publish
, getGitWorkingTreeStatus
, checkCleanWorkingTree
, getVersionFromGitTag
- , getBowerInfo
+ , getBowerRepositoryInfo
, getModulesAndBookmarks
, getResolvedDependencies
) where
@@ -79,11 +80,16 @@ defaultPublishOptions = PublishOptions
-- | Attempt to retrieve package metadata from the current directory.
-- Calls exitFailure if no package metadata could be retrieved.
-preparePackage :: PublishOptions -> IO D.UploadedPackage
+unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage
+unsafePreparePackage opts = either (\e -> printError e >> exitFailure) pure =<< preparePackage opts
+
+-- | Attempt to retrieve package metadata from the current directory.
+-- Returns a PackageError on failure
+preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage)
preparePackage opts =
runPrepareM (preparePackage' opts)
- >>= either (\e -> printError e >> exitFailure)
- handleWarnings
+ >>= either (pure . Left) (fmap Right . handleWarnings)
+
where
handleWarnings (result, warns) = do
printWarnings warns
@@ -121,19 +127,24 @@ otherError = throwError . OtherError
catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
catchLeft a f = either f pure a
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM cond act = cond >>= flip unless act
+
preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
preparePackage' opts = do
- exists <- liftIO (doesFileExist "bower.json")
- unless exists (userError BowerJSONNotFound)
-
+ unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)
checkCleanWorkingTree opts
pkgMeta <- liftIO (Bower.decodeFile "bower.json")
>>= flip catchLeft (userError . CouldntDecodeBowerJSON)
+ unlessM (liftIO (doesFileExist "LICENSE")) (userError LicenseNotFound)
+
(pkgVersionTag, pkgVersion) <- publishGetVersion opts
- pkgGithub <- getBowerInfo pkgMeta
+ pkgGithub <- getBowerRepositoryInfo pkgMeta
(pkgBookmarks, pkgModules) <- getModulesAndBookmarks
+ unless (bowerLicenseExists pkgMeta) (userError NoLicenseSpecified)
+
let declaredDeps = map fst (bowerDependencies pkgMeta ++
bowerDevDependencies pkgMeta)
pkgResolvedDependencies <- getResolvedDependencies declaredDeps
@@ -193,8 +204,8 @@ getVersionFromGitTag = do
dropPrefix prefix str =
fromMaybe str (stripPrefix prefix str)
-getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
-getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
+getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
+getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
where
tryExtract pkgMeta =
case bowerRepository pkgMeta of
@@ -204,6 +215,9 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
(Left (BadRepositoryType repositoryType))
maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
+bowerLicenseExists :: PackageMeta -> Bool
+bowerLicenseExists = any (not . null) . bowerLicense
+
extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
extractGithub = stripGitHubPrefixes
>>> fmap (splitOn "/")
diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs
index 3e214a6..169f094 100644
--- a/src/Language/PureScript/Publish/BoxesHelpers.hs
+++ b/src/Language/PureScript/Publish/BoxesHelpers.hs
@@ -36,3 +36,6 @@ bulletedList f = map (indented . para . ("* " ++) . f)
printToStderr :: Boxes.Box -> IO ()
printToStderr = hPutStr stderr . Boxes.render
+
+printToStdout :: Boxes.Box -> IO ()
+printToStdout = putStr . Boxes.render
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index baec5aa..b669477 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -10,6 +10,7 @@ module Language.PureScript.Publish.ErrorsWarnings
, RepositoryFieldError(..)
, JSONSource(..)
, printError
+ , printErrorToStdout
, renderError
, printWarnings
, renderWarnings
@@ -54,11 +55,13 @@ data PackageWarning
-- | An error that should be fixed by the user.
data UserError
= BowerJSONNotFound
+ | LicenseNotFound
| BowerExecutableNotFound [String] -- list of executable names tried
| CouldntDecodeBowerJSON (ParseError BowerError)
| TagMustBeCheckedOut
| AmbiguousVersions [Version] -- Invariant: should contain at least two elements
| BadRepositoryField RepositoryFieldError
+ | NoLicenseSpecified
| MissingDependencies (NonEmpty PackageName)
| CompileError P.MultipleErrors
| DirtyWorkingTree
@@ -70,6 +73,7 @@ data RepositoryFieldError
| NotOnGithub
deriving (Show)
+
-- | An error that probably indicates a bug in this module.
data InternalError
= JSONError JSONSource (ParseError BowerError)
@@ -88,6 +92,9 @@ data OtherError
printError :: PackageError -> IO ()
printError = printToStderr . renderError
+printErrorToStdout :: PackageError -> IO ()
+printErrorToStdout = printToStdout . renderError
+
renderError :: PackageError -> Box
renderError err =
case err of
@@ -122,6 +129,12 @@ displayUserError e = case e of
"The bower.json file was not found. Please create one, or run " ++
"`pulp init`."
)
+ LicenseNotFound ->
+ para (concat
+ ["No LICENSE file was found. Please create one. ",
+ "Distributing code without a license means that nobody ",
+ "will be able to (legally) use it."
+ ])
BowerExecutableNotFound names ->
para (concat
[ "The Bower executable was not found (tried: ", format names, "). Please"
@@ -168,6 +181,12 @@ displayUserError e = case e of
] ++ bulletedList showVersion vs
BadRepositoryField err ->
displayRepositoryError err
+ NoLicenseSpecified ->
+ para (concat
+ ["No license specified in bower.json. Please add one. ",
+ "Distributing code without a license means that nobody ",
+ "will be able to (legally) use it."
+ ])
MissingDependencies pkgs ->
let singular = NonEmpty.length pkgs == 1
pl a b = if singular then b else a
@@ -190,7 +209,7 @@ displayUserError e = case e of
CompileError err ->
vcat
[ para "Compile error:"
- , indented (P.prettyPrintMultipleErrorsBox False err)
+ , indented (vcat (P.prettyPrintMultipleErrorsBox False err))
]
DirtyWorkingTree ->
para (
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 0b50a5f..68388e9 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -63,7 +63,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S
--
-- * Group mutually recursive value and data declarations into binding groups.
--
-desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
desugar externs =
map removeSignedLiterals
>>> traverse desugarObjectConstructors
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 3949673..d92a5cd 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -35,7 +35,7 @@ import Language.PureScript.Types
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
createBindingGroupsModule
- :: (Functor m, Applicative m, MonadError MultipleErrors m)
+ :: (MonadError MultipleErrors m)
=> [Module]
-> m [Module]
createBindingGroupsModule =
@@ -52,7 +52,7 @@ collapseBindingGroupsModule =
createBindingGroups
:: forall m
- . (Functor m, Applicative m, MonadError MultipleErrors m)
+ . (MonadError MultipleErrors m)
=> ModuleName
-> [Declaration]
-> m [Declaration]
@@ -171,7 +171,7 @@ getTypeName _ = internalError "Expected DataDeclaration"
--
toBindingGroup
:: forall m
- . (Functor m, MonadError MultipleErrors m)
+ . (MonadError MultipleErrors m)
=> ModuleName
-> SCC Declaration
-> m Declaration
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index da646f6..095bad3 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -36,7 +36,7 @@ isLeft (Right _) = False
-- |
-- Replace all top-level binders in a module with case expressions.
--
-desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
rethrow (addHint (ErrorInModule name)) $
Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps
@@ -44,7 +44,7 @@ desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
-- |
-- Validates that case head and binder lengths match.
--
-validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+validateCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
validateCases = flip parU f
where
(f, _, _) = everywhereOnValuesM return validate return
@@ -69,7 +69,7 @@ validateCases = flip parU f
positionedBinder (PositionedBinder p _ _) = Just p
positionedBinder _ = Nothing
-desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+desugarAbs :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarAbs = flip parU f
where
(f, _, _) = everywhereOnValuesM return replace return
@@ -83,7 +83,7 @@ desugarAbs = flip parU f
-- |
-- Replace all top-level binders with case expressions.
--
-desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
where
desugarRest :: [Declaration] -> m [Declaration]
@@ -109,7 +109,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
inSameGroup _ _ = False
-toDecls :: forall m. (Functor m, Applicative m, Monad m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
args <- mapM fromVarBinder bs
let body = foldr (Abs . Left) val args
@@ -147,7 +147,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)
toTuple (PositionedDeclaration _ _ d) = toTuple d
toTuple _ = internalError "Not a value declaration"
-makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
+makeCaseDeclaration :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
makeCaseDeclaration ident alternatives = do
let namedArgs = map findName . fst <$> alternatives
argNames = foldl1 resolveNames namedArgs
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index e175bbe..ee923ca 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -26,10 +26,10 @@ import Control.Monad.Supply.Class
-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function,
-- and all @DoNotationLet@ constructors with let expressions.
--
-desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
+desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts
-desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
+desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d)
desugarDo d =
let (f, _, _) = everywhereOnValuesM return replace return
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 8fd50da..410f905 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -44,13 +44,13 @@ import Language.PureScript.Linter.Imports
-- Replaces all local names with qualified names within a list of modules. The
-- modules should be topologically sorted beforehand.
--
-desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
desugarImports externs modules =
fmap snd (desugarImportsWithEnv externs modules)
desugarImportsWithEnv
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> [ExternsFile]
-> [Module]
-> m (Env, [Module])
@@ -141,7 +141,7 @@ elaborateExports exps (Module ss coms mn decls refs) =
--
renameInModule
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)
=> Env
-> Imports
-> Module
@@ -334,7 +334,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
--
updateExportRefs
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Module
-> m Module
updateExportRefs (Module ss coms mn decls exps) =
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index 84776cd..242b5a0 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -31,7 +31,7 @@ import Language.PureScript.Sugar.Names.Env
-- |
-- Finds all exportable members of a module, disregarding any explicit exports.
--
-findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports
+findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports
findExportable (Module _ _ mn ds _) =
rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
where
@@ -56,7 +56,7 @@ findExportable (Module _ _ mn ds _) =
-- Resolves the exports for a module, filtering out members that have not been
-- exported and elaborating re-exports of other modules.
--
-resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
+resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
resolveExports env mn imps exps refs =
rethrow (addHint (ErrorInModule mn)) $ do
filtered <- filterModule mn exps refs
@@ -164,7 +164,7 @@ resolveExports env mn imps exps refs =
exps' <- envModuleExports <$> mn'' `M.lookup` env
((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')
let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors
- return ((name, intersect relevantDctors dctors'), mnOrig)
+ return ((name, relevantDctors `intersect` dctors'), mnOrig)
go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"
@@ -199,7 +199,7 @@ resolveExports env mn imps exps refs =
--
filterModule
:: forall m
- . (Applicative m, MonadError MultipleErrors m)
+ . (MonadError MultipleErrors m)
=> ModuleName
-> Exports
-> [DeclarationRef]
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
index c0e3276..c035178 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -37,7 +37,7 @@ import Language.PureScript.Sugar.Names.Env
--
findImports
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> [Declaration]
-> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
findImports = foldM (go Nothing) M.empty
@@ -56,7 +56,7 @@ type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
--
resolveImports
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Env
-> Module
-> m (Module, Imports)
@@ -160,7 +160,7 @@ resolveImports env (Module ss coms currentModule decls exps) =
-- | Constructs a set of imports for a single module import.
resolveModuleImport
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Env
-> Imports
-> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])
@@ -187,7 +187,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps
--
resolveImport
:: forall m
- . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> Exports
-> Imports
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 2e84f08..61a4d05 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -19,7 +19,11 @@ import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
-desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
+desugarObjectConstructors
+ :: forall m
+ . (MonadSupply m, MonadError MultipleErrors m)
+ => Module
+ -> m Module
desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts
where
@@ -38,7 +42,7 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
| b' <- stripPositionInfo b
, BinaryNoParens op u val <- b'
, isAnonymousArgument u = return $ OperatorSection op (Right val)
- desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps
+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps
desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do
obj <- freshIdent'
Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 4b09c2c..01f8522 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -57,7 +57,7 @@ type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorNam
--
rebracket
:: forall m
- . (Applicative m, MonadError MultipleErrors m)
+ . (MonadError MultipleErrors m)
=> [ExternsFile]
-> [Module]
-> m [Module]
@@ -103,7 +103,7 @@ rebracket externs ms = do
Nothing ->
maybe id rethrowWithPosition pos $
throwError . errorMessage $ UnknownValue name
- goBinder _ (BinaryNoParensBinder _ _ _) =
+ goBinder _ (BinaryNoParensBinder {}) =
internalError "BinaryNoParensBinder has no OpBinder"
goBinder pos other = return (pos, other)
@@ -116,7 +116,7 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)
go other = other
rebracketModule
- :: (Applicative m, MonadError MultipleErrors m)
+ :: (MonadError MultipleErrors m)
=> [[(Qualified Ident, Associativity)]]
-> Module
-> m Module
@@ -178,7 +178,7 @@ customOperatorTable fixities =
desugarOperatorSections
:: forall m
- . (Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ . (MonadSupply m, MonadError MultipleErrors m)
=> Module
-> m Module
desugarOperatorSections (Module ss coms mn ds exts) =
@@ -189,8 +189,11 @@ desugarOperatorSections (Module ss coms mn ds exts) =
(goDecl, _, _) = everywhereOnValuesM return goExpr return
goExpr :: Expr -> m Expr
- goExpr (OperatorSection op (Left val)) = return $ App op val
- goExpr (OperatorSection op (Right val)) = do
+ goExpr (OperatorSection op eVal) = do
arg <- freshIdent'
- return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
+ let var = Var (Qualified Nothing arg)
+ f2 a b = Abs (Left arg) $ App (App op a) b
+ return $ case eVal of
+ Left val -> f2 val var
+ Right val -> f2 var val
goExpr other = return other
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 03a7324..1b9ab39 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -45,7 +45,7 @@ type Desugar = StateT MemberMap
-- instance dictionary expressions.
--
desugarTypeClasses
- :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ :: (MonadSupply m, MonadError MultipleErrors m)
=> [ExternsFile]
-> [Module]
-> m [Module]
@@ -62,7 +62,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu
fromExternsDecl _ _ = Nothing
desugarModule
- :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ :: (MonadSupply m, MonadError MultipleErrors m)
=> Module
-> Desugar m Module
desugarModule (Module ss coms name decls (Just exps)) = do
@@ -171,7 +171,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
-- };
-}
desugarDecl
- :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ :: (MonadSupply m, MonadError MultipleErrors m)
=> ModuleName
-> [DeclarationRef]
-> Declaration
@@ -259,7 +259,7 @@ unit = TypeApp tyObject REmpty
typeInstanceDictionaryDeclaration
:: forall m
- . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ . (MonadSupply m, MonadError MultipleErrors m)
=> Ident
-> ModuleName
-> [Constraint]
@@ -297,7 +297,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
, let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
]
- let props = ObjectLiteral (members ++ superclasses)
+ let props = Literal $ ObjectLiteral (members ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
dict = TypeClassDictionaryConstructorApp className props
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 6a9344c..f788d48 100644
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -32,7 +32,7 @@ import qualified Language.PureScript.Constants as C
-- | Elaborates deriving instance declarations by code generation.
deriveInstances
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m)
+ :: (MonadError MultipleErrors m, MonadSupply m)
=> Module
-> m Module
deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
@@ -40,7 +40,7 @@ deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (derive
-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
-- elaborates that into an instance declaration via code generation.
deriveInstance
- :: (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ :: (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
-> [Declaration]
-> Declaration
@@ -82,7 +82,7 @@ typesProxy :: ModuleName
typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
deriveGeneric
- :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ :: forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
-> [Declaration]
-> ProperName 'TypeName
@@ -115,15 +115,21 @@ deriveGeneric mn ds tyConNm dargs = do
return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
where
caseResult idents =
- App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
- . ArrayLiteral
+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
+ . Literal . ArrayLiteral
$ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
toSpineFun :: Expr -> Type -> Expr
toSpineFun i r | Just rec <- objectType r =
- lamNull . recordConstructor . ArrayLiteral .
- map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
- $ decomposeRec rec
+ lamNull . recordConstructor . Literal . ArrayLiteral
+ . map
+ (\(str,typ) ->
+ Literal $ ObjectLiteral
+ [ ("recLabel", Literal (StringLiteral str))
+ , ("recValue", toSpineFun (Accessor str i) typ)
+ ]
+ )
+ $ decomposeRec rec
toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i
mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d
mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"
@@ -132,30 +138,37 @@ deriveGeneric mn ds tyConNm dargs = do
mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
where
mkSigProd :: [Expr] -> Expr
- mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
- (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))
- ) . ArrayLiteral
+ mkSigProd =
+ App
+ (App
+ (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
+ (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name))))
+ )
+ . Literal
+ . ArrayLiteral
mkSigRec :: [Expr] -> Expr
- mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . Literal . ArrayLiteral
proxy :: Type -> Type
proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
mkProdClause (ctorName, tys) =
- ObjectLiteral
- [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
- , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
+ Literal $ ObjectLiteral
+ [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))))
+ , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
]
mkProductSignature :: Type -> Expr
mkProductSignature r | Just rec <- objectType r =
- lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
- , ("recValue", mkProductSignature typ)
- ]
- | (str, typ) <- decomposeRec rec
- ]
+ lamNull . mkSigRec $
+ [ Literal $ ObjectLiteral
+ [ ("recLabel", Literal (StringLiteral str))
+ , ("recValue", mkProductSignature typ)
+ ]
+ | (str, typ) <- decomposeRec rec
+ ]
mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))
(TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))
instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
@@ -182,10 +195,17 @@ deriveGeneric mn ds tyConNm dargs = do
mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
mkAlternative (ctorName, tys) = do
idents <- replicateM (length tys) freshIdent'
- return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
- . Right
- $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
- (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
+ return $
+ CaseAlternative
+ [ prodBinder
+ [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
+ , LiteralBinder (ArrayLiteral (map VarBinder idents))
+ ]
+ ]
+ . Right
+ $ liftApplicative
+ (mkJust $ Constructor (Qualified (Just mn) ctorName))
+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch = (++ [catchAll])
@@ -202,15 +222,15 @@ deriveGeneric mn ds tyConNm dargs = do
fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))
mkRecCase :: [(String, Type)] -> CaseAlternative
- mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
- ]
- ]
- . Right
- $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
+ mkRecCase rs =
+ CaseAlternative
+ [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]
+ . Right
+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
mkRecFun :: [(String, Type)] -> Expr
mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)
- where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
+ where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
@@ -226,7 +246,7 @@ deriveGeneric mn ds tyConNm dargs = do
mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
deriveEq ::
- forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
-> [Declaration]
-> ProperName 'TypeName
@@ -255,7 +275,7 @@ deriveEq mn ds tyConNm = do
| length xs /= 1 = xs ++ [catchAll]
| otherwise = xs -- Avoid redundant case
where
- catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))
+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (Literal (BooleanLiteral False)))
mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
mkCtorClause (ctorName, tys) = do
@@ -267,7 +287,7 @@ deriveEq mn ds tyConNm = do
caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
conjAll :: [Expr] -> Expr
- conjAll [] = BooleanLiteral True
+ conjAll [] = Literal (BooleanLiteral True)
conjAll xs = foldl1 preludeConj xs
toEqTest :: Expr -> Expr -> Type -> Expr
@@ -278,7 +298,7 @@ deriveEq mn ds tyConNm = do
toEqTest l r _ = preludeEq l r
deriveOrd ::
- forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
-> [Declaration]
-> ProperName 'TypeName
@@ -357,7 +377,7 @@ deriveOrd mn ds tyConNm = do
toOrdering l r _ = preludeCompare l r
findTypeDecl
- :: (Functor m, MonadError MultipleErrors m)
+ :: (MonadError MultipleErrors m)
=> ProperName 'TypeName
-> [Declaration]
-> m Declaration
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 8294d82..8072ff2 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -36,7 +36,7 @@ import Language.PureScript.Traversals
-- |
-- Replace all top level type declarations in a module with type annotations
--
-desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module]
desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
rethrow (addHint (ErrorInModule name)) $
Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 6684639..d020b44 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -40,7 +40,7 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
addDataType
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> DataDeclType
-> ProperName 'TypeName
@@ -56,7 +56,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
addDataConstructor moduleName dtype name (map fst args) dctor tys
addDataConstructor
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> DataDeclType
-> ProperName 'TypeName
@@ -74,7 +74,7 @@ addDataConstructor moduleName dtype name args dctor tys = do
putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
addTypeSynonym
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> ProperName 'TypeName
-> [(String, Maybe Kind)]
@@ -88,7 +88,7 @@ addTypeSynonym moduleName name args ty kind = do
, typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
valueIsNotDefined
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> Ident
-> m ()
@@ -99,7 +99,7 @@ valueIsNotDefined moduleName name = do
Nothing -> return ()
addValue
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> Ident
-> Type
@@ -110,7 +110,7 @@ addValue moduleName name ty nameKind = do
putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
addTypeClass
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> ProperName 'ClassName
-> [(String, Maybe Kind)]
@@ -126,7 +126,7 @@ addTypeClass moduleName pn args implies ds =
toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
addTypeClassDictionaries
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Maybe ModuleName
-> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)
-> m ()
@@ -135,7 +135,7 @@ addTypeClassDictionaries mn entries =
where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)
checkDuplicateTypeArguments
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> [String]
-> m ()
checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
@@ -145,7 +145,7 @@ checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
firstDup = listToMaybe $ args \\ nub args
checkTypeClassInstance
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> Type
-> m ()
@@ -161,7 +161,7 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
-- Check that type synonyms are fully-applied in a type
--
checkTypeSynonyms
- :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Type
-> m ()
checkTypeSynonyms = void . replaceAllTypeSynonyms
@@ -181,7 +181,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
--
typeCheckAll
:: forall m
- . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> [DeclarationRef]
-> [Declaration]
@@ -343,7 +343,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
--
typeCheckModule
:: forall m
- . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Module
-> m Module
typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 48d878a..63f8c73 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -4,7 +4,7 @@
-- |
-- Type class entailment
--
-module Language.PureScript.TypeChecker.Entailment (entails) where
+module Language.PureScript.TypeChecker.Entailment (Context, replaceTypeClassDictionaries) where
import Prelude ()
import Prelude.Compat
@@ -16,8 +16,9 @@ import qualified Data.Map as M
import Control.Arrow (Arrow(..))
import Control.Monad.State
+import Control.Monad.Writer
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Supply.Class (MonadSupply(..))
import Language.PureScript.Crash
import Language.PureScript.AST
@@ -28,22 +29,47 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
+-- | The 'Context' tracks those constraints which can be satisfied.
+type Context = M.Map (Maybe ModuleName)
+ (M.Map (Qualified (ProperName 'ClassName))
+ (M.Map (Qualified Ident)
+ TypeClassDictionaryInScope))
+
+-- | Merge two type class contexts
+combineContexts :: Context -> Context -> Context
+combineContexts = M.unionWith (M.unionWith M.union)
+
+-- | Replace type class dictionary placeholders with inferred type class dictionaries
+replaceTypeClassDictionaries
+ :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+ => Bool
+ -> ModuleName
+ -> Expr
+ -> m (Expr, [(Ident, Constraint)])
+replaceTypeClassDictionaries shouldGeneralize mn =
+ let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return
+ in flip evalStateT M.empty . runWriterT . f
+ where
+ go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint
+ go other = return (other, [])
+
-- |
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
entails
:: forall m
- . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => ModuleName
- -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+ => Bool
+ -> ModuleName
+ -> Context
-> Constraint
- -> m Expr
-entails moduleName context = solve
+ -> StateT Context m (Expr, [(Ident, Constraint)])
+entails shouldGeneralize moduleName context = solve
where
- forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
- forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
- forClassName _ _ = internalError "forClassName: expected qualified class name"
+ forClassName :: Context -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
+ forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
+ forClassName _ _ _ = internalError "forClassName: expected qualified class name"
ctorModules :: Type -> Maybe ModuleName
ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn
@@ -51,37 +77,58 @@ entails moduleName context = solve
ctorModules (TypeApp ty _) = ctorModules ty
ctorModules _ = Nothing
- findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
- findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
+ findDicts :: Context -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
+ findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx
- solve :: Constraint -> m Expr
+ solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)])
solve (className, tys) = do
- dict <- go 0 className tys
- return $ dictionaryValueToValue dict
+ (dict, unsolved) <- go 0 className tys
+ return (dictionaryValueToValue dict, unsolved)
where
- go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue
+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> StateT Context m (DictionaryValue, [(Ident, Constraint)])
go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
go work className' tys' = do
+ -- Get the inferred constraint context so far, and merge it with the global context
+ inferred <- get
let instances = do
- tcd <- forClassName className' tys'
+ tcd <- forClassName (combineContexts context inferred) className' tys'
-- Make sure the type unifies with the type in the type instance definition
subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd)
return (subst, tcd)
- (subst, tcd) <- unique instances
- -- Solve any necessary subgoals
- args <- solveSubgoals subst (tcdDependencies tcd)
- return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
- (mkDictionary (tcdName tcd) args)
- (tcdPath tcd)
+ solution <- lift $ unique instances
+ case solution of
+ Left (subst, tcd) -> do
+ -- Solve any necessary subgoals
+ (args, unsolved) <- solveSubgoals subst (tcdDependencies tcd)
+ let match = foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
+ (mkDictionary (tcdName tcd) args)
+ (tcdPath tcd)
+ return (match, unsolved)
+ Right unsolved@(unsolvedClassName@(Qualified _ pn), unsolvedTys) -> do
+ -- Generate a fresh name for the unsolved constraint's new dictionary
+ ident <- freshIdent ("dict" ++ runProperName pn)
+ let qident = Qualified Nothing ident
+ -- Store the new dictionary in the Context so that we can solve this goal in
+ -- future.
+ let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing
+ newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))
+ modify (combineContexts newContext)
+ return (LocalDictionaryValue qident, [(ident, unsolved)])
where
- unique :: [(a, TypeClassDictionaryInScope)] -> m (a, TypeClassDictionaryInScope)
- unique [] = throwError . errorMessage $ NoInstanceFound className' tys'
- unique [a] = return a
+ unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint)
+ unique [] | shouldGeneralize && all canBeGeneralized tys' = return $ Right (className, tys)
+ | otherwise = throwError . errorMessage $ NoInstanceFound className' tys'
+ unique [a] = return $ Left a
unique tcds | pairwise overlapping (map snd tcds) = do
tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)
- return (head tcds)
- | otherwise = return (minimumBy (compare `on` length . tcdPath . snd) tcds)
+ return $ Left (head tcds)
+ | otherwise = return $ Left (minimumBy (compare `on` length . tcdPath . snd) tcds)
+
+ canBeGeneralized :: Type -> Bool
+ canBeGeneralized TUnknown{} = True
+ canBeGeneralized Skolem{} = True
+ canBeGeneralized _ = False
-- |
-- Check if two dictionaries are overlapping
@@ -98,11 +145,12 @@ entails moduleName context = solve
-- Create dictionaries for subgoals which still need to be solved by calling go recursively
-- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
-- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> m (Maybe [DictionaryValue])
- solveSubgoals _ Nothing = return Nothing
+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)])
+ solveSubgoals _ Nothing = return (Nothing, [])
solveSubgoals subst (Just subgoals) = do
- dict <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals
- return $ Just dict
+ zipped <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals
+ let (dicts, unsolved) = unzip zipped
+ return (Just dicts, concat unsolved)
-- Make a dictionary from subgoal dictionaries by applying the correct function
mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
@@ -134,6 +182,7 @@ entails moduleName context = solve
-- and return a substitution from type variables to types which makes the type heads unify.
--
typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]
+typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just []
typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []
typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index ae3325b..188cf97 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -43,7 +43,7 @@ freshKind = do
-- | Update the substitution to solve a kind constraint
solveKind
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> Int
-> Kind
-> m ()
@@ -68,7 +68,7 @@ substituteKind sub = everywhereOnKinds go
-- | Make sure that an unknown does not occur in a kind
occursCheck
- :: (Functor m, Applicative m, MonadError MultipleErrors m)
+ :: (MonadError MultipleErrors m)
=> Int
-> Kind
-> m ()
@@ -80,7 +80,7 @@ occursCheck u k = void $ everywhereOnKindsM go k
-- | Unify two kinds
unifyKinds
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> Kind
-> Kind
-> m ()
@@ -101,14 +101,14 @@ unifyKinds k1 k2 = do
-- | Infer the kind of a single type
kindOf
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
=> Type
-> m Kind
kindOf ty = fst <$> kindOfWithScopedVars ty
-- | Infer the kind of a single type, returning the kinds of any scoped type variables
kindOfWithScopedVars ::
- (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
+ (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
Type ->
m (Kind, [(String, Kind)])
kindOfWithScopedVars ty =
@@ -121,7 +121,7 @@ kindOfWithScopedVars ty =
-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
kindsOf
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
=> Bool
-> ModuleName
-> ProperName 'TypeName
@@ -139,7 +139,7 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
tidyUp (k, sub) = starIfUnknown $ substituteKind sub k
freshKindVar
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> (String, Maybe Kind)
-> Kind
-> m (ProperName 'TypeName, Kind)
@@ -150,7 +150,7 @@ freshKindVar (arg, Just kind') kind = do
-- | Simultaneously infer the kinds of several mutually recursive type constructors
kindsOfAll
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
=> ModuleName
-> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]
-> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]
@@ -178,7 +178,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
-- | Solve the set of kind constraints associated with the data constructors for a type constructor
solveTypes
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> Bool
-> [Type]
-> [Kind]
@@ -202,14 +202,14 @@ starIfUnknown k = k
-- | Infer a kind for a type
infer
- :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> Type
-> m (Kind, [(String, Kind)])
infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty
infer'
:: forall m
- . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ . (MonadError MultipleErrors m, MonadState CheckState m)
=> Type
-> m (Kind, [(String, Kind)])
infer' (ForAll ident ty _) = do
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 752e9be..e4ac9d8 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -84,7 +83,7 @@ bindTypes newNames action = do
-- | Temporarily bind a collection of names to types
withScopedTypeVars
- :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadWriter MultipleErrors m)
=> ModuleName
-> [(String, Kind)]
-> m a
@@ -112,20 +111,20 @@ withTypeClassDictionaries entries action = do
-- | Get the currently available map of type class dictionaries
getTypeClassDictionaries
- :: (Functor m, MonadState CheckState m)
+ :: (MonadState CheckState m)
=> m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
-- | Lookup type class dictionaries in a module.
lookupTypeClassDictionaries
- :: (Functor m, MonadState CheckState m)
+ :: (MonadState CheckState m)
=> Maybe ModuleName
-> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get
-- | Temporarily bind a collection of names to local variables
bindLocalVariables
- :: (Functor m, MonadState CheckState m)
+ :: (MonadState CheckState m)
=> ModuleName
-> [(Ident, Type, NameVisibility)]
-> m a
@@ -135,7 +134,7 @@ bindLocalVariables moduleName bindings =
-- | Temporarily bind a collection of names to local type variables
bindLocalTypeVariables
- :: (Functor m, MonadState CheckState m)
+ :: (MonadState CheckState m)
=> ModuleName
-> [(ProperName 'TypeName, Kind)]
-> m a
@@ -144,15 +143,15 @@ bindLocalTypeVariables moduleName bindings =
bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
-- | Update the visibility of all names to Defined
-makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()
+makeBindingGroupVisible :: (MonadState CheckState m) => m ()
makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
-- | Update the visibility of all names to Defined in the scope of the provided action
-withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
+withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a
withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action
-- | Perform an action while preserving the names from the @Environment@.
-preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a
+preservingNames :: (MonadState CheckState m) => m a -> m a
preservingNames action = do
orig <- gets (names . checkEnv)
a <- action
@@ -161,7 +160,7 @@ preservingNames action = do
-- | Lookup the type of a value by name in the @Environment@
lookupVariable
- :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
=> ModuleName
-> Qualified Ident
-> m Type
@@ -173,7 +172,7 @@ lookupVariable currentModule (Qualified moduleName var) = do
-- | Lookup the visibility of a value by name in the @Environment@
getVisibility
- :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
=> ModuleName
-> Qualified Ident
-> m NameVisibility
@@ -185,7 +184,7 @@ getVisibility currentModule (Qualified moduleName var) = do
-- | Assert that a name is visible
checkVisibility
- :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
=> ModuleName
-> Qualified Ident
-> m ()
@@ -197,7 +196,7 @@ checkVisibility currentModule name@(Qualified _ var) = do
-- | Lookup the kind of a type by name in the @Environment@
lookupTypeVariable
- :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
=> ModuleName
-> Qualified (ProperName 'TypeName)
-> m Kind
@@ -208,7 +207,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
Just (k, _) -> return k
-- | Get the current @Environment@
-getEnv :: (Functor m, MonadState CheckState m) => m Environment
+getEnv :: (MonadState CheckState m) => m Environment
getEnv = checkEnv <$> get
-- | Update the @Environment@
@@ -225,8 +224,7 @@ runCheck = runCheck' initEnvironment
-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.
runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment)
-runCheck' env check = fmap (second checkEnv) $ runStateT check (emptyCheckState env)
-
+runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env)
-- | Make an assertion, failing with an error message
guardWith :: (MonadError e m) => e -> Bool -> m ()
guardWith _ True = return ()
@@ -234,14 +232,14 @@ guardWith e False = throwError e
-- | Run a computation in the substitution monad, generating a return value and the final substitution.
liftUnify ::
- (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
m a ->
m (a, Substitution)
liftUnify = liftUnifyWarnings (const id)
-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.
liftUnifyWarnings ::
- (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
(Substitution -> ErrorMessage -> ErrorMessage) ->
m a ->
m (a, Substitution)
diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs
index bf10f36..ba07ba3 100644
--- a/src/Language/PureScript/TypeChecker/Rows.hs
+++ b/src/Language/PureScript/TypeChecker/Rows.hs
@@ -36,7 +36,7 @@ import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Types
-- | Ensure rows do not contain duplicate labels
-checkDuplicateLabels :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()
+checkDuplicateLabels :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()
checkDuplicateLabels =
let (_, f, _) = everywhereOnValuesM def go def
in void . f
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index a345c08..f302cd5 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -53,7 +53,7 @@ newSkolemConstant = do
-- |
-- Introduce skolem scope at every occurence of a ForAll
--
-introduceSkolemScope :: (Functor m, Applicative m, MonadState CheckState m) => Type -> m Type
+introduceSkolemScope :: (MonadState CheckState m) => Type -> m Type
introduceSkolemScope = everywhereOnTypesM go
where
go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 023642e..fceef79 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -39,11 +39,11 @@ import Language.PureScript.TypeChecker.Unify
import Language.PureScript.Types
-- | Check that one type subsumes another, rethrowing errors to provide a better error message
-subsumes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
+subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2
-- | Check tahat one type subsumes another
-subsumes' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>
+subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>
Maybe Expr ->
Type ->
Type ->
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index ae85eee..b2600cc 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -57,7 +57,7 @@ replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try
go c args (TypeApp f arg) = go (c + 1) (arg : args) f
go _ _ _ = return Nothing
-replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
+replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type
replaceAllTypeSynonyms d = do
env <- getEnv
either throwError return $ replaceAllTypeSynonyms' env d
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 74bd82f..bd8f600 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
-- |
-- This module implements the type checker
@@ -61,7 +62,7 @@ import Language.PureScript.Types
-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
typesOf ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName ->
[(Ident, Expr)] ->
m [(Ident, (Expr, Type))]
@@ -69,23 +70,38 @@ typesOf moduleName vals = do
tys <- fmap tidyUp . liftUnifyWarnings replace $ do
(untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
- ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict
- return $ ds1 ++ ds2
+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
+ return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)
- forM tys $ \(ident, (val, ty)) -> do
+ forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do
-- Replace type class dictionary placeholders with actual dictionaries
- val' <- replaceTypeClassDictionaries moduleName val
+ (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val
+ let unsolvedTypeVars = nub $ unknownsInType ty
+ -- Generalize and constrain the type
+ let generalized = generalize unsolved ty
+ -- Make sure any unsolved type constraints only use type variables which appear
+ -- unknown in the inferred type.
+ when shouldGeneralize $ do
+ tell . errorMessage $ MissingTypeDeclaration ident generalized
+ forM_ unsolved $ \(_, (className, classTys)) -> do
+ let constraintTypeVars = nub $ foldMap unknownsInType classTys
+ when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $
+ throwError . errorMessage $ NoInstanceFound className classTys
-- Check skolem variables did not escape their scope
skolemEscapeCheck val'
-- Check rows do not contain duplicate labels
checkDuplicateLabels val'
- return (ident, (val', varIfUnknown ty))
+ return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))
where
+ -- | Generalize type vars using forall and add inferred constraints
+ generalize unsolved = varIfUnknown . constrain unsolved
+ -- | Add any unsolved constraints
+ constrain [] = id
+ constrain cs = ConstrainedType (map snd cs)
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
- tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (substituteType sub) val, substituteType sub ty))) ts
+ tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
-- Replace all the wildcards types with their inferred types
replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty
- replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty))
replace _ em = em
type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
@@ -93,7 +109,7 @@ type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
type UntypedData = [(Ident, Type)]
typeDictionaryForBindingGroup ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName ->
[(Ident, Expr)] ->
m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
@@ -118,7 +134,7 @@ typeDictionaryForBindingGroup moduleName vals = do
return (untyped, typed, dict, untypedDict)
checkTypedBindingGroupElement ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName ->
(Ident, (Expr, Type, Bool)) ->
TypeData ->
@@ -137,17 +153,15 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
return (ident, (val'', ty''))
typeForBindingGroupElement ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Bool ->
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
(Ident, Expr) ->
TypeData ->
UntypedData ->
m (Ident, (Expr, Type))
-typeForBindingGroupElement warn (ident, val) dict untypedDict = do
+typeForBindingGroupElement (ident, val) dict untypedDict = do
-- Infer the type with the new names in scope
TypedValue _ val' ty <- bindNames dict $ infer val
unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)
- when warn . tell . errorMessage $ MissingTypeDeclaration ident ty
return (ident, (TypedValue True val' ty, ty))
-- | Check if a value contains a type annotation
@@ -165,23 +179,10 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco
g other = other
-
--- | Replace type class dictionary placeholders with inferred type class dictionaries
-replaceTypeClassDictionaries ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- Expr ->
- m Expr
-replaceTypeClassDictionaries mn =
- let (_, f, _) = everywhereOnValuesTopDownM return go return
- in f
- where
- go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
- go other = return other
-
+
-- | Check the kind of a type, failing if it is not of kind *.
checkTypeKind ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>
+ (MonadState CheckState m, MonadError MultipleErrors m) =>
Type ->
Kind ->
m ()
@@ -193,7 +194,7 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind =
-- This is necessary during type checking to avoid unifying a polymorphic type with a
-- unification variable.
instantiatePolyTypeWithUnknowns ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>
+ (MonadState CheckState m, MonadError MultipleErrors m) =>
Expr ->
Type ->
m (Expr, Type)
@@ -207,32 +208,32 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- | Infer a type for a value, rethrowing any error to provide a more useful error message
infer ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
m Expr
infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
-- | Infer a type for a value
infer' ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
m Expr
-infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt
-infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber
-infer' v@(StringLiteral _) = return $ TypedValue True v tyString
-infer' v@(CharLiteral _) = return $ TypedValue True v tyChar
-infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
-infer' (ArrayLiteral vals) = do
+infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt
+infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber
+infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString
+infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar
+infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean
+infer' (Literal (ArrayLiteral vals)) = do
ts <- traverse infer vals
els <- freshType
forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t
- return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)
-infer' (ObjectLiteral ps) = do
+ return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)
+infer' (Literal (ObjectLiteral ps)) = do
ensureNoDuplicateProperties ps
ts <- traverse (infer . snd) ps
let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
ty = TypeApp tyObject $ rowFromList (fields, REmpty)
- return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty
+ return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty
infer' (ObjectUpdate o ps) = do
ensureNoDuplicateProperties ps
row <- freshType
@@ -280,10 +281,10 @@ infer' (Case vals binders) = do
return $ TypedValue True (Case vals' binders') ret
infer' (IfThenElse cond th el) = do
cond' <- check cond tyBoolean
- v2@(TypedValue _ _ t2) <- infer th
- v3@(TypedValue _ _ t3) <- infer el
- (v2', v3', t) <- meet v2 v3 t2 t3
- return $ TypedValue True (IfThenElse cond' v2' v3') t
+ th'@(TypedValue _ _ thTy) <- infer th
+ el'@(TypedValue _ _ elTy) <- infer el
+ unifyTypes thTy elTy
+ return $ TypedValue True (IfThenElse cond' th' el') thTy
infer' (Let ds val) = do
(ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
return $ TypedValue True (Let ds' val') valTy
@@ -303,7 +304,7 @@ infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do
infer' _ = internalError "Invalid argument to infer"
inferLetBinding ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
[Declaration] ->
[Declaration] ->
Expr ->
@@ -329,7 +330,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
(untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
- ds2' <- forM untyped $ \e -> typeForBindingGroupElement False e dict untypedDict
+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']
bindNames dict $ do
makeBindingGroupVisible
@@ -341,16 +342,16 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
-- | Infer the types of variables brought into scope by a binder
inferBinder :: forall m.
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Type ->
Binder ->
m (M.Map Ident Type)
inferBinder _ NullBinder = return M.empty
-inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty
-inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty
-inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty
-inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty
-inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty
+inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty
+inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
+inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty
+inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty
+inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty
inferBinder val (VarBinder name) = return $ M.singleton name val
inferBinder val (ConstructorBinder ctor binders) = do
env <- getEnv
@@ -369,7 +370,7 @@ inferBinder val (ConstructorBinder ctor binders) = do
where
go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret
go args ret = (args, ret)
-inferBinder val (ObjectBinder props) = do
+inferBinder val (LiteralBinder (ObjectLiteral props)) = do
row <- freshType
rest <- freshType
m1 <- inferRowProperties row rest props
@@ -383,7 +384,7 @@ inferBinder val (ObjectBinder props) = do
m1 <- inferBinder propTy binder
m2 <- inferRowProperties nrow (RCons name propTy row) binders
return $ m1 `M.union` m2
-inferBinder val (ArrayBinder binders) = do
+inferBinder val (LiteralBinder (ArrayLiteral binders)) = do
el <- freshType
m1 <- M.unions <$> traverse (inferBinder el) binders
unifyTypes val (TypeApp tyArray el)
@@ -420,7 +421,7 @@ binderRequiresMonotype _ = True
-- | Instantiate polytypes only when necessitated by a binder.
instantiateForBinders ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
[Expr] ->
[CaseAlternative] ->
m ([Expr], [Type])
@@ -437,7 +438,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
-- Check the types of the return values in a set of binders in a case statement
--
checkBinders ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
[Type] ->
Type ->
[CaseAlternative] ->
@@ -467,7 +468,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
-- Check the type of a value, rethrowing errors to provide a better error message
--
check ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
Type ->
m Expr
@@ -478,7 +479,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
--
check'
:: forall m
- . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Expr
-> Type
-> m Expr
@@ -524,19 +525,19 @@ check' val u@(TUnknown _) = do
(val'', ty') <- instantiatePolyTypeWithUnknowns val' ty
unifyTypes ty' u
return $ TypedValue True val'' ty'
-check' v@(NumericLiteral (Left _)) t | t == tyInt =
+check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt =
return $ TypedValue True v t
-check' v@(NumericLiteral (Right _)) t | t == tyNumber =
+check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber =
return $ TypedValue True v t
-check' v@(StringLiteral _) t | t == tyString =
+check' v@(Literal (StringLiteral _)) t | t == tyString =
return $ TypedValue True v t
-check' v@(CharLiteral _) t | t == tyChar =
+check' v@(Literal (CharLiteral _)) t | t == tyChar =
return $ TypedValue True v t
-check' v@(BooleanLiteral _) t | t == tyBoolean =
+check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean =
return $ TypedValue True v t
-check' (ArrayLiteral vals) t@(TypeApp a ty) = do
+check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do
unifyTypes a tyArray
- array <- ArrayLiteral <$> forM vals (`check` ty)
+ array <- Literal . ArrayLiteral <$> forM vals (`check` ty)
return $ TypedValue True array t
check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do
unifyTypes t tyFunction
@@ -587,10 +588,10 @@ check' (IfThenElse cond th el) ty = do
th' <- check th ty
el' <- check el ty
return $ TypedValue True (IfThenElse cond' th' el') ty
-check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
+check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyObject = do
ensureNoDuplicateProperties ps
ps' <- checkProperties e ps row False
- return $ TypedValue True (ObjectLiteral ps') t
+ return $ TypedValue True (Literal (ObjectLiteral ps')) t
check' (TypeClassDictionaryConstructorApp name ps) t = do
ps' <- check' ps t
return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
@@ -641,7 +642,7 @@ check' val ty = do
-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
--
checkProperties ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
[(String, Expr)] ->
Type ->
@@ -673,7 +674,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
-- | Check the type of a function application, rethrowing errors to provide a better error message
checkFunctionApplication ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
Type ->
Expr ->
@@ -685,7 +686,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication
-- | Check the type of a function application
checkFunctionApplication' ::
- (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
Type ->
Expr ->
@@ -720,25 +721,6 @@ checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
return (fnTy, App fn dict)
checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg
--- | Compute the meet of two types, i.e. the most general type which both types subsume.
--- TODO: is this really needed?
-meet ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>
- Expr ->
- Expr ->
- Type ->
- Type ->
- m (Expr, Expr, Type)
-meet e1 e2 (ForAll ident t1 _) t2 = do
- t1' <- replaceVarWithUnknown ident t1
- meet e1 e2 t1' t2
-meet e1 e2 t1 (ForAll ident t2 _) = do
- t2' <- replaceVarWithUnknown ident t2
- meet e1 e2 t1 t2'
-meet e1 e2 t1 t2 = do
- unifyTypes t1 t2
- return (e1, e2, t1)
-
-- |
-- Ensure a set of property names and value does not contain duplicate labels
--
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 92d7b7f..c8ed0d7 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -23,6 +23,7 @@ module Language.PureScript.TypeChecker.Unify (
freshType,
solveType,
substituteType,
+ unknownsInType,
unifyTypes,
unifyRows,
unifiesWith,
@@ -56,7 +57,7 @@ freshType = do
return $ TUnknown t
-- | Update the substitution to solve a type constraint
-solveType :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m ()
+solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m ()
solveType u t = do
occursCheck u t
modify $ \cs -> cs { checkSubstitution =
@@ -77,7 +78,7 @@ substituteType sub = everywhereOnTypes go
go other = other
-- | Make sure that an unknown does not occur in a type
-occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Type -> m ()
+occursCheck :: (MonadError MultipleErrors m) => Int -> Type -> m ()
occursCheck _ TUnknown{} = return ()
occursCheck u t = void $ everywhereOnTypesM go t
where
@@ -93,7 +94,7 @@ unknownsInType t = everythingOnTypes (.) go t []
go _ = id
-- | Unify two types, updating the current substitution
-unifyTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
+unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
unifyTypes t1 t2 = do
sub <- gets checkSubstitution
rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)
@@ -139,7 +140,7 @@ unifyTypes t1 t2 = do
-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification
-- error.
--
-unifyRows :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
+unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
unifyRows r1 r2 =
let
(s1, r1') = rowToList r1
@@ -205,7 +206,7 @@ replaceVarWithUnknown ident ty = do
-- |
-- Replace type wildcards with unknowns
--
-replaceTypeWildcards :: (Functor m, Applicative m, MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type
+replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type
replaceTypeWildcards = everywhereOnTypesM replace
where
replace TypeWildcard = do
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index f2505ed..925095b 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -248,7 +248,7 @@ everywhereOnTypesTopDown f = go . f
go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
go other = f other
-everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type
+everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type
everywhereOnTypesM f = go
where
go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
@@ -261,7 +261,7 @@ everywhereOnTypesM f = go
go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
go other = f other
-everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type
+everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type
everywhereOnTypesTopDownM f = go <=< f
where
go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml
deleted file mode 100644
index 49a6a68..0000000
--- a/stack-lts-2.yaml
+++ /dev/null
@@ -1,13 +0,0 @@
-resolver: lts-2.22
-packages:
-- '.'
-extra-deps:
-- aeson-better-errors-0.8.0
-- bower-json-0.7.0.0
-- boxes-0.1.4
-- pattern-arrows-0.0.2
-- sourcemap-0.1.6
-- fsnotify-0.2.1
-- hfsevents-0.1.6
-- pipes-http-1.0.2
-flags: {}
diff --git a/stack-lts-3.yaml b/stack-lts-5.yaml
index 69f14a9..2671991 100644
--- a/stack-lts-3.yaml
+++ b/stack-lts-5.yaml
@@ -1,6 +1,6 @@
-resolver: lts-3.22
+resolver: lts-5.4
packages:
- '.'
extra-deps:
-- sourcemap-0.1.6
+- bower-json-0.8.0
flags: {}
diff --git a/stack-nightly.yaml b/stack-nightly.yaml
index 2a5da38..c389d15 100644
--- a/stack-nightly.yaml
+++ b/stack-nightly.yaml
@@ -2,4 +2,4 @@ flags: {}
packages:
- '.'
extra-deps: []
-resolver: nightly-2016-02-25
+resolver: nightly-2016-03-17
diff --git a/stack.yaml b/stack.yaml
index 34bfedc..2671991 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,5 +1,6 @@
resolver: lts-5.4
packages:
- '.'
-extra-deps: []
+extra-deps:
+- bower-json-0.8.0
flags: {}
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 5fdb416..91bdf52 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -18,6 +18,7 @@ import System.Exit
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as Docs
import qualified Language.PureScript.Publish as Publish
+import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
import TestUtils
@@ -29,16 +30,19 @@ publishOpts = Publish.defaultPublishOptions
where testVersion = ("v999.0.0", Version [999,0,0] [])
main :: IO ()
-main = do
- pushd "examples/docs" $ do
- Docs.Package{..} <- Publish.preparePackage publishOpts
- forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
- let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
- (find ((==) mn . Docs.modName) pkgModules)
- in forM_ pragmas (flip runAssertionIO mdl)
+main = pushd "examples/docs" $ do
+ res <- Publish.preparePackage publishOpts
+ case res of
+ Left e -> Publish.printErrorToStdout e >> exitFailure
+ Right Docs.Package{..} ->
+ forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
+ let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
+ (find ((==) mn . Docs.modName) pkgModules)
+ in forM_ pragmas (`runAssertionIO` mdl)
+
takeJust :: String -> Maybe a -> a
-takeJust msg = maybe (error msg) id
+takeJust msg = fromMaybe (error msg)
data Assertion
-- | Assert that a particular declaration is documented with the given
@@ -254,8 +258,8 @@ testCases =
, ("ExplicitTypeSignatures",
[ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
- , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt))
- , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber))
+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
])
]
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index 49321ed..af84c96 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -19,12 +19,12 @@ import Data.Version
import Language.PureScript.Docs
import Language.PureScript.Publish
+import Language.PureScript.Publish.ErrorsWarnings as Publish
import TestUtils
main :: IO ()
-main = do
- testPackage "tests/support/prelude"
+main = testPackage "tests/support/prelude"
data TestResult
= ParseFailed String
@@ -53,14 +53,26 @@ testRunOptions = defaultPublishOptions
-- | Given a directory which contains a package, produce JSON from it, and then
-- | attempt to parse it again, and ensure that it doesn't change.
testPackage :: String -> IO ()
-testPackage dir = do
- pushd dir $ do
- r <- roundTrip <$> preparePackage testRunOptions
- case r of
+testPackage dir = pushd dir $ do
+ res <- preparePackage testRunOptions
+ case res of
+ Left e -> preparePackageError e
+ Right package -> case roundTrip package of
Pass _ -> do
putStrLn ("psc-publish test passed for: " ++ dir)
pure ()
other -> do
putStrLn ("psc-publish tests failed on " ++ dir ++ ":")
- putStrLn (show other)
+ print other
exitFailure
+ where
+ preparePackageError e@(UserError BowerJSONNotFound) = do
+ Publish.printErrorToStdout e
+ putStrLn ""
+ putStrLn "=========================================="
+ putStrLn "Did you forget to update the submodules?"
+ putStrLn "$ git submodule sync; git submodule update"
+ putStrLn "=========================================="
+ putStrLn ""
+ exitFailure
+ preparePackageError e = Publish.printErrorToStdout e >> exitFailure