diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# zephyr +[![Maintainer: coot](https://img.shields.io/badge/maintainer-coot-lightgrey.svg)](http://github.com/coot) + +Experimental tree shaking tool for [PureScript](https://github.com/purescript/purescript). + +# Usage +``` +# compile your project (or use `pulp build -- --dump-corefn`) +purs compile -g corefn bower_components/purescript-*/src/**/*.purs src/**/*.purs + +# run `zephyr` +zephyr -f Main.main + +# bundle your code +webpack +``` + +`zephyr` reads corefn json representation from `output` directory, removes non +transitive dependencies of entry points and dumps common js modules (or corefn +representation) to `dce-output` directory. + +# Zephyr eval + +Zephyr can evaluate some literal expressions. +```purescript +import Config (isProduction) + +a = if isProduction + then "api/prod/" + else "api/dev/" +``` +will be transformed to +``` +a = "api/prod/" +``` +whenever `isProduction` is `true`. This allows you to have different +development and production environment while still ship a minified code in your +production environment. You may define `isProduction` in a module under +a `src-prod` directory and include it when compiling production code with `pulp +build -I src-prod` and to have another copy for your development environment +under `src-dev` where `isProduction` is set to `false`. + +# Build & Test + +To build just run `stack build` (or with `nix` `stack --nix build`). If you +want to run test `stack --nix test` is the prefered method, `stack test` will +also work, unless you don't have one of the dependencies: `git`, `node`, `npm` +and `bower`. + +# Comments + +The `-f` switch is not 100% safe. When on `zephyr` will remove exports from +foreign modules that seems to be not used: are not used in purescript code and +seem not to be used in the foreign module. If you simply assign to `exports` +using javascript dot notation then you will be fine, but if you use square +notation `exports[var]` in a dynamic way (i.e. var is a true variable rather +than a string literal) then `zephyr` might remove code that shouldn't be +removed. + +It is good to run `webpack` or `rollup` to run a javascript tree shaking +algorithm on the javascript code that is pulled in your bundle by your by your +foreign imports. + +# Tests + +It is tested on dozeon of various projects of +[@alexmingoia](https://github.com/alexmingoia), +[@bodil](https://github.com/bodil), [@coot](https://github.com/coot), +[@purescript-contrib](https://github.com/purescript-contrib) and +[@slamdata](https://github.com/slamdata) including: +* [purescript-pux](https://github.com/alexmingoia/purescript-pux) +* [purescript-smolder](https://github.com/bodil/purescript-smolder) +* [purescript-signal](https://github.com/bodil/purescript-signal) +* [purescript-aff](https://github.com/slamdata/purescript-aff) +* [purescript-matryoshka](https://github.com/slamdata/purescript-matryoshka) +* [purescript-argonaout](https://github.com/purescript-contrib/purescript-argonaut) +* [purescript-profunctor-lenses](https://github.com/purescript-contrib/purescript-profunctor-lenses) +* [purescript-react-hocs](https://github.com/coot/purescript-react-hocs) (_karma tests_) +* [purescript-react-redox](https://github.com/coot/purescript-react-redox) (_karma test_) + +Checkout unit test suite to see all of them. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Command/DCE.hs b/app/Command/DCE.hs new file mode 100644 --- /dev/null +++ b/app/Command/DCE.hs @@ -0,0 +1,277 @@ +-- | Dead code elimination command based on `Language.PureScript.CoreFn.DCE`. +module Command.DCE + ( command + , runDCECommand + , dceOptions + , entryPointOpt + ) where + +import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Supply +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except +import Control.Monad.Writer +import qualified Data.Aeson as A +import Data.Aeson.Internal (JSONPath) +import qualified Data.Aeson.Internal as A +import Data.Aeson.Parser (eitherDecodeWith, json) +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as B (fromStrict, toStrict) +import qualified Data.ByteString.UTF8 as BU8 +import Data.Bool (bool) +import Data.Either (Either, lefts, rights) +import Data.List (intercalate, null) +import qualified Data.Map as M +import Data.Maybe (isNothing, listToMaybe) +import Data.Monoid ((<>)) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Traversable (for) +import Data.Version (Version) +import Formatting (sformat, string, stext, (%)) +import qualified Language.PureScript as P +import qualified Language.PureScript.CoreFn as CoreFn +import qualified Language.PureScript.CoreFn.FromJSON as CoreFn +import Language.PureScript.DCE +import qualified Language.PureScript.Errors.JSON as P +import qualified Options.Applicative as Opts +import qualified System.Console.ANSI as ANSI +import System.Directory (doesDirectoryExist, getCurrentDirectory) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath.Glob (compile, globDir1) +import System.IO (hPutStrLn, stderr) + +import Command.DCEOptions + +inputDirectoryOpt :: Opts.Parser FilePath +inputDirectoryOpt = Opts.strOption $ + Opts.short 'i' + <> Opts.long "input-directory" + <> Opts.value "output" + <> Opts.showDefault + <> Opts.help "Input directory (purs output directory)." + +outputDirectoryOpt :: Opts.Parser FilePath +outputDirectoryOpt = Opts.strOption $ + Opts.short 'o' + <> Opts.long "dce-output" + <> Opts.value "dce-output" + <> Opts.showDefault + <> Opts.help "Output directory." + +entryPointOpt :: Opts.Parser EntryPoint +entryPointOpt = Opts.argument (Opts.auto >>= checkIfQualified) $ + Opts.metavar "entry-point" + <> Opts.help "Qualified identifier. All code which is not a transitive dependency of an entry point will be removed. You can pass multiple entry points." + where + checkIfQualified (EntryPoint q@(P.Qualified Nothing _)) = fail $ + "not a qualified indentifier: '" ++ T.unpack (P.showQualified P.runIdent q) ++ "'" + checkIfQualified e = return e + +verboseOutputOpt :: Opts.Parser Bool +verboseOutputOpt = Opts.switch $ + Opts.short 'v' + <> Opts.long "verbose" + <> Opts.showDefault + <> Opts.help "Verbose CoreFn parser errors." + +dceForeignOpt :: Opts.Parser Bool +dceForeignOpt = Opts.switch $ + Opts.short 'f' + <> Opts.long "dce-foreign" + <> Opts.showDefault + <> Opts.help "dce foriegn modules" + +comments :: Opts.Parser Bool +comments = Opts.switch $ + Opts.short 'c' + <> Opts.long "comments" + <> Opts.help "Include comments in the generated code" + +verboseErrors :: Opts.Parser Bool +verboseErrors = Opts.switch $ + Opts.short 'v' + <> Opts.long "verbose-errors" + <> Opts.help "Display verbose error messages" + +codegenTargets :: Opts.Parser [P.CodegenTarget] +codegenTargets = Opts.option targetParser $ + Opts.short 'g' + <> Opts.long "codegen" + <> Opts.value [P.JS] + <> Opts.help + ( "Specifies comma-separated codegen targets to include. " + <> targetsMessage + <> " The default target is 'js', but if this option is used only the targets specified will be used." + ) + +targets :: M.Map String P.CodegenTarget +targets = M.fromList + [ ("js", P.JS) + , ("sourcemaps", P.JSSourceMap) + , ("corefn", P.CoreFn) + ] + +targetsMessage :: String +targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys targets) <> "'." + +targetParser :: Opts.ReadM [P.CodegenTarget] +targetParser = + Opts.str >>= \s -> + for (T.split (== ',') s) + $ maybe (Opts.readerError targetsMessage) pure + . flip M.lookup targets + . T.unpack + . T.strip + +noPrefix :: Opts.Parser Bool +noPrefix = Opts.switch $ + Opts.short 'p' + <> Opts.long "no-prefix" + <> Opts.help "Do not include comment header" + +jsonErrors :: Opts.Parser Bool +jsonErrors = Opts.switch $ + Opts.long "json-errors" + <> Opts.help "Print errors to stderr as JSON" + +pureScriptOptions :: Opts.Parser P.Options +pureScriptOptions = + P.Options + <$> verboseErrors + <*> (not <$> comments) + <*> (handleTargets <$> codegenTargets) + where + -- Ensure that the JS target is included if sourcemaps are + handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget + handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts) + +dceOptions :: Opts.Parser DCEOptions +dceOptions = DCEOptions + <$> Opts.some entryPointOpt + <*> inputDirectoryOpt + <*> outputDirectoryOpt + <*> verboseOutputOpt + <*> dceForeignOpt + <*> pureScriptOptions + <*> (not <$> noPrefix) + <*> jsonErrors + +readInput :: [FilePath] -> IO [Either (FilePath, JSONPath, String) (Version, CoreFn.Module CoreFn.Ann)] +readInput inputFiles = forM inputFiles (\f -> addPath f . decodeCoreFn <$> B.readFile f) + where + decodeCoreFn :: B.ByteString -> Either (JSONPath, String) (Version, CoreFn.Module CoreFn.Ann) + decodeCoreFn = eitherDecodeWith json (A.iparse CoreFn.moduleFromJSON) . B.fromStrict + + addPath + :: FilePath + -> Either (JSONPath, String) (Version, CoreFn.Module CoreFn.Ann) + -> Either (FilePath, JSONPath, String) (Version, CoreFn.Module CoreFn.Ann) + addPath f = either (Left . incl) Right + where incl (l,r) = (f,l,r) +-- +-- | Argumnets: verbose, use JSON, warnings, errors +printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () +printWarningsAndErrors verbose False warnings errors = do + pwd <- getCurrentDirectory + cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr + let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd } + when (P.nonEmpty warnings) $ + hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings) + case errors of + Left errs -> do + hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs) + exitFailure + Right _ -> return () +printWarningsAndErrors verbose True warnings errors = do + hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $ + P.JSONResult (P.toJSONErrors verbose P.Warning warnings) + (either (P.toJSONErrors verbose P.Error) (const []) errors) + either (const exitFailure) (const (return ())) errors + +data DCEAppError + = ParseErrors [Text] + | InputNotDirectory FilePath + | NoInputs FilePath + | CompilationError (DCEError 'Error) + +formatDCEAppError :: DCEOptions -> FilePath -> DCEAppError -> Text +formatDCEAppError opts _ (ParseErrors errs) = + let errs' = + if dceVerbose opts + then errs + else take 5 errs ++ case length $ drop 5 errs of + 0 -> [] + x -> ["... (" <> T.pack (show x) <> " more)"] + in sformat + (string%": Failed parsing:\n "%stext) + (colorString errorColor "Error") + (T.intercalate "\n\t" errs') +formatDCEAppError _ _ (NoInputs path) + = sformat + (stext%": No inputs found under "%string%" directory.\n Please run `purs compile --dump-corefn ..` or `pulp build -- --dump-corefn`") + (colorText errorColor "Error") + (colorString codeColor path) +formatDCEAppError _ _ (InputNotDirectory path) + = sformat + (stext%": Directory "%string%" does not exists.") + (colorText errorColor "Error") + (colorString codeColor path) +formatDCEAppError _ relPath (CompilationError err) + = T.pack $ displayDCEError relPath err + +dceCommand :: DCEOptions -> ExceptT DCEAppError IO () +dceCommand DCEOptions {..} = do + -- initial checks + inptDirExist <- lift $ doesDirectoryExist dceInputDir + unless inptDirExist $ + throwError (InputNotDirectory dceInputDir) + + -- read files, parse errors + let entryPoints = runEntryPoint <$> dceEntryPoints + cfnGlb = compile "**/corefn.json" + inpts <- liftIO $ globDir1 cfnGlb dceInputDir >>= readInput + let errs = lefts inpts + unless (null errs) $ + throwError (ParseErrors $ formatError `map` errs) + + let mPursVer = fmap fst . listToMaybe . rights $ inpts + when (isNothing mPursVer) $ + throwError (NoInputs dceInputDir) + + -- run `dceEval` and `dce` on the `CoreFn` + (mods, warns) <- mapExceptT (fmap $ first CompilationError) + $ runWriterT + $ dceEval (snd `map` rights inpts) >>= flip dce entryPoints + relPath <- liftIO getCurrentDirectory + liftIO $ traverse (hPutStrLn stderr . uncurry (displayDCEWarning relPath)) (zip (zip [1..] (repeat (length warns))) warns) + let filePathMap = M.fromList $ map (\m -> (CoreFn.moduleName m, Right $ CoreFn.modulePath m)) mods + foreigns <- P.inferForeignModules filePathMap + let makeActions = P.buildMakeActions dceOutputDir filePathMap foreigns dceUsePrefix + (makeErrors, makeWarnings) <- + liftIO + $ P.runMake dcePureScriptOptions + $ runSupplyT 0 $ traverse (\m -> P.codegen makeActions m P.initEnvironment mempty) mods + liftIO $ printWarningsAndErrors (P.optionsVerboseErrors dcePureScriptOptions) dceJsonErrors makeWarnings makeErrors + return () + where + formatError :: (FilePath, JSONPath, String) -> Text + formatError (f, p, err) = + if dceVerbose + then sformat (string%":\n "%string) f (A.formatError p err) + else T.pack f + +runDCECommand :: DCEOptions -> IO () +runDCECommand opts = do + res <- runExceptT $ dceCommand opts + relPath <- getCurrentDirectory + case res of + Left e -> (hPutStrLn stderr . T.unpack . formatDCEAppError opts relPath $ e) *> exitFailure + Right _ -> exitSuccess + +command :: Opts.Parser (IO ()) +command = runDCECommand <$> (Opts.helper <*> dceOptions) diff --git a/app/Command/DCEOptions.hs b/app/Command/DCEOptions.hs new file mode 100644 --- /dev/null +++ b/app/Command/DCEOptions.hs @@ -0,0 +1,29 @@ +-- | +-- Helper module for `zephyr`. +module Command.DCEOptions where + +import qualified Data.Text as T +import qualified Language.PureScript as P + +newtype EntryPoint = EntryPoint { runEntryPoint :: P.Qualified P.Ident } + +instance Read EntryPoint where + readsPrec _ s = case unsnoc (T.splitOn "." (T.pack s)) of + Just (as, a) | not (null as) -> [(EntryPoint (P.mkQualified (P.Ident a) (P.ModuleName $ P.ProperName <$> as)), "")] + | otherwise -> [(EntryPoint (P.Qualified Nothing (P.Ident a)), "")] + Nothing -> [] + where + unsnoc :: [a] -> Maybe ([a], a) + unsnoc [] = Nothing + unsnoc as = Just (init as, last as) + +data DCEOptions = DCEOptions + { dceEntryPoints :: [EntryPoint] + , dceInputDir :: FilePath + , dceOutputDir :: FilePath + , dceVerbose :: Bool + , dceForeign :: Bool + , dcePureScriptOptions :: P.Options + , dceUsePrefix :: Bool + , dceJsonErrors :: Bool + } diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Command.DCE +import Options.Applicative ((<**>)) +import qualified Options.Applicative as Opts +import qualified System.IO as IO + +main :: IO () +main = do + IO.hSetEncoding IO.stdout IO.utf8 + IO.hSetEncoding IO.stderr IO.utf8 + let info = Opts.info (dceOptions <**> Opts.helper) (Opts.progDesc "tree shaking breeze for PureScript") + opts <- Opts.execParser info + runDCECommand opts diff --git a/src/Language/PureScript/DCE.hs b/src/Language/PureScript/DCE.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/DCE.hs @@ -0,0 +1,7 @@ +module Language.PureScript.DCE + ( module DCE ) where + +import Language.PureScript.DCE.CoreFn as DCE +import Language.PureScript.DCE.Foreign as DCE +import Language.PureScript.DCE.Errors as DCE +import Language.PureScript.DCE.Eval as DCE diff --git a/src/Language/PureScript/DCE/Constants.hs b/src/Language/PureScript/DCE/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/DCE/Constants.hs @@ -0,0 +1,41 @@ +-- | +-- Various constants used by zephyr. +module Language.PureScript.DCE.Constants where + +import Language.PureScript.Names + +unit :: ModuleName +unit = ModuleName [ProperName "Data", ProperName "Unit"] + +pattern Unit :: ModuleName +pattern Unit = ModuleName [ProperName "Data", ProperName "Unit"] + +semigroup :: ModuleName +semigroup = ModuleName [ProperName "Data", ProperName "Semigroup"] + +pattern Semigroup :: ModuleName +pattern Semigroup = ModuleName [ProperName "Data", ProperName "Semigroup"] + +semiring :: ModuleName +semiring = ModuleName [ProperName "Data", ProperName "Semiring"] + +pattern Ring :: ModuleName +pattern Ring = ModuleName [ProperName "Data", ProperName "Ring"] + +ring :: ModuleName +ring = ModuleName [ProperName "Data", ProperName "Ring"] + +pattern Semiring :: ModuleName +pattern Semiring = ModuleName [ProperName "Data", ProperName "Semiring"] + +pattern HeytingAlgebra :: ModuleName +pattern HeytingAlgebra = ModuleName [ProperName "Data", ProperName "HeytingAlgebra"] + +heytingAlgebra :: ModuleName +heytingAlgebra = ModuleName [ProperName "Data", ProperName "HeytingAlgebra"] + +pattern UnsafeCoerce :: ModuleName +pattern UnsafeCoerce = ModuleName [ProperName "Unsafe", ProperName "Coerce"] + +unsafeCoerce :: ModuleName +unsafeCoerce = ModuleName [ProperName "Unsafe", ProperName "Coerce"] diff --git a/src/Language/PureScript/DCE/CoreFn.hs b/src/Language/PureScript/DCE/CoreFn.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/DCE/CoreFn.hs @@ -0,0 +1,260 @@ +-- | +-- Dead code elimination for `CoreFn`. +module Language.PureScript.DCE.CoreFn + ( dce + , dceExpr + ) where + +import Prelude.Compat +import Control.Arrow ((***)) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Writer +import Data.Graph +import Data.Foldable (foldl', foldr') +import Data.List (any, elem, filter, groupBy, sortBy) +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.Set as S +import Language.PureScript.CoreFn +import Language.PureScript.DCE.Errors +import Language.PureScript.DCE.Utils (bindIdents, unBind) +import Language.PureScript.Names + +type Key = Qualified Ident + +data DCEVertex + = BindVertex (Bind Ann) + | ForeignVertex (Qualified Ident) + +-- | +-- Dead code elimination of a list of modules module +dce + :: forall m + . (MonadError (DCEError 'Error) m, MonadWriter [DCEError 'Warning] m) + => [Module Ann] -- ^ modules to dce + -> [Qualified Ident] -- ^ entry points used to build the graph of + -- dependencies across module boundaries + -> m [Module Ann] -- ^ dead code eliminated modules +dce _ [] = throwError NoEntryPointFound +dce modules entryPoints = + if null entryPointVertices then throwError NoEntryPointFound else do + let found = ((\(_, qi, _) -> qi) . keyForVertex) `map` entryPointVertices + notFound = filter (not . (`elem` found)) entryPoints + unless (null notFound) + (tell [EntryPointsNotFound notFound]) + return (uncurry runDCE `map` reachableInModule) + where + + -- | + -- DCE of a single module. + runDCE + :: [(DCEVertex, Key, [Key])] + -- ^ list of qualified names that has to be preserved + -> Module Ann + -> Module Ann + runDCE vs Module{..} = + let + -- | filter declarations preserving the order + moduleDecls' :: [Bind Ann] + moduleDecls' = dceExpr `map` filter filterByIdents moduleDecls + where + declIdents :: [Ident] + declIdents = concatMap toIdents vs + + toIdents :: (DCEVertex, Key, [Key]) -> [Ident] + toIdents (BindVertex b, _, _) = bindIdents b + toIdents _ = [] + + filterByIdents :: Bind Ann -> Bool + filterByIdents = any (`elem` declIdents) . bindIdents + + idents :: [Ident] + idents = concatMap bindIdents moduleDecls' + + moduleExports' :: [Ident] + moduleExports' = + filter (`elem` (idents ++ moduleForeign')) moduleExports + + mods :: [ModuleName] + mods = mapMaybe getQual (concatMap (\(_, _, ks) -> ks) vs) + + moduleImports' :: [(Ann, ModuleName)] + moduleImports' = filter ((`elem` mods) . snd) moduleImports + + moduleForeign' :: [Ident] + moduleForeign' = filter + ((`S.member` reachableSet) . Qualified (Just moduleName)) + moduleForeign + where + reachableSet = foldr' + (\(_, k, ks) s -> S.insert k s `S.union` S.fromList ks) + S.empty vs + + in Module + moduleSourceSpan + moduleComments + moduleName + modulePath + moduleImports' + moduleExports' + moduleForeign' + moduleDecls' + + (graph, keyForVertex, vertexForKey) = graphFromEdges verts + + -- | The Vertex set. + verts :: [(DCEVertex, Key, [Key])] + verts = do + Module _ _ mn _ _ _ mf ds <- modules + concatMap (toVertices mn) ds + ++ ((\q -> (ForeignVertex q, q, [])) . flip mkQualified mn) `map` mf + where + toVertices :: ModuleName -> Bind Ann -> [(DCEVertex, Key, [Key])] + toVertices mn b@(NonRec _ i e) = + [(BindVertex b, mkQualified i mn, deps e)] + toVertices mn b@(Rec bs) = + let ks :: [(Key, [Key])] + ks = map (\((_, i), e) -> (mkQualified i mn, deps e)) bs + in map (\(k, ks') -> (BindVertex b, k, map fst ks ++ ks')) ks + + -- | Find dependencies of an expression. + deps :: Expr Ann -> [Key] + deps = go + where + (_, go, _, _) = everythingOnValues (++) + (const []) + onExpr + onBinder + (const []) + + -- | Build graph from qualified identifiers. + onExpr :: Expr Ann -> [Key] + onExpr (Var _ i) = [i | isQualified i] + onExpr _ = [] + + onBinder :: Binder Ann -> [Key] + onBinder (ConstructorBinder _ _ c _) = + [fmap (Ident . runProperName) c] + onBinder _ = [] + + -- | Vertices corresponding to the entry points which we want to keep. + entryPointVertices :: [Vertex] + entryPointVertices = catMaybes $ do + (_, k, _) <- verts + guard $ k `elem` entryPoints + return (vertexForKey k) + + -- | The list of reachable vertices grouped by module name. + reachableList :: [[(DCEVertex, Key, [Key])]] + reachableList + = groupBy (\(_, k1, _) (_, k2, _) -> getQual k1 == getQual k2) + $ sortBy (\(_, k1, _) (_, k2, _) -> getQual k1 `compare` getQual k2) + $ map keyForVertex (concatMap (reachable graph) entryPointVertices) + + reachableInModule :: [([(DCEVertex, Key, [Key])], Module Ann)] + reachableInModule = do + vs <- reachableList + m <- modules + guard (getModuleName vs == Just (moduleName m)) + return (vs, m) + + getModuleName :: [(DCEVertex, Key, [Key])] -> Maybe ModuleName + getModuleName [] = Nothing + getModuleName ((_, k, _) : _) = getQual k + +-- | +-- Dead code elimination of local identifiers in `Bind`s, which detects and +-- removes unused bindings. +dceExpr :: Bind Ann -> Bind Ann +dceExpr = go + where + (go, _, _) = everywhereOnValues id exprFn id + + exprFn :: Expr Ann -> Expr Ann + exprFn (Let ann bs ex) = + let nbs = foldr' bindFn [] bs + in if null nbs + then ex + else Let ann nbs ex + + where + bindFn :: Bind Ann -> [Bind Ann] -> [Bind Ann] + bindFn b@(NonRec _ i _) r | i `elem` reachableIdents = b : r + | otherwise = r + bindFn (Rec l) r = + let l' = filter (\((_, i), _) -> i `elem` reachableIdents) l + in if null l' + then r + else Rec l' : r + + (graph, keyForVertex, vertexForKey) = graphFromEdges verts + + -- | Build list of vertices + -- + -- Under the assumption that all identifiers are unique, which is + -- fullfiled by PureScript. + verts :: [(Ident, Ident, [Ident])] + verts = do + let bes = unBind `concatMap` bs + (i, e) <- bes + let deps = fst `map` filter fn bes + where + fn (i', _) = i' /= i && isUsedInExpr i' e + return (i, i, deps) + + entryPointVertices :: [Vertex] + entryPointVertices = catMaybes $ do + (_, i, _) <- verts + guard $ isUsedInExpr i ex + return (vertexForKey i) + + reachableIdents = map fn $ reachable graph `concatMap` entryPointVertices + where + fn v = case keyForVertex v of (_, i, _) -> i + exprFn e = e + + isUsedInExpr :: Ident -> Expr Ann -> Bool + isUsedInExpr i (Literal _ (ArrayLiteral es)) + = any (isUsedInExpr i) es + isUsedInExpr i (Literal _ (ObjectLiteral es)) + = any (isUsedInExpr i . snd) es + isUsedInExpr _ (Literal _ _) = False + isUsedInExpr i (Constructor _ _ _ is) = i `elem` is + isUsedInExpr i (Accessor _ _ e) = isUsedInExpr i e + isUsedInExpr i (ObjectUpdate _ e ups) + = isUsedInExpr i e || any (isUsedInExpr i . snd) ups + isUsedInExpr i (App _ (Abs _ i' e) r) + = if isUsedInExpr i r + then isUsedInExpr i' e + else isUsedInExpr i e + isUsedInExpr i (App _ l r) = isUsedInExpr i l || isUsedInExpr i r + isUsedInExpr i (Abs _ i' e) = i /= i' && isUsedInExpr i e + isUsedInExpr i (Var _ qi) = qi == Qualified Nothing i + isUsedInExpr i (Case _ es alts) + = any (isUsedInExpr i) es || any (isUsedInCaseAlternative i) alts + isUsedInExpr i (Let _ bs e) = + if shadowed + then used + else used || isUsedInExpr i e + where + -- | + -- Check if an identifier is used in bindings and the resulting + -- expression. A binding might shadow an identifier. The first Boolean + -- value denotes if i is used in any bind expression, the second if it was + -- shadowed. + (used, shadowed) = foldl' fn (False, False) (concatMap unBind bs) + + fn (u, s) (i', e') + | s || i == i' = (u, True) + | otherwise = (u || isUsedInExpr i e', False) + + isUsedInCaseAlternative i (CaseAlternative bs ee) = + not (any (\b -> case b of + VarBinder _ i' -> i == i' + _ -> False) bs + ) + && + (case ee of + Right e -> isUsedInExpr i e + Left es + -> any (uncurry (||) . (isUsedInExpr i *** isUsedInExpr i)) es) diff --git a/src/Language/PureScript/DCE/Errors.hs b/src/Language/PureScript/DCE/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/DCE/Errors.hs @@ -0,0 +1,150 @@ +-- | +-- Errors used in dead call elimination. +module Language.PureScript.DCE.Errors + ( DCEError(..) + , displayDCEError + , displayDCEWarning + , Level(..) + , warnColor + , errorColor + , codeColor + , colorString + , colorText + ) + where + +import Prelude.Compat + +import Data.Char (isSpace) +import Data.List (intersperse, dropWhileEnd) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Formatting (sformat, string, stext, (%)) +import Language.PureScript.AST.SourcePos + ( SourceSpan(..) + , displaySourceSpan + ) +import Language.PureScript.Names +import Language.PureScript.PSString +import Language.PureScript.CoreFn.Ann +import qualified Text.PrettyPrint.Boxes as Box +import qualified System.Console.ANSI as ANSI + +data Level = Error | Warning deriving (Show) + +-- | +-- Error type shared by `dce` and `dceEval`. +data DCEError (a :: Level) + = IdentifierNotFound ModuleName Ann (Qualified Ident) + | ArrayIdxOutOfBound ModuleName Ann Integer + | AccessorNotFound ModuleName Ann PSString + | NoEntryPointFound + | EntryPointsNotFound [Qualified Ident] + deriving (Show) + +getAnn :: DCEError a -> Maybe (ModuleName, SourceSpan) +getAnn (IdentifierNotFound mn (ss, _, _, _) _) = Just (mn, ss) +getAnn (ArrayIdxOutOfBound mn (ss, _, _, _) _) = Just (mn, ss) +getAnn (AccessorNotFound mn (ss, _, _, _) _) = Just (mn, ss) +getAnn _ = Nothing + +formatDCEError :: DCEError a -> Box.Box +formatDCEError (IdentifierNotFound _ _ qi) = + Box.text "Unknown value " + Box.<+> colorBox codeColor (T.unpack $ showQualified runIdent qi) + Box.<> "." +formatDCEError (ArrayIdxOutOfBound _ _ i) = + Box.text "Array literal lacks required index" + Box.<+> colorBox codeColor (show i) + Box.<> "." +formatDCEError (AccessorNotFound _ _ acc) = + Box.text "Object literal lacks required label" + Box.<+> colorBox codeColor (T.unpack $ prettyPrintString acc) + Box.<> "." +formatDCEError NoEntryPointFound = "No entry point found." +formatDCEError (EntryPointsNotFound qis) = + Box.text ("Entry point" ++ if length qis > 1 then "s:" else "") + Box.<+> foldr1 (Box.<>) (intersperse (Box.text ", ") + $ map (colorBox codeColor . T.unpack . showQualified runIdent) qis) + Box.<+> "not found." + +renderDCEError :: FilePath -> DCEError a -> Box.Box +renderDCEError relPath err = + case getAnn err of + Just (mn, ss) -> paras + [ Box.text "in module" + Box.<+> colorBox codeColor (T.unpack (runModuleName mn)) + , line $ "at " <> displaySourceSpan relPath ss + , indent $ formatDCEError err + ] + Nothing -> paras [ formatDCEError err ] + +displayDCEError :: FilePath -> DCEError 'Error -> String +displayDCEError relPath err = renderBox $ paras + [ colorBox errorColor "Error" + , indent $ renderDCEError relPath err + ] + +displayDCEWarning :: FilePath -> (Int, Int) -> DCEError 'Warning -> String +displayDCEWarning relPath (idx, count) err = renderBox $ paras + [ colorBox warnColor "Warning" + Box.<+> Box.text (show idx ++ " of " ++ show count) + , indent $ renderDCEError relPath err + ] + +paras :: [Box.Box] -> Box.Box +paras = Box.vcat Box.left + +line :: Text -> Box.Box +line = Box.text . T.unpack + +renderBox :: Box.Box -> String +renderBox = unlines + . map (dropWhileEnd isSpace) + . dropWhile whiteSpace + . dropWhileEnd whiteSpace + . lines + . Box.render + where + whiteSpace = all isSpace + +indent :: Box.Box -> Box.Box +indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2 + +ansiColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) -> String +ansiColor (colorIntensity, color, consoleIntensity) = ANSI.setSGRCode + [ ANSI.SetColor ANSI.Foreground colorIntensity color + , ANSI.SetConsoleIntensity consoleIntensity + ] + +ansiColorReset :: String +ansiColorReset = ANSI.setSGRCode [ANSI.Reset] + +errorColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) +errorColor = (ANSI.Dull, ANSI.Red, ANSI.BoldIntensity) + +warnColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) +warnColor = (ANSI.Dull, ANSI.Yellow, ANSI.BoldIntensity) + +codeColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) +codeColor = (ANSI.Dull, ANSI.Yellow, ANSI.NormalIntensity) + +colorString + :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) + -> String + -> String +colorString color s = ansiColor color ++ s ++ ansiColorReset + +colorText + :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) + -> Text + -> Text +colorText color t = sformat + (string%stext%string) (ansiColor color) t ansiColorReset + +colorBox + :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) + -> String + -> Box.Box +colorBox color = Box.text . colorString color diff --git a/src/Language/PureScript/DCE/Eval.hs b/src/Language/PureScript/DCE/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/DCE/Eval.hs @@ -0,0 +1,546 @@ +-- | +-- Evaluation of PureScript's expressions used in dead call elimnation. +module Language.PureScript.DCE.Eval + ( dceEval ) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.State +import Control.Monad.Writer +import Data.Functor (($>)) +import Language.PureScript.AST.Literals +import Language.PureScript.CoreFn +import Language.PureScript.DCE.Errors +import Language.PureScript.DCE.Utils +import Language.PureScript.Names +import Language.PureScript.PSString + +import Control.Applicative ((<|>)) +import Control.Arrow (second) +import Data.Maybe (Maybe(..), fromJust, isJust, maybeToList) +import Data.Monoid (First(..)) +import Language.PureScript.DCE.Constants as C +import Prelude.Compat hiding (mod) +import Safe (atMay) + +type Stack = [[(Ident, Expr Ann)]] + +-- | +-- Evaluate expressions in a module: +-- +-- * @Data.Eq.eq@ of two literals +-- * @Data.Array.index@ on a literal array +-- * Object accessors +-- * Semigroup operations (@Array@, @String@, @Unit@) +-- * Semiring operations (@Unit@, @Unit@, @Unit@) +-- +-- Keep stack of local identifiers from @let@ and @case@ expressions, ignoring +-- the ones that are comming from abstractions. +dceEval + :: forall m + . (MonadError (DCEError 'Error) m, MonadWriter [DCEError 'Warning] m) + => [Module Ann] + -> m [Module Ann] +dceEval mods = traverse go mods + where + go :: Module Ann -> m (Module Ann) + go Module{..} = do + decls <- (flip evalStateT (moduleName, []) . onBind') `traverse` moduleDecls + return $ Module + moduleSourceSpan + moduleComments + moduleName + modulePath + moduleImports + moduleExports + moduleForeign + decls + + (onBind', _) = everywhereOnValuesM onBind onExpr onBinders + (modify $ second (drop 1)) + -- pop recent value in the stack (it was added in `onBinders`) + + onBind :: Bind Ann -> StateT (ModuleName, Stack) m (Bind Ann) + onBind b = modify (second (unBind b :)) $> b + + -- | + -- Track local identifiers in case binders, push them onto the stack. + onBinders + :: [Expr Ann] + -> [Binder Ann] + -> StateT (ModuleName, Stack) m [Binder Ann] + onBinders es bs = do + let bes = concatMap fn (zip bs es) + modify (second (bes :)) + return bs + where + fn :: (Binder Ann, Expr Ann) -> [(Ident, Expr Ann)] + fn (NullBinder _, _ ) = [] + fn (LiteralBinder _ _, _) = [] + fn (VarBinder _ i, e) = [(i,e)] + fn (ConstructorBinder _ _ _ as, e) = concatMap fn (zip as (repeat e)) + fn (NamedBinder _ i b, e) = (i, e) : fn (b, e) + + -- | + -- Evaluate expressions, keep the stack of local identifiers. It does not + -- track identifiers which are coming from abstractions, but `Let` and + -- `Case` binders are pushed into / poped from the stack. + -- * `Let` binds are added in `onBind` and poped from the stack + -- when visiting `Let` expression. + -- * `Case` binds are added in `onBinders` and poped in the + -- `everywhereOnValuesM` monadic action. + onExpr + :: Expr Ann + -> StateT (ModuleName, Stack) m (Expr Ann) + onExpr (Case ann es cs) = do + es' <- map (>>= castToLiteral) <$> traverse eval es + let cs' = getFirst $ foldMap (fndCase (fromJust `map` es')) cs + if all isJust es' + then case cs' of + Nothing -> return $ Case ann es [] + Just (CaseAlternative bs (Right e)) + | not (any binds bs) -> return e + | otherwise -> return $ Case ann es (maybeToList cs') + Just (CaseAlternative bs (Left gs)) + -> do + gs' <- fltGuards gs + return $ Case ann es [CaseAlternative bs (Left gs')] + else + return + $ Case ann es + $ filter (fltBinders es' . caseAlternativeBinders) cs + where + fltGuards + :: [(Guard Ann, Expr Ann)] + -> StateT (ModuleName, Stack) m [(Guard Ann, Expr Ann)] + fltGuards [] = return [] + fltGuards ((g,e):rest) = do + v <- eval g + case v of + Just (Literal _ t) + | t `eqLit` BooleanLiteral True + -> return [(Literal (extractAnn g) (BooleanLiteral True), e)] + | otherwise -- guard expression must evaluate to a Boolean + -> fltGuards rest + _ -> ((g,e) :) <$> fltGuards rest + onExpr l@Let {} = modify (second (drop 1)) $> l + onExpr e@Var{} = do + v <- eval e + case v of + Just l@(Literal _ NumericLiteral{}) -> return l + Just l@(Literal _ CharLiteral{}) -> return l + Just l@(Literal _ BooleanLiteral{}) -> return l + -- preserve string, array and object literals + Just _ -> return e + Nothing -> return e + onExpr e = do + v <- eval e + case v of + Just l -> return l + Nothing -> return e + + -- | + -- Evaluate an expression + -- * `Data.Eq.eq` of two literals + -- * `Data.Array.index` on a literal array + -- * Object accessors + -- * Semigroup operations (Array, String, Unit) + -- * Semiring operations (Int, Number, Unit) + -- * Heyting algebra operations (Boolean, Unit) + eval :: Expr Ann -> StateT (ModuleName, Stack) m (Maybe (Expr Ann)) + eval (Var _ (Qualified Nothing i)) = do + (_, s) <- get + join <$> traverse eval (fnd i s) + where + fnd :: Ident -> Stack -> Maybe (Expr Ann) + fnd j s = getFirst $ foldMap (First . lookup j) s + eval (Var ann qi@(Qualified (Just mn) i)) = do + (cmn, _) <- get + case findQualifiedExpr mn i of + Nothing -> throwError (IdentifierNotFound cmn ann qi) + Just (Right e) -> eval e + Just (Left _) -> return Nothing + eval e@Literal{} = return (Just e) + eval + (App ann + (App _ + (App _ + (Var _ + (Qualified + (Just (ModuleName [ProperName "Data", ProperName "Eq"])) + (Ident "eq"))) + (Var _ inst)) + e1) + e2) + = if inst `elem` + [ Qualified (Just mn) (Ident "eqBoolean") + , Qualified (Just mn) (Ident "eqInt") + , Qualified (Just mn) (Ident "eqNumber") + , Qualified (Just mn) (Ident "eqChar") + , Qualified (Just mn) (Ident "eqString") + , Qualified (Just mn) (Ident "eqUnit") + , Qualified (Just mn) (Ident "eqVoid") + ] + then do + v1 <- eval e1 + v2 <- eval e2 + case (v1, v2) of + (Just (Literal _ l1), Just (Literal _ l2)) + -> return $ Just $ Literal ann $ BooleanLiteral (eqLit l1 l2) + (_, _) + -> return Nothing + else return Nothing + where + mn = ModuleName [ProperName "Data", ProperName "Eq"] + eval (Accessor ann a (Literal _ (ObjectLiteral as))) = do + (mn, _) <- get + e <- maybe (throwError (AccessorNotFound mn ann a)) return (a `lookup` as) + eval e + eval (App _ + (App _ + (Var ann@(ss, _, _, _) + (Qualified + (Just (ModuleName [ProperName "Data", ProperName "Array"])) + (Ident "index"))) + (Literal _ (ArrayLiteral as))) + (Literal _ (NumericLiteral (Left x)))) + = do + (mn, _) <- get + e <- maybe + (tell [ArrayIdxOutOfBound mn ann x] $> Nothing) + eval + (as `atMay` fromIntegral x) + return + $ App ann + (Var (ss, [], Nothing, Just (IsConstructor SumType [Ident "value0"])) + (Qualified + (Just (ModuleName [ProperName "Data", ProperName "Maybe"])) + (Ident "Just"))) + <$> e + -- | Eval Semigroup + eval + (App ann + (App _ + (App _ + (Var _ (Qualified (Just C.Semigroup) (Ident "append"))) + (Var _ qi)) + e1) + e2) + | qi == Qualified (Just C.semigroup) (Ident "semigroupArray") + , Literal _ (ArrayLiteral a1) <- e1 + , Literal _ (ArrayLiteral a2) <- e2 + = return $ Just $ Literal ann (ArrayLiteral $ a1 ++ a2) + | qi == Qualified (Just C.semigroup) (Ident "semigroupString") + , Literal _ (StringLiteral s1) <- e1 + , Just t1 <- decodeString s1 + , Literal _ (StringLiteral s2) <- e2 + , Just t2 <- decodeString s2 + = return $ Just $ Literal ann (StringLiteral (mkString $ t1 <> t2) ) + | qi == Qualified (Just C.semigroup) (Ident "semigroupUnit") + = return $ Just $ Var ann (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + -- | Eval Semiring + eval + (App (ss, c, _, _) + (App _ + (App _ + (Var _ (Qualified (Just C.Semiring) (Ident "add"))) + (Var _ qi)) + e1) + e2) + | qi == Qualified (Just C.semiring) (Ident "semiringInt") + , Literal _ (NumericLiteral (Left a1)) <- e1 + , Literal _ (NumericLiteral (Left a2)) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Left (a1 + a2))) + | qi == Qualified (Just C.semiring) (Ident "semiringNumber") + , Literal _ (NumericLiteral (Right a1)) <- e1 + , Literal _ (NumericLiteral (Right a2)) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Right (a1 + a2))) + | qi == Qualified (Just C.semiring) (Ident "semiringUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (Var _ (Qualified (Just C.Semiring) (Ident "zero"))) + (Var _ qi)) + | qi == Qualified (Just C.semiring) (Ident "semiringInt") + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Left 0)) + | qi == Qualified + (Just C.semiring) + (Ident "semiringNumber") + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Right 0.0)) + | qi == Qualified (Just C.semiring) (Ident "semiringUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (Var _ (Qualified (Just C.Semiring) (Ident "one"))) + (Var _ qi)) + | qi == Qualified (Just C.semiring) (Ident "semiringInt") + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Left 1)) + | qi == Qualified (Just C.semiring) (Ident "semiringNumber") + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Right 1.0)) + | qi == Qualified (Just C.semiring) (Ident "semiringUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (App _ + (App _ + (Var _ (Qualified (Just C.Semiring) (Ident "mul"))) + (Var _ qi)) + e1) + e2) + | qi == Qualified (Just C.semiring) (Ident "semiringInt") + , Literal _ (NumericLiteral (Left a1)) <- e1 + , Literal _ (NumericLiteral (Left a2)) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Left (a1 * a2))) + | qi == Qualified (Just C.semiring) (Ident "semiringNumber") + , Literal _ (NumericLiteral (Right a1)) <- e1 + , Literal _ (NumericLiteral (Right a2)) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Right (a1 * a2))) + | qi == Qualified (Just C.semiring) (Ident "semiringUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + -- || Eval Ring + eval + (App (ss, c, _, _) + (App _ + (App _ + (Var _ (Qualified (Just C.Ring) (Ident "sub"))) + (Var _ qi)) + e1) + e2) + | qi == Qualified (Just C.ring) (Ident "ringInt") + , Literal _ (NumericLiteral (Left a1)) <- e1 + , Literal _ (NumericLiteral (Left a2)) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Left (quot a1 a2))) + | qi == Qualified (Just C.ring) (Ident "ringNumber") + , Literal _ (NumericLiteral (Right a1)) <- e1 + , Literal _ (NumericLiteral (Right a2)) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Right (a1 / a2))) + | qi == Qualified (Just C.ring) (Ident "unitRing") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + eval + (App (ss, c, _, _) + (App _ + (Var _ (Qualified (Just C.Ring) (Ident "negate"))) + (Var _ qi)) + e) + | qi == Qualified (Just C.ring) (Ident "ringInt") + , Literal _ (NumericLiteral (Left a)) <- e + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Left (-a))) + | qi == Qualified (Just C.ring) (Ident "ringNumber") + , Literal _ (NumericLiteral (Right a)) <- e + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (NumericLiteral (Right (-a))) + | qi == Qualified (Just C.ring) (Ident "unitRing") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + -- | Eval HeytingAlgebra + eval + (App (ss, c, _, _) + (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "ff"))) + (Var _ qi)) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") + = return $ Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral False) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "tt"))) + (Var _ qi)) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") + = return $ Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral True) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (App _ + (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "not"))) + (Var _ qi)) + e) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") + , Literal _ (BooleanLiteral b) <- e + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (BooleanLiteral (not b)) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (App _ + (App _ + (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "implies"))) + (Var _ qi)) + e1) + e2) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") + , Literal _ (BooleanLiteral b1) <- e1 + , Literal _ (BooleanLiteral b2) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (BooleanLiteral (not b1 && b2)) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (App _ + (App _ + (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "disj"))) + (Var _ qi)) + e1) + e2) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") + , Literal _ (BooleanLiteral b1) <- e1 + , Literal _ (BooleanLiteral b2) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (BooleanLiteral (b1 || b2)) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval + (App (ss, c, _, _) + (App _ + (App _ + (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "conj"))) + (Var _ qi)) + e1) + e2) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") + , Literal _ (BooleanLiteral b1) <- e1 + , Literal _ (BooleanLiteral b2) <- e2 + = return $ Just $ Literal + (ss, c, Nothing, Nothing) + (BooleanLiteral (b1 && b2)) + | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit") + = return $ Just $ Var + (ss, c, Nothing, Nothing) + (Qualified (Just C.unit) (Ident "unit")) + | otherwise + = return Nothing + eval _ = return Nothing + + eqLit :: Literal a -> Literal b -> Bool + eqLit (NumericLiteral (Left a)) (NumericLiteral (Left b)) = a == b + eqLit (NumericLiteral (Right a)) (NumericLiteral (Right b)) = a == b + eqLit (StringLiteral a) (StringLiteral b) = a == b + eqLit (CharLiteral a) (CharLiteral b) = a == b + eqLit (BooleanLiteral a) (BooleanLiteral b) = a == b + eqLit _ _ = False + + fltBinders :: [Maybe (Literal (Expr Ann))] -> [Binder Ann] -> Bool + fltBinders (Just l1 : ts) (LiteralBinder _ l2 : bs) = l1 `eqLit` l2 && fltBinders ts bs + fltBinders _ _ = True + + -- | + -- Cast an expression to a literal. + castToLiteral :: Expr Ann -> Maybe (Literal (Expr Ann)) + castToLiteral (Literal _ l) = Just l + castToLiteral _ = Nothing + + fndCase :: [Literal (Expr Ann)] -> CaseAlternative Ann -> First (CaseAlternative Ann) + fndCase as c = + if matches as (caseAlternativeBinders c) + then First (Just c) + else First Nothing + where + matches :: [Literal (Expr Ann)] -> [Binder Ann] -> Bool + matches [] _ = True + matches _ [] = True + matches (t:ts) (LiteralBinder _ t' : bs) = t `eqLit` t' && matches ts bs + matches (t:ts) (NamedBinder _ _ (LiteralBinder _ t') : bs) = t `eqLit` t' && matches ts bs + matches (_:ts) (_:bs) = matches ts bs + + -- Does a binder binds? + binds :: Binder Ann -> Bool + binds (NullBinder _) = False + binds (LiteralBinder _ (NumericLiteral _)) = False + binds (LiteralBinder _ (StringLiteral _)) = False + binds (LiteralBinder _ (CharLiteral _)) = False + binds (LiteralBinder _ (BooleanLiteral _)) = False + binds (LiteralBinder _ (ArrayLiteral bs)) = any binds bs + binds (LiteralBinder _ (ObjectLiteral bs)) = any (binds . snd) bs + binds (VarBinder _ _) = True + binds (ConstructorBinder _ _ _ bs) = any binds bs + binds NamedBinder{} = True + + -- | + -- Find a qualified name in the list of modules `mods`, return `Left ()` for + -- `Prim` values, generics and foreign imports, `Right` for found bindings. + findQualifiedExpr :: ModuleName -> Ident -> Maybe (Either () (Expr Ann)) + findQualifiedExpr (ModuleName (ProperName "Prim" : _)) _ = Just (Left ()) + findQualifiedExpr (ModuleName [ProperName "Data", ProperName "Generic"]) (Ident "anyProxy") = Just (Left ()) + findQualifiedExpr mn i + = Right <$> (mod >>= getFirst . foldMap fIdent . concatMap unBind . moduleDecls) + <|> Left <$> (mod >>= getFirst . foldMap ffIdent . moduleForeign) + where + mod :: Maybe (Module Ann) + mod = getFirst $ foldMap (\m -> if moduleName m == mn then First (Just m) else First Nothing) mods + + fIdent :: (Ident, Expr Ann) -> First (Expr Ann) + fIdent (i', e) | i == i' = First (Just e) + | otherwise = First Nothing + + ffIdent :: Ident -> First () + ffIdent i' | i == i' = First (Just ()) + | otherwise = First Nothing diff --git a/src/Language/PureScript/DCE/Foreign.hs b/src/Language/PureScript/DCE/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/DCE/Foreign.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Simple dead call elimination in foreign modules. +module Language.PureScript.DCE.Foreign + ( dceForeignModule ) where + +import Prelude.Compat +import Control.Monad +import Data.Graph +import Data.Foldable (foldr') +import Data.List (any, elem, filter) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Language.JavaScript.Parser.AST + ( JSStatement(..) + , JSExpression(..) + , JSCommaList(..) + , JSBlock(..) + , JSSwitchParts(..) + , JSTryCatch(..) + , JSTryFinally(..) + , JSArrayElement(..) + , JSObjectProperty(..) + , JSCommaTrailingList(..) + ) +import Language.PureScript.Names + +-- | foldr over `JSCommaList` +foldrJSCommaList :: (a -> b -> b) -> JSCommaList a -> b -> b +foldrJSCommaList _ JSLNil b = b +foldrJSCommaList fn (JSLOne a) !b = fn a b +foldrJSCommaList fn (JSLCons as _ a) !b = foldrJSCommaList fn as (fn a b) + +-- | +-- Filter export statements in a foreign module. This is not 100% safe. It +-- might remove declarations that are used somewhere in the foreign module (for +-- example by using @'eval'@). +dceForeignModule :: [Ident] -> [JSStatement] -> [JSStatement] +dceForeignModule is stmts = filter filterExports stmts + + where + filterExports :: JSStatement -> Bool + filterExports (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ x) _) _ _ _) + = fltr (unquote . T.pack $ x) + filterExports (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ x)) _ _ _) + = fltr (T.pack x) + filterExports _ = True + + fltr :: Text -> Bool + fltr t = any (fromMaybe True . (path graph <$> vertexForKey t <*>) . Just) entryPointVertices + -- one of `entryPointVertices` depend on this vertex + || any (isUsedInStmt t) nonExps + -- it is used in any non export statements + + -- Build a graph of exports statements. Its initial set of edges point from + -- an export statement to all other export statements that are using it. + -- When checking if we need to include that vartex we just check if there is + -- a path from a vertex to one of `entryPointVertices`. + exps :: [JSStatement] + exps = filter isExportStatement stmts + + nonExps = filter (not . isExportStatement) stmts + + (graph, _, vertexForKey) = graphFromEdges verts + + verts :: [(JSStatement, Text, [Text])] + verts = mapMaybe toVert exps + where + toVert :: JSStatement -> Maybe (JSStatement, Text, [Text]) + toVert s + | Just name <- exportStatementName s = Just (s, name, foldr' (fn name) [] exps) + | otherwise = Nothing + + fn name s' nms + | isUsedInStmt name s' + , Just n <- exportStatementName s' = n:nms + | otherwise = nms + + entryPointVertices :: [Vertex] + entryPointVertices = catMaybes $ do + (_, k, _) <- verts + guard $ k `elem` ns + return (vertexForKey k) + where + ns = runIdent <$> is + + unquote :: Text -> Text + unquote = T.drop 1 . T.dropEnd 1 + + isExportStatement :: JSStatement -> Bool + isExportStatement (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ _)) _ _ _) = True + isExportStatement (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ _) _) _ _ _) = True + isExportStatement _ = False + + exportStatementName :: JSStatement -> Maybe Text + exportStatementName (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ i)) _ _ _) = Just . T.pack $ i + exportStatementName (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ i) _) _ _ _) = Just . unquote . T.pack $ i + exportStatementName _ = Nothing + + -- Check if (export) identifier is used within a JSStatement. + isUsedInStmt :: Text -> JSStatement -> Bool + isUsedInStmt n (JSStatementBlock _ ss _ _) = any (isUsedInStmt n) ss + isUsedInStmt n (JSDoWhile _ stm _ _ e _ _) = isUsedInStmt n stm || isUsedInExpr n e + isUsedInStmt n (JSFor _ _ es1 _ es2 _ es3 _ s) = isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s + isUsedInStmt n (JSForIn _ _ e1 _ e2 _ s) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s + isUsedInStmt n (JSForVar _ _ _ es1 _ es2 _ es3 _ s) = isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s + isUsedInStmt n (JSForVarIn _ _ _ e1 _ e2 _ s) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s + isUsedInStmt n (JSFunction _ _ _ _ _ (JSBlock _ ss _) _) = any (isUsedInStmt n) ss + isUsedInStmt n (JSIf _ _ e _ s) = isUsedInExpr n e || isUsedInStmt n s + isUsedInStmt n (JSIfElse _ _ e _ s1 _ s2) = isUsedInExpr n e || isUsedInStmt n s1 || isUsedInStmt n s2 + isUsedInStmt n (JSLabelled _ _ s) = isUsedInStmt n s + isUsedInStmt _ (JSEmptyStatement _) = False + isUsedInStmt n (JSExpressionStatement e _) = isUsedInExpr n e + isUsedInStmt n (JSAssignStatement e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2 + isUsedInStmt n (JSMethodCall e _ es _ _) = isUsedInExpr n e || isUsedInExprs n es + isUsedInStmt n (JSReturn _ me _) = fromMaybe False (isUsedInExpr n <$> me) + isUsedInStmt n (JSSwitch _ _ e _ _ sps _ _) = isUsedInExpr n e || any (isUsedInSwitchParts n) sps + isUsedInStmt n (JSThrow _ e _) = isUsedInExpr n e + isUsedInStmt n (JSTry _ (JSBlock _ ss _) cs f) = any (isUsedInStmt n) ss || any (isUsedInTryCatch n) cs || isUsedInFinally n f + isUsedInStmt n (JSVariable _ es _) = isUsedInExprs n es + isUsedInStmt n (JSWhile _ _ e _ s) = isUsedInExpr n e || isUsedInStmt n s + isUsedInStmt n (JSWith _ _ e _ s _) = isUsedInExpr n e || isUsedInStmt n s + isUsedInStmt _ JSBreak{} = False + isUsedInStmt _ JSConstant{} = False + isUsedInStmt _ JSContinue{} = False + + -- Check is (export) identifier is used withing a JSExpression + isUsedInExpr :: Text -> JSExpression -> Bool + isUsedInExpr n (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ i)) = n == T.pack i + isUsedInExpr n (JSMemberDot e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2 + isUsedInExpr n (JSArrayLiteral _ as _) = any (isUsedInArrayElement n) as + isUsedInExpr n (JSAssignExpression e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2 + isUsedInExpr n (JSCallExpression e _ es _) = isUsedInExpr n e || isUsedInExprs n es + isUsedInExpr n (JSCallExpressionDot e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2 + isUsedInExpr n (JSCallExpressionSquare e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2 + isUsedInExpr n (JSExpressionBinary e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2 + isUsedInExpr n (JSExpressionParen _ e _) = isUsedInExpr n e + isUsedInExpr n (JSExpressionPostfix e _) = isUsedInExpr n e + isUsedInExpr n (JSExpressionTernary e1 _ e2 _ e3) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInExpr n e3 + isUsedInExpr n (JSFunctionExpression _ _ _ _ _ (JSBlock _ ss _)) = any (isUsedInStmt n) ss + isUsedInExpr n (JSMemberExpression e _ es _) = isUsedInExpr n e || isUsedInExprs n es + isUsedInExpr n (JSMemberNew _ e _ es _) = isUsedInExpr n e || isUsedInExprs n es + isUsedInExpr n (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ i) _) = n == (unquote .T.pack $ i) + isUsedInExpr n (JSMemberSquare e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2 + isUsedInExpr n (JSNewExpression _ e) = isUsedInExpr n e + isUsedInExpr n (JSObjectLiteral _ ops _) = foldrJSCommaList (\p b -> isUsedInObjectProperty n p || b) (fromCTList ops) False + where + fromCTList (JSCTLComma as _) = as + fromCTList (JSCTLNone as) = as + isUsedInExpr n (JSUnaryExpression _ e) = isUsedInExpr n e + isUsedInExpr n (JSVarInitExpression e _) = isUsedInExpr n e + isUsedInExpr _ JSIdentifier{} = False + isUsedInExpr _ JSDecimal{} = False + isUsedInExpr _ JSLiteral{} = False + isUsedInExpr _ JSHexInteger{} = False + isUsedInExpr _ JSOctal{} = False + isUsedInExpr _ JSStringLiteral{} = False + isUsedInExpr _ JSRegEx{} = False + isUsedInExpr n (JSCommaExpression e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2 + + isUsedInExprs :: Text -> JSCommaList JSExpression -> Bool + isUsedInExprs n es = foldrJSCommaList fn es False + where + fn :: JSExpression -> Bool -> Bool + fn e b = isUsedInExpr n e || b + + -- Check if (export) identifier is used withing a JSSitchParts + isUsedInSwitchParts :: Text -> JSSwitchParts -> Bool + isUsedInSwitchParts n (JSCase _ e _ ss) = isUsedInExpr n e || any (isUsedInStmt n) ss + isUsedInSwitchParts n (JSDefault _ _ ss) = any (isUsedInStmt n) ss + + -- Check if (export) identifier is used withing a JSTryCatch + isUsedInTryCatch :: Text -> JSTryCatch -> Bool + isUsedInTryCatch n (JSCatch _ _ e _ (JSBlock _ ss _)) = isUsedInExpr n e || any (isUsedInStmt n) ss + isUsedInTryCatch n (JSCatchIf _ _ e1 _ e2 _ (JSBlock _ ss _)) = isUsedInExpr n e1 || isUsedInExpr n e2 || any (isUsedInStmt n) ss + + -- | + -- Check if (export) identifier is used withing a JSTryFinally + isUsedInFinally :: Text -> JSTryFinally -> Bool + isUsedInFinally n (JSFinally _ (JSBlock _ ss _)) = any (isUsedInStmt n) ss + isUsedInFinally _ JSNoFinally = False + + -- | + -- Check if (export) identifier is used withing a JSArrayElement + isUsedInArrayElement :: Text -> JSArrayElement -> Bool + isUsedInArrayElement n (JSArrayElement e) = isUsedInExpr n e + isUsedInArrayElement _ JSArrayComma{} = False + + -- | + -- Check if (export) identifier is used withing a JSObjectProperty + isUsedInObjectProperty :: Text -> JSObjectProperty -> Bool + isUsedInObjectProperty n (JSPropertyAccessor _ _ _ es _ (JSBlock _ ss _)) = any (isUsedInExpr n) es || any (isUsedInStmt n) ss + isUsedInObjectProperty n (JSPropertyNameandValue _ _ es) = any (isUsedInExpr n) es diff --git a/src/Language/PureScript/DCE/Utils.hs b/src/Language/PureScript/DCE/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/DCE/Utils.hs @@ -0,0 +1,93 @@ +-- | +-- Helper module for dead call elimination. +module Language.PureScript.DCE.Utils where + +import Prelude.Compat +import Control.Arrow (first, second, (***), (+++)) +import Language.PureScript.CoreFn +import Language.PureScript.Names + +bindIdents :: Bind Ann -> [Ident] +bindIdents (NonRec _ i _) = [i] +bindIdents (Rec bs) = (snd . fst) `map` bs + +bindExprs :: Bind Ann -> [Expr Ann] +bindExprs (NonRec _ _ e) = [e] +bindExprs (Rec bs) = snd `map` bs + +unBind :: Bind Ann -> [(Ident, Expr Ann)] +unBind (NonRec _ i e) = [(i, e)] +unBind (Rec bs) = first snd `map` bs + +everywhereOnValuesM + :: forall m a + . (Monad m) + => (Bind a -> m (Bind a)) + -> (Expr a -> m (Expr a)) + -> ([Expr a] -> [Binder a] -> m [Binder a]) + -> m () + -- ^ monadic computation fired after handling case alternative + -> (Bind a -> m (Bind a), Expr a -> m (Expr a)) +everywhereOnValuesM f g h mh = (f', g') + where + f' (NonRec a name e) = NonRec a name <$> g' e >>= f + f' (Rec es) = Rec <$> traverse (traverse g) es >>= f + + g' (Literal ann e) = Literal ann <$> handleLiteral g' e >>= g + g' (Accessor ann prop e) = Accessor ann prop <$> g' e >>= g + g' (ObjectUpdate ann obj vs) = ObjectUpdate ann <$> g' obj <*> traverse (traverse g') vs >>= g + g' (Abs ann name e) = Abs ann name <$> g' e >>= g + g' (App ann v1 v2) = App ann <$> g' v1 <*> g' v2 >>= g + g' (Case ann vs alts) = do + vs' <- traverse g' vs + alts' <- traverse (handleCaseAlternative vs') alts + g (Case ann vs' alts') + g' (Let ann ds e) = Let ann <$> traverse f' ds <*> g' e >>= g + g' e = g e + + handleCaseAlternative :: [Expr a] -> CaseAlternative a -> m (CaseAlternative a) + handleCaseAlternative es (CaseAlternative bs r) = do + bs' <- h es bs + rs <- g'' r + mh + return (CaseAlternative bs' rs) + where + g'' :: Either [(Guard a, Expr a)] (Expr a) -> m (Either [(Guard a, Expr a)] (Expr a)) + g'' (Left es') = Left <$> traverse gn es' + g'' (Right e) = Right <$> g' e + + gn (e1, e2) = (,) <$> g' e1 <*> g' e2 + + handleLiteral :: (b -> m b) -> Literal b -> m (Literal b) + handleLiteral i (ArrayLiteral ls) = ArrayLiteral <$> traverse i ls + handleLiteral i (ObjectLiteral ls) = ObjectLiteral <$> traverse (traverse i) ls + handleLiteral _ other = return other + +unAnn :: Expr a -> Expr () +unAnn (Literal _ l) = Literal () (unAnn <$> l) +unAnn (Constructor _ n cn is) = Constructor () n cn is +unAnn (Accessor _ s e) = Accessor () s (unAnn e) +unAnn (ObjectUpdate _ e es) = ObjectUpdate () (unAnn e) (second unAnn <$> es) +unAnn (Abs _ i e) = Abs () i (unAnn e) +unAnn (App _ e1 e2) = App () (unAnn e1) (unAnn e2) +unAnn (Var _ i) = Var () i +unAnn (Case _ es cs) = Case () (unAnn `map` es) (gn `map` cs) + where + gn :: CaseAlternative a -> CaseAlternative () + gn (CaseAlternative bs es') = CaseAlternative (unAnnBinder `map` bs) (map (unAnn *** unAnn) +++ unAnn $ es') + + unAnnBinder :: Binder a -> Binder () + unAnnBinder (NullBinder _) = NullBinder () + unAnnBinder (LiteralBinder _ l) = LiteralBinder () (unAnnBinder <$> l) + unAnnBinder (VarBinder _ i) = VarBinder () i + unAnnBinder (ConstructorBinder _ n cn bs) = ConstructorBinder () n cn (unAnnBinder `map` bs) + unAnnBinder (NamedBinder _ i b) = NamedBinder () i (unAnnBinder b) +unAnn (Let _ bs e) = Let () (unAnnBind `map` bs) (unAnn e) + where + unAnnBind (NonRec _ i e') = NonRec () i (unAnn e') + unAnnBind (Rec bs') = Rec ((first (const ()) *** unAnn) `map` bs') + +-- | +-- Helper function for pretty printing errors in tests. +showExpr :: Expr a -> String +showExpr = show . unAnn diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,396 @@ +module Main (main) where + +import Prelude () +import Prelude.Compat hiding (exp) +import Control.Monad (when) +import Control.Monad.Trans.Class +import Control.Monad.Except +import Data.List (init, last) +import Data.Foldable (forM_) +import Data.Maybe (fromJust, fromMaybe, isJust, maybe) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + , getCurrentDirectory + , setCurrentDirectory + ) +import System.Exit (ExitCode(..)) +import System.IO (hSetEncoding, stdout, stderr, utf8) +import System.Process (readProcess, readProcessWithExitCode) +import Test.Hspec +import Test.HUnit (assertEqual) + +import qualified TestDCECoreFn +import qualified TestDCEEval + +data CoreLibTest = CoreLibTest + { coreLibTestRepo :: Text + -- ^ git repo + , coreLibTestNpmModules :: [Text] + -- ^ additional node modules to install + , coreLibTestEntries :: [Text] + -- ^ entry points for `zephyr` + , coreLibZephyrOptions :: Maybe [Text] + -- ^ zephyr options + , coreLibTestJsCmd :: Maybe (Text, Text) + -- ^ node script, expected output + } + +coreLibs :: [CoreLibTest] +coreLibs = + [ CoreLibTest "https://github.com/alexmingoia/purescript-pux.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/bodil/purescript-smolder.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/bodil/purescript-signal.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/bodil/purescript-test-unit.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/slamdata/purescript-aff.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/slamdata/purescript-avar.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/slamdata/purescript-matryoshka.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/slamdata/purescript-routing.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/slamdata/purescript-routing.git" [] + ["Routing.matches"] + Nothing + (Just + ( "console.log(Object.keys(require('./dce-output/Routing')))" + , "[ 'hashes', 'matches', 'matches\\'', 'matchWith', 'hashChanged' ]")) + , CoreLibTest "https://github.com/slamdata/purescript-search.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest + "https://github.com/purescript/purescript-console.git" + [] + ["Control.Monad.Eff.Console.log"] + Nothing + (Just + ( "require('./dce-output/Control.Monad.Eff.Console').log('hello')()" + , "hello")) + , CoreLibTest "https://github.com/purescript/purescript-free.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-prelude.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest + "https://github.com/purescript/purescript-partial.git" + [] + ["Test.Main.main", "Test.Main.safely", "Test.Main.safely2"] + Nothing + (Just + ( "var r = require('./dce-output/Test.Main'); console.log(r.safely == r.safely2)" + , "true")) + , CoreLibTest "https://github.com/purescript/purescript-arrays.git" [] ["Test.Main.main"] (Just ["-f"]) Nothing + , CoreLibTest "https://github.com/purescript/purescript-control.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-enums.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-generics-rep.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-maps.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-record.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-refs.git" + [] + ["Control.Monad.Eff.Ref.newRef", "Control.Monad.Eff.Ref.readRef", "Control.Monad.Eff.Ref.writeRef"] + Nothing + (Just + ( "console.log(Object.keys(require('./dce-output/Control.Monad.Eff.Ref')))" + , "[ 'newRef', 'readRef', 'writeRef' ]" + )) + , CoreLibTest "https://github.com/purescript/purescript-strings.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-transformers.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-quickcheck.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript/purescript-unsafe-coerce.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-argonaut.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-argonaut-codecs.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-argonaut-core.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-argonaut-generic.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-argonaut-traversals.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-foreign-lens.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-handlebars.git" ["handlebars"] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-js-date.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-lens.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-profunctor-lenses.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-nullable.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-options.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-parsing.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-precise.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-string-parsers.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-strongcheck.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-unicode.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-js-timers.git" [] ["Test.Main.main"] Nothing Nothing + , CoreLibTest "https://github.com/purescript-contrib/purescript-unsafe-reference.git" [] ["Test.Main.main"] Nothing Nothing + ] + +data LibTest = LibTest + { libTestEntries :: [Text] + , libTestZephyrOptions :: Maybe [Text] + , libTestJsCmd :: Text + , libTestShouldPass :: Bool + -- ^ true if should run without error, false if should error + } + +libTests :: [LibTest] +libTests = + [ LibTest ["Unsafe.Coerce.Test.unsafeX"] Nothing "require('./dce-output/Unsafe.Coerce.Test').unsafeX(1)(1);" True + ] + +data KarmaTest = KarmaTest + { karmaTestRepo :: Text + -- ^ git repo + , karmaTestEntry :: Text + -- ^ `zephyre entry point + } + +karmaTests :: [KarmaTest] +karmaTests = + [ KarmaTest "https://github.com/coot/purescript-react-hocs.git" "Test.Main.main" + , KarmaTest "https://github.com/coot/purescript-react-redox.git""Test.Karma.Main.main" + ] + +data TestError + = GitError Text ExitCode String + | NpmError Text ExitCode String + | BowerError Text ExitCode String + | PursError Text ExitCode String + | PursBundleError Text ExitCode String + | BrowserifyError Text ExitCode String + | ZephyrError Text ExitCode String + | NodeError Text ExitCode String String + | JsCmdError Text Text + deriving (Eq) + +instance Show TestError where + show (GitError repo ec err) + = "git failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err + show (NpmError repo ec err) + = "npm failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err + show (BowerError repo ec err) + = "bower failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err + show (PursError repo ec err) + = "purs compile failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err + show (PursBundleError repo ec err) + = "purs bundle failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err + show (BrowserifyError repo ec err) + = "browserify failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err + show (ZephyrError repo ec err) + = "zephyr failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n" ++ err + show (NodeError repo ec std err) + = "node failed \"" ++ T.unpack repo ++ "\" (" ++ show ec ++ ")\n\n" ++ std ++ "\n\n" ++ err + show (JsCmdError exp got) = "expected:\n\n" ++ T.unpack exp ++ "\n\nbut got:\n\n" ++ T.unpack got ++ "\n" + +isGitError :: TestError -> Bool +isGitError (GitError _ _ _) = True +isGitError _ = False + +cloneRepo + :: Text + -> ExceptT TestError IO FilePath +cloneRepo coreLibTestRepo = do + let dir = head $ T.splitOn "." $ last $ T.splitOn "/" coreLibTestRepo + + repoExist <- lift $ doesDirectoryExist $ T.unpack dir + unless repoExist $ do + (ecGit, _, errGc) <- lift $ readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack coreLibTestRepo, T.unpack dir] "" + when (ecGit /= ExitSuccess) (throwError (GitError coreLibTestRepo ecGit errGc)) + return (T.unpack dir) + +npmInstall + :: Text + -> [Text] + -> ExceptT TestError IO () +npmInstall coreLibTestRepo npmModules = do + pkgJson <- lift $ doesFileExist "package.json" + nodeModulesExists <- lift $ doesDirectoryExist "node_modules" + when ((pkgJson || not (null npmModules)) && not nodeModulesExists) $ do + when (not $ null $ npmModules) $ do + (ecNpm, _, errNpm) <- lift $ readProcessWithExitCode "npm" (["install"] ++ T.unpack `map` npmModules) "" + when (ecNpm /= ExitSuccess) (throwError (NpmError coreLibTestRepo ecNpm errNpm)) + (ecNpm, _, errNpm) <- lift $ readProcessWithExitCode "npm" ["install"] "" + when (ecNpm /= ExitSuccess) (throwError (NpmError coreLibTestRepo ecNpm errNpm)) + +bowerInstall + :: Text + -> ExceptT TestError IO () +bowerInstall coreLibTestRepo = do + bowerComponentsExists <- lift $ doesDirectoryExist "bower_components" + when (not bowerComponentsExists) $ do + (ecBower, _, errBower) <- lift $ readProcessWithExitCode "bower" ["install"] "" + when (ecBower /= ecBower) (throwError (BowerError coreLibTestRepo ecBower errBower)) + +pursCompile + :: Text + -> ExceptT TestError IO () +pursCompile coreLibTestRepo = do + outputDirExists <- lift $ doesDirectoryExist "output" + when (not outputDirExists) $ do + (ecPurs, _, errPurs) <- lift + $ readProcessWithExitCode + "stack" + [ "exec" + , "purs" + , "--" + , "compile" + , "--codegen" , "corefn" + , "bower_components/purescript-*/src/**/*.purs" + , "src/**/*.purs" + , "test/**/*.purs" + ] + "" + when (ecPurs /= ExitSuccess) (throwError $ PursError coreLibTestRepo ecPurs errPurs) + +runZephyr + :: Text + -> [Text] + -> Maybe [Text] + -> ExceptT TestError IO () +runZephyr coreLibTestRepo coreLibTestEntries zephyrOptions = do + outputDirExists <- lift $ doesDirectoryExist "dce-output" + when outputDirExists $ + lift $ removeDirectoryRecursive "dce-output" + (ecZephyr, _, errZephyr) <- lift $ readProcessWithExitCode "stack" (["exec", "zephyr", "--"] ++ T.unpack `map` fromMaybe ["-f"] zephyrOptions ++ T.unpack `map` coreLibTestEntries) "" + when (ecZephyr /= ExitSuccess) (throwError $ ZephyrError coreLibTestRepo ecZephyr errZephyr) + + +runCoreLibTest :: CoreLibTest -> ExceptT TestError IO () +runCoreLibTest (CoreLibTest {..}) = do + dir <- cloneRepo coreLibTestRepo + lift $ setCurrentDirectory dir + npmInstall coreLibTestRepo coreLibTestNpmModules + bowerInstall coreLibTestRepo + pursCompile coreLibTestRepo + runZephyr coreLibTestRepo coreLibTestEntries coreLibZephyrOptions + + (ecNode, stdNode, errNode) <- lift + $ readProcessWithExitCode + "node" + [ "-e" + , T.unpack $ maybe defaultJsCmd fst coreLibTestJsCmd + ] + "" + + lift $ setCurrentDirectory ".." + + when (ecNode /= ExitSuccess) + (throwError $ NodeError coreLibTestRepo ecNode stdNode errNode) + when (isJust coreLibTestJsCmd && Just (T.strip $ T.pack stdNode) /= (snd <$> coreLibTestJsCmd)) + (throwError $ JsCmdError (fromJust $ snd <$> coreLibTestJsCmd) (T.pack stdNode)) + + where + defaultJsCmd = "setTimeout(process.exit.bind(process , 0), 2000); require('./dce-output/Test.Main/index.js').main()" + +runLibTest + :: LibTest + -> ExceptT TestError IO () +runLibTest (LibTest {..}) = do + bowerInstall "LibTest" + pursCompile "LibTest" + runZephyr "LibTest" libTestEntries libTestZephyrOptions + (ecNode, stdNode, errNode) <- lift + $ readProcessWithExitCode + "node" + [ "-e" + , T.unpack libTestJsCmd + ] + "" + when (libTestShouldPass && ecNode /= ExitSuccess) + (throwError $ NodeError "LibTest (should pass)" ecNode stdNode errNode) + when (not libTestShouldPass && ecNode == ExitSuccess) + (throwError $ NodeError "LibTest (should fail)" ecNode stdNode errNode) + +runKarmaTest + :: KarmaTest + -> ExceptT TestError IO () +runKarmaTest KarmaTest{..} = do + dir <- cloneRepo karmaTestRepo + lift $ setCurrentDirectory dir + npmInstall karmaTestRepo [] + bowerInstall karmaTestRepo + pursCompile karmaTestRepo + runZephyr karmaTestRepo [karmaTestEntry] Nothing + + (ecBundle, _, errBundle) <- lift $ readProcessWithExitCode + "purs" + [ "bundle" + , "--main", T.unpack (T.intercalate "." . init . T.splitOn "." $ karmaTestEntry) + , "dce-output/**/*.js" + , "-o" , "karma/test.js" + ] + "" + lift $ setCurrentDirectory ".." + when (ecBundle /= ExitSuccess) (throwError $ PursBundleError karmaTestRepo ecBundle errBundle) + + (ecBrowserify, _, errBrowserify) <- lift $ readProcessWithExitCode + "browserify" + [ "-e", "karma/test.js" + , "-i", "react/addons" + , "-i", "react/lib/ReactContext" + , "-i", "react/lib/ExecutionEnvironment" + , "-o", "karma/index.js" + ] + "" + when (ecBrowserify /= ExitSuccess) (throwError $ BrowserifyError karmaTestRepo ecBrowserify errBrowserify) + + (ecKarma, stdKarma, errKarma) <- lift $ readProcessWithExitCode + "karma" + [ "start" + , "--single-run" + ] + "" + when (ecKarma /= ExitSuccess) (throwError $ NodeError karmaTestRepo ecKarma stdKarma errKarma) + +assertCoreLib + :: CoreLibTest + -> Expectation +assertCoreLib l = do + res <- runExceptT . runCoreLibTest $ l + assertEqual "core lib should run" (Right ()) res + +assertLib + :: LibTest + -> Expectation +assertLib l = do + res <- runExceptT . runLibTest $ l + assertEqual "lib should run" (Right ()) res + +assertKarma + :: KarmaTest + -> Expectation +assertKarma l = do + res <- runExceptT . runKarmaTest $ l + when (either (not . isGitError) (const True) res) + (setCurrentDirectory "..") + assertEqual "karma should run" (Right ()) res + +coreLibSpec :: Spec +coreLibSpec = do + context "test libraries" $ + forM_ coreLibs $ \l@(CoreLibTest repo _ _ _ _) -> + specify (T.unpack repo) $ assertCoreLib l + +libSpec :: Spec +libSpec = do + context "TestLib" $ + forM_ libTests $ \l -> + specify (T.unpack $ T.intercalate (T.pack " ") $ libTestEntries l) $ assertLib l + +karmaSpec :: Spec +karmaSpec = + context "karma tests" $ + forM_ karmaTests $ \l@(KarmaTest repo _) -> + specify (T.unpack repo) $ assertKarma l + +changeDir :: FilePath -> Spec -> Spec +changeDir path = around_ + $ \runTests -> do + createDirectoryIfMissing False path + cwd <- getCurrentDirectory + setCurrentDirectory path + runTests + setCurrentDirectory cwd + +main :: IO () +main = do + readProcess "stack" ["exec", "purs", "--", "--version"] "" >>= putStrLn . (\v -> "\npurs version: " ++ v) + + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + + TestDCECoreFn.main + TestDCEEval.main + + hspec $ changeDir "test/tests" libSpec + hspec $ changeDir ".temp" coreLibSpec + hspec karmaSpec diff --git a/test/TestDCECoreFn.hs b/test/TestDCECoreFn.hs new file mode 100644 --- /dev/null +++ b/test/TestDCECoreFn.hs @@ -0,0 +1,125 @@ +module TestDCECoreFn (main) where + +import Prelude () +import Prelude.Compat + +import Data.List (concatMap) + +import Language.PureScript.AST.Literals +import Language.PureScript.AST.SourcePos +import Language.PureScript.CoreFn +import Language.PureScript.DCE +import Language.PureScript.Names +import Language.PureScript.PSString + +import Test.Hspec + +main :: IO () +main = hspec spec + +getNames :: Bind a -> [Ident] +getNames (NonRec _ i _) = [i] +getNames (Rec l) = (\((_, i), _) -> i) `map` l + +hasIdent :: Ident -> [Bind Ann] -> Bool +hasIdent i = (i `elem`) . concatMap getNames + +ann :: Ann +ann = ssAnn (SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0)) + +spec :: Spec +spec = + context "dceExpr" $ do + specify "should remove unused identifier" $ do + let e :: Expr Ann + e = Let ann + [ NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a')) + , NonRec ann (Ident "used") (Literal ann (CharLiteral 'b')) + ] + (Var ann (Qualified Nothing (Ident "used"))) + case dceExpr (NonRec ann (Ident "v") e) of + NonRec _ _ (Let _ bs _) -> do + bs `shouldSatisfy` not . hasIdent (Ident "notUsed") + bs `shouldSatisfy` hasIdent (Ident "used") + _ -> return () + + specify "should not remove transitive dependency" $ do + let e :: Expr Ann + e = Let ann + [ NonRec ann (Ident "used") (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "trDep")))) + , NonRec ann (Ident "trDep") (Literal ann (CharLiteral 'a')) + ] + (Var ann (Qualified Nothing (Ident "used"))) + case dceExpr (NonRec ann (Ident "v") e) of + NonRec _ _ (Let _ bs _) -> do + bs `shouldSatisfy` hasIdent (Ident "trDep") + bs `shouldSatisfy` hasIdent (Ident "used") + _ -> return () + + specify "should include all used recursive binds" $ do + let e :: Expr Ann + e = Let ann + [ NonRec ann (Ident "entry") (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "mutDep1")))) + , Rec + [ ((ann, Ident "mutDep1"), Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "mutDep2")))) + , ((ann, Ident "mutDep2"), Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "mutDep1")))) + ] + ] + (App ann (Var ann (Qualified Nothing (Ident "entry"))) (Literal ann (CharLiteral 'a'))) + case dceExpr (NonRec ann (Ident "v") e) of + NonRec _ _ (Let _ bs _) -> do + bs `shouldSatisfy` hasIdent (Ident "entry") + bs `shouldSatisfy` hasIdent (Ident "mutDep1") + bs `shouldSatisfy` hasIdent (Ident "mutDep2") + _ -> return () + + specify "should dce case expressions" $ do + let e :: Expr Ann + e = Let ann + [ NonRec ann (Ident "usedInExpr") (Literal ann (CharLiteral 'a')) + , NonRec ann (Ident "notUsed") (Literal ann (CharLiteral 'a')) + , NonRec ann (Ident "usedInGuard") (Literal ann (CharLiteral 'a')) + , NonRec ann (Ident "usedInResult1") (Literal ann (CharLiteral 'a')) + , NonRec ann (Ident "usedInResult2") (Literal ann (CharLiteral 'a')) + ] + (Case ann + [Var ann (Qualified Nothing (Ident "usedInExpr"))] + [ CaseAlternative + [NullBinder ann] + (Left + [ ( Var ann (Qualified Nothing (Ident "usedInGuard")) + , Var ann (Qualified Nothing (Ident "usedInResult1")) + ) + ]) + , CaseAlternative + [NullBinder ann] + (Right $ Var ann (Qualified Nothing (Ident "usedInResult2"))) + ]) + case dceExpr (NonRec ann (Ident "v") e) of + NonRec _ _ (Let _ bs _) -> do + bs `shouldSatisfy` hasIdent (Ident "usedInExpr") + bs `shouldSatisfy` not . hasIdent (Ident "notUsed") + bs `shouldSatisfy` hasIdent (Ident "usedInGuard") + bs `shouldSatisfy` hasIdent (Ident "usedInResult1") + bs `shouldSatisfy` hasIdent (Ident "usedInResult2") + _ -> return () + + specify "should not remove shadowed identifiers" $ do + let e :: Expr Ann + e = Let ann + [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a')) + , NonRec ann (Ident "sunny") (Literal ann (CharLiteral 'a')) + ] + $ Let ann + [ NonRec ann (Ident "shadow") (Literal ann (CharLiteral 'a')) ] + $ Literal ann + $ ObjectLiteral + [ ( mkString "a", Var ann (Qualified Nothing (Ident "shadow")) ) + , ( mkString "b", Var ann (Qualified Nothing (Ident "sunny")) ) + ] + case dceExpr (NonRec ann (Ident "v") e) of + NonRec _ _ (Let _ bs (Let _ cs _)) -> do + bs `shouldSatisfy` hasIdent (Ident "sunny") + bs `shouldSatisfy` not . hasIdent (Ident "shadow") + cs `shouldSatisfy` hasIdent (Ident "shadow") + _ -> undefined diff --git a/test/TestDCEEval.hs b/test/TestDCEEval.hs new file mode 100644 --- /dev/null +++ b/test/TestDCEEval.hs @@ -0,0 +1,337 @@ +module TestDCEEval (main) where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Writer + +import Language.PureScript.AST.Literals +import Language.PureScript.AST.SourcePos +import Language.PureScript.CoreFn +import Language.PureScript.DCE +import Language.PureScript.DCE.Constants as C +import Language.PureScript.Names +import Language.PureScript.PSString + +import Language.PureScript.DCE.Utils (showExpr) + +import Test.Hspec +import Test.HUnit (assertFailure) + +main :: IO () +main = hspec spec + +ss :: SourceSpan +ss = SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0) + +ann :: Ann +ann = ssAnn ss + +spec :: Spec +spec = + context "dceEval" $ do + let eqModName = ModuleName [ProperName "Data", ProperName "Eq"] + eq = Qualified (Just eqModName) (Ident "eq") + eqBoolean = Qualified (Just eqModName) (Ident "eqBoolean") + eqMod = Module ss [] eqModName "" [] [] + [ Ident "refEq" ] + [ NonRec ann (Ident "eq") + (Abs ann (Ident "dictEq") + (Abs ann (Ident "x") + (Abs ann (Ident "y") + (Literal ann (BooleanLiteral True))))) + , NonRec ann (Ident "eqBoolean") + (App ann + (Var ann (Qualified (Just eqModName) (Ident "Eq"))) + (Var ann (Qualified (Just eqModName) (Ident "refEq")))) + , NonRec ann (Ident "Eq") + (Abs ann (Ident "eq") + (Literal ann (ObjectLiteral [(mkString "eq", Var ann (Qualified Nothing (Ident "eq")))]))) + ] + booleanMod = Module ss [] (ModuleName [ProperName "Data", ProperName "Boolean"]) "" [] [] [] + [ NonRec ann (Ident "otherwise") (Literal ann (BooleanLiteral True)) ] + arrayMod = Module ss [] (ModuleName [ProperName "Data", ProperName "Array"]) "" + [] [] [] + [ NonRec ann (Ident "index") + (Abs ann (Ident "as") + (Abs ann (Ident "ix") + (Literal ann (CharLiteral 'f')))) + ] + unsafeCoerceMod = Module ss [] C.unsafeCoerce "" + [] [] [] + [ NonRec ann (Ident "unsafeCoerce") + (Abs ann (Ident "x") + (Var ann (Qualified Nothing (Ident "x")))) + ] + testMod e = Module ss [] mn mp [] [] [] + [ NonRec ann (Ident "v") e + , NonRec ann (Ident "f") + (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x")))) + ] + + mn = ModuleName [ProperName "Test"] + mp = "src/Test.purs" + + dceEvalExpr' :: Expr Ann -> [Module Ann] -> Either (DCEError 'Error) (Expr Ann) + dceEvalExpr' e mods = case runWriterT $ dceEval ([testMod e , eqMod , booleanMod , arrayMod, unsafeCoerceMod] ++ mods) of + Right (((Module _ _ _ _ _ _ _ [NonRec _ _ e', _]): _), _) -> Right e' + Right _ -> undefined + Left err -> Left err + + dceEvalExpr :: Expr Ann -> Either (DCEError 'Error) (Expr Ann) + dceEvalExpr e = dceEvalExpr' e [] + + specify "should simplify if when comparing two literal values" $ do + let v :: Expr Ann + v = + App ann + (App ann + (App ann + (Var ann eq) + (Var ann eqBoolean)) + (Literal ann (BooleanLiteral True))) + (Literal ann (BooleanLiteral True)) + e :: Expr Ann + e = Case ann [v] + [ CaseAlternative + [ LiteralBinder ann (BooleanLiteral True) ] + (Right (Literal ann (CharLiteral 't'))) + , CaseAlternative + [ LiteralBinder ann (BooleanLiteral False) ] + (Right (Literal ann (CharLiteral 'f'))) + ] + case dceEvalExpr e of + Right (Literal _ (CharLiteral 't')) -> return () + Right x -> assertFailure $ "unexepcted expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should simplify `if true`" $ do + let e :: Expr Ann + e = Case ann [Literal ann (BooleanLiteral True)] + [ CaseAlternative + [ LiteralBinder ann (BooleanLiteral True) ] + (Right (Literal ann (CharLiteral 't'))) + , CaseAlternative + [ LiteralBinder ann (BooleanLiteral False) ] + (Right (Literal ann (CharLiteral 'f'))) + ] + case dceEvalExpr e of + Right (Literal _ (CharLiteral 't')) -> return () + Right x -> assertFailure $ "unexepcted expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should simplify case when comparing two literal values" $ do + let v :: Expr Ann + v = + App ann + (App ann + (App ann + (Var ann eq) + (Var ann eqBoolean)) + (Literal ann (BooleanLiteral True))) + (Literal ann (BooleanLiteral True)) + e :: Expr Ann + e = Let ann [NonRec ann (Ident "v") v] + (Case ann [Var ann (Qualified Nothing (Ident "v"))] + [ CaseAlternative + [ LiteralBinder ann (BooleanLiteral True) ] + (Right (Literal ann (CharLiteral 't'))) + , CaseAlternative + [ LiteralBinder ann (BooleanLiteral False) ] + (Right (Literal ann (CharLiteral 'f'))) + ]) + case dceEvalExpr e of + Right (Let _ [NonRec _ (Ident "v") _] (Literal _ (CharLiteral 't'))) -> return () + Right x -> assertFailure $ "unexpected expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should not simplify application" $ do + let v :: Expr Ann + v = + App ann + (App ann + (App ann + (Var ann (Qualified (Just mn) (Ident "f"))) + (Var ann eqBoolean)) + (Literal ann (BooleanLiteral True))) + (Literal ann (BooleanLiteral True)) + e :: Expr Ann + e = Let ann [NonRec ann (Ident "v") v] + (Case ann [Var ann (Qualified Nothing (Ident "v"))] + [ CaseAlternative + [ LiteralBinder ann (BooleanLiteral True) ] + (Right (Literal ann (CharLiteral 't'))) + , CaseAlternative + [ LiteralBinder ann (BooleanLiteral False) ] + (Right (Literal ann (CharLiteral 'f'))) + ]) + case dceEvalExpr e of + Right e' -> + if showExpr e' /= showExpr e -- dirty + then assertFailure $ "unexpected expression:\n" ++ showExpr e' ++ "\nexpected:\n" ++ showExpr e + else return () + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "eval guards" $ do + let e :: Expr Ann + e = Case ann [Literal ann (BooleanLiteral True)] + [ CaseAlternative + [ VarBinder ann (Ident "x") ] + (Left + [ (App ann + (App ann + (App ann + (Var ann eq) + (Var ann eqBoolean)) + (Var ann (Qualified Nothing (Ident "x")))) + (Literal ann (BooleanLiteral True)) + , Literal ann (CharLiteral 't')) + , ( Var ann (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise")) + , (Literal ann (CharLiteral 'f')) + ) + ]) + ] + case dceEvalExpr e of + Right (Case _ + [ Literal _ (BooleanLiteral True)] + [ CaseAlternative + [ VarBinder _ (Ident "x") ] + (Left [ (Literal _ (BooleanLiteral True), Literal _ (CharLiteral 't')) ]) + ] + ) -> return () + Right x -> assertFailure $ "unexpected expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should evaluate exported literal" $ do + let um :: Module Ann + um = Module ss [] + (ModuleName [ProperName "Utils"]) + "src/Utils.purs" + [] + [Ident "isProduction"] + [] + [NonRec ann (Ident "isProduction") (Literal ann (BooleanLiteral True))] + e :: Expr Ann + e = Case ann + [ Var ann (Qualified (Just (ModuleName [ProperName "Utils"])) (Ident "isProduction"))] + [ CaseAlternative [LiteralBinder ann (BooleanLiteral True)] (Right (Literal ann (CharLiteral 't'))) + , CaseAlternative [LiteralBinder ann (BooleanLiteral False)] (Right (Literal ann (CharLiteral 'f'))) + ] + mm :: Module Ann + mm = Module + ss + [] + (ModuleName [ProperName "Main"]) + "src/Main.purs" + [] + [] + [] + [NonRec ann (Ident "main") e] + case runWriterT $ dceEval [mm, um] of + Right (((Module _ _ _ _ _ _ _ [NonRec _ (Ident "main") (Literal _ (CharLiteral 't'))]) : _), _) -> return () + Right r -> assertFailure $ "unexpected result:\n" ++ show r + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should evaluate accessor expression" $ do + let e :: Expr Ann + e = (Accessor ann (mkString "a") (Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 't'))]))) + case dceEvalExpr e of + Right (Literal _ (CharLiteral 't')) -> return () + Right x -> assertFailure $ "unexpected expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should evaluate accessing array by index" $ do + let e :: Expr Ann + e = (App ann + (App ann + (Var ann (Qualified (Just (ModuleName [ProperName "Data", ProperName "Array"])) (Ident "index"))) + (Literal ann (ArrayLiteral [Literal ann (CharLiteral 't')]))) + (Literal ann (NumericLiteral (Left 0)))) + case dceEvalExpr e of + Right (App _ (Var _ (Qualified (Just (ModuleName [ProperName "Data", ProperName "Maybe"])) (Ident "Just"))) (Literal _ (CharLiteral 't'))) -> return () + Right x -> assertFailure $ "unexpected expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + context "context stack" $ do + specify "let and case binders" $ do + let e :: Expr Ann + e = Let ann [ NonRec ann (Ident "v") (Literal ann (CharLiteral 'v')) ] + (Case ann + [ Literal ann (CharLiteral 't') ] + [ CaseAlternative + [ VarBinder ann (Ident "v") ] + (Right (Var ann (Qualified Nothing (Ident "v")))) + ] + ) + case dceEvalExpr e of + Right (Let _ _ (Case _ _ [ CaseAlternative _ (Right (Literal _ (CharLiteral 't'))) ])) -> return () + Right x -> assertFailure $ "unexpected expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "nested let bindings" $ do + let e :: Expr Ann + e = Let ann [ NonRec ann (Ident "a") (Literal ann (CharLiteral 'a')) ] + (Let ann [ NonRec ann (Ident "a") (Literal ann (CharLiteral 'b')) ] + (Var ann (Qualified Nothing (Ident "a")))) + case dceEvalExpr e of + Right (Let _ _ (Let _ _ (Literal _ (CharLiteral 'b')))) -> return () + Right x -> assertFailure $ "unexpected expression:\n" ++ showExpr x + Left err -> assertFailure $ "compilation error: " ++ show err + + context "Var inlining" $ do + let oModName = ModuleName [ProperName "Other"] + oMod = Module ss [] oModName "" [] [] [] + [ NonRec ann (Ident "o") $ Literal ann (ObjectLiteral [(mkString "a", Var ann (Qualified (Just eqModName) (Ident "eq"))) ]) + , NonRec ann (Ident "a") $ Literal ann (ArrayLiteral [ Var ann (Qualified (Just eqModName) (Ident "eq")) ]) + , NonRec ann (Ident "s") $ Literal ann (StringLiteral (mkString "very-long-string")) + , NonRec ann (Ident "b") $ Literal ann (BooleanLiteral True) + , NonRec ann (Ident "c") $ Literal ann (CharLiteral 'a') + , NonRec ann (Ident "n") $ Literal ann (NumericLiteral (Left 0)) + ] + specify "should not inline Var linking to an object literal" $ do + let e :: Expr Ann + e = Var ann (Qualified (Just oModName) (Ident "o")) + case dceEvalExpr' e [oMod] of + Right Var{} -> return () + Right e' -> assertFailure $ "unexpected expression: " ++ showExpr e' + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should not inline Var linking to an array literal" $ do + let e :: Expr Ann + e = Var ann (Qualified (Just oModName) (Ident "a")) + case dceEvalExpr' e [oMod] of + Right Var{} -> return () + Right e' -> assertFailure $ "unexpected expression: " ++ showExpr e' + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should not inline Var linking to a string literal" $ do + let e :: Expr Ann + e = Var ann (Qualified (Just oModName) (Ident "s")) + case dceEvalExpr' e [oMod] of + Right Var{} -> return () + Right e' -> assertFailure $ "unexpected expression: " ++ showExpr e' + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should inline Var lining to a boolean literal" $ do + let e :: Expr Ann + e = Var ann (Qualified (Just oModName) (Ident "b")) + case dceEvalExpr' e [oMod] of + Right (Literal _ (BooleanLiteral{})) -> return () + Right e' -> assertFailure $ "wront expression: " ++ showExpr e' + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should inline Var lining to a char literal" $ do + let e :: Expr Ann + e = Var ann (Qualified (Just oModName) (Ident "c")) + case dceEvalExpr' e [oMod] of + Right (Literal _ (CharLiteral{})) -> return () + Right e' -> assertFailure $ "wront expression: " ++ showExpr e' + Left err -> assertFailure $ "compilation error: " ++ show err + + specify "should inline Var lining to a numeric literal" $ do + let e :: Expr Ann + e = Var ann (Qualified (Just oModName) (Ident "n")) + case dceEvalExpr' e [oMod] of + Right (Literal _ (NumericLiteral{})) -> return () + Right e' -> assertFailure $ "wront expression: " ++ showExpr e' + Left err -> assertFailure $ "compilation error: " ++ show err diff --git a/zephyr.cabal b/zephyr.cabal new file mode 100644 --- /dev/null +++ b/zephyr.cabal @@ -0,0 +1,161 @@ +name: zephyr +version: 0.1.1.0 +synopsis: Zephyr tree shaking for PureScript Language +description: + Tree shaking tool and partial evaluator for PureScript + CoreFn AST. +homepage: https://github.com/coot/zephyr#readme +license: MPL-2.0 +license-file: LICENSE +author: Marcin Szamotulski +maintainer: Marcin Szamotulski +copyright: (c) 2017-2018 Marcin Szamotulski +build-type: Simple +extra-source-files: README.md +category: Development +cabal-version: >=1.10 +tested-with: ghc + +library + hs-source-dirs: src + default-extensions: + ConstraintKinds + DataKinds + DeriveFunctor + EmptyDataDecls + FlexibleContexts + KindSignatures + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + OverloadedStrings + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + ViewPatterns + ghc-options: + -Wall + -fmax-pmcheck-iterations=4000000 + exposed-modules: + Language.PureScript.DCE + , Language.PureScript.DCE.Constants + , Language.PureScript.DCE.CoreFn + , Language.PureScript.DCE.Foreign + , Language.PureScript.DCE.Errors + , Language.PureScript.DCE.Eval + , Language.PureScript.DCE.Utils + build-depends: + aeson >=1.0 && <1.3 + , ansi-terminal >=0.7.1 && <0.8 + , base >= 4.7 && < 5 + , base-compat >=0.6.0 + , bytestring + , boxes >=0.1.4 && <0.2.0 + , containers + , directory >=1.2.3 + , filepath + , formatting + , Glob >=0.9 && <0.10 + , language-javascript >=0.6.0.9 && <0.7 + , mtl >=2.1.0 && <2.3.0 + , optparse-applicative >=0.13.0 + , purescript + , safe >=0.3.14 && <0.4 + , text + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , utf8-string >=1 && <2 + default-language: Haskell2010 + +executable zephyr + hs-source-dirs: app + main-is: Main.hs + other-modules: + Command.DCE + Command.DCEOptions + default-extensions: + DataKinds + FlexibleContexts + OverloadedStrings + RecordWildCards + ghc-options: + -Wall + -O2 + -fno-warn-unused-do-bind + -threaded + -rtsopts + -with-rtsopts=-N + build-depends: + aeson >=1.0 && <1.3 + , ansi-terminal >=0.7.1 && <0.8 + , base + , base-compat >=0.6.0 + , bytestring + , containers + , directory >=1.2.3 + , filepath + , formatting + , Glob >=0.9 && <0.10 + , language-javascript >=0.6.0.9 && <0.7 + , mtl >=2.1.0 && <2.3.0 + , optparse-applicative >=0.13.0 + , purescript >= 0.12 && < 0.13 + , text + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , utf8-string >=1 && <2 + , zephyr + default-language: Haskell2010 + +test-suite zephyr-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-extensions: + DataKinds + DoAndIfThenElse + FlexibleInstances + OverloadedStrings + RecordWildCards + TupleSections + main-is: Main.hs + build-depends: + aeson >=1.0 && <1.3 + , ansi-terminal >=0.7.1 && <0.8 + , base >=4.8 && <5 + , base-compat >=0.6.0 + , bytestring + , containers + , directory >=1.2.3 + , filepath + , hspec + , hspec-core + , HUnit + , language-javascript >=0.6.0.9 && <0.7 + , mtl >=2.1.0 && <2.3.0 + , optparse-applicative >=0.13.0 + , process < 1.7.0.0 + , purescript + , text + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , utf8-string >=1 && <2 + , zephyr + other-modules: + TestDCECoreFn + , TestDCEEval + ghc-options: + -Wall + -threaded + -rtsopts + -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/coot/zephyr