summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-07-13 23:57:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-07-13 23:57:00 (GMT)
commitb7f4ed1fe863071139b42f9f40421ef693fbe2cf (patch)
tree9041e9aca491d6f4b494bd0fe86b1920521acad6
parente2d6ce02076b1c8f647b25efe19b89f61e02bbaf (diff)
version 0.7.1.00.7.1.0
Diffstat
-rw-r--r--psc-bundle/Main.hs503
-rw-r--r--psc-publish/ErrorsWarnings.hs16
-rw-r--r--psc-publish/Main.hs55
-rw-r--r--psc/Main.hs2
-rw-r--r--psc/Make.hs140
-rw-r--r--psci/Make.hs127
-rw-r--r--psci/PSCi.hs29
-rw-r--r--purescript.cabal15
-rw-r--r--src/Language/PureScript.hs154
-rw-r--r--src/Language/PureScript/AST/Binders.hs2
-rw-r--r--src/Language/PureScript/Bundle.hs540
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs3
-rw-r--r--src/Language/PureScript/Docs/ParseAndDesugar.hs43
-rw-r--r--src/Language/PureScript/Docs/Types.hs75
-rw-r--r--src/Language/PureScript/Errors.hs69
-rw-r--r--src/Language/PureScript/Linter.hs3
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs275
-rw-r--r--src/Language/PureScript/Make.hs314
-rw-r--r--src/Language/PureScript/Pretty/Values.hs96
19 files changed, 1392 insertions, 1069 deletions
diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs
index f939e2f..5b66605 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -20,15 +20,9 @@
module Main (main) where
-import Data.List (nub)
-import Data.Maybe (mapMaybe, catMaybes)
import Data.Traversable (for)
-import Data.Generics (everything, everywhere, mkQ, mkT)
-import Data.Graph
import Data.Version (showVersion)
-import qualified Data.Set as S
-
import Control.Applicative
import Control.Monad
import Control.Monad.Error.Class
@@ -41,66 +35,12 @@ import System.Exit (exitFailure)
import System.IO (stderr, hPutStrLn)
import System.Directory (createDirectoryIfMissing)
-import Language.JavaScript.Parser
+import Language.PureScript.Bundle
import Options.Applicative as Opts
import qualified Paths_purescript as Paths
--- | The type of error messages. We separate generation and rendering of errors using a data
--- type, in case we need to match on error types later.
-data ErrorMessage
- = UnsupportedModulePath String
- | InvalidTopLevel
- | UnableToParseModule
- | UnsupportedExport
- | ErrorInFile FilePath ErrorMessage
- deriving Show
-
--- | Modules are either "regular modules" (i.e. those generated by psc-make) or foreign modules.
-data ModuleType
- = Regular
- | Foreign
- deriving (Show, Eq, Ord)
-
--- | A module is identified by its module name and its type.
-data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
-
-moduleName :: ModuleIdentifier -> String
-moduleName (ModuleIdentifier name _) = name
-
--- | A piece of code is identified by its module and its name. These keys are used to label vertices
--- in the dependency graph.
-type Key = (ModuleIdentifier, String)
-
--- | An export is either a "regular export", which exports a name from the regular module we are in,
--- or a reexport of a declaration in the corresponding foreign module.
---
--- Regular exports are labelled, since they might re-export an operator with another name.
-data ExportType
- = RegularExport String
- | ForeignReexport
- deriving (Show, Eq, Ord)
-
--- | There are four types of module element we are interested in:
---
--- 1) Require statements
--- 2) Member declarations
--- 3) Export lists
--- 4) Everything else
---
--- Each is labelled with the original AST node which generated it, so that we can dump it back
--- into the output during codegen.
-data ModuleElement
- = Require JSNode String ModuleIdentifier
- | Member JSNode Bool String [JSNode] [Key]
- | ExportsList [(ExportType, String, JSNode, [Key])]
- | Other JSNode
- deriving Show
-
--- | A module is just a list of elements of the types listed above.
-data Module = Module ModuleIdentifier [ModuleElement] deriving Show
-
-- | Command line options.
data Options = Options
{ optionsInputFiles :: [FilePath]
@@ -110,33 +50,6 @@ data Options = Options
, optionsNamespace :: String
} deriving Show
--- | Prepare an error message for consumption by humans.
-printErrorMessage :: ErrorMessage -> [String]
-printErrorMessage (UnsupportedModulePath s) =
- [ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
- , "The following file names are supported:"
- , " 1) index.js (psc-make native modules)"
- , " 2) foreign.js (psc-make foreign modules)"
- ]
-printErrorMessage InvalidTopLevel =
- [ "Expected a list of source elements at the top level." ]
-printErrorMessage UnableToParseModule =
- [ "The module could not be parsed." ]
-printErrorMessage UnsupportedExport =
- [ "An export was unsupported. Exports can be defined in one of two ways: "
- , " 1) exports.name = ..."
- , " 2) exports = { ... }"
- ]
-printErrorMessage (ErrorInFile filename e) =
- ("Error in file " ++ show filename ++ ":")
- : ""
- : map (" " ++) (printErrorMessage e)
-
--- | Unpack the node inside a JSNode. This is useful when pattern matching.
-node :: JSNode -> Node
-node (NN n) = n
-node (NT n _ _) = n
-
-- | 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 filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> (guessModuleType (takeFileName filename))
@@ -145,419 +58,23 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f
guessModuleType "foreign.js" = pure Foreign
guessModuleType name = throwError $ UnsupportedModulePath name
--- | Calculate the ModuleIdentifier which a require(...) statement imports.
-checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
-checkImportPath "./foreign" m _ =
- Just (ModuleIdentifier (moduleName m) Foreign)
-checkImportPath name _ names
- | name `S.member` names = Just (ModuleIdentifier name Regular)
-checkImportPath _ _ _ = Nothing
-
--- | Compute the dependencies of all elements in a module, and add them to the tree.
---
--- Members and exports can have dependencies. A dependency is of one of the following forms:
---
--- 1) module.name or member["name"]
---
--- where module was imported using
---
--- var module = require("Module.Name");
---
--- 2) name
---
--- where name is the name of a member defined in the current module.
-withDeps :: Module -> Module
-withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
- where
- -- | Collects all modules which are imported, so that we can identify dependencies of the first type.
- imports :: [(String, ModuleIdentifier)]
- imports = mapMaybe toImport es
- where
- toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
- toImport (Require _ nm mid) = Just (nm, mid)
- toImport _ = Nothing
-
- -- | Collects all member names in scope, so that we can identify dependencies of the second type.
- boundNames :: [String]
- boundNames = mapMaybe toBoundName es
- where
- toBoundName :: ModuleElement -> Maybe String
- toBoundName (Member _ _ nm _ _) = Just nm
- toBoundName _ = Nothing
-
- -- | Calculate dependencies and add them to the current element.
- expandDeps :: ModuleElement -> ModuleElement
- expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))
- expandDeps (ExportsList exps) = ExportsList (map expand exps)
- where
- expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
- expandDeps other = other
-
- dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]
- dependencies m = everything (++) (mkQ [] toReference)
- where
- toReference :: Node -> [(ModuleIdentifier, String)]
- toReference (JSMemberDot [ mn ] _ nm)
- | JSIdentifier mn' <- node mn
- , JSIdentifier nm' <- node nm
- , Just mid <- lookup mn' imports
- = [(mid, nm')]
- toReference (JSMemberSquare [ mn ] _ nm _)
- | JSIdentifier mn' <- node mn
- , JSExpression [ s ] <- node nm
- , JSStringLiteral _ nm' <- node s
- , Just mid <- lookup mn' imports
- = [(mid, nm')]
- toReference (JSIdentifier nm)
- | nm `elem` boundNames
- = [(m, nm)]
- toReference _ = []
-
--- | Attempt to create a Module from a Javascript AST.
---
--- 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) => S.Set String -> ModuleIdentifier -> JSNode -> m Module
-toModule mids mid top
- | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns
- | otherwise = throwError InvalidTopLevel
- where
- toModuleElement :: JSNode -> m ModuleElement
- toModuleElement n
- | JSVariables var [ varIntro ] _ <- node n
- , JSLiteral "var" <- node var
- , JSVarDecl impN [ eq, req, impP ] <- node varIntro
- , JSIdentifier importName <- node impN
- , JSLiteral "=" <- node eq
- , JSIdentifier "require" <- node req
- , JSArguments _ [ impS ] _ <- node impP
- , JSStringLiteral _ importPath <- node impS
- , Just importPath' <- checkImportPath importPath mid mids
- = pure (Require n importName importPath')
- toModuleElement n
- | JSVariables var [ varIntro ] _ <- node n
- , JSLiteral "var" <- node var
- , JSVarDecl declN (eq : decl) <- node varIntro
- , JSIdentifier name <- node declN
- , JSLiteral "=" <- node eq
- = pure (Member n False name decl [])
- toModuleElement n
- | JSExpression (e : op : decl) <- node n
- , Just name <- accessor (node e)
- , JSOperator eq <- node op
- , JSLiteral "=" <- node eq
- = pure (Member n True name decl [])
- where
- accessor :: Node -> Maybe String
- accessor (JSMemberDot [ exports ] _ nm)
- | JSIdentifier "exports" <- node exports
- , JSIdentifier name <- node nm
- = Just name
- accessor (JSMemberSquare [ exports ] _ nm _)
- | JSIdentifier "exports" <- node exports
- , JSExpression [e] <- node nm
- , JSStringLiteral _ name <- node e
- = Just name
- accessor _ = Nothing
- toModuleElement n
- | JSExpression (mnExp : op : obj: _) <- node n
- , JSMemberDot [ mn ] _ e <- node mnExp
- , JSIdentifier "module" <- node mn
- , JSIdentifier "exports" <- node e
- , JSOperator eq <- node op
- , JSLiteral "=" <- node eq
- , JSObjectLiteral _ props _ <- node obj
- = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props))
- where
- toExport :: Node -> m (ExportType, String, JSNode, [Key])
- toExport (JSPropertyNameandValue name _ [val] ) =
- (,,val,[]) <$> exportType (node val)
- <*> extractLabel (node name)
- toExport _ = throwError UnsupportedExport
-
- exportType :: Node -> m ExportType
- exportType (JSMemberDot [f] _ _)
- | JSIdentifier "$foreign" <- node f
- = pure ForeignReexport
- exportType (JSMemberSquare [f] _ _ _)
- | JSIdentifier "$foreign" <- node f
- = pure ForeignReexport
- exportType (JSIdentifier s) = pure (RegularExport s)
- exportType _ = throwError UnsupportedExport
-
- extractLabel :: Node -> m String
- extractLabel (JSStringLiteral _ nm) = pure nm
- extractLabel (JSIdentifier nm) = pure nm
- extractLabel _ = throwError UnsupportedExport
-
- isSeparator :: Node -> Bool
- isSeparator (JSLiteral ",") = True
- isSeparator _ = False
- toModuleElement other = pure (Other other)
-
--- | Eliminate unused code based on the specified entry point set.
-compile :: [Module] -> [ModuleIdentifier] -> [Module]
-compile modules [] = modules
-compile modules entryPoints = filteredModules
- where
- (graph, _, vertexFor) = graphFromEdges verts
-
- -- | The vertex set
- verts :: [(ModuleElement, Key, [Key])]
- verts = do
- Module mid els <- modules
- concatMap (toVertices mid) els
- where
- -- | Create a set of vertices for a module element.
- --
- -- Some special cases worth commenting on:
- --
- -- 1) Regular exports which simply export their own name do not count as dependencies.
- -- Regular exports which rename and reexport an operator do count, however.
- --
- -- 2) Require statements don't contribute towards dependencies, since they effectively get
- -- inlined wherever they are used inside other module elements.
- toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]
- toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)]
- toVertices p m@(ExportsList exps) = mapMaybe toVertex exps
- where
- toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks)
- toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks)
- toVertex _ = Nothing
- toVertices _ _ = []
-
- -- | The set of vertices whose connected components we are interested in keeping.
- entryPointVertices :: [Vertex]
- entryPointVertices = catMaybes $ do
- (_, k@(mid, _), _) <- verts
- guard $ mid `elem` entryPoints
- return (vertexFor k)
-
- -- | The set of vertices reachable from an entry point
- reachableSet :: S.Set Vertex
- reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
-
- filteredModules :: [Module]
- filteredModules = map filterUsed modules
- where
- filterUsed :: Module -> Module
- filterUsed (Module mid ds) = Module mid (map filterExports (go ds))
- where
- go :: [ModuleElement] -> [ModuleElement]
- go [] = []
- go (d : Other semi : rest)
- | JSLiteral ";" <- node semi
- , not (isDeclUsed d)
- = go rest
- go (d : rest)
- | not (isDeclUsed d) = go rest
- | otherwise = d : go rest
-
- -- | Filter out the exports for members which aren't used.
- filterExports :: ModuleElement -> ModuleElement
- filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
- filterExports me = me
-
- isDeclUsed :: ModuleElement -> Bool
- isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
- isDeclUsed _ = True
-
- isKeyUsed :: Key -> Bool
- isKeyUsed k
- | Just me <- vertexFor k = me `S.member` reachableSet
- | otherwise = False
-
--- | Topologically sort the module dependency graph, so that when we generate code, modules can be
--- defined in the right order.
-sortModules :: [Module] -> [Module]
-sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
- where
- (graph, nodeFor, _) = graphFromEdges $ do
- m@(Module mid els) <- modules
- return (m, mid, mapMaybe getKey els)
-
- getKey :: ModuleElement -> Maybe ModuleIdentifier
- getKey (Require _ _ mi) = Just mi
- getKey _ = Nothing
-
--- | A module is empty if it contains no exported members (in other words,
--- if the only things left after dead code elimination are module imports and
--- "other" foreign code).
---
--- If a module is empty, we don't want to generate code for it.
-isModuleEmpty :: Module -> Bool
-isModuleEmpty (Module _ els) = all isElementEmpty els
- where
- isElementEmpty :: ModuleElement -> Bool
- isElementEmpty (ExportsList exps) = null exps
- isElementEmpty (Require _ _ _) = True
- isElementEmpty (Other _) = True
- isElementEmpty _ = False
-
--- | Generate code for a set of modules, including a call to main().
---
--- Modules get defined on the global PS object, as follows:
---
--- var PS = { };
--- (function(exports) {
--- ...
--- })(PS["Module.Name"] = PS["Module.Name"] || {});
---
--- In particular, a module and its foreign imports share the same namespace inside PS.
--- This saves us from having to generate unique names for a module and its foreign imports,
--- and is safe since a module shares a namespace with its foreign imports in PureScript as well
--- (so there is no way to have overlaps in code generated by psc-make).
-codeGen :: Options -> [Module] -> String
-codeGen Options{..} ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))
- where
- moduleToJS :: Module -> [JSNode]
- moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
- where
- declToJS :: ModuleElement -> [JSNode]
- declToJS (Member n _ _ _ _) = [n]
- declToJS (Other n) = [n]
- declToJS (Require _ nm req) =
- [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
- [ NN (JSVarDecl (sp (JSIdentifier nm))
- [ sp (JSLiteral "=")
- , moduleReference sp (moduleName req)
- ])
- ]
- (nt (JSLiteral ";"))) ]
- declToJS (ExportsList exps) = map toExport exps
-
- where
- toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
- toExport (_, nm, val, _) =
- NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
- (nt (JSLiteral "["))
- (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
- (nt (JSLiteral "]")))
- , NN (JSOperator (sp (JSLiteral "=")))
- , reindent val
- , nt (JSLiteral ";")
- ])
-
- reindent :: JSNode -> JSNode
- reindent (NT n _ _) = sp n
- reindent nn = nn
-
- indent :: [JSNode] -> [JSNode]
- indent = everywhere (mkT squash)
- where
- squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
- squash nn = nn
-
- splat (CommentA pos s) = CommentA (keepCol pos) s
- splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
- splat ann = ann
-
- keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
-
- prelude :: [JSNode]
- prelude =
- [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
- , WhiteSpace tokenPosnEmpty "\n"
- ])
- [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
- [ sp (JSLiteral "=")
- , NN (JSObjectLiteral (sp (JSLiteral "{"))
- []
- (sp (JSLiteral "}")))
- ])
- ]
- (nt (JSLiteral ";")))
- , lf
- ]
-
- moduleReference :: (Node -> JSNode) -> String -> JSNode
- moduleReference f mn =
- NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
- (nt (JSLiteral "["))
- (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
- (nt (JSLiteral "]")))
-
- wrap :: String -> [JSNode] -> [JSNode]
- wrap mn ds =
- [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))
- (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))
- []
- (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))
- (NN (JSBlock [sp (JSLiteral "{")]
- (lf : ds)
- [nl (JSLiteral "}")])))]))
- (nt (JSLiteral ")")))
- , NN (JSArguments (nt (JSLiteral "("))
- [ NN (JSExpression [ moduleReference nt mn
- , NN (JSOperator (sp (JSLiteral "=")))
- , NN (JSExpressionBinary "||"
- [ moduleReference sp mn ]
- (sp (JSLiteral "||"))
- [ emptyObj ])
- ])
- ]
- (nt (JSLiteral ")")))
- ])
- , nt (JSLiteral ";")
- , lf
- ]
- where
- emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
-
- runMain :: String -> [JSNode]
- runMain mn =
- [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]
- (nt (JSLiteral "["))
- (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
- (nt (JSLiteral "]")))
- ]
- (nt (JSLiteral "."))
- (nt (JSIdentifier "main")))
- , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))
- ])
- , nt (JSLiteral ";")
- ]
-
- nt :: Node -> JSNode
- nt n = NT n tokenPosnEmpty []
-
- lf :: JSNode
- lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
-
- sp :: Node -> JSNode
- sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
-
- nl :: Node -> JSNode
- nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
-
-- | 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 :: forall m. (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String
-app opts@Options{..} = do
+app Options{..} = do
inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles
when (null inputFiles) . liftIO $ do
hPutStrLn stderr "psc-bundle: No input files."
exitFailure
input <- for inputFiles $ \filename -> do
js <- liftIO (readFile filename)
- ast <- fromRight (parse js filename)
mid <- guessModuleIdentifier filename
- return (mid, ast)
-
- let mids = S.fromList (map (moduleName . fst) input)
+ return (mid, js)
- modules <- mapM (fmap withDeps . uncurry (toModule mids)) input
-
- let compiled = compile modules (map (`ModuleIdentifier` Regular) optionsEntryPoints)
- sorted = sortModules (filter (not . isModuleEmpty) compiled)
-
- return (codeGen opts sorted)
-
- where
- fromRight :: Either a b -> m b
- fromRight (Right b) = pure b
- fromRight (Left _) = throwError UnableToParseModule
+ let entryIds = (map (`ModuleIdentifier` Regular) optionsEntryPoints)
+
+ bundle input entryIds optionsMainModule optionsNamespace
-- | Command line options parser.
options :: Parser Options
@@ -572,10 +89,10 @@ options = Options <$> some inputFile
metavar "FILE"
<> help "The input .js file(s)"
- outputFile :: Parser FilePath
- outputFile = strOption $
- short 'o'
- <> long "output"
+ outputFile :: Parser FilePath
+ outputFile = strOption $
+ short 'o'
+ <> long "output"
<> help "The output .js file"
entryPoint :: Parser String
diff --git a/psc-publish/ErrorsWarnings.hs b/psc-publish/ErrorsWarnings.hs
index 20509d8..18371b3 100644
--- a/psc-publish/ErrorsWarnings.hs
+++ b/psc-publish/ErrorsWarnings.hs
@@ -33,7 +33,7 @@ data PackageError
deriving (Show)
data PackageWarning
- = ResolutionNotVersion PackageName
+ = NoResolvedVersion PackageName
| UndeclaredDependency PackageName
| UnacceptableVersion (PackageName, String)
deriving (Show)
@@ -253,7 +253,7 @@ displayOtherError e = case e of
[ "An IO exception occurred:", show exc ]
data CollectedWarnings = CollectedWarnings
- { resolutionNotVersions :: [PackageName]
+ { noResolvedVersions :: [PackageName]
, undeclaredDependencies :: [PackageName]
, unacceptableVersions :: [(PackageName, String)]
}
@@ -268,7 +268,7 @@ collectWarnings :: [PackageWarning] -> CollectedWarnings
collectWarnings = foldMap singular
where
singular w = case w of
- ResolutionNotVersion pn -> CollectedWarnings [pn] [] []
+ NoResolvedVersion pn -> CollectedWarnings [pn] [] []
UndeclaredDependency pn -> CollectedWarnings [] [pn] []
UnacceptableVersion t -> CollectedWarnings [] [] [t]
@@ -276,7 +276,7 @@ renderWarnings :: [PackageWarning] -> Box
renderWarnings warns =
let CollectedWarnings{..} = collectWarnings warns
go toBox warns' = toBox <$> NonEmpty.nonEmpty warns'
- mboxes = [ go warnResolutionNotVersions resolutionNotVersions
+ mboxes = [ go warnNoResolvedVersions noResolvedVersions
, go warnUndeclaredDependencies undeclaredDependencies
, go warnUnacceptableVersions unacceptableVersions
]
@@ -286,18 +286,18 @@ renderWarnings warns =
, indented (vcat (intersperse spacer boxes))
]
-warnResolutionNotVersions :: NonEmpty PackageName -> Box
-warnResolutionNotVersions pkgNames =
+warnNoResolvedVersions :: NonEmpty PackageName -> Box
+warnNoResolvedVersions pkgNames =
let singular = NonEmpty.length pkgNames == 1
pl a b = if singular then b else a
packages = pl "packages" "package"
- were = pl "were" "was"
anyOfThese = pl "any of these" "this"
these = pl "these" "this"
in vcat $
[ para (concat
- ["The following ", packages, " ", were, " not resolved to a version:"])
+ ["The following ", packages, " did not appear to have a resolved "
+ , "version:"])
] ++
bulletedList runPackageName (NonEmpty.toList pkgNames)
++
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
index bff4fb2..301c3e7 100644
--- a/psc-publish/Main.hs
+++ b/psc-publish/Main.hs
@@ -3,15 +3,18 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Main where
+
import Prelude hiding (userError)
import Data.Maybe
import Data.Char (isSpace)
import Data.String (fromString)
-import Data.List (stripPrefix, isSuffixOf, (\\))
+import Data.List (stripPrefix, isSuffixOf, (\\), nubBy)
import Data.List.Split (splitOn)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Version
+import Data.Function (on)
import Safe (headMay)
import qualified Data.ByteString.Lazy.Char8 as BL
@@ -37,6 +40,7 @@ import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName,
runPackageName, parsePackageName, Repository(..))
import qualified Web.Bower.PackageMeta as Bower
+import qualified Language.PureScript as P (version)
import qualified Language.PureScript.Docs as D
import Utils
import ErrorsWarnings
@@ -106,6 +110,7 @@ preparePackage' = do
pkgResolvedDependencies <- getResolvedDependencies declaredDeps
let pkgUploader = D.NotYetKnown
+ let pkgCompilerVersion = P.version
return D.Package{..}
@@ -170,6 +175,12 @@ readProcess' prog args stdin = do
data DependencyStatus
= Missing
+ -- ^ Listed in bower.json, but not installed.
+ | NoResolution
+ -- ^ In the output of `bower list --json --offline`, there was no
+ -- _resolution key. This can be caused by adding the dependency using
+ -- `bower link`, or simply copying it into bower_components instead of
+ -- installing it normally.
| ResolvedOther String
-- ^ Resolved, but to something other than a version. The String argument
-- is the resolution type. The values it can take that I'm aware of are
@@ -196,18 +207,35 @@ getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
getResolvedDependencies declaredDeps = do
depsBS <- fromString <$> readProcess' "bower" ["list", "--json", "--offline"] ""
- deps <- catchLeft (parse asBowerResolvedDependencies depsBS)
- (internalError . JSONError FromBowerList)
+ -- Check for undeclared dependencies
+ toplevels <- catchJSON (parse asToplevelDependencies depsBS)
+ warnUndeclared declaredDeps toplevels
- warnUndeclared declaredDeps (map fst deps)
+ deps <- catchJSON (parse asResolvedDependencies depsBS)
handleDeps deps
where
- asBowerResolvedDependencies ::
- Parse BowerError [(PackageName, DependencyStatus)]
- asBowerResolvedDependencies =
- key "dependencies"
- (eachInObjectWithKey (parsePackageName . T.unpack) asDependencyStatus)
+ catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
+
+-- | Extracts all dependencies and their versions from
+-- `bower list --json --offline`
+asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
+asResolvedDependencies = nubBy ((==) `on` fst) <$> go
+ where
+ go =
+ fmap (fromMaybe []) $
+ keyMay "dependencies" $
+ (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
+ asDependencyStatus
+ <*> (concatMap snd <$> eachInObject asResolvedDependencies)
+
+-- | Extracts only the top level dependency names from the output of
+-- `bower list --json --offline`
+asToplevelDependencies :: Parse BowerError [PackageName]
+asToplevelDependencies =
+ fmap (map fst) $
+ key "dependencies" $
+ eachInObjectWithKey (parsePackageName . T.unpack) (return ())
asDependencyStatus :: Parse e DependencyStatus
asDependencyStatus = do
@@ -217,7 +245,7 @@ asDependencyStatus = do
return Missing
else
key "pkgMeta" $
- key "_resolution" $ do
+ keyOrDefault "_resolution" NoResolution $ do
type_ <- key "type" asString
case type_ of
"version" -> ResolvedVersion <$> key "tag" asString
@@ -230,12 +258,12 @@ warnUndeclared declared actual =
handleDeps ::
[(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
handleDeps deps = do
- let (missing, notVersion, installed) = partitionDeps deps
+ let (missing, noVersion, installed) = partitionDeps deps
case missing of
(x:xs) ->
userError (MissingDependencies (x :| xs))
[] -> do
- mapM_ (warn . ResolutionNotVersion . fst) notVersion
+ mapM_ (warn . NoResolvedVersion) noVersion
withVersions <- catMaybes <$> mapM tryExtractVersion' installed
filterM (liftIO . isPureScript . bowerDir . fst) withVersions
@@ -244,7 +272,8 @@ handleDeps deps = do
go (pkgName, d) (ms, os, is) =
case d of
Missing -> (pkgName : ms, os, is)
- ResolvedOther o -> (ms, (pkgName, o) : os, is)
+ NoResolution -> (ms, pkgName : os, is)
+ ResolvedOther _ -> (ms, pkgName : os, is)
ResolvedVersion v -> (ms, os, (pkgName, v) : is)
bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
diff --git a/psc/Main.hs b/psc/Main.hs
index f38dd5a..0faced9 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -36,7 +36,7 @@ import System.FilePath.Glob (glob)
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
-import Make
+import Language.PureScript.Make
data PSCMakeOptions = PSCMakeOptions
{ pscmInput :: [FilePath]
diff --git a/psc/Make.hs b/psc/Make.hs
deleted file mode 100644
index 4ab18bc..0000000
--- a/psc/Make.hs
+++ /dev/null
@@ -1,140 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Make
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TupleSections #-}
-
-module Make
- ( Make(..)
- , runMake
- , buildMakeActions
- ) where
-
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Trans.Except
-import Control.Monad.Reader
-import Control.Monad.Writer
-
-import Data.Maybe (fromMaybe)
-import Data.Time.Clock
-import Data.Traversable (traverse)
-import Data.Version (showVersion)
-import qualified Data.Map as M
-
-import System.Directory
- (doesFileExist, getModificationTime, createDirectoryIfMissing)
-import System.FilePath ((</>), takeDirectory)
-import System.IO.Error (tryIOError)
-
-import qualified Language.PureScript as P
-import qualified Language.PureScript.CodeGen.JS as J
-import qualified Language.PureScript.CoreFn as CF
-import qualified Paths_purescript as Paths
-
-newtype Make a = Make { unMake :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
-
-runMake :: P.Options -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
-runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
-
-makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
-makeIO f io = do
- e <- liftIO $ tryIOError io
- either (throwError . P.singleError . f) return e
-
--- Traverse (Either e) instance (base 4.7)
-traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
-traverseEither _ (Left x) = pure (Left x)
-traverseEither f (Right y) = Right <$> f y
-
-buildMakeActions :: FilePath
- -> M.Map P.ModuleName (Either P.RebuildPolicy String)
- -> M.Map P.ModuleName (FilePath, P.ForeignJS)
- -> Bool
- -> P.MakeActions Make
-buildMakeActions outputDir filePathMap foreigns usePrefix =
- P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
- where
-
- getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
- getInputTimestamp mn = do
- let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
- e1 <- traverseEither getTimestamp path
- fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
- return $ fmap (max fPath) e1
-
- getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
- getOutputTimestamp mn = do
- let filePath = P.runModuleName mn
- jsFile = outputDir </> filePath </> "index.js"
- externsFile = outputDir </> filePath </> "externs.purs"
- min <$> getTimestamp jsFile <*> getTimestamp externsFile
-
- readExterns :: P.ModuleName -> Make (FilePath, String)
- readExterns mn = do
- let path = outputDir </> P.runModuleName mn </> "externs.purs"
- (path, ) <$> readTextFile path
-
- codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
- codegen m _ nextVar exts = do
- let mn = CF.moduleName m
- foreignInclude <- case mn `M.lookup` foreigns of
- Just (path, _)
- | not $ requiresForeign m -> do
- tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
- return Nothing
- | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
- Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
- | otherwise -> return Nothing
- pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
- let filePath = P.runModuleName mn
- jsFile = outputDir </> filePath </> "index.js"
- externsFile = outputDir </> filePath </> "externs.purs"
- foreignFile = outputDir </> filePath </> "foreign.js"
- prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
- js = unlines $ map ("// " ++) prefix ++ [pjs]
- writeTextFile jsFile js
- maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
- writeTextFile externsFile exts
-
- requiresForeign :: CF.Module a -> Bool
- requiresForeign = not . null . CF.moduleForeign
-
- getTimestamp :: FilePath -> Make (Maybe UTCTime)
- getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
- exists <- doesFileExist path
- traverse (const $ getModificationTime path) $ guard exists
-
- readTextFile :: FilePath -> Make String
- readTextFile path = do
- verboseErrorsEnabled <- asks P.optionsVerboseErrors
- makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
- when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
- readFile path
-
- writeTextFile :: FilePath -> String -> Make ()
- writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
- mkdirp path
- putStrLn $ "Writing " ++ path
- writeFile path text
- where
- mkdirp :: FilePath -> IO ()
- mkdirp = createDirectoryIfMissing True . takeDirectory
-
- progress :: String -> Make ()
- progress = liftIO . putStrLn
diff --git a/psci/Make.hs b/psci/Make.hs
deleted file mode 100644
index b416c57..0000000
--- a/psci/Make.hs
+++ /dev/null
@@ -1,127 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Make
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TupleSections #-}
-
-module Make where
-
-import Data.List (isPrefixOf)
-import Data.Maybe (fromMaybe)
-import Data.Time.Clock
-import Data.Traversable (traverse)
-import qualified Data.Map as M
-
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
-import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
-
-import System.Directory (getModificationTime, doesFileExist)
-import System.FilePath ((</>), pathSeparator)
-import System.IO.Error (tryIOError)
-
-import qualified Language.PureScript as P
-import qualified Language.PureScript.CodeGen.JS as J
-import qualified Language.PureScript.CoreFn as CF
-
-import IO (mkdirp)
-
-options :: P.Options
-options = P.Options False False Nothing False False False Nothing
-
-modulesDir :: FilePath
-modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
-
-newtype Make a = Make { unMake :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
-
-runMake :: Make a -> IO (Either P.MultipleErrors a)
-runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
-
-makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
-makeIO f io = do
- e <- liftIO $ tryIOError io
- either (throwError . P.singleError . f) return e
-
--- Traverse (Either e) instance (base 4.7)
-traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
-traverseEither _ (Left x) = pure (Left x)
-traverseEither f (Right y) = Right <$> f y
-
-buildMakeActions :: M.Map P.ModuleName (Either P.RebuildPolicy String)
- -> M.Map P.ModuleName P.ForeignJS
- -> P.MakeActions Make
-buildMakeActions filePathMap foreigns =
- P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
- where
-
- getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
- getInputTimestamp mn = do
- let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
- traverseEither getTimestamp path
-
- getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
- getOutputTimestamp mn = do
- let filePath = P.runModuleName mn
- jsFile = modulesDir </> filePath </> "index.js"
- externsFile = modulesDir </> filePath </> "externs.purs"
- min <$> getTimestamp jsFile <*> getTimestamp externsFile
-
- readExterns :: P.ModuleName -> Make (FilePath, String)
- readExterns mn = do
- let path = modulesDir </> P.runModuleName mn </> "externs.purs"
- (path, ) <$> readTextFile path
-
- codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
- codegen m _ nextVar exts = do
- let mn = CF.moduleName m
- foreignInclude <- case CF.moduleName m `M.lookup` foreigns of
- Just path
- | not $ requiresForeign m -> do tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
- return Nothing
- | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
- Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
- | otherwise -> return Nothing
- pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
- let filePath = P.runModuleName $ CF.moduleName m
- jsFile = modulesDir </> filePath </> "index.js"
- externsFile = modulesDir </> filePath </> "externs.purs"
- foreignFile = modulesDir </> filePath </> "foreign.js"
- writeTextFile jsFile pjs
- maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
- writeTextFile externsFile exts
-
- requiresForeign :: CF.Module a -> Bool
- requiresForeign = not . null . CF.moduleForeign
-
- getTimestamp :: FilePath -> Make (Maybe UTCTime)
- getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
- exists <- doesFileExist path
- traverse (const $ getModificationTime path) $ guard exists
-
- readTextFile :: FilePath -> Make String
- readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
-
- writeTextFile :: FilePath -> String -> Make ()
- writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
- mkdirp path
- writeFile path text
-
- progress :: String -> Make ()
- progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
index fd38f04..258a580 100644
--- a/psci/PSCi.hs
+++ b/psci/PSCi.hs
@@ -21,7 +21,7 @@
module PSCi where
import Data.Foldable (traverse_)
-import Data.List (intercalate, nub, sort)
+import Data.List (intercalate, nub, sort, isPrefixOf)
import Data.Traversable (traverse)
import Data.Tuple (swap)
import Data.Version (showVersion)
@@ -30,10 +30,12 @@ import qualified Data.Map as M
import Control.Applicative
import Control.Arrow (first)
import Control.Monad
+import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.State.Strict
+import Control.Monad.IO.Class (liftIO)
import Control.Monad.Writer (runWriter)
import qualified Control.Monad.Trans.State.Lazy as L
@@ -45,6 +47,7 @@ import System.Exit
import System.FilePath (pathSeparator, (</>), isPathSeparator)
import System.FilePath.Glob (glob)
import System.Process (readProcessWithExitCode)
+import System.IO.Error (tryIOError)
import qualified Language.PureScript as P
import qualified Language.PureScript.Names as N
@@ -53,7 +56,6 @@ import qualified Paths_purescript as Paths
import qualified Directive as D
import Completion (completion)
import IO (mkdirp)
-import Make
import Parser (parseCommand)
import Types
@@ -240,10 +242,25 @@ importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
indexFile :: FilePath
indexFile = ".psci_modules" ++ pathSeparator : "index.js"
-make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> Make P.Environment
-make PSCiState{..} ms =
- let filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
- in P.make (buildMakeActions filePathMap (M.map snd psciForeignFiles)) (psciLoadedModules ++ ms)
+modulesDir :: FilePath
+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
+
+-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
+-- options and ignores the warning messages.
+runMake :: P.Make a -> IO (Either P.MultipleErrors a)
+runMake mk = fmap (fmap fst) $ P.runMake (P.Options False False Nothing False False False Nothing) mk
+
+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a
+makeIO f io = do
+ e <- liftIO $ tryIOError io
+ either (throwError . P.singleError . f) return e
+
+make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
+make PSCiState{..} ms = P.make actions' (psciLoadedModules ++ ms)
+ where
+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
+ actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
+ actions' = actions { P.progress = \s -> unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s }
-- |
-- Takes a value declaration and evaluates it with the current state.
diff --git a/purescript.cabal b/purescript.cabal
index 81cf95f..da90e20 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.7.0.0
+version: 0.7.1.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -46,7 +46,9 @@ library
aeson-better-errors >= 0.8,
bytestring -any,
text -any,
- split -any
+ split -any,
+ language-javascript == 0.5.*,
+ syb -any
exposed-modules: Language.PureScript
Language.PureScript.AST
@@ -56,6 +58,7 @@ library
Language.PureScript.AST.SourcePos
Language.PureScript.AST.Traversals
Language.PureScript.AST.Exported
+ Language.PureScript.Bundle
Language.PureScript.CodeGen
Language.PureScript.CodeGen.Externs
Language.PureScript.CodeGen.JS
@@ -83,6 +86,8 @@ library
Language.PureScript.Errors
Language.PureScript.Kinds
Language.PureScript.Linter
+ Language.PureScript.Linter.Exhaustive
+ Language.PureScript.Make
Language.PureScript.ModuleDependencies
Language.PureScript.Names
Language.PureScript.Options
@@ -152,7 +157,6 @@ executable psc
main-is: Main.hs
buildable: True
hs-source-dirs: psc
- other-modules: Make
ghc-options: -Wall -O2 -fno-warn-unused-do-bind
executable psci
@@ -169,7 +173,6 @@ executable psci
Directive
Completion
PSCi
- Make
IO
ghc-options: -Wall -O2
@@ -217,9 +220,7 @@ executable psc-bundle
other-modules:
other-extensions:
build-depends: base >=4 && <5,
- language-javascript == 0.5.*,
- syb -any,
- containers -any,
+ purescript -any,
filepath -any,
directory -any,
mtl -any,
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index f7c3f2d..c2fa84b 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -20,37 +20,18 @@
module Language.PureScript
( module P
- , RebuildPolicy(..)
- , MakeActions(..)
- , SupplyVar()
- , Externs()
- , make
, version
) where
-import Data.Function (on)
-import Data.List (sortBy, groupBy)
-import Data.Maybe (fromMaybe)
-import Data.Time.Clock
import Data.Version (Version)
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Control.Applicative
-import Control.Arrow ((&&&))
-import Control.Monad
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Reader
-import Control.Monad.Writer
-import Control.Monad.Supply.Class (fresh)
import Language.PureScript.AST as P
import Language.PureScript.Comments as P
-import Language.PureScript.CodeGen.Externs (moduleToPs)
import Language.PureScript.Environment as P
import Language.PureScript.Errors as P
import Language.PureScript.Kinds as P
import Language.PureScript.Linter as P
+import Language.PureScript.Make as P
import Language.PureScript.ModuleDependencies as P
import Language.PureScript.Names as P
import Language.PureScript.Options as P
@@ -61,141 +42,8 @@ import Language.PureScript.Sugar as P
import Control.Monad.Supply as P
import Language.PureScript.TypeChecker as P
import Language.PureScript.Types as P
-import qualified Language.PureScript.CoreFn as CoreFn
-import qualified Language.PureScript.Constants as C
import qualified Paths_purescript as Paths
--- |
--- Actions that require implementations when running in "make" mode.
---
-data MakeActions m = MakeActions {
- -- |
- -- Get the timestamp for the input file(s) for a module. If there are multiple
- -- files (.purs and foreign files, for example) the timestamp should be for
- -- the most recently modified file.
- --
- getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
- -- |
- -- Get the timestamp for the output files for a module. This should be the
- -- timestamp for the oldest modified file, or Nothing if any of the required
- -- output files are missing.
- --
- , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
- -- |
- -- Read the externs file for a module as a string and also return the actual
- -- path for the file.
- , readExterns :: ModuleName -> m (FilePath, String)
- -- |
- -- Run the code generator for the module and write any required output files.
- --
- , codegen :: CoreFn.Module CoreFn.Ann -> Environment -> SupplyVar -> Externs -> m ()
- -- |
- -- Respond to a progress update.
- --
- , progress :: String -> m ()
- }
-
--- |
--- Generated code for an externs file.
---
-type Externs = String
-
--- |
--- A value to be used in the Supply monad.
---
-type SupplyVar = Integer
-
--- |
--- Determines when to rebuild a module
---
-data RebuildPolicy
- -- | Never rebuild this module
- = RebuildNever
- -- | Always rebuild this module
- | RebuildAlways deriving (Show, Eq, Ord)
-
--- |
--- Compiles in "make" mode, compiling each module separately to a js files and an externs file
---
--- 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, MonadReader P.Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => MakeActions m
- -> [(Either RebuildPolicy FilePath, Module)]
- -> m Environment
-make MakeActions{..} ms = do
- (sorted, graph) <- sortModules $ map (importPrim . snd) ms
- mapM_ lint sorted
- toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
- inputTimestamp <- getInputTimestamp moduleName'
- outputTimestamp <- getOutputTimestamp moduleName'
- return $ case (inputTimestamp, outputTimestamp) of
- (Right (Just t1), Just t2) | t1 < t2 -> s
- (Left RebuildNever, Just _) -> s
- _ -> S.insert moduleName' s) S.empty sorted
-
- marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
- (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
- evalSupplyT nextVar $ go initEnvironment desugared
- where
-
- go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
- go env [] = return env
- go env ((False, m) : ms') = do
- (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
- go env' ms'
- go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
- lift $ progress $ "Compiling " ++ runModuleName moduleName'
- (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
- regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
- let mod' = Module coms moduleName' regrouped exps
- corefn = CoreFn.moduleToCoreFn env' mod'
- [renamed] = renameInModules [corefn]
- exts = moduleToPs mod' env'
- nextVar <- fresh
- lift $ codegen renamed env' nextVar exts
- go env' ms'
-
- rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
- rebuildIfNecessary _ _ [] = return []
- rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
- let deps = fromMaybe [] $ moduleName' `M.lookup` graph
- toRebuild' = toRebuild `S.union` S.fromList deps
- (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
- rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
- (path, externs) <- readExterns moduleName'
- externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]
- case externsModules of
- [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
- _ -> throwError . errorMessage . InvalidExternsFile $ path
- where
- alterErrors = flip catchError $ \(MultipleErrors errs) ->
- throwError . MultipleErrors $ flip map errs $ \e -> case e of
- SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
- _ -> e
-
-reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
-reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
- where
- combine :: (Ord a) => [(a, b)] -> M.Map a [b]
- combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
-
--- |
--- Add an import declaration for a module if it does not already explicitly import it.
---
-addDefaultImport :: ModuleName -> Module -> Module
-addDefaultImport toImport m@(Module coms mn decls exps) =
- if isExistingImport `any` decls || mn == toImport then m
- else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
- where
- isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
- isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
- isExistingImport _ = False
-
-importPrim :: Module -> Module
-importPrim = addDefaultImport (ModuleName [ProperName C.prim])
-
version :: Version
version = Paths.version
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index e6eaec7..f264c23 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -69,7 +69,7 @@ data Binder
-- |
-- A binder with source position information
--
- | PositionedBinder SourceSpan [Comment] Binder deriving (Show, D.Data, D.Typeable)
+ | PositionedBinder SourceSpan [Comment] Binder deriving (Show, Eq, D.Data, D.Typeable)
-- |
-- Collect all names introduced in binders in an expression
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
new file mode 100644
index 0000000..87606f7
--- /dev/null
+++ b/src/Language/PureScript/Bundle.hs
@@ -0,0 +1,540 @@
+-----------------------------------------------------------------------------
+--
+-- Module : psc-bundle
+-- Copyright : (c) Phil Freeman 2015
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- | Bundles compiled PureScript modules for the browser.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Bundle javascript for use in the browser.
+--
+-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
+-- performs dead code elimination, filters empty modules,
+-- and generates the final Javascript bundle.
+module Language.PureScript.Bundle (
+ bundle
+ , ModuleIdentifier(..)
+ , moduleName
+ , ModuleType(..)
+ , ErrorMessage(..)
+ , printErrorMessage
+) where
+
+import Data.List (nub)
+import Data.Maybe (mapMaybe, catMaybes)
+import Data.Generics (everything, everywhere, mkQ, mkT)
+import Data.Graph
+import Data.Version (showVersion)
+
+import qualified Data.Set as S
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Error.Class
+import Language.JavaScript.Parser
+
+import qualified Paths_purescript as Paths
+
+-- | The type of error messages. We separate generation and rendering of errors using a data
+-- type, in case we need to match on error types later.
+data ErrorMessage
+ = UnsupportedModulePath String
+ | InvalidTopLevel
+ | UnableToParseModule
+ | UnsupportedExport
+ | ErrorInFile FilePath ErrorMessage
+ deriving Show
+
+-- | Modules are either "regular modules" (i.e. those generated by psc-make) or foreign modules.
+data ModuleType
+ = Regular
+ | Foreign
+ deriving (Show, Eq, Ord)
+
+-- | A module is identified by its module name and its type.
+data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
+
+moduleName :: ModuleIdentifier -> String
+moduleName (ModuleIdentifier name _) = name
+
+-- | A piece of code is identified by its module and its name. These keys are used to label vertices
+-- in the dependency graph.
+type Key = (ModuleIdentifier, String)
+
+-- | An export is either a "regular export", which exports a name from the regular module we are in,
+-- or a reexport of a declaration in the corresponding foreign module.
+--
+-- Regular exports are labelled, since they might re-export an operator with another name.
+data ExportType
+ = RegularExport String
+ | ForeignReexport
+ deriving (Show, Eq, Ord)
+
+-- | There are four types of module element we are interested in:
+--
+-- 1) Require statements
+-- 2) Member declarations
+-- 3) Export lists
+-- 4) Everything else
+--
+-- Each is labelled with the original AST node which generated it, so that we can dump it back
+-- into the output during codegen.
+data ModuleElement
+ = Require JSNode String ModuleIdentifier
+ | Member JSNode Bool String [JSNode] [Key]
+ | ExportsList [(ExportType, String, JSNode, [Key])]
+ | Other JSNode
+ deriving Show
+
+-- | A module is just a list of elements of the types listed above.
+data Module = Module ModuleIdentifier [ModuleElement] deriving Show
+
+-- | Prepare an error message for consumption by humans.
+printErrorMessage :: ErrorMessage -> [String]
+printErrorMessage (UnsupportedModulePath s) =
+ [ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
+ , "The following file names are supported:"
+ , " 1) index.js (psc-make native modules)"
+ , " 2) foreign.js (psc-make foreign modules)"
+ ]
+printErrorMessage InvalidTopLevel =
+ [ "Expected a list of source elements at the top level." ]
+printErrorMessage UnableToParseModule =
+ [ "The module could not be parsed." ]
+printErrorMessage UnsupportedExport =
+ [ "An export was unsupported. Exports can be defined in one of two ways: "
+ , " 1) exports.name = ..."
+ , " 2) exports = { ... }"
+ ]
+printErrorMessage (ErrorInFile filename e) =
+ ("Error in file " ++ show filename ++ ":")
+ : ""
+ : map (" " ++) (printErrorMessage e)
+
+-- | Unpack the node inside a JSNode. This is useful when pattern matching.
+node :: JSNode -> Node
+node (NN n) = n
+node (NT n _ _) = n
+
+-- | Calculate the ModuleIdentifier which a require(...) statement imports.
+checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
+checkImportPath "./foreign" m _ =
+ Just (ModuleIdentifier (moduleName m) Foreign)
+checkImportPath name _ names
+ | name `S.member` names = Just (ModuleIdentifier name Regular)
+checkImportPath _ _ _ = Nothing
+
+-- | Compute the dependencies of all elements in a module, and add them to the tree.
+--
+-- Members and exports can have dependencies. A dependency is of one of the following forms:
+--
+-- 1) module.name or member["name"]
+--
+-- where module was imported using
+--
+-- var module = require("Module.Name");
+--
+-- 2) name
+--
+-- where name is the name of a member defined in the current module.
+withDeps :: Module -> Module
+withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
+ where
+ -- | Collects all modules which are imported, so that we can identify dependencies of the first type.
+ imports :: [(String, ModuleIdentifier)]
+ imports = mapMaybe toImport es
+ where
+ toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
+ toImport (Require _ nm mid) = Just (nm, mid)
+ toImport _ = Nothing
+
+ -- | Collects all member names in scope, so that we can identify dependencies of the second type.
+ boundNames :: [String]
+ boundNames = mapMaybe toBoundName es
+ where
+ toBoundName :: ModuleElement -> Maybe String
+ toBoundName (Member _ _ nm _ _) = Just nm
+ toBoundName _ = Nothing
+
+ -- | Calculate dependencies and add them to the current element.
+ expandDeps :: ModuleElement -> ModuleElement
+ expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))
+ expandDeps (ExportsList exps) = ExportsList (map expand exps)
+ where
+ expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
+ expandDeps other = other
+
+ dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]
+ dependencies m = everything (++) (mkQ [] toReference)
+ where
+ toReference :: Node -> [(ModuleIdentifier, String)]
+ toReference (JSMemberDot [ mn ] _ nm)
+ | JSIdentifier mn' <- node mn
+ , JSIdentifier nm' <- node nm
+ , Just mid <- lookup mn' imports
+ = [(mid, nm')]
+ toReference (JSMemberSquare [ mn ] _ nm _)
+ | JSIdentifier mn' <- node mn
+ , JSExpression [ s ] <- node nm
+ , JSStringLiteral _ nm' <- node s
+ , Just mid <- lookup mn' imports
+ = [(mid, nm')]
+ toReference (JSIdentifier nm)
+ | nm `elem` boundNames
+ = [(m, nm)]
+ toReference _ = []
+
+-- | Attempt to create a Module from a Javascript AST.
+--
+-- 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) => S.Set String -> ModuleIdentifier -> JSNode -> m Module
+toModule mids mid top
+ | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns
+ | otherwise = throwError InvalidTopLevel
+ where
+ toModuleElement :: JSNode -> m ModuleElement
+ toModuleElement n
+ | JSVariables var [ varIntro ] _ <- node n
+ , JSLiteral "var" <- node var
+ , JSVarDecl impN [ eq, req, impP ] <- node varIntro
+ , JSIdentifier importName <- node impN
+ , JSLiteral "=" <- node eq
+ , JSIdentifier "require" <- node req
+ , JSArguments _ [ impS ] _ <- node impP
+ , JSStringLiteral _ importPath <- node impS
+ , Just importPath' <- checkImportPath importPath mid mids
+ = pure (Require n importName importPath')
+ toModuleElement n
+ | JSVariables var [ varIntro ] _ <- node n
+ , JSLiteral "var" <- node var
+ , JSVarDecl declN (eq : decl) <- node varIntro
+ , JSIdentifier name <- node declN
+ , JSLiteral "=" <- node eq
+ = pure (Member n False name decl [])
+ toModuleElement n
+ | JSExpression (e : op : decl) <- node n
+ , Just name <- accessor (node e)
+ , JSOperator eq <- node op
+ , JSLiteral "=" <- node eq
+ = pure (Member n True name decl [])
+ where
+ accessor :: Node -> Maybe String
+ accessor (JSMemberDot [ exports ] _ nm)
+ | JSIdentifier "exports" <- node exports
+ , JSIdentifier name <- node nm
+ = Just name
+ accessor (JSMemberSquare [ exports ] _ nm _)
+ | JSIdentifier "exports" <- node exports
+ , JSExpression [e] <- node nm
+ , JSStringLiteral _ name <- node e
+ = Just name
+ accessor _ = Nothing
+ toModuleElement n
+ | JSExpression (mnExp : op : obj: _) <- node n
+ , JSMemberDot [ mn ] _ e <- node mnExp
+ , JSIdentifier "module" <- node mn
+ , JSIdentifier "exports" <- node e
+ , JSOperator eq <- node op
+ , JSLiteral "=" <- node eq
+ , JSObjectLiteral _ props _ <- node obj
+ = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props))
+ where
+ toExport :: Node -> m (ExportType, String, JSNode, [Key])
+ toExport (JSPropertyNameandValue name _ [val] ) =
+ (,,val,[]) <$> exportType (node val)
+ <*> extractLabel (node name)
+ toExport _ = throwError UnsupportedExport
+
+ exportType :: Node -> m ExportType
+ exportType (JSMemberDot [f] _ _)
+ | JSIdentifier "$foreign" <- node f
+ = pure ForeignReexport
+ exportType (JSMemberSquare [f] _ _ _)
+ | JSIdentifier "$foreign" <- node f
+ = pure ForeignReexport
+ exportType (JSIdentifier s) = pure (RegularExport s)
+ exportType _ = throwError UnsupportedExport
+
+ extractLabel :: Node -> m String
+ extractLabel (JSStringLiteral _ nm) = pure nm
+ extractLabel (JSIdentifier nm) = pure nm
+ extractLabel _ = throwError UnsupportedExport
+
+ isSeparator :: Node -> Bool
+ isSeparator (JSLiteral ",") = True
+ isSeparator _ = False
+ toModuleElement other = pure (Other other)
+
+-- | Eliminate unused code based on the specified entry point set.
+compile :: [Module] -> [ModuleIdentifier] -> [Module]
+compile modules [] = modules
+compile modules entryPoints = filteredModules
+ where
+ (graph, _, vertexFor) = graphFromEdges verts
+
+ -- | The vertex set
+ verts :: [(ModuleElement, Key, [Key])]
+ verts = do
+ Module mid els <- modules
+ concatMap (toVertices mid) els
+ where
+ -- | Create a set of vertices for a module element.
+ --
+ -- Some special cases worth commenting on:
+ --
+ -- 1) Regular exports which simply export their own name do not count as dependencies.
+ -- Regular exports which rename and reexport an operator do count, however.
+ --
+ -- 2) Require statements don't contribute towards dependencies, since they effectively get
+ -- inlined wherever they are used inside other module elements.
+ toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]
+ toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)]
+ toVertices p m@(ExportsList exps) = mapMaybe toVertex exps
+ where
+ toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks)
+ toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks)
+ toVertex _ = Nothing
+ toVertices _ _ = []
+
+ -- | The set of vertices whose connected components we are interested in keeping.
+ entryPointVertices :: [Vertex]
+ entryPointVertices = catMaybes $ do
+ (_, k@(mid, _), _) <- verts
+ guard $ mid `elem` entryPoints
+ return (vertexFor k)
+
+ -- | The set of vertices reachable from an entry point
+ reachableSet :: S.Set Vertex
+ reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
+
+ filteredModules :: [Module]
+ filteredModules = map filterUsed modules
+ where
+ filterUsed :: Module -> Module
+ filterUsed (Module mid ds) = Module mid (map filterExports (go ds))
+ where
+ go :: [ModuleElement] -> [ModuleElement]
+ go [] = []
+ go (d : Other semi : rest)
+ | JSLiteral ";" <- node semi
+ , not (isDeclUsed d)
+ = go rest
+ go (d : rest)
+ | not (isDeclUsed d) = go rest
+ | otherwise = d : go rest
+
+ -- | Filter out the exports for members which aren't used.
+ filterExports :: ModuleElement -> ModuleElement
+ filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
+ filterExports me = me
+
+ isDeclUsed :: ModuleElement -> Bool
+ isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
+ isDeclUsed _ = True
+
+ isKeyUsed :: Key -> Bool
+ isKeyUsed k
+ | Just me <- vertexFor k = me `S.member` reachableSet
+ | otherwise = False
+
+-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
+-- defined in the right order.
+sortModules :: [Module] -> [Module]
+sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
+ where
+ (graph, nodeFor, _) = graphFromEdges $ do
+ m@(Module mid els) <- modules
+ return (m, mid, mapMaybe getKey els)
+
+ getKey :: ModuleElement -> Maybe ModuleIdentifier
+ getKey (Require _ _ mi) = Just mi
+ getKey _ = Nothing
+
+-- | A module is empty if it contains no exported members (in other words,
+-- if the only things left after dead code elimination are module imports and
+-- "other" foreign code).
+--
+-- If a module is empty, we don't want to generate code for it.
+isModuleEmpty :: Module -> Bool
+isModuleEmpty (Module _ els) = all isElementEmpty els
+ where
+ isElementEmpty :: ModuleElement -> Bool
+ isElementEmpty (ExportsList exps) = null exps
+ isElementEmpty (Require _ _ _) = True
+ isElementEmpty (Other _) = True
+ isElementEmpty _ = False
+
+-- | Generate code for a set of modules, including a call to main().
+--
+-- Modules get defined on the global PS object, as follows:
+--
+-- var PS = { };
+-- (function(exports) {
+-- ...
+-- })(PS["Module.Name"] = PS["Module.Name"] || {});
+--
+-- In particular, a module and its foreign imports share the same namespace inside PS.
+-- This saves us from having to generate unique names for a module and its foreign imports,
+-- and is safe since a module shares a namespace with its foreign imports in PureScript as well
+-- (so there is no way to have overlaps in code generated by psc-make).
+codeGen :: Maybe String -- ^ main module
+ -> String -- ^ namespace
+ -> [Module] -- ^ input modules
+ -> String
+codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))
+ where
+ moduleToJS :: Module -> [JSNode]
+ moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
+ where
+ declToJS :: ModuleElement -> [JSNode]
+ declToJS (Member n _ _ _ _) = [n]
+ declToJS (Other n) = [n]
+ declToJS (Require _ nm req) =
+ [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
+ [ NN (JSVarDecl (sp (JSIdentifier nm))
+ [ sp (JSLiteral "=")
+ , moduleReference sp (moduleName req)
+ ])
+ ]
+ (nt (JSLiteral ";"))) ]
+ declToJS (ExportsList exps) = map toExport exps
+
+ where
+ toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
+ toExport (_, nm, val, _) =
+ NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
+ (nt (JSLiteral "["))
+ (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
+ (nt (JSLiteral "]")))
+ , NN (JSOperator (sp (JSLiteral "=")))
+ , reindent val
+ , nt (JSLiteral ";")
+ ])
+
+ reindent :: JSNode -> JSNode
+ reindent (NT n _ _) = sp n
+ reindent nn = nn
+
+ indent :: [JSNode] -> [JSNode]
+ indent = everywhere (mkT squash)
+ where
+ squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
+ squash nn = nn
+
+ splat (CommentA pos s) = CommentA (keepCol pos) s
+ splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
+ splat ann = ann
+
+ keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
+
+ prelude :: [JSNode]
+ prelude =
+ [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
+ , WhiteSpace tokenPosnEmpty "\n"
+ ])
+ [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
+ [ sp (JSLiteral "=")
+ , NN (JSObjectLiteral (sp (JSLiteral "{"))
+ []
+ (sp (JSLiteral "}")))
+ ])
+ ]
+ (nt (JSLiteral ";")))
+ , lf
+ ]
+
+ moduleReference :: (Node -> JSNode) -> String -> JSNode
+ moduleReference f mn =
+ NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
+ (nt (JSLiteral "["))
+ (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
+ (nt (JSLiteral "]")))
+
+ wrap :: String -> [JSNode] -> [JSNode]
+ wrap mn ds =
+ [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))
+ (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))
+ []
+ (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))
+ (NN (JSBlock [sp (JSLiteral "{")]
+ (lf : ds)
+ [nl (JSLiteral "}")])))]))
+ (nt (JSLiteral ")")))
+ , NN (JSArguments (nt (JSLiteral "("))
+ [ NN (JSExpression [ moduleReference nt mn
+ , NN (JSOperator (sp (JSLiteral "=")))
+ , NN (JSExpressionBinary "||"
+ [ moduleReference sp mn ]
+ (sp (JSLiteral "||"))
+ [ emptyObj ])
+ ])
+ ]
+ (nt (JSLiteral ")")))
+ ])
+ , nt (JSLiteral ";")
+ , lf
+ ]
+ where
+ emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
+
+ runMain :: String -> [JSNode]
+ runMain mn =
+ [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]
+ (nt (JSLiteral "["))
+ (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
+ (nt (JSLiteral "]")))
+ ]
+ (nt (JSLiteral "."))
+ (nt (JSIdentifier "main")))
+ , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))
+ ])
+ , nt (JSLiteral ";")
+ ]
+
+ nt :: Node -> JSNode
+ nt n = NT n tokenPosnEmpty []
+
+ lf :: JSNode
+ lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
+
+ sp :: Node -> JSNode
+ sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
+
+ nl :: Node -> JSNode
+ nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
+
+-- | The bundling function.
+-- This function performs dead code elimination, filters empty modules
+-- and generates and prints the final Javascript bundle.
+bundle :: forall m. (Applicative m, MonadError ErrorMessage m)
+ => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc-make@.
+ -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
+ -> Maybe String -- ^ An optional main module.
+ -> String -- ^ The namespace (e.g. PS).
+ -> m String
+bundle inputStrs entryPoints mainModule namespace = do
+ input <- forM inputStrs $ \(ident, js) -> do
+ ast <- either (const $ throwError UnableToParseModule) pure $ parse js (moduleName ident)
+ return (ident, ast)
+
+ let mids = S.fromList (map (moduleName . fst) input)
+
+ modules <- mapM (fmap withDeps . uncurry (toModule mids)) input
+
+ let compiled = compile modules entryPoints
+ sorted = sortModules (filter (not . isModuleEmpty) compiled)
+
+ return (codeGen mainModule namespace sorted)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 72548f5..83b7228 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -23,6 +23,7 @@ import Data.Data
import Data.Traversable (traverse)
import Language.PureScript.Comments
+import Language.PureScript.Traversals
-- |
-- Built-in unary operators
@@ -294,7 +295,7 @@ everywhereOnJSTopDownM f = f >=> go
go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2
go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js
go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2
- go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (traverse f') js
+ go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (sndM f') js
go (JSAccessor prop j) = JSAccessor prop <$> f' j
go (JSFunction name args j) = JSFunction name args <$> f' j
go (JSApp j js) = JSApp <$> f' j <*> traverse f' js
diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs
index 9ad10d2..300adb2 100644
--- a/src/Language/PureScript/Docs/ParseAndDesugar.hs
+++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs
@@ -53,20 +53,41 @@ parseAndDesugar inputFiles depsFiles callback = do
depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
runExceptT $ do
- let eParsed = P.parseModulesFromFiles fileInfoToString (inputFiles' ++ depsFiles')
- ms <- throwLeft ParseError eParsed
+ ms <- parseFiles (inputFiles' ++ depsFiles')
+ ms' <- sortModules (map snd ms)
+ (bs, ms'') <- desugarWithBookmarks ms ms'
+ liftIO $ callback bs ms''
+
+parseFiles ::
+ [(FileInfo, FilePath)]
+ -> ExceptT ParseDesugarError IO [(FileInfo, P.Module)]
+parseFiles =
+ throwLeft ParseError . P.parseModulesFromFiles fileInfoToString
+
+sortModules ::
+ [P.Module]
+ -> ExceptT ParseDesugarError IO [P.Module]
+sortModules =
+ fmap fst . throwLeft SortModulesError . sortModules' . map importPrim
+ where
+ sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)
+ sortModules' = P.sortModules
- let depsModules = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) ms)
- let eSorted = P.sortModules . map (importPrim . snd) $ ms
- (ms', _) <- throwLeft SortModulesError eSorted
+desugarWithBookmarks ::
+ [(FileInfo, P.Module)]
+ -> [P.Module]
+ -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module])
+desugarWithBookmarks msInfo msSorted = do
+ msDesugared <- throwLeft DesugarError (desugar msSorted)
- modules <- throwLeft DesugarError (desugar ms')
- let modules' = map (addPackage depsModules) modules
- bookmarks = concatMap collectBookmarks modules'
- liftIO (callback bookmarks (takeLocals modules'))
+ let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
+ msPackages = map (addPackage msDeps) msDesugared
+ bookmarks = concatMap collectBookmarks msPackages
- where
- throwLeft f = either (throwError . f) return
+ return (bookmarks, takeLocals msPackages)
+
+throwLeft :: (MonadError e m) => (l -> e) -> Either l r -> m r
+throwLeft f = either (throwError . f) return
-- | Specifies whether a PureScript source file is considered as:
--
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index c4afecb..fccea8a 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -10,7 +10,8 @@ module Language.PureScript.Docs.Types
where
import Control.Arrow (first, (***))
-import Control.Applicative ((<$>), (<*>))
+import Control.Applicative ((<$>), (<*>), pure)
+import Control.Monad (when)
import Data.Functor ((<$))
import Data.Maybe (mapMaybe)
import Data.Version
@@ -22,7 +23,7 @@ import Data.Text (Text)
import Data.ByteString.Lazy (ByteString)
import qualified Data.Text as T
-import Web.Bower.PackageMeta hiding (Version)
+import Web.Bower.PackageMeta hiding (Version, displayError)
import qualified Language.PureScript as P
@@ -43,6 +44,9 @@ data Package a = Package
, pkgResolvedDependencies :: [(PackageName, Version)]
, pkgGithub :: (GithubUser, GithubRepo)
, pkgUploader :: a
+ , pkgCompilerVersion :: Version
+ -- ^ The version of the PureScript compiler which was used to generate
+ -- this data. We store this in order to reject packages which are too old.
}
deriving (Show, Eq, Ord)
@@ -62,6 +66,7 @@ verifyPackage verifiedUser Package{..} =
pkgResolvedDependencies
pkgGithub
verifiedUser
+ pkgCompilerVersion
packageName :: Package a -> PackageName
packageName = bowerName . pkgMeta
@@ -170,7 +175,10 @@ newtype GithubRepo
deriving (Show, Eq, Ord)
data PackageError
- = ErrorInPackageMeta BowerError
+ = CompilerTooOld Version Version
+ -- ^ Minimum allowable version for generating data with the current
+ -- parser, and actual version used.
+ | ErrorInPackageMeta BowerError
| InvalidVersion
| InvalidDeclarationType String
| InvalidChildDeclarationType String
@@ -204,14 +212,21 @@ ignorePackage (FromDep _ x) = x
----------------------
-- Parsing
-parseUploadedPackage :: ByteString -> Either (ParseError PackageError) UploadedPackage
-parseUploadedPackage = parse asUploadedPackage
+parseUploadedPackage :: Version -> ByteString -> Either (ParseError PackageError) UploadedPackage
+parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion
-parseVerifiedPackage :: ByteString -> Either (ParseError PackageError) VerifiedPackage
-parseVerifiedPackage = parse asVerifiedPackage
+parseVerifiedPackage :: Version -> ByteString -> Either (ParseError PackageError) VerifiedPackage
+parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion
+
+asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)
+asPackage minimumVersion uploader = do
+ -- If the compilerVersion key is missing, we can be sure that it was produced
+ -- with 0.7.0.0, since that is the only released version that included the
+ -- psc-publish tool before this key was added.
+ compilerVersion <- keyOrDefault "compilerVersion" (Version [0,7,0,0] []) asVersion
+ when (compilerVersion < minimumVersion)
+ (throwCustomError $ CompilerTooOld minimumVersion compilerVersion)
-asPackage :: (forall e. Parse e a) -> Parse PackageError (Package a)
-asPackage uploader =
Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
<*> key "version" asVersion
<*> key "versionTag" asString
@@ -220,9 +235,10 @@ asPackage uploader =
<*> key "resolvedDependencies" asResolvedDependencies
<*> key "github" asGithub
<*> key "uploader" uploader
+ <*> pure compilerVersion
-asUploadedPackage :: Parse PackageError UploadedPackage
-asUploadedPackage = asPackage asNotYetKnown
+asUploadedPackage :: Version -> Parse PackageError UploadedPackage
+asUploadedPackage minVersion = asPackage minVersion asNotYetKnown
asNotYetKnown :: Parse e NotYetKnown
asNotYetKnown = NotYetKnown <$ asNull
@@ -230,8 +246,35 @@ asNotYetKnown = NotYetKnown <$ asNull
instance A.FromJSON NotYetKnown where
parseJSON = toAesonParser' asNotYetKnown
-asVerifiedPackage :: Parse PackageError VerifiedPackage
-asVerifiedPackage = asPackage asGithubUser
+asVerifiedPackage :: Version -> Parse PackageError VerifiedPackage
+asVerifiedPackage minVersion = asPackage minVersion asGithubUser
+
+displayPackageError :: PackageError -> Text
+displayPackageError e = case e of
+ CompilerTooOld minV usedV ->
+ "Expecting data produced by at least version " <> T.pack (showVersion minV)
+ <> " of the compiler, but it appears that " <> T.pack (showVersion usedV)
+ <> " was used."
+ ErrorInPackageMeta err ->
+ "Error in package metadata: " <> showBowerError err
+ InvalidVersion ->
+ "Invalid version"
+ InvalidDeclarationType str ->
+ "Invalid declaration type: \"" <> T.pack str <> "\""
+ InvalidChildDeclarationType str ->
+ "Invalid child declaration type: \"" <> T.pack str <> "\""
+ InvalidFixity ->
+ "Invalid fixity"
+ InvalidKind str ->
+ "Invalid kind: \"" <> T.pack str <> "\""
+ InvalidDataDeclType str ->
+ "Invalid data declaration type: \"" <> T.pack str <> "\""
+ where
+ (<>) = T.append
+
+instance A.FromJSON a => A.FromJSON (Package a) where
+ parseJSON = toAesonParser displayPackageError
+ (asPackage (Version [0,0,0,0] []) fromAesonParser)
asGithubUser :: Parse e GithubUser
asGithubUser = GithubUser <$> asString
@@ -239,11 +282,6 @@ asGithubUser = GithubUser <$> asString
instance A.FromJSON GithubUser where
parseJSON = toAesonParser' asGithubUser
-instance A.FromJSON a => A.FromJSON (Package a) where
- -- TODO: actual error display
- parseJSON = toAesonParser (T.pack . show)
- (asPackage fromAesonParser)
-
asVersion :: Parse PackageError Version
asVersion = withString (maybe (Left InvalidVersion) Right . parseVersion')
@@ -396,6 +434,7 @@ instance A.ToJSON a => A.ToJSON (Package a) where
pkgResolvedDependencies
, "github" .= pkgGithub
, "uploader" .= pkgUploader
+ , "compilerVersion" .= showVersion P.version
]
instance A.ToJSON NotYetKnown where
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 5d61105..869384d 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -19,7 +19,7 @@
module Language.PureScript.Errors where
import Data.Either (lefts, rights)
-import Data.List (intercalate)
+import Data.List (intercalate, transpose)
import Data.Function (on)
import Data.Monoid
import Data.Foldable (fold, foldMap)
@@ -120,6 +120,7 @@ data SimpleErrorMessage
| TransitiveExportError DeclarationRef [DeclarationRef]
| ShadowedName Ident
| WildcardInferredType Type
+ | NotExhaustivePattern [[Binder]]
| ClassOperator ProperName Ident
deriving (Show)
@@ -229,6 +230,7 @@ errorCode em = case unwrapErrorMessage em of
(TransitiveExportError _ _) -> "TransitiveExportError"
(ShadowedName _) -> "ShadowedName"
(WildcardInferredType _) -> "WildcardInferredType"
+ (NotExhaustivePattern _) -> "NotExhaustivePattern"
(ClassOperator _ _) -> "ClassOperator"
-- |
@@ -272,6 +274,9 @@ data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
-- | A map from rigid type variable name/unknown variable pairs to new variables.
type UnknownMap = M.Map (LabelType, Unknown) Unknown
+-- | How critical the issue is
+data Level = Error | Warning deriving Show
+
-- |
-- Extract nested error messages from wrapper errors
--
@@ -344,8 +349,8 @@ onTypesInErrorMessageM f = g
-- |
-- Pretty print a single error, simplifying if necessary
--
-prettyPrintSingleError :: Bool -> ErrorMessage -> State UnknownMap Box.Box
-prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
+prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
+prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
where
-- |
-- Pretty print an ErrorMessage
@@ -373,7 +378,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
, indent . line $ path
]
goSimple (ErrorParsingExterns err) =
- paras [ line "Error parsing externs files: "
+ paras [ lineWithLevel "parsing externs files: "
, indent . line . show $ err
]
goSimple (ErrorParsingFFIModule path) =
@@ -556,56 +561,61 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
]
goSimple (WildcardInferredType ty) =
line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
+ goSimple (NotExhaustivePattern bs) =
+ paras $ [ line "Pattern could not be determined to cover all cases."
+ , line $ "The definition has the following uncovered cases:\n"
+ , indent $ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
+ ]
go (NotYetDefined names err) =
paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
, indent $ go err
]
go (ErrorUnifyingTypes t1 t2 err) =
- paras [ line "Error unifying type "
+ paras [ lineWithLevel "unifying type "
, indent $ line $ prettyPrintType t1
, line "with type"
, indent $ line $ prettyPrintType t2
, go err
]
go (ErrorInExpression expr err) =
- paras [ line "Error in expression:"
+ paras [ lineWithLevel "in expression:"
, indent $ line $ prettyPrintValue expr
, go err
]
go (ErrorInModule mn err) =
- paras [ line $ "Error in module " ++ show mn ++ ":"
+ paras [ lineWithLevel $ "in module " ++ show mn ++ ":"
, go err
]
go (ErrorInSubsumption t1 t2 err) =
- paras [ line "Error checking that type "
+ paras [ lineWithLevel "checking that type "
, indent $ line $ prettyPrintType t1
, line "subsumes type"
, indent $ line $ prettyPrintType t2
, go err
]
go (ErrorInInstance name ts err) =
- paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
+ paras [ lineWithLevel $ "in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
, go err
]
go (ErrorCheckingKind ty err) =
- paras [ line "Error checking kind of type "
+ paras [ lineWithLevel "checking kind of type "
, indent $ line $ prettyPrintType ty
, go err
]
go (ErrorInferringType expr err) =
- paras [ line "Error inferring type of value "
+ paras [ lineWithLevel "inferring type of value "
, indent $ line $ prettyPrintValue expr
, go err
]
go (ErrorCheckingType expr ty err) =
- paras [ line "Error checking that value "
+ paras [ lineWithLevel "checking that value "
, indent $ line $ prettyPrintValue expr
, line "has type"
, indent $ line $ prettyPrintType ty
, go err
]
go (ErrorInApplication f t a err) =
- paras [ line "Error applying function"
+ paras [ lineWithLevel "applying function"
, indent $ line $ prettyPrintValue f
, line "of type"
, indent $ line $ prettyPrintType t
@@ -614,35 +624,35 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
, go err
]
go (ErrorInDataConstructor nm err) =
- paras [ line $ "Error in data constructor " ++ show nm ++ ":"
+ paras [ lineWithLevel $ "in data constructor " ++ show nm ++ ":"
, go err
]
go (ErrorInTypeConstructor nm err) =
- paras [ line $ "Error in type constructor " ++ show nm ++ ":"
+ paras [ lineWithLevel $ "in type constructor " ++ show nm ++ ":"
, go err
]
go (ErrorInBindingGroup nms err) =
- paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
+ paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map show nms) ++ ":"
, go err
]
go (ErrorInDataBindingGroup err) =
- paras [ line $ "Error in data binding group:"
+ paras [ lineWithLevel $ "in data binding group:"
, go err
]
go (ErrorInTypeSynonym name err) =
- paras [ line $ "Error in type synonym " ++ show name ++ ":"
+ paras [ lineWithLevel $ "in type synonym " ++ show name ++ ":"
, go err
]
go (ErrorInValueDeclaration n err) =
- paras [ line $ "Error in value declaration " ++ show n ++ ":"
+ paras [ lineWithLevel $ "in value declaration " ++ show n ++ ":"
, go err
]
go (ErrorInForeignImport nm err) =
- paras [ line $ "Error in foreign import " ++ show nm ++ ":"
+ paras [ lineWithLevel $ "in foreign import " ++ show nm ++ ":"
, go err
]
go (PositionedError srcSpan err) =
- paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
+ paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
, indent $ go err
]
go (SimpleErrorWrapper sem) = goSimple sem
@@ -650,6 +660,9 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
line :: String -> Box.Box
line = Box.text
+ lineWithLevel :: String -> Box.Box
+ lineWithLevel text = line $ show level ++ " " ++ text
+
suggestions :: ErrorMessage -> [Box.Box]
suggestions = suggestions' . unwrapErrorMessage
where
@@ -727,23 +740,23 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
-- Pretty print multiple errors
--
prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
-prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
+prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error:" "Multiple errors:" full
-- |
-- Pretty print multiple warnings
--
prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
-prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
+prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning:" "Multiple warnings:" full
-prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State UnknownMap String
-prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = do
- result <- prettyPrintSingleError full e
+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap String
+prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
+ result <- prettyPrintSingleError full level e
return $ renderBox $
Box.vcat Box.left [ Box.text intro
, result
]
-prettyPrintMultipleErrorsWith _ intro full (MultipleErrors es) = do
- result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full
+prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
+ result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
return $ renderBox $
Box.vcat Box.left [ Box.text intro
, Box.vsep 1 Box.left result
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 5989a5c..6b72b71 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -16,7 +16,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Language.PureScript.Linter (lint) where
+module Language.PureScript.Linter (lint, module L) where
import Data.List (mapAccumL, nub)
import Data.Maybe (mapMaybe)
@@ -30,6 +30,7 @@ import Control.Monad.Writer.Class
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Errors
+import Language.PureScript.Linter.Exhaustive as L
-- | Lint the PureScript AST.
-- |
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
new file mode 100644
index 0000000..f12c3cb
--- /dev/null
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -0,0 +1,275 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Exhaustive
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- | Module for exhaustivity checking over pattern matching definitions
+-- | The algorithm analyses the clauses of a definition one by one from top
+-- | to bottom, where in each step it has the cases already missing (uncovered),
+-- | and it generates the new set of missing cases.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Linter.Exhaustive
+ ( checkExhaustive
+ , checkExhaustiveModule
+ ) where
+
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.List (foldl', sortBy, nub)
+import Data.Function (on)
+
+import Control.Monad (unless)
+import Control.Applicative
+import Control.Monad.Writer.Class
+
+import Language.PureScript.AST.Binders
+import Language.PureScript.AST.Declarations
+import Language.PureScript.Environment
+import Language.PureScript.Names as P
+import Language.PureScript.Kinds
+import Language.PureScript.Types as P
+import Language.PureScript.Errors
+
+import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)
+
+-- |
+-- Qualifies a propername from a given qualified propername and a default module name
+--
+qualifyName :: a -> ModuleName -> Qualified a -> Qualified a
+qualifyName n defmn qn = Qualified (Just mn) n
+ where
+ (mn, _) = qualify defmn qn
+
+-- |
+-- Given an environment and a datatype or newtype name,
+-- this function returns the associated data constructors if it is the case of a datatype
+-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)
+-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])
+--
+getConstructors :: Environment -> ModuleName -> (Qualified ProperName) -> [(ProperName, [Type])]
+getConstructors env defmn n = extractConstructors lnte
+ where
+ qpn :: Qualified ProperName
+ qpn = getConsDataName n
+
+ getConsDataName :: (Qualified ProperName) -> (Qualified ProperName)
+ getConsDataName con = qualifyName nm defmn con
+ where
+ nm = case getConsInfo con of
+ Nothing -> error $ "ProperName " ++ show con ++ " not in the scope of the current environment in getConsDataName."
+ Just (_, pm, _, _) -> pm
+
+ getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident])
+ getConsInfo con = M.lookup con dce
+ where
+ dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
+ dce = dataConstructors env
+
+ lnte :: Maybe (Kind, TypeKind)
+ lnte = M.lookup qpn (types env)
+
+ extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]
+ extractConstructors (Just (_, DataType _ pt)) = pt
+ extractConstructors _ = error "Data name not in the scope of the current environment in extractConstructors"
+
+-- |
+-- Replicates a wildcard binder
+--
+initialize :: Int -> [Binder]
+initialize l = replicate l NullBinder
+
+-- |
+-- Applies a function over two lists of tuples that may lack elements
+--
+genericMerge :: Ord a =>
+ (a -> Maybe b -> Maybe c -> d) ->
+ [(a, b)] ->
+ [(a, c)] ->
+ [d]
+genericMerge _ [] [] = []
+genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs
+genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs
+genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
+ | s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr
+ | s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs'
+ | otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs'
+
+-- |
+-- Find the uncovered set between two binders:
+-- the first binder is the case we are trying to cover the second one is the matching binder
+--
+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> [Binder]
+missingCasesSingle _ _ _ NullBinder = []
+missingCasesSingle _ _ _ (VarBinder _) = []
+missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
+missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl
+missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =
+ concatMap (\cp -> missingCasesSingle env mn cp cb) allPatterns
+ where
+ allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))
+ $ getConstructors env mn con
+missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')
+ | con == con' = map (ConstructorBinder con) (missingCasesMultiple env mn bs bs')
+ | otherwise = [cb]
+missingCasesSingle _ _ NullBinder (ArrayBinder bs)
+ | null bs = []
+ | otherwise = []
+missingCasesSingle env mn NullBinder (ObjectBinder bs) =
+ map (ObjectBinder . zip (map fst bs)) allMisses
+ where
+ allMisses = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)
+missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
+ map (ObjectBinder . zip sortedNames) $ uncurry (missingCasesMultiple env mn) (unzip binders)
+ where
+ sortNames = sortBy (compare `on` fst)
+
+ (sbs, sbs') = (sortNames bs, sortNames bs')
+
+ compB :: a -> Maybe a -> Maybe a -> (a, a)
+ compB e b b' = (fm b, fm b')
+ where
+ fm = fromMaybe e
+
+ compBS :: Eq a => b -> a -> Maybe b -> Maybe b -> (a, (b, b))
+ 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]
+missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)
+ | bl == br = []
+ | otherwise = [BooleanBinder bl]
+missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
+missingCasesSingle _ _ b _ = [b]
+
+-- |
+-- Returns the uncovered set of binders
+-- the first argument is the list of uncovered binders at step i
+-- the second argument is the (i+1)th clause of a pattern matching definition
+--
+-- The idea of the algorithm is as follows:
+-- it processes each binder of the two lists (say, `x` and `y`) one by one
+-- at each step two cases arises:
+-- - there are no missing cases between `x` and `y`: this is very straightforward, it continues with the remaining cases
+-- but keeps the uncovered binder in its position.
+-- - there are missing cases, let us call it the set `U`: on the one hand, we mix each new uncovered case in `U`
+-- with the current tail of uncovered set. On the other hand, it continues with the remaining cases: here we
+-- can use `x` (but it will generate overlapping cases), or `y`, which will generate non-overlapping cases.
+--
+-- As an example, consider:
+--
+-- data N = Z | S N
+-- f Z Z = Z --> {[S _, _], [Z, S _]} which are the right non-overlapping cases (GHC uses this).
+--
+-- if we use `x` instead of `y` (in this case, `y` stands for `Z` and `x` for `_`) we obtain:
+-- f Z Z = Z --> {[S _, _], [_, S _]} you can see that both cases overlaps each other.
+--
+-- Up to now, we've decided to use `x` just because we expect to generate uncovered cases which might be
+-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
+-- (which ought to be available soon), or increase the complexity of the algorithm.
+--
+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> [[Binder]]
+missingCasesMultiple env mn = go
+ where
+ go [] _ = []
+ go (x:xs) (y:ys)
+ | null miss = map (x :) (go xs ys)
+ | otherwise = map (: xs) miss ++ map (x :) (go xs ys)
+ where
+ miss = missingCasesSingle env mn x y
+ go _ _ = error "Argument lengths did not match in missingCasesMultiple."
+
+-- |
+-- Guard handling
+--
+-- We say a guard is exhaustive iff it has an `otherwise` (or `true`) expression.
+-- Example:
+-- f x | x < 0 = 0
+-- | otherwise = 1
+-- is exhaustive, whereas `f x | x < 0` is not
+--
+-- The function below say whether or not a guard has an `otherwise` expression
+-- It is considered that `otherwise` is defined in Prelude
+--
+isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool
+isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
+ where
+ isOtherwise :: Expr -> Bool
+ isOtherwise (TypedValue _ (BooleanLiteral True) _) = True
+ isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True
+ isOtherwise _ = False
+isExhaustiveGuard (Right _) = True
+
+-- |
+-- Returns the uncovered set of case alternatives
+--
+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> [[Binder]]
+missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
+
+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> [[Binder]]
+missingAlternative env mn ca uncovered
+ | isExhaustiveGuard (caseAlternativeResult ca) = missingCases env mn uncovered ca
+ | otherwise = [uncovered]
+
+-- |
+-- Main exhaustivity checking function
+-- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument),
+-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
+-- Then, returns the uncovered set of case alternatives.
+--
+checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> [CaseAlternative] -> m ()
+checkExhaustive env mn cas = makeResult . nub $ foldl' step [initial] cas
+ where
+ step :: [[Binder]] -> CaseAlternative -> [[Binder]]
+ step uncovered ca = concatMap (missingAlternative env mn ca) uncovered
+
+ initial :: [Binder]
+ initial = initialize numArgs
+ where
+ numArgs = length . caseAlternativeBinders . head $ cas
+
+ makeResult :: [[Binder]] -> m ()
+ makeResult bss = unless (null bss) tellWarning
+ where
+ tellWarning = tell . errorMessage $ NotExhaustivePattern bss
+
+-- |
+-- Exhaustivity checking over a list of declarations
+--
+checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
+checkExhaustiveDecls env mn ds =
+ let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
+
+ f' :: Declaration -> m Declaration
+ f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d
+ where
+ convert :: (Ident, NameKind, Expr) -> Declaration
+ convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
+ f' d@(ValueDeclaration name _ _ _) = censor (onErrorMessages (ErrorInValueDeclaration name)) $ f d
+ f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (onErrorMessages (PositionedError pos)) (f' dec)
+ -- Don't generate two warnings for desugared dictionaries.
+ f' d@TypeInstanceDeclaration{} = return d
+ f' d = f d
+
+ in mapM_ f' ds
+ where
+ checkExpr :: Expr -> m Expr
+ checkExpr c@(Case _ cas) = checkExhaustive env mn cas >> return c
+ checkExpr other = return other
+
+-- |
+-- Exhaustivity checking over a single module
+--
+checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
+checkExhaustiveModule env (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
+
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
new file mode 100644
index 0000000..ba35dd7
--- /dev/null
+++ b/src/Language/PureScript/Make.hs
@@ -0,0 +1,314 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Make
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Make
+ (
+ -- * Make API
+ RebuildPolicy(..)
+ , MakeActions(..)
+ , SupplyVar()
+ , Externs()
+ , make
+
+ -- * Implementation of Make API using files on disk
+ , Make(..)
+ , runMake
+ , buildMakeActions
+ ) where
+
+import Control.Applicative
+import Control.Arrow ((&&&))
+import Control.Monad
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Trans.Except
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.Supply
+import Control.Monad.Supply.Class (fresh)
+
+import Data.Function (on)
+import Data.List (sortBy, groupBy)
+import Data.Maybe (fromMaybe)
+import Data.Time.Clock
+import Data.Traversable (traverse)
+import Data.Version (showVersion)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import System.Directory
+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
+import System.FilePath ((</>), takeDirectory)
+import System.IO.Error (tryIOError)
+
+
+import Language.PureScript.AST
+import Language.PureScript.CodeGen.Externs (moduleToPs)
+import Language.PureScript.Environment
+import Language.PureScript.Errors
+import Language.PureScript.Linter
+import Language.PureScript.ModuleDependencies
+import Language.PureScript.Names
+import Language.PureScript.Options
+import Language.PureScript.Parser
+import Language.PureScript.Pretty
+import Language.PureScript.Renamer
+import Language.PureScript.Sugar
+import Language.PureScript.TypeChecker
+import qualified Language.PureScript.Constants as C
+
+import qualified Language.PureScript.CodeGen.JS as J
+import qualified Language.PureScript.CoreFn as CF
+import qualified Paths_purescript as Paths
+
+-- |
+-- Actions that require implementations when running in "make" mode.
+--
+data MakeActions m = MakeActions {
+ -- |
+ -- Get the timestamp for the input file(s) for a module. If there are multiple
+ -- files (.purs and foreign files, for example) the timestamp should be for
+ -- the most recently modified file.
+ --
+ getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
+ -- |
+ -- Get the timestamp for the output files for a module. This should be the
+ -- timestamp for the oldest modified file, or Nothing if any of the required
+ -- output files are missing.
+ --
+ , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
+ -- |
+ -- Read the externs file for a module as a string and also return the actual
+ -- path for the file.
+ , readExterns :: ModuleName -> m (FilePath, String)
+ -- |
+ -- Run the code generator for the module and write any required output files.
+ --
+ , codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> m ()
+ -- |
+ -- Respond to a progress update.
+ --
+ , progress :: String -> m ()
+ }
+
+-- |
+-- Generated code for an externs file.
+--
+type Externs = String
+
+-- |
+-- A value to be used in the Supply monad.
+--
+type SupplyVar = Integer
+
+-- |
+-- Determines when to rebuild a module
+--
+data RebuildPolicy
+ -- | Never rebuild this module
+ = RebuildNever
+ -- | Always rebuild this module
+ | RebuildAlways deriving (Show, Eq, Ord)
+
+-- |
+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
+--
+-- 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, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => MakeActions m
+ -> [(Either RebuildPolicy FilePath, Module)]
+ -> m Environment
+make MakeActions{..} ms = do
+ (sorted, graph) <- sortModules $ map (importPrim . snd) ms
+ mapM_ lint sorted
+ toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
+ inputTimestamp <- getInputTimestamp moduleName'
+ outputTimestamp <- getOutputTimestamp moduleName'
+ return $ case (inputTimestamp, outputTimestamp) of
+ (Right (Just t1), Just t2) | t1 < t2 -> s
+ (Left RebuildNever, Just _) -> s
+ _ -> S.insert moduleName' s) S.empty sorted
+
+ marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
+ (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
+ evalSupplyT nextVar $ go initEnvironment desugared
+ where
+
+ go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
+ go env [] = return env
+ go env ((False, m) : ms') = do
+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
+ go env' ms'
+ go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
+ lift $ progress $ "Compiling " ++ runModuleName moduleName'
+ (checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
+ checkExhaustiveModule env' checked
+ regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
+ let mod' = Module coms moduleName' regrouped exps
+ corefn = CF.moduleToCoreFn env' mod'
+ [renamed] = renameInModules [corefn]
+ exts = moduleToPs mod' env'
+ nextVar <- fresh
+ lift $ codegen renamed env' nextVar exts
+ go env' ms'
+
+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
+ rebuildIfNecessary _ _ [] = return []
+ rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph
+ toRebuild' = toRebuild `S.union` S.fromList deps
+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
+ rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
+ (path, externs) <- readExterns moduleName'
+ externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
+ case externsModules of
+ [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
+ _ -> throwError . errorMessage . InvalidExternsFile $ path
+ where
+ alterErrors = flip catchError $ \(MultipleErrors errs) ->
+ throwError . MultipleErrors $ flip map errs $ \e -> case e of
+ SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
+ _ -> e
+
+reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
+reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
+ where
+ combine :: (Ord a) => [(a, b)] -> M.Map a [b]
+ combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
+
+-- |
+-- Add an import declaration for a module if it does not already explicitly import it.
+--
+addDefaultImport :: ModuleName -> Module -> Module
+addDefaultImport toImport m@(Module coms mn decls exps) =
+ if isExistingImport `any` decls || mn == toImport then m
+ else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
+ where
+ isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
+ isExistingImport _ = False
+
+importPrim :: Module -> Module
+importPrim = addDefaultImport (ModuleName [ProperName C.prim])
+
+-- |
+-- A monad for running make actions
+--
+newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
+
+-- |
+-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
+--
+runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
+
+makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
+makeIO f io = do
+ e <- liftIO $ tryIOError io
+ either (throwError . singleError . f) return e
+
+-- Traverse (Either e) instance (base 4.7)
+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
+traverseEither _ (Left x) = pure (Left x)
+traverseEither f (Right y) = Right <$> f y
+
+-- |
+-- A set of make actions that read and write modules from the given directory.
+--
+buildMakeActions :: FilePath -- ^ the output directory
+ -> M.Map ModuleName (Either RebuildPolicy String) -- ^ a map between module names and paths to the file containing the PureScript module
+ -> M.Map ModuleName (FilePath, ForeignJS) -- ^ a map between module name and the file containing the foreign javascript for the module
+ -> Bool -- ^ Generate a prefix comment?
+ -> MakeActions Make
+buildMakeActions outputDir filePathMap foreigns usePrefix =
+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
+ where
+
+ getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
+ getInputTimestamp mn = do
+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
+ e1 <- traverseEither getTimestamp path
+ fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
+ return $ fmap (max fPath) e1
+
+ getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
+ getOutputTimestamp mn = do
+ let filePath = runModuleName mn
+ jsFile = outputDir </> filePath </> "index.js"
+ externsFile = outputDir </> filePath </> "externs.purs"
+ min <$> getTimestamp jsFile <*> getTimestamp externsFile
+
+ readExterns :: ModuleName -> Make (FilePath, String)
+ readExterns mn = do
+ let path = outputDir </> runModuleName mn </> "externs.purs"
+ (path, ) <$> readTextFile path
+
+ codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> Make ()
+ codegen m _ nextVar exts = do
+ let mn = CF.moduleName m
+ foreignInclude <- case mn `M.lookup` foreigns of
+ Just (path, _)
+ | not $ requiresForeign m -> do
+ tell $ errorMessage $ UnnecessaryFFIModule mn path
+ return Nothing
+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
+ Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
+ | otherwise -> return Nothing
+ pjs <- evalSupplyT nextVar $ prettyPrintJS <$> J.moduleToJs m foreignInclude
+ let filePath = runModuleName mn
+ jsFile = outputDir </> filePath </> "index.js"
+ externsFile = outputDir </> filePath </> "externs.purs"
+ foreignFile = outputDir </> filePath </> "foreign.js"
+ prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
+ js = unlines $ map ("// " ++) prefix ++ [pjs]
+ writeTextFile jsFile js
+ maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
+ writeTextFile externsFile exts
+
+ requiresForeign :: CF.Module a -> Bool
+ requiresForeign = not . null . CF.moduleForeign
+
+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
+ getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
+ exists <- doesFileExist path
+ traverse (const $ getModificationTime path) $ guard exists
+
+ readTextFile :: FilePath -> Make String
+ readTextFile path = do
+ verboseErrorsEnabled <- asks optionsVerboseErrors
+ makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ do
+ when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
+ readFile path
+
+ writeTextFile :: FilePath -> String -> Make ()
+ writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
+ mkdirp path
+ putStrLn $ "Writing " ++ path
+ writeFile path text
+ where
+ mkdirp :: FilePath -> IO ()
+ mkdirp = createDirectoryIfMissing True . takeDirectory
+
+ progress :: String -> Make ()
+ progress = liftIO . putStrLn
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index e3942ab..b4772ef 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -15,7 +15,8 @@
module Language.PureScript.Pretty.Values (
prettyPrintValue,
- prettyPrintBinder
+ prettyPrintBinder,
+ prettyPrintBinderAtom
) where
import Data.Maybe (fromMaybe)
@@ -40,11 +41,7 @@ literals = mkPattern' match
match (CharLiteral c) = return $ show c
match (BooleanLiteral True) = return "true"
match (BooleanLiteral False) = return "false"
- match (ArrayLiteral xs) = concat <$> sequence
- [ return "[ "
- , withIndent $ prettyPrintMany prettyPrintValue' xs
- , return " ]"
- ]
+ match (ArrayLiteral xs) = return $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps
match (ObjectConstructor ps) = prettyPrintObject' ps
match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"
@@ -95,7 +92,7 @@ prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
prettyPrintCaseAlternative (CaseAlternative binders result) =
concat <$> sequence
- [ intercalate ", " <$> forM binders prettyPrintBinder'
+ [ return (unwords (map prettyPrintBinderAtom binders))
, prettyPrintResult result
]
where
@@ -118,7 +115,7 @@ prettyPrintDoNotationElement (DoNotationValue val) =
prettyPrintValue' val
prettyPrintDoNotationElement (DoNotationBind binder val) =
concat <$> sequence
- [ prettyPrintBinder' binder
+ [ return (prettyPrintBinder binder)
, return " <- "
, prettyPrintValue' val
]
@@ -131,13 +128,10 @@ prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintD
prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String
prettyPrintObject' [] = return "{}"
-prettyPrintObject' ps = concat <$> sequence
- [ return "{\n"
- , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
- , return "\n"
- , currentIndent
- , return "}"
- ]
+prettyPrintObject' ps = return $ "{ " ++ intercalate ", " (map prettyPrintObjectProperty ps) ++ "}"
+ where
+ prettyPrintObjectProperty :: (String, Maybe Expr) -> String
+ prettyPrintObjectProperty (key, value) = prettyPrintObjectKey key ++ ": " ++ maybe "_" prettyPrintValue value
ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
ifThenElse = mkPattern match
@@ -190,55 +184,35 @@ prettyPrintValue' = runKleisli $ runPattern matchValue
, [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
]
-prettyPrintBinderAtom :: Pattern PrinterState Binder String
-prettyPrintBinderAtom = mkPattern' match
+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 (VarBinder ident) = show ident
+prettyPrintBinderAtom (ConstructorBinder ctor []) = show ctor
+prettyPrintBinderAtom (ObjectBinder bs) =
+ "{ "
+ ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)
+ ++ " }"
where
- match :: Binder -> StateT PrinterState Maybe String
- match NullBinder = return "_"
- match (StringBinder str) = return $ show str
- match (CharBinder c) = return $ show c
- match (NumberBinder num) = return $ either show show num
- match (BooleanBinder True) = return "true"
- match (BooleanBinder False) = return "false"
- match (VarBinder ident) = return $ show ident
- match (ConstructorBinder ctor args) = concat <$> sequence
- [ return $ show ctor ++ " "
- , unwords <$> forM args match
- ]
- match (ObjectBinder bs) = concat <$> sequence
- [ return "{\n"
- , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
- , currentIndent
- , return "}"
- ]
- match (ArrayBinder bs) = concat <$> sequence
- [ return "["
- , unwords <$> mapM prettyPrintBinder' bs
- , return "]"
- ]
- match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
- match (PositionedBinder _ _ binder) = prettyPrintBinder' binder
+ prettyPrintObjectPropertyBinder :: (String, Binder) -> String
+ prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder
+prettyPrintBinderAtom (ArrayBinder bs) =
+ "[ "
+ ++ intercalate ", " (map prettyPrintBinder bs)
+ ++ " ]"
+prettyPrintBinderAtom (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
+prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
+prettyPrintBinderAtom b = parens (prettyPrintBinder b)
-- |
-- Generate a pretty-printed string representing a Binder
--
prettyPrintBinder :: Binder -> String
-prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
-
-prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
-prettyPrintBinder' = runKleisli $ runPattern matchBinder
- where
- matchBinder :: Pattern PrinterState Binder String
- matchBinder = prettyPrintBinderAtom <+> fmap parens matchBinder
-
-prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
-prettyPrintObjectPropertyBinder (key, binder) = concat <$> sequence
- [ return $ prettyPrintObjectKey key ++ ": "
- , prettyPrintBinder' binder
- ]
-
-prettyPrintObjectProperty :: (String, Maybe Expr) -> StateT PrinterState Maybe String
-prettyPrintObjectProperty (key, value) = concat <$> sequence
- [ return $ prettyPrintObjectKey key ++ ": "
- , maybe (pure "_") prettyPrintValue' value
- ]
+prettyPrintBinder (ConstructorBinder ctor []) = show ctor
+prettyPrintBinder (ConstructorBinder ctor args) = show ctor ++ " " ++ unwords (map prettyPrintBinderAtom args)
+prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder
+prettyPrintBinder b = prettyPrintBinderAtom b
generated by cgit v0.10.2 at 2021-04-13 04:36:21 (GMT)