purescript 0.7.0.0 → 0.7.1.0
raw patch · 19 files changed
+1392/−1069 lines, 19 filesdep ~base
Dependency ranges changed: base
Files
- psc-bundle/Main.hs +10/−493
- psc-publish/ErrorsWarnings.hs +8/−8
- psc-publish/Main.hs +42/−13
- psc/Main.hs +1/−1
- psc/Make.hs +0/−140
- psci/Make.hs +0/−127
- psci/PSCi.hs +23/−6
- purescript.cabal +8/−7
- src/Language/PureScript.hs +1/−153
- src/Language/PureScript/AST/Binders.hs +1/−1
- src/Language/PureScript/Bundle.hs +540/−0
- src/Language/PureScript/CodeGen/JS/AST.hs +2/−1
- src/Language/PureScript/Docs/ParseAndDesugar.hs +32/−11
- src/Language/PureScript/Docs/Types.hs +57/−18
- src/Language/PureScript/Errors.hs +41/−28
- src/Language/PureScript/Linter.hs +2/−1
- src/Language/PureScript/Linter/Exhaustive.hs +275/−0
- src/Language/PureScript/Make.hs +314/−0
- src/Language/PureScript/Pretty/Values.hs +35/−61
psc-bundle/Main.hs view
@@ -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.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 @@ , 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 @@ 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 @@ 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
psc-publish/ErrorsWarnings.hs view
@@ -33,7 +33,7 @@ deriving (Show) data PackageWarning- = ResolutionNotVersion PackageName+ = NoResolvedVersion PackageName | UndeclaredDependency PackageName | UnacceptableVersion (PackageName, String) deriving (Show)@@ -253,7 +253,7 @@ [ "An IO exception occurred:", show exc ] data CollectedWarnings = CollectedWarnings- { resolutionNotVersions :: [PackageName]+ { noResolvedVersions :: [PackageName] , undeclaredDependencies :: [PackageName] , unacceptableVersions :: [(PackageName, String)] }@@ -268,7 +268,7 @@ 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 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 @@ , 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) ++
psc-publish/Main.hs view
@@ -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 @@ 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 @@ pkgResolvedDependencies <- getResolvedDependencies declaredDeps let pkgUploader = D.NotYetKnown+ let pkgCompilerVersion = P.version return D.Package{..} @@ -170,6 +175,12 @@ 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,19 +207,36 @@ 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 isMissing <- keyOrDefault "missing" False asBool@@ -217,7 +245,7 @@ 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 @@ 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 @@ 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
psc/Main.hs view
@@ -36,7 +36,7 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths -import Make+import Language.PureScript.Make data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath]
− psc/Make.hs
@@ -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
− psci/Make.hs
@@ -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
psci/PSCi.hs view
@@ -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 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.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 Directive as D import Completion (completion) import IO (mkdirp)-import Make import Parser (parseCommand) import Types @@ -240,10 +242,25 @@ 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.
purescript.cabal view
@@ -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 @@ 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 @@ 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 @@ 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 @@ 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 @@ Directive Completion PSCi- Make IO ghc-options: -Wall -O2 @@ -217,9 +220,7 @@ 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,
src/Language/PureScript.hs view
@@ -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 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
src/Language/PureScript/AST/Binders.hs view
@@ -69,7 +69,7 @@ -- | -- 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
+ src/Language/PureScript/Bundle.hs view
@@ -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)
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -23,6 +23,7 @@ import Data.Traversable (traverse) import Language.PureScript.Comments+import Language.PureScript.Traversals -- | -- Built-in unary operators@@ -294,7 +295,7 @@ 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
src/Language/PureScript/Docs/ParseAndDesugar.hs view
@@ -53,20 +53,41 @@ depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles runExceptT $ do- let eParsed = P.parseModulesFromFiles fileInfoToString (inputFiles' ++ depsFiles')- ms <- throwLeft ParseError eParsed-- let depsModules = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) ms)- let eSorted = P.sortModules . map (importPrim . snd) $ ms- (ms', _) <- throwLeft SortModulesError eSorted+ ms <- parseFiles (inputFiles' ++ depsFiles')+ ms' <- sortModules (map snd ms)+ (bs, ms'') <- desugarWithBookmarks ms ms'+ liftIO $ callback bs ms'' - modules <- throwLeft DesugarError (desugar ms')- let modules' = map (addPackage depsModules) modules- bookmarks = concatMap collectBookmarks modules'- liftIO (callback bookmarks (takeLocals modules'))+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- throwLeft f = either (throwError . f) return+ sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)+ sortModules' = P.sortModules++desugarWithBookmarks ::+ [(FileInfo, P.Module)]+ -> [P.Module]+ -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module])+desugarWithBookmarks msInfo msSorted = do+ msDesugared <- throwLeft DesugarError (desugar msSorted)++ let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)+ msPackages = map (addPackage msDeps) msDesugared+ bookmarks = concatMap collectBookmarks msPackages++ 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: --
src/Language/PureScript/Docs/Types.hs view
@@ -10,7 +10,8 @@ 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.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 @@ , 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 @@ pkgResolvedDependencies pkgGithub verifiedUser+ pkgCompilerVersion packageName :: Package a -> PackageName packageName = bowerName . pkgMeta@@ -170,7 +175,10 @@ 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 @@ ---------------------- -- 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 :: (forall e. Parse e a) -> Parse PackageError (Package a)-asPackage uploader =+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)+ Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta <*> key "version" asVersion <*> key "versionTag" asString@@ -220,9 +235,10 @@ <*> 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,20 +246,42 @@ 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 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 @@ pkgResolvedDependencies , "github" .= pkgGithub , "uploader" .= pkgUploader+ , "compilerVersion" .= showVersion P.version ] instance A.ToJSON NotYetKnown where
src/Language/PureScript/Errors.hs view
@@ -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 @@ | TransitiveExportError DeclarationRef [DeclarationRef] | ShadowedName Ident | WildcardInferredType Type+ | NotExhaustivePattern [[Binder]] | ClassOperator ProperName Ident deriving (Show) @@ -229,6 +230,7 @@ (TransitiveExportError _ _) -> "TransitiveExportError" (ShadowedName _) -> "ShadowedName" (WildcardInferredType _) -> "WildcardInferredType"+ (NotExhaustivePattern _) -> "NotExhaustivePattern" (ClassOperator _ _) -> "ClassOperator" -- |@@ -272,6 +274,9 @@ -- | 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 @@ -- | -- 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 @@ , 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 @@ ] 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 @@ , 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 @@ 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 @@ -- 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
src/Language/PureScript/Linter.hs view
@@ -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 Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors+import Language.PureScript.Linter.Exhaustive as L -- | Lint the PureScript AST. -- |
+ src/Language/PureScript/Linter/Exhaustive.hs view
@@ -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+
+ src/Language/PureScript/Make.hs view
@@ -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
src/Language/PureScript/Pretty/Values.hs view
@@ -15,7 +15,8 @@ module Language.PureScript.Pretty.Values ( prettyPrintValue,- prettyPrintBinder+ prettyPrintBinder,+ prettyPrintBinderAtom ) where import Data.Maybe (fromMaybe)@@ -40,11 +41,7 @@ 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 @@ 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 @@ prettyPrintValue' val prettyPrintDoNotationElement (DoNotationBind binder val) = concat <$> sequence- [ prettyPrintBinder' binder+ [ return (prettyPrintBinder binder) , return " <- " , prettyPrintValue' val ]@@ -131,13 +128,10 @@ 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 @@ , [ 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