zephyr (empty) → 0.1.1.0
raw patch · 17 files changed
+3087/−0 lines, 17 filesdep +Globdep +HUnitdep +aesonsetup-changed
Dependencies added: Glob, HUnit, aeson, ansi-terminal, base, base-compat, boxes, bytestring, containers, directory, filepath, formatting, hspec, hspec-core, language-javascript, mtl, optparse-applicative, process, purescript, safe, text, transformers, transformers-base, transformers-compat, utf8-string, zephyr
Files
- LICENSE +373/−0
- README.md +81/−0
- Setup.hs +2/−0
- app/Command/DCE.hs +277/−0
- app/Command/DCEOptions.hs +29/−0
- app/Main.hs +14/−0
- src/Language/PureScript/DCE.hs +7/−0
- src/Language/PureScript/DCE/Constants.hs +41/−0
- src/Language/PureScript/DCE/CoreFn.hs +260/−0
- src/Language/PureScript/DCE/Errors.hs +150/−0
- src/Language/PureScript/DCE/Eval.hs +546/−0
- src/Language/PureScript/DCE/Foreign.hs +195/−0
- src/Language/PureScript/DCE/Utils.hs +93/−0
- test/Main.hs +396/−0
- test/TestDCECoreFn.hs +125/−0
- test/TestDCEEval.hs +337/−0
- zephyr.cabal +161/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,81 @@+# zephyr+[](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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Command/DCE.hs view
@@ -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)
+ app/Command/DCEOptions.hs view
@@ -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+ }
+ app/Main.hs view
@@ -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
+ src/Language/PureScript/DCE.hs view
@@ -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
+ src/Language/PureScript/DCE/Constants.hs view
@@ -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"]
+ src/Language/PureScript/DCE/CoreFn.hs view
@@ -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)
+ src/Language/PureScript/DCE/Errors.hs view
@@ -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
+ src/Language/PureScript/DCE/Eval.hs view
@@ -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
+ src/Language/PureScript/DCE/Foreign.hs view
@@ -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
+ src/Language/PureScript/DCE/Utils.hs view
@@ -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
+ test/Main.hs view
@@ -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
+ test/TestDCECoreFn.hs view
@@ -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
+ test/TestDCEEval.hs view
@@ -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
+ zephyr.cabal view
@@ -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 <profunctor@pm.me>+maintainer: Marcin Szamotulski <profunctor@pm.me>+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