diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -9,6 +9,7 @@ - [@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 @@ - [@epost](https://github.com/epost) (Erik Post) - My existing contributions and all future contributions until further notice are Copyright Erik Post, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license - [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/INSTALL.md b/INSTALL.md --- a/INSTALL.md +++ b/INSTALL.md @@ -6,8 +6,8 @@ ## 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 @@ ## 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`. @@ -38,10 +38,6 @@ 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 diff --git a/examples/docs/LICENSE b/examples/docs/LICENSE new file mode 100644 --- /dev/null +++ b/examples/docs/LICENSE @@ -0,0 +1,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 --- 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 --- /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 --- /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 --- /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 --- /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 --- 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 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 + put s = State (\_ -> Tuple s unit) -main = do - let t1 = test - Control.Monad.Eff.Console.log "Done" +-- 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 --- 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 @@ } 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 @@ -- | 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 @@ 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 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -32,7 +32,7 @@ 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 @@ 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 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -5,7 +5,6 @@ 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 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 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -11,8 +11,9 @@ 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 System.Directory import System.FilePath import System.IO +import System.IO.Error (isEOFError) import qualified Paths_purescript as Paths @@ -87,7 +89,7 @@ (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 @@ 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 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -38,8 +38,8 @@ 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 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -107,7 +107,7 @@ 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 = 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 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -214,7 +214,7 @@ 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 @@ 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 --- 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 @@ Harry Garrood , Christoph Hegemann -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 @@ , 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 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 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 @@ 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 @@ 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 @@ , 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 @@ 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 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -27,7 +27,7 @@ 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 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -21,4 +21,4 @@ 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 --- a/src/Language/PureScript/AST.hs +++ b/src/Language/PureScript/AST.hs @@ -1,24 +1,14 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.AST --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | The initial PureScript AST +-- | +-- 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 --- 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 @@ -- = NullBinder -- | - -- A binder which matches a boolean 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 + -- A binder which matches a literal -- - | NumberBinder (Either Integer Double) + | LiteralBinder (Literal Binder) -- | -- A binder which binds an identifier -- @@ -59,14 +48,6 @@ -- | 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 @@ 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 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -19,6 +19,7 @@ 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 @@ -- data Expr -- | - -- A numeric literal - -- - = NumericLiteral (Either Integer Double) - -- | - -- A string literal - -- - | StringLiteral String - -- | - -- A character literal - -- - | CharLiteral Char - -- | - -- A boolean literal + -- A literal value -- - | BooleanLiteral Bool + = Literal (Literal Expr) -- | -- A prefix -, will be desugared -- @@ -342,18 +331,9 @@ -- | 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/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Literals.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- | +-- The core functional representation for literal values. +-- +module Language.PureScript.AST.Literals where + +-- | +-- Data type for literal values. Parameterised so it can be used for Exprs and +-- Binders. +-- +data Literal a + -- | + -- A numeric literal + -- + = NumericLiteral (Either Integer Double) + -- | + -- A string literal + -- + | StringLiteral String + -- | + -- A character literal + -- + | CharLiteral Char + -- | + -- A boolean literal + -- + | BooleanLiteral Bool + -- | + -- An array literal + -- + | ArrayLiteral [a] + -- | + -- An object literal + -- + | ObjectLiteral [(String, a)] + deriving (Eq, Ord, Show, Read, Functor) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs --- 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 --- 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.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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -141,7 +141,7 @@ 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 @@ -- -- 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 @@ -- | 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 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -47,7 +47,7 @@ -- 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 @@ 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 @@ 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 @@ -- 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 @@ 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 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -347,7 +347,7 @@ 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 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -78,7 +78,7 @@ -- 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 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -43,12 +43,12 @@ -- | -- 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 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -96,9 +96,9 @@ 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 @@ -- (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 --- a/src/Language/PureScript/CoreFn.hs +++ b/src/Language/PureScript/CoreFn.hs @@ -1,17 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The core functional representation +-- | +-- The core functional representation -- ------------------------------------------------------------------------------ - module Language.PureScript.CoreFn ( module C ) where @@ -20,7 +9,7 @@ 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 --- 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 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -17,7 +17,7 @@ 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 @@ -- 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 @@ 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 @@ -- 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 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -8,7 +8,7 @@ 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/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs deleted file mode 100644 --- a/src/Language/PureScript/CoreFn/Literals.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} - --- | --- The core functional representation for literal values. --- -module Language.PureScript.CoreFn.Literals where - --- | --- Data type for literal values. Parameterised so it can be used for Exprs and --- Binders. --- -data Literal a - -- | - -- A numeric literal - -- - = NumericLiteral (Either Integer Double) - -- | - -- A string literal - -- - | StringLiteral String - -- | - -- A character literal - -- - | CharLiteral Char - -- | - -- A boolean literal - -- - | BooleanLiteral Bool - -- | - -- An array literal - -- - | ArrayLiteral [a] - -- | - -- An object literal - -- - | ObjectLiteral [(String, a)] - deriving (Show, Read, Functor) diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -1,24 +1,13 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Traversals --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | CoreFn traversal helpers +-- | +-- 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 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -29,8 +29,7 @@ -- 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 --- 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 @@ -- 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 @@ -- types. -- convertModules :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> m [Module] convertModules = @@ -81,7 +79,7 @@ -- 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 @@ -- types. -- typeCheckIfNecessary :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> [Module] -> m [Module] @@ -122,7 +120,7 @@ -- 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 @@ -- 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 --- 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ 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 @@ pure (importedFrom, [Left r']) other -> errOther other - other -> do - errOther other + other -> errOther other where thd :: (a, b, c) -> c @@ -233,9 +227,8 @@ -- 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: 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 @@ -- 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 @@ 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 @@ -- 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 @@ 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 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -11,11 +11,10 @@ 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -35,7 +35,7 @@ -- * 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 @@ 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 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -148,6 +148,7 @@ | CaseBinderLengthDiffers Int [Binder] | IncorrectAnonymousArgument | InvalidOperatorInBinder Ident Ident + | DeprecatedRequirePath deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -328,6 +329,7 @@ CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" IncorrectAnonymousArgument -> "IncorrectAnonymousArgument" InvalidOperatorInBinder{} -> "InvalidOperatorInBinder" + DeprecatedRequirePath{} -> "DeprecatedRequirePath" -- | -- A stack trace for an error @@ -447,6 +449,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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 @@ 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 @@ -- 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 @@ 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 @@ -- | -- 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 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -74,12 +74,12 @@ 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 @@ 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 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -19,6 +19,7 @@ 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 @@ 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 @@ 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 @@ " = ?" <> (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 "" s >>= runTokenParser "" (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 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -24,12 +24,12 @@ 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 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -21,21 +21,20 @@ 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 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -34,7 +34,7 @@ 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 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -76,8 +76,8 @@ 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 @@ -- 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 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -10,9 +10,9 @@ 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 @@ } 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 @@ 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 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -15,10 +15,10 @@ 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 @@ 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 --- 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.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 @@ 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 @@ 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 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -25,38 +25,38 @@ 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 @@ 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 --- 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 @@ 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 @@ 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 @@ 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 _ = "" 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 @@ 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) + parseJSON o = PursuitQuery <$> (parseJSON o) -data PursuitResponse - = ModuleResponse { moduleResponseName :: Text - , moduleResponsePackage :: Text} - | DeclarationResponse { declarationResponseType :: Text - , declarationResponseModule :: Text - , declarationResponseIdent :: Text - , declarationResponsePackage :: Text - } - deriving (Show,Eq) +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 @@ (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 @@ _ <- string "::" spaces type' <- many1 anyChar - return (unpack name, type') + pure (unpack name, type') identifier :: Parser Text identifier = do @@ -227,14 +223,15 @@ 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 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -42,7 +42,7 @@ 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 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -29,7 +29,7 @@ -- | 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 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -24,6 +24,7 @@ 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 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 @@ 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 (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 @@ -- | -- 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 @@ 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 @@ -- | -- 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 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -70,7 +70,7 @@ -- lintImports :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports @@ -152,7 +152,7 @@ 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 @@ 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 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -40,7 +40,7 @@ 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 @@ -- 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 @@ , 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 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -184,7 +184,6 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -36,7 +36,7 @@ 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 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -148,7 +148,7 @@ 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 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -274,8 +274,7 @@ 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 --- 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 --- Stability : experimental --- Portability : --- -- | -- Pretty printer for values -- ------------------------------------------------------------------------------ - module Language.PureScript.Pretty.Values ( prettyPrintValue, prettyPrintBinder, @@ -75,12 +63,7 @@ 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 @@ -- | 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 _ (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 @@ 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 --- 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 @@ , getGitWorkingTreeStatus , checkCleanWorkingTree , getVersionFromGitTag - , getBowerInfo + , getBowerRepositoryInfo , getModulesAndBookmarks , getResolvedDependencies ) where @@ -79,11 +80,16 @@ -- | 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 @@ 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 @@ 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 @@ -203,6 +214,9 @@ unless (repositoryType == "git") (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 diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -36,3 +36,6 @@ 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 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -10,6 +10,7 @@ , RepositoryFieldError(..) , JSONSource(..) , printError + , printErrorToStdout , renderError , printWarnings , renderWarnings @@ -54,11 +55,13 @@ -- | 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 @@ | NotOnGithub deriving (Show) + -- | An error that probably indicates a bug in this module. data InternalError = JSONError JSONSource (ParseError BowerError) @@ -88,6 +92,9 @@ printError :: PackageError -> IO () printError = printToStderr . renderError +printErrorToStdout :: PackageError -> IO () +printErrorToStdout = printToStdout . renderError + renderError :: PackageError -> Box renderError err = case err of @@ -122,6 +129,12 @@ "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 @@ ] ++ 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 @@ 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 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -63,7 +63,7 @@ -- -- * 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 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -35,7 +35,7 @@ -- 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 @@ createBindingGroups :: forall m - . (Functor m, Applicative m, MonadError MultipleErrors m) + . (MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration] @@ -171,7 +171,7 @@ -- 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 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -36,7 +36,7 @@ -- | -- 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 @@ -- | -- 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 @@ 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 @@ -- | -- 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 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 (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 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -26,10 +26,10 @@ -- 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 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -44,13 +44,13 @@ -- 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 @@ -- 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 @@ -- 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 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -31,7 +31,7 @@ -- | -- 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 @@ -- 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 @@ 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 @@ -- 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 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -37,7 +37,7 @@ -- 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 @@ -- 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 @@ -- | 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 @@ -- 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 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -19,7 +19,11 @@ 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 @@ | 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 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -57,7 +57,7 @@ -- rebracket :: forall m - . (Applicative m, MonadError MultipleErrors m) + . (MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] @@ -103,7 +103,7 @@ 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 @@ go other = other rebracketModule - :: (Applicative m, MonadError MultipleErrors m) + :: (MonadError MultipleErrors m) => [[(Qualified Ident, Associativity)]] -> Module -> m Module @@ -178,7 +178,7 @@ 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 @@ (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 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -45,7 +45,7 @@ -- 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 @@ 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 @@ -- }; -} desugarDecl - :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + :: (MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration @@ -259,7 +259,7 @@ typeInstanceDictionaryDeclaration :: forall m - . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + . (MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] @@ -297,7 +297,7 @@ , 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 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -32,7 +32,7 @@ -- | 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 @@ -- | 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 [ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ | 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 @@ 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 @@ 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 @@ 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 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -36,7 +36,7 @@ -- | -- 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 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -40,7 +40,7 @@ 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 @@ 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 @@ 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 @@ , 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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 --- 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 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.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,38 +77,59 @@ 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 @@ -- 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 @@ -- 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 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -43,7 +43,7 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ 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 @@ -- | 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 @@ -- | 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 @@ -- | 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 --- 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 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ 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 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ 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 @@ -- | 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 @@ -- | 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 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -36,7 +36,7 @@ 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 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -53,7 +53,7 @@ -- | -- 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 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -39,11 +39,11 @@ 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 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -57,7 +57,7 @@ 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 --- 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 @@ -- | 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 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ -- | 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 @@ 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' _ = 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 @@ 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 @@ -- | 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 @@ 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 @@ 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 @@ -- | 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 @@ -- 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 @@ -- 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' :: 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 @@ (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 @@ 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 @@ -- 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 @@ -- | 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 @@ -- | 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 -> @@ -719,25 +720,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 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -23,6 +23,7 @@ freshType, solveType, substituteType, + unknownsInType, unifyTypes, unifyRows, unifiesWith, @@ -56,7 +57,7 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ -- | -- 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 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -248,7 +248,7 @@ 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 @@ 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 --- 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-3.yaml deleted file mode 100644 --- a/stack-lts-3.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: lts-3.22 -packages: -- '.' -extra-deps: -- sourcemap-0.1.6 -flags: {} diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml new file mode 100644 --- /dev/null +++ b/stack-lts-5.yaml @@ -0,0 +1,6 @@ +resolver: lts-5.4 +packages: +- '.' +extra-deps: +- bower-json-0.8.0 +flags: {} diff --git a/stack-nightly.yaml b/stack-nightly.yaml --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -2,4 +2,4 @@ packages: - '.' extra-deps: [] -resolver: nightly-2016-02-25 +resolver: nightly-2016-03-17 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,6 @@ resolver: lts-5.4 packages: - '.' -extra-deps: [] +extra-deps: +- bower-json-0.8.0 flags: {} diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -18,6 +18,7 @@ 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 @@ 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 @@ , ("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 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -19,12 +19,12 @@ 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 @@ -- | 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