diff options
| author | PhilFreeman <> | 2016-03-26 20:48:00 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2016-03-26 20:48:00 (GMT) |
| commit | 6bc83edfdc50ee74921ae3e0e751a764c8a618fa (patch) | |
| tree | c7b64824ccb2279ce03f4b751e2e3656fa1a1937 | |
| parent | 0bdc658bac6649643d96d50c5803c123273de9af (diff) | |
version 0.8.3.00.8.3.0
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). @@ -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 @@ -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 |