zephyr 0.2.1 → 0.3.1
raw patch · 23 files changed
+2745/−2319 lines, 23 filesdep +asyncdep −transformers-basedep −transformers-compatdep ~Globdep ~aesondep ~ansi-terminal
Dependencies added: async
Dependencies removed: transformers-base, transformers-compat
Dependency ranges changed: Glob, aeson, ansi-terminal, base, boxes, language-javascript, purescript, safe
Files
- README.md +32/−15
- app/Command/DCE.hs +0/−358
- app/Command/DCEOptions.hs +0/−18
- app/Command/Options.hs +165/−0
- app/Command/Run.hs +367/−0
- app/Main.hs +7/−4
- src/Language/PureScript/DCE/Constants.hs +15/−15
- src/Language/PureScript/DCE/CoreFn.hs +119/−114
- src/Language/PureScript/DCE/Errors.hs +43/−11
- src/Language/PureScript/DCE/Eval.hs +390/−311
- src/Language/PureScript/DCE/Foreign.hs +199/−141
- test/Generators.hs +0/−306
- test/Main.hs +14/−409
- test/Test/CoreFn.hs +188/−0
- test/Test/CoreLib.hs +156/−0
- test/Test/Eval.hs +339/−0
- test/Test/Generators.hs +319/−0
- test/Test/Karma.hs +93/−0
- test/Test/Lib.hs +84/−0
- test/Test/Utils.hs +150/−0
- test/TestDCECoreFn.hs +0/−190
- test/TestDCEEval.hs +0/−359
- zephyr.cabal +65/−68
README.md view
@@ -1,12 +1,11 @@ # zephyr [](http://github.com/coot)-[](https://travis-ci.org/coot/zephyr)-[](https://ci.appveyor.com/project/coot/zephyr)+ -Experimental tree shaking tool for [PureScript](https://github.com/purescript/purescript).+An experimental tree-shaking tool for [PureScript](https://github.com/purescript/purescript). # Usage-```+```sh # compile your project (or use `pulp build -- -g corefn`) purs compile -g corefn bower_components/purescript-*/src/**/*.purs src/**/*.purs @@ -19,13 +18,27 @@ or you can bundle with `pulp`: -```+```sh pulp browserify --skip-compile -o dce-output -t app.js ``` You can also specify modules as entry points, which is the same as specifying all exported identifiers. +```sh+# include all identifiers from Data.Eq module+zephyr Data.Eq++# as above+zephyr module:Data.Eq++# include Data.Eq.Eq identifier of Data.Eq module+zephyr ident:Data.Eq.Eq++# include Data.Eq.eq identifier (not the lower case of the identifier!)+zephyr Data.Eq.eq+```+ `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.@@ -41,7 +54,7 @@ else "api/dev/" ``` will be transformed to-```+```purescript a = "api/prod/" ``` whenever `isProduction` is `true`. This allows you to have different@@ -53,21 +66,25 @@ # 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`.+```sh+cabal build exe:zephyr+``` +To run tests++```sh+cabal run zephyr-test+```+ # Comments -The `-f` switch is not 100% safe. When on `zephyr` will remove exports from+The `-f` switch is not 100% safe. Upon running, `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+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.+The best practice is to run a JavaScript tree-shaking algorithm via `webpack` or +`rollup` on the JavaScript code that is pulled in your bundle by foreign imports.
− app/Command/DCE.hs
@@ -1,358 +0,0 @@--- | Dead code elimination command based on `Language.PureScript.CoreFn.DCE`.-module Command.DCE- ( 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.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSL.Char8 (unpack)-import qualified Data.ByteString.Lazy.UTF8 as BU8-import Data.Bool (bool)-import Data.Either (Either, lefts, rights, partitionEithers)-import Data.Foldable (traverse_)-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 qualified Data.Text.Lazy.Encoding as TE-import Data.Traversable (for)-import Data.Version (Version)-import Formatting (sformat, string, stext, (%))-import qualified Language.JavaScript.Parser as JS-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 ((</>))-import System.FilePath.Glob (compile, globDir1)-import System.IO (hPutStrLn, stderr)--import Command.DCEOptions-import Language.PureScript.DCE.Errors (EntryPoint (..))--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 or a module name. All code which is not a transitive dependency of an entry point (or any exported identifier from a give module) 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."- )--dceNoEvalOpt :: Opts.Parser Bool-dceNoEvalOpt = Opts.flag True False $- Opts.short 'e'- <> Opts.long "no-eval"- <> Opts.showDefault- <> Opts.internal- <> Opts.help "do not evaluate"--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.many entryPointOpt- <*> inputDirectoryOpt- <*> outputDirectoryOpt- <*> verboseOutputOpt- <*> dceForeignOpt- <*> pureScriptOptions- <*> (not <$> noPrefix)- <*> jsonErrors- <*> dceNoEvalOpt--readInput :: [FilePath] -> IO [Either (FilePath, JSONPath, String) (Version, CoreFn.Module CoreFn.Ann)]-readInput inputFiles = forM inputFiles (\f -> addPath f . decodeCoreFn <$> BSL.readFile f)- where- decodeCoreFn :: BSL.ByteString -> Either (JSONPath, String) (Version, CoreFn.Module CoreFn.Ann)- decodeCoreFn = eitherDecodeWith json (A.iparse CoreFn.moduleFromJSON)-- 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 . 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 --codegen corefn ..` or"- %"`pulp build -- --codegen 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---getEntryPoints- :: [CoreFn.Module CoreFn.Ann]- -> [EntryPoint]- -> [Either EntryPoint (P.Qualified P.Ident)]-getEntryPoints mods = go []- where- go acc [] = acc- go acc ((EntryPoint i) : eps) = - if i `fnd` mods- then go (Right i : acc) eps- else go (Left (EntryPoint i) : acc) eps- go acc ((EntryModule mn) : eps) = go (modExports mn mods ++ acc) eps-- modExports :: P.ModuleName -> [CoreFn.Module CoreFn.Ann] -> [Either EntryPoint (P.Qualified P.Ident)]- modExports mn [] = [Left (EntryModule mn)]- modExports mn (CoreFn.Module{moduleName,moduleExports} : ms)- | mn == moduleName- = (Right . flip P.mkQualified mn) `map` moduleExports- | otherwise- = modExports mn ms-- fnd :: P.Qualified P.Ident -> [CoreFn.Module CoreFn.Ann] -> Bool- fnd _ [] = False- fnd qi@(P.Qualified (Just mn) i) (CoreFn.Module{moduleName,moduleExports} : ms)- = if moduleName == mn && i `elem` moduleExports- then True- else fnd qi ms- fnd _ _ = False--dceCommand :: DCEOptions -> ExceptT DCEAppError IO ()-dceCommand DCEOptions {..} = do- -- initial checks- inptDirExist <- lift $ doesDirectoryExist dceInputDir- unless inptDirExist $- throwError (InputNotDirectory dceInputDir)-- -- read files, parse errors- let 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)-- let (notFound, entryPoints) = partitionEithers $ getEntryPoints (fmap snd . rights $ inpts) dceEntryPoints-- when (not $ null notFound) $- throwError (CompilationError $ EntryPointsNotFound notFound)-- when (null $ entryPoints) $- throwError (CompilationError $ NoEntryPoint)-- -- run `dceEval` and `dce` on the `CoreFn`- (mods, warns) <- mapExceptT (fmap $ first CompilationError)- $ runWriterT- $ if dceNoEval- then return $ dce (snd `map` rights inpts) entryPoints- else dceEval (snd `map` rights inpts) >>= return . 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-- -- copy externs files- -- we do not have access to data to regenerate extern files (they relay on- -- more information than is present in `CoreFn.Module`).- _ <- for mods $ \m -> lift $ do- let mn = P.runModuleName $ CoreFn.moduleName m- exts <- BSL.readFile (dceInputDir </> T.unpack mn </> "externs.json")- BSL.writeFile (dceOutputDir </> T.unpack mn </> "externs.json") exts-- when dceForeign $- forM_ mods $ \(CoreFn.Module{moduleName,moduleForeign}) -> liftIO $- case moduleName `M.lookup` foreigns of- Nothing -> return ()- Just fp -> do- jsCode <- BSL.Char8.unpack <$> BSL.readFile fp- case JS.parse jsCode fp of- Left _ -> return ()- Right (JS.JSAstProgram ss ann) ->- let ss' = dceForeignModule moduleForeign ss- jsAst' = JS.JSAstProgram ss' ann- foreignFile- = dceOutputDir </> T.unpack (P.runModuleName moduleName) </> "foreign.js"- in- BSL.writeFile foreignFile (TE.encodeUtf8 $ JS.renderToText jsAst')- Right _ -> return ()- 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
− app/Command/DCEOptions.hs
@@ -1,18 +0,0 @@--- |--- Helper module for `zephyr`.-module Command.DCEOptions where--import qualified Language.PureScript as P-import Language.PureScript.DCE.Errors (EntryPoint)--data DCEOptions = DCEOptions- { dceEntryPoints :: [EntryPoint]- , dceInputDir :: FilePath- , dceOutputDir :: FilePath- , dceVerbose :: Bool- , dceForeign :: Bool- , dcePureScriptOptions :: P.Options- , dceUsePrefix :: Bool- , dceJsonErrors :: Bool- , dceNoEval :: Bool- }
+ app/Command/Options.hs view
@@ -0,0 +1,165 @@+-- | `zephyr` command line option parser+--+module Command.Options+ ( Options (..)+ , parseOptions+ ) where++import Data.List (intercalate)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Traversable (for)++import qualified Language.PureScript as P+import Language.PureScript.DCE.Errors (EntryPoint (..))++import qualified Options.Applicative as Opts+++-- | @zephyr@ options+--+data Options = Options+ { optEntryPoints :: [EntryPoint]+ -- ^ List of entry points.+ , optInputDir :: FilePath+ -- ^ Input directory, default: @outout@.+ , optOutputDir :: FilePath+ -- ^ Output directory, default: @dce-output@.+ , optVerbose :: Bool+ -- ^ Verbose output.+ , optForeign :: Bool+ -- ^ Dead code eliminate foreign javascript module.+ , optPureScriptOptions :: P.Options+ -- ^ PureScription options+ , optUsePrefix :: Bool+ , optJsonErrors :: Bool+ -- ^ Print errors in `JSON` format; default 'False'.+ , optEvaluate :: Bool+ -- ^ Rewirite using an evaluation; it can reduce literal expressions; default+ -- 'False'.+ }+++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 or a module name (it may be prefixed with `ident:` or `module:`). All code which is not a transitive dependency of an entry point (or any exported identifier from a give module) 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."+ )++dceEvalOpt :: Opts.Parser Bool+dceEvalOpt = Opts.switch $+ Opts.short 'e'+ <> Opts.long "evaluate"+ <> Opts.showDefault+ <> Opts.help "rewrite using simple evaluation"++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)++parseOptions :: Opts.Parser Options+parseOptions = Options+ <$> Opts.many entryPointOpt+ <*> inputDirectoryOpt+ <*> outputDirectoryOpt+ <*> verboseOutputOpt+ <*> dceForeignOpt+ <*> pureScriptOptions+ <*> (not <$> noPrefix)+ <*> jsonErrors+ <*> dceEvalOpt+
+ app/Command/Run.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | Dead code elimination command based on `Language.PureScript.CoreFn.DCE`.+--+module Command.Run+ ( runZephyr+ ) where++import Control.Applicative ((<|>))+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.Exception+import Control.Concurrent.QSem+import qualified Control.Concurrent.Async as Async++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 qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL.Char8 (unpack)+import qualified Data.ByteString.Lazy.UTF8 as BU8+import Data.Bool (bool)+import Data.Either (Either, lefts, rights, partitionEithers)+import Data.Foldable (for_, traverse_)+import Data.List (null)+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Maybe (isNothing, listToMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Encoding as TE+import Data.Version (Version)+import Formatting (sformat, string, stext, (%))++import GHC.Conc.Sync (getNumCapabilities)++import qualified Language.PureScript.Docs.Types as Docs+import qualified Language.JavaScript.Parser as JS+import qualified Language.PureScript as P+import qualified Language.PureScript.CoreFn as CoreFn+import qualified Language.PureScript.CoreFn.FromJSON as CoreFn+import qualified Language.PureScript.Errors.JSON as P+import qualified System.Console.ANSI as ANSI+import System.Directory (copyFile, doesDirectoryExist, getCurrentDirectory, removeFile)+import System.Exit (exitFailure, exitSuccess)+import System.FilePath ((</>), (-<.>))+import System.FilePath.Glob (compile, globDir1)+import System.IO (hPutStrLn, stderr)++import Command.Options+import Language.PureScript.DCE.Errors (EntryPoint (..))++import Language.PureScript.DCE ( DCEError (..)+ , Level (..)+ )+import qualified Language.PureScript.DCE as DCE+++readInput :: [FilePath]+ -> IO [Either+ (FilePath, JSONPath, String)+ (Version, CoreFn.Module CoreFn.Ann)+ ]++readInput inputFiles = do+ -- limit parallelizm to at most the number of capablities+ sem <- getNumCapabilities >>= newQSem+ threads <-+ forM inputFiles $ \f -> do+ waitQSem sem+ mask $ \unmask -> Async.async $+ (unmask $ do+ c <- BSL.readFile f+ -- being strict here forces reading the file and promptly closing its file+ -- descriptor+ case decodeCoreFn c of+ Left (p, e) -> pure $ Left (f, p, e)+ Right r@(!_, !_) -> pure $ Right r+ )+ `finally`+ signalQSem sem+ forM threads Async.wait+ where+ decodeCoreFn :: BSL.ByteString+ -> Either (JSONPath, String)+ (Version, CoreFn.Module CoreFn.Ann)+ decodeCoreFn = eitherDecodeWith json (A.iparse CoreFn.moduleFromJSON)+++-- | Argumnets: verbose, use JSON, warnings, errors+--+printWarningsAndErrors+ :: Bool -- ^ be verbose+ -> Bool -- ^ use 'JSON'+ -> P.MultipleErrors -- ^ warnings+ -> Either P.MultipleErrors a -- ^ errors+ -> 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 . A.encode $+ P.JSONResult (P.toJSONErrors verbose P.Warning warnings)+ (either (P.toJSONErrors verbose P.Error) (const []) errors)+ either (const exitFailure) (const (return ())) errors+++-- | Application exception+--+data DCEAppError+ = ParseErrors ![Text]+ -- ^ parser errors+ | InputNotDirectory !FilePath+ -- ^ input directory does not exists (or is not a directory)+ | NoInputs !FilePath+ -- ^ no input files+ | DCEAppError !(DCEError 'Error)+ -- ^ PureScript errors+++-- | Render 'DCEAppError' as 'Text'+--+formatDCEAppError :: Options -> FilePath -> DCEAppError -> Text+formatDCEAppError opts _ (ParseErrors errs) =+ let errs' =+ if optVerbose 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)+ (DCE.colorString DCE.errorColor "Error")+ (T.intercalate "\n\t" errs')+formatDCEAppError _ _ (NoInputs path)+ = sformat+ (stext%": No inputs found under "%string%" directory.\n"+ %" Please run `purs compile --codegen corefn ..` or"+ %"`pulp build -- --codegen corefn`")+ (DCE.colorText DCE.errorColor "Error")+ (DCE.colorString DCE.codeColor path)+formatDCEAppError _ _ (InputNotDirectory path)+ = sformat+ (stext%": Directory "%string%" does not exists.")+ (DCE.colorText DCE.errorColor "Error")+ (DCE.colorString DCE.codeColor path)+formatDCEAppError _ relPath (DCEAppError err)+ = T.pack $ DCE.displayDCEError relPath err+++-- | Given list of modules and list of entry points, find qualilfied names of+-- roots.+--+getEntryPoints+ :: [CoreFn.Module CoreFn.Ann]+ -> [EntryPoint]+ -> [Either EntryPoint (P.Qualified P.Ident)]+getEntryPoints mods = go []+ where+ go acc [] = acc+ go acc ((EntryPoint i) : eps) =+ if i `fnd` mods+ then go (Right i : acc) eps+ else go (Left (EntryPoint i) : acc) eps+ go acc ((EntryModule mn) : eps) = go (modExports mn mods ++ acc) eps+ go acc ((err@EntryParseError{}) : eps) = go (Left err : acc) eps++ modExports :: P.ModuleName -> [CoreFn.Module CoreFn.Ann] -> [Either EntryPoint (P.Qualified P.Ident)]+ modExports mn [] = [Left (EntryModule mn)]+ modExports mn (CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleExports } : ms)+ | mn == moduleName+ = (Right . flip P.mkQualified mn) `map` moduleExports+ | otherwise+ = modExports mn ms++ fnd :: P.Qualified P.Ident -> [CoreFn.Module CoreFn.Ann] -> Bool+ fnd _ [] = False+ fnd qi@(P.Qualified (Just mn) i) (CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleExports } : ms)+ = if moduleName == mn && i `elem` moduleExports+ then True+ else fnd qi ms+ fnd _ _ = False+++dceCommand :: Options -> ExceptT DCEAppError IO ()+dceCommand Options { optEntryPoints+ , optInputDir+ , optOutputDir+ , optVerbose+ , optForeign+ , optPureScriptOptions+ , optUsePrefix+ , optJsonErrors+ , optEvaluate+ } = do+ -- initial checks+ inptDirExist <- lift $ doesDirectoryExist optInputDir+ unless inptDirExist $+ throwError (InputNotDirectory optInputDir)++ -- read files, parse errors+ let cfnGlb = compile "**/corefn.json"+ inpts0 <- liftIO $ globDir1 cfnGlb optInputDir >>= readInput+ -- force inputs sequentially+ inpts <- liftIO $ traverse evaluate inpts0+ let errs = lefts inpts+ unless (null errs) $+ throwError (ParseErrors $ formatError `map` errs)++ let mPursVer = fmap fst . listToMaybe . rights $ inpts+ when (isNothing mPursVer) $+ throwError (NoInputs optInputDir)++ let (notFound, entryPoints) =+ partitionEithers+ (getEntryPoints+ (fmap snd . rights $ inpts)+ optEntryPoints)++ when (not $ null notFound) $+ case filter DCE.isEntryParseError notFound of+ [] -> throwError (DCEAppError $ EntryPointsNotFound notFound)+ perrs ->+ let fn (EntryParseError s) acc = s : acc+ fn _ acc = acc+ in throwError (DCEAppError $ EntryPointsNotParsed (foldr fn [] perrs))++ when (null $ entryPoints) $+ throwError (DCEAppError NoEntryPoint)++ -- run `evaluate` and `runDeadCodeElimination` on `CoreFn` representation+ let mods = if optEvaluate+ then DCE.runDeadCodeElimination+ entryPoints+ (DCE.evaluate (snd `map` rights inpts))+ else DCE.runDeadCodeElimination+ entryPoints+ (snd `map` rights inpts)++ let filePathMap =+ M.fromList+ (map+ (\m -> (CoreFn.moduleName m, Right $ CoreFn.modulePath m))+ mods)+ foreigns <- P.inferForeignModules filePathMap+ let makeActions = (P.buildMakeActions optOutputDir filePathMap foreigns optUsePrefix)+ { P.ffiCodegen = \CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleForeign } -> liftIO $ do+ let codegenTargets = P.optionsCodegenTargets optPureScriptOptions+ when (S.member P.JS codegenTargets) $ do+ case moduleName `M.lookup` foreigns of+ -- run `runForeignModuleDeadCodeElimination`+ Just path | optForeign -> do+ jsCode <- BSL.Char8.unpack <$> BSL.readFile path+ case JS.parse jsCode path of+ Left _ -> return ()+ Right (JS.JSAstProgram ss ann) ->+ let ss' = DCE.runForeignModuleDeadCodeElimination moduleForeign ss+ jsAst' = JS.JSAstProgram ss' ann+ foreignFile = optOutputDir+ </> T.unpack (P.runModuleName moduleName)+ </> "foreign.js"+ in BSL.writeFile foreignFile (TE.encodeUtf8 $ JS.renderToText jsAst')+ Right _ -> return ()++ Just _path -> do+ let filePath = T.unpack (P.runModuleName moduleName)+ copyFile (optInputDir </> filePath </> "foreign.js")+ (optOutputDir </> filePath </> "foreign.js")++ Nothing -> pure ()+ }++ (makeErrors, makeWarnings) <-+ liftIO+ $ P.runMake optPureScriptOptions+ $ runSupplyT 0+ $ traverse+ (\m ->+ P.codegen makeActions m+ (Docs.Module (CoreFn.moduleName m) Nothing [] [])+ (moduleToExternsFile m))+ mods++ traverse_ (liftIO . P.runMake optPureScriptOptions . P.ffiCodegen makeActions) mods++ -- copy extern files; We do not have access to data to regenerate extern+ -- files (they relay on more information than is present in 'CoreFn.Module'+ -- represenation).+ for_ mods $ \m -> lift $ do+ let mn = CoreFn.moduleName m+ copyExterns mn "cbor" <|> do+ -- zephyr will always generate "externs.cbor" file, if we are working+ -- on a project using purescript-0.13.6 we need to remove it.+ removeFile (optOutputDir </> (T.unpack $ P.runModuleName mn) </> "externs.cbor")+ copyExterns mn "json"+ liftIO $+ printWarningsAndErrors+ (P.optionsVerboseErrors optPureScriptOptions)+ optJsonErrors+ (suppressFFIErrors makeWarnings)+ (either (Left . suppressFFIErrors) Right makeErrors)++ where++ formatError :: (FilePath, JSONPath, String) -> Text+ formatError (f, p, err) =+ if optVerbose+ then sformat (string%":\n "%string) f (A.formatError p err)+ else T.pack f++ copyExterns :: P.ModuleName -> String -> IO ()+ copyExterns mn extension = do+ let filePath = T.unpack . P.runModuleName $ mn+ copyFile (optInputDir </> filePath </> "externs" -<.> extension)+ (optOutputDir </> filePath </> "externs" -<.> extension)++ -- a hack: purescript codegen function reads FFI from disk, and checks+ -- against it.+ suppressFFIErrors :: P.MultipleErrors -> P.MultipleErrors+ suppressFFIErrors (P.MultipleErrors errs) = P.MultipleErrors $ filter fn errs+ where+ fn (P.ErrorMessage _ P.UnnecessaryFFIModule{}) = False+ fn (P.ErrorMessage _ P.UnusedFFIImplementations{}) = False+ fn _ = True++ moduleToExternsFile :: CoreFn.Module a -> P.ExternsFile+ moduleToExternsFile CoreFn.Module {CoreFn.moduleName} = P.ExternsFile {+ P.efVersion = mempty,+ P.efModuleName = moduleName,+ P.efExports = [],+ P.efImports = [],+ P.efFixities = [],+ P.efTypeFixities = [],+ P.efDeclarations = [],+ P.efSourceSpan = P.SourceSpan "none" (P.SourcePos 0 0) (P.SourcePos 0 0)+ }+++runZephyr+ :: Options+ -> IO ()+runZephyr opts = do+ res <- runExceptT $ dceCommand opts+ relPath <- getCurrentDirectory+ case res of+ Left e ->+ (hPutStrLn stderr . T.unpack . formatDCEAppError opts relPath $ e)+ *> exitFailure+ Right{} ->+ exitSuccess
app/Main.hs view
@@ -1,6 +1,5 @@-module Main where+module Main (main) where -import Command.DCE import Data.Monoid ((<>)) import Data.Version (showVersion) import qualified Options.Applicative as Opts@@ -8,15 +7,19 @@ import System.Environment (getArgs) import qualified System.IO as IO +import Command.Run+import Command.Options + main :: IO () main = do IO.hSetEncoding IO.stdout IO.utf8 IO.hSetEncoding IO.stderr IO.utf8- let pinfo = Opts.info (versionOpt <*> Opts.helper <*> dceOptions) (Opts.progDesc "tree shaking breeze for PureScript")+ let pinfo = Opts.info (versionOpt <*> Opts.helper <*> parseOptions)+ (Opts.progDesc "tree-shaking breeze for PureScript") getArgs >>= Opts.handleParseResult . execParserPure pinfo- >>= runDCECommand+ >>= runZephyr where execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a execParserPure pinfo [] = Opts.Failure $
src/Language/PureScript/DCE/Constants.hs view
@@ -7,46 +7,46 @@ import Language.PureScript.Names unit :: ModuleName-unit = ModuleName [ProperName "Data", ProperName "Unit"] +unit = ModuleName "Data.Unit" pattern Unit :: ModuleName-pattern Unit = ModuleName [ProperName "Data", ProperName "Unit"]+pattern Unit = ModuleName "Data.Unit" semigroup :: ModuleName-semigroup = ModuleName [ProperName "Data", ProperName "Semigroup"] +semigroup = ModuleName "Data.Semigroup" maybeMod :: ModuleName-maybeMod = ModuleName [ProperName "Data", ProperName "Maybe"] +maybeMod = ModuleName "Data.Maybe" pattern Semigroup :: ModuleName-pattern Semigroup = ModuleName [ProperName "Data", ProperName "Semigroup"] +pattern Semigroup = ModuleName "Data.Semigroup" semiring :: ModuleName-semiring = ModuleName [ProperName "Data", ProperName "Semiring"]+semiring = ModuleName "Data.Semiring" pattern Ring :: ModuleName-pattern Ring = ModuleName [ProperName "Data", ProperName "Ring"]+pattern Ring = ModuleName "Data.Ring" ring :: ModuleName-ring = ModuleName [ProperName "Data", ProperName "Ring"]+ring = ModuleName "Data.Ring" pattern Semiring :: ModuleName-pattern Semiring = ModuleName [ProperName "Data", ProperName "Semiring"]+pattern Semiring = ModuleName "Data.Semiring" pattern HeytingAlgebra :: ModuleName-pattern HeytingAlgebra = ModuleName [ProperName "Data", ProperName "HeytingAlgebra"]+pattern HeytingAlgebra = ModuleName "Data.HeytingAlgebra" heytingAlgebra :: ModuleName-heytingAlgebra = ModuleName [ProperName "Data", ProperName "HeytingAlgebra"]+heytingAlgebra = ModuleName "Data.HeytingAlgebra" pattern UnsafeCoerce :: ModuleName-pattern UnsafeCoerce = ModuleName [ProperName "Unsafe", ProperName "Coerce"]+pattern UnsafeCoerce = ModuleName "Unsafe.Coerce" unsafeCoerce :: ModuleName-unsafeCoerce = ModuleName [ProperName "Unsafe", ProperName "Coerce"]+unsafeCoerce = ModuleName "Unsafe.Coerce" eqMod :: ModuleName-eqMod = ModuleName [ProperName "Data", ProperName "Eq"]+eqMod = ModuleName "Data.Eq" pattern Eq :: ModuleName-pattern Eq = ModuleName [ProperName "Data", ProperName "Eq"]+pattern Eq = ModuleName "Data.Eq"
src/Language/PureScript/DCE/CoreFn.hs view
@@ -1,11 +1,11 @@ -- | -- Dead code elimination for `CoreFn`. module Language.PureScript.DCE.CoreFn- ( dce- , dceExpr+ ( runDeadCodeElimination+ , runBindDeadCodeElimination ) where -import Prelude.Compat+import Prelude.Compat hiding (mod) import Control.Arrow ((***)) import Control.Monad import Data.Graph@@ -19,142 +19,147 @@ type Key = Qualified Ident + data DCEVertex = BindVertex (Bind Ann) | ForeignVertex (Qualified Ident) --- |--- Dead code elimination of a list of modules module-dce- :: [Module Ann] -- ^ modules to dce- -> [Qualified Ident] -- ^ entry points used to build the graph of- -- dependencies across module boundaries- -> [Module Ann] -- ^ dead code eliminated modules-dce modules entryPoints = uncurry runDCE `map` reachableInModule++-- | Dead code elimination of a list of modules module+--+runDeadCodeElimination+ :: [Qualified Ident]+ -- ^ entry points used to build the graph of+ -- dependencies across module boundaries+ -> [Module Ann]+ -- ^ modules to dce+ -> [Module Ann]+ -- ^ dead code eliminated modules+runDeadCodeElimination entryPoints modules = uncurry runModuleDeadCodeElimination `map` reachableInModule where+ -- DCE of a single module.+ runModuleDeadCodeElimination+ :: [(DCEVertex, Key, [Key])]+ -- list of qualified names that has to be preserved+ -> Module Ann+ -> Module Ann+ runModuleDeadCodeElimination vs mod@Module{ moduleDecls+ , moduleExports+ , moduleImports+ , moduleName+ , moduleForeign+ } = + let+ -- | filter declarations preserving the order+ moduleDecls' :: [Bind Ann]+ moduleDecls' = runBindDeadCodeElimination `map` filter filterByIdents moduleDecls+ where+ declIdents :: [Ident]+ declIdents = concatMap toIdents vs - -- |- -- 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 _ = [] - toIdents :: (DCEVertex, Key, [Key]) -> [Ident]- toIdents (BindVertex b, _, _) = bindIdents b- toIdents _ = []+ filterByIdents :: Bind Ann -> Bool+ filterByIdents = any (`elem` declIdents) . bindIdents - filterByIdents :: Bind Ann -> Bool- filterByIdents = any (`elem` declIdents) . bindIdents+ idents :: [Ident]+ idents = concatMap bindIdents moduleDecls' - idents :: [Ident]- idents = concatMap bindIdents moduleDecls'+ moduleExports' :: [Ident]+ moduleExports' =+ filter (`elem` (idents ++ moduleForeign')) moduleExports - moduleExports' :: [Ident]- moduleExports' =- filter (`elem` (idents ++ moduleForeign')) moduleExports+ mods :: [ModuleName]+ mods = mapMaybe getQual (concatMap (\(_, _, ks) -> ks) vs) - mods :: [ModuleName]- mods = mapMaybe getQual (concatMap (\(_, _, ks) -> ks) vs)+ moduleImports' :: [(Ann, ModuleName)]+ moduleImports' = filter ((`elem` mods) . snd) moduleImports - 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 - 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 mod { moduleImports = moduleImports'+ , moduleExports = moduleExports'+ , moduleForeign = moduleForeign'+ , moduleDecls = moduleDecls'+ } - in Module- moduleSourceSpan- moduleComments- moduleName- modulePath- moduleImports'- moduleExports'- moduleForeign'- moduleDecls'+ (graph, keyForVertex, vertexForKey) = graphFromEdges verts - (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 - -- | 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 []) - -- | 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 _ = [] - -- | 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 _ = [] - 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) - -- | 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) - -- | 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) - 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 - getModuleName :: [(DCEVertex, Key, [Key])] -> Maybe ModuleName- getModuleName [] = Nothing- getModuleName ((_, k, _) : _) = getQual k --- |--- Dead code elimination of local identifiers in `Bind`s, which detects and+-- | Dead code elimination of local identifiers in `Bind`s, which detects and -- removes unused bindings.-dceExpr :: Bind Ann -> Bind Ann-dceExpr = go+--+runBindDeadCodeElimination :: Bind Ann -> Bind Ann+runBindDeadCodeElimination = go where (go, _, _) = everywhereOnValues id exprFn id
src/Language/PureScript/DCE/Errors.hs view
@@ -3,6 +3,7 @@ module Language.PureScript.DCE.Errors ( EntryPoint (..) , showEntryPoint+ , isEntryParseError , DCEError(..) , displayDCEError , displayDCEWarning@@ -17,8 +18,8 @@ import Prelude.Compat -import Data.Char (isLower, isSpace)-import Data.List (intersperse, dropWhileEnd)+import Data.Char (isLower, isUpper, isSpace)+import Data.List (dropWhileEnd, findIndex, intersperse) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T@@ -36,29 +37,55 @@ data EntryPoint = EntryPoint (Qualified Ident) | EntryModule ModuleName+ | EntryParseError String deriving Show +isEntryParseError :: EntryPoint -> Bool+isEntryParseError (EntryParseError _) = True+isEntryParseError _ = False+ showEntryPoint :: EntryPoint -> Text showEntryPoint (EntryPoint qi) = showQualified showIdent qi showEntryPoint (EntryModule mn) = runModuleName mn+showEntryPoint (EntryParseError s) = T.pack s instance Read EntryPoint where- readsPrec _ s = case unsnoc (T.splitOn "." (T.pack s)) of+ readsPrec _ s+ | Just idx <- findIndex (== ':') s+ = case take idx s of+ "ident"+ -> case unsnoc (T.splitOn "." (T.pack $ drop (idx + 1) s)) of+ Just (as, a)+ | not (null as)+ , True <- not (T.null a)+ -> [(EntryPoint (mkQualified (Ident a) (ModuleName $ T.intercalate "." as)), "")]+ _ -> [(EntryParseError s, "")]+ "module"+ -> case unsnoc (T.splitOn "." (T.pack $ drop (idx + 1) s)) of+ Just (as, a)+ | not (null as)+ , True <- not (T.null a)+ , True <- isUpper (T.head a)+ -> [(EntryModule $ ModuleName $ T.intercalate "." (as ++ [a]), "")]+ _ -> [(EntryParseError s, "")]+ _ -> [(EntryParseError s, "")]+ readsPrec _ s+ = case unsnoc (T.splitOn "." (T.pack s)) of Just (as, a) | not (null as) , True <- not (T.null a) , True <- isLower (T.head a)- -> [(EntryPoint (mkQualified (Ident a) (ModuleName $ ProperName <$> as)), "")]+ -> [(EntryPoint (mkQualified (Ident a) (ModuleName $ T.intercalate "." as)), "")] | True <- not (T.null a)- -> [(EntryModule $ ModuleName $ ProperName <$> as ++ [a], "")]+ -> [(EntryModule $ ModuleName $ T.intercalate "." (as ++ [a]), "")] | otherwise- -> []- Nothing -> []- where- unsnoc :: [a] -> Maybe ([a], a)- unsnoc [] = Nothing- unsnoc as = Just (init as, last as)+ -> [(EntryParseError s, "")]+ Nothing -> [(EntryParseError s, "")] +unsnoc :: [a] -> Maybe ([a], a)+unsnoc [] = Nothing+unsnoc as = Just (init as, last as)+ -- | -- Error type shared by `dce` and `dceEval`. data DCEError (a :: Level)@@ -66,6 +93,7 @@ | ArrayIdxOutOfBound ModuleName Ann Integer | AccessorNotFound ModuleName Ann PSString | NoEntryPoint+ | EntryPointsNotParsed [String] | EntryPointsNotFound [EntryPoint] deriving (Show) @@ -91,6 +119,10 @@ Box.<+> colorBox codeColor (T.unpack $ prettyPrintString acc) Box.<> "." formatDCEError NoEntryPoint = "No entry point given."+formatDCEError (EntryPointsNotParsed eps) =+ Box.text ("Parsing error for entry point" ++ if length eps > 1 then "s:" else "")+ Box.<+> foldr1 (Box.<>) (intersperse (Box.text ", ")+ $ map (colorBox codeColor) eps) formatDCEError (EntryPointsNotFound eps) = Box.text ("Entry point" ++ if length eps > 1 then "s:" else "") Box.<+> foldr1 (Box.<>) (intersperse (Box.text ", ")
src/Language/PureScript/DCE/Eval.hs view
@@ -1,53 +1,86 @@--- |--- Evaluation of PureScript's expressions used in dead call elimnation.+-- | Evaluation of PureScript's expressions used in dead call elimnation.+-- module Language.PureScript.DCE.Eval- ( dceEval ) where+ ( evaluate ) where +import Control.Applicative ((<|>))+import Control.Exception (Exception (..), throw) import Control.Monad-import Control.Monad.Except-import Control.Monad.State import Control.Monad.Writer-import Data.Functor (($>))-import Data.Maybe (fromMaybe)++import Data.List (find)+import Data.Maybe (Maybe(..), fromMaybe)+import Data.Monoid (First(..))+import qualified Data.Text as T+import qualified Language.PureScript.DCE.Constants as C+import Prelude.Compat hiding (mod)+import Safe (atMay)+ import Language.PureScript.AST.Literals import Language.PureScript.CoreFn-import Language.PureScript.DCE.Errors+--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 qualified Language.PureScript.DCE.Constants as C-import Prelude.Compat hiding (mod)-import Safe (atMay) data EvalState = NotYet -- ^ an expression has not yet been evaluated | Done -- ^ an expression has been evaluated deriving (Eq, Show) -type Stack = [[(Ident, (Expr Ann, EvalState))]] -initStack :: [(Ident, Expr Ann)] -> [(Ident, (Expr Ann, EvalState))]-initStack = map (\(i, e) -> (i, (e, NotYet)))+data StackT frame =+ EmptyStack+ | ConsStack !frame !(StackT frame)+ deriving (Show, Functor) ++type Stack = StackT [((Ident, Expr Ann), EvalState)]++-- | Errors thrown by the evaluation.+--+data EvaluationError+ = QualifiedExpresionError Ann (Qualified Ident) ![ModuleName]+ -- ^ qualified expression not found in the list of modules+ | OutOfBoundArrayIndex Ann+ -- ^ out of bound array index+ | NotFoundRecordField Ann PSString+ -- ^ record field not found+ deriving Show++instance Exception EvaluationError+++pushStack :: [(Ident, Expr Ann)]+ -> Stack+ -> Stack+pushStack frame st = map (\s -> (s, NotYet)) frame `ConsStack` st+++lookupStack :: Ident+ -> Stack+ -> Maybe ((Ident, Expr Ann), EvalState)+lookupStack _i EmptyStack = Nothing+lookupStack i (ConsStack f fs) = case find (\((i', _), _) -> i == i') f of+ Nothing -> lookupStack i fs+ Just x -> Just x++ -- Mark first found expression as evaluated to avoid infinite loops. markDone :: Ident -> Stack -> Stack-markDone _ [] = []-markDone i (l : ls) =- case foldr fn ([], False) l of- (l', True) -> l' : ls- (l', False) -> l' : markDone i ls+markDone _ EmptyStack = EmptyStack+markDone i (ConsStack l ls) =+ case foldr fn ([], False) l of+ (l', True) -> ConsStack l' ls+ (l', False) -> ConsStack l' (markDone i ls) where- fn (i', v) (is, done)- | i == i' = ((i', (fst v, Done)) : is, True)- | otherwise = ((i', v) : is, done)+ fn x@(a@(i', _), _) (is, done)+ | i == i' = ((a, Done) : is, True)+ | otherwise = (x : is, done) --- |--- Evaluate expressions in a module:++-- | Evaluate expressions in a module: -- -- * @Data.Eq.eq@ of two literals -- * @Data.Array.index@ on a literal array@@ -56,145 +89,196 @@ -- * 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+-- the ones that are comming from abstractions (we are not reducing+-- applications).+--+evaluate :: [Module Ann] -> [Module Ann]++evaluate mods = rewriteModule `map` 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`)+ rewriteModule :: Module Ann -> Module Ann+ rewriteModule mod@Module{ moduleName, moduleDecls } =+ mod { moduleDecls = rewriteBind moduleName `map` moduleDecls } - onBind :: Bind Ann -> StateT (ModuleName, Stack) m (Bind Ann)- onBind b = modify (second (initStack (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 (initStack 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)+ rewriteBind :: ModuleName+ -> Bind Ann -> Bind Ann+ rewriteBind mn (NonRec a i e) =+ NonRec a i (rewriteExpr mn EmptyStack 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+ rewriteBind mn (Rec binds') =+ Rec [ rewriteExpr mn stack <$> bind'+ | bind' <- binds' + ]+ where+ stack = pushStack ((\((_, i), e) -> (i, e)) `map` binds')+ EmptyStack+++ -- Push identifiers defined in binders onto the stack+ pushBinders :: [Expr Ann] -> [Binder Ann] -> Stack -> Stack+ pushBinders es bs = pushStack (concatMap fn (zip bs es))+ 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 `pushBinders` and poped in the+ -- `everywhereOnValuesM` monadic action.+ --+ rewriteExpr :: ModuleName -> Stack+ -> Expr Ann -> Expr Ann+ rewriteExpr mn st c@(Case ann es cs) =+ -- purescript is a strict language, so we can take advantage of that+ -- and evalute all the expressions now+ let es' :: [Maybe (Expr Ann)]+ es' = eval mods mn st `map` es+ in case traverse (join . fmap fltLiteral) es' of+ Nothing ->+ -- remove cases whcich do not match+ Case ann es+ $ filter+ (fltBinders ((>>= fltLiteral) `map` es') . caseAlternativeBinders)+ cs+ Just es'' ->+ -- all es evaluated to a literal, we can try to find the matching+ -- `CaseAlternative`+ case foldMap (fndCase es'') cs of+ First Nothing -> c+ First (Just (CaseAlternative bs (Right e)))+ -- we found a matching `CaseAlternative`, we can eliminate the case+ -- expression+ -> rewriteExpr mn (pushBinders es'' bs st) e+ First (Just (CaseAlternative bs (Left gs)))+ -- we found a matching `CaseAlternative` with guards; we can+ -- simplify the case expression and the list of guards+ -> Case ann es [CaseAlternative bs (Left (fltGuards mn (pushBinders es bs st) gs))]++ -- todo: evaluate bindings+ rewriteExpr mn st (Let ann bs e) =+ Let ann bs+ (rewriteExpr mn (pushStack (concatMap unBind bs) st) e)++ rewriteExpr mn st e@Var{} =+ case eval mods mn st e of+ Just l@(Literal _ NumericLiteral{}) -> l+ Just l@(Literal _ CharLiteral{}) -> l+ Just l@(Literal _ BooleanLiteral{}) -> l+ -- preserve string, array and object literals+ Just _ -> e+ Nothing -> e++ rewriteExpr mn st e =+ case eval mods mn st e of+ Just l -> l+ Nothing -> e++ fltBinders :: [Maybe (Expr Ann)]+ -> [Binder Ann]+ -> Bool+ fltBinders (Just (Literal _ l1) : ts) (LiteralBinder _ l2 : bs) =+ l1 `eqLit` l2 && fltBinders ts bs+ fltBinders _ _ = True+ 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+ :: ModuleName+ -> Stack+ -> [(Guard Ann, Expr Ann)]+ -> [(Guard Ann, Expr Ann)]+ fltGuards _ _ [] = []+ fltGuards mn st (guard'@(g, e) : rest) =+ case eval mods mn st g of Just (Literal _ t) | t `eqLit` BooleanLiteral True- -> return [(Literal (extractAnn g) (BooleanLiteral True), e)]+ -> [(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+ -> fltGuards mn st rest+ _ -> guard' : fltGuards mn st rest - -- |- -- 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, EvalState)- fnd j s = getFirst $ foldMap (First . lookup j) s+ fltLiteral :: Expr Ann -> Maybe (Expr Ann)+ fltLiteral e@Literal {} = Just e+ fltLiteral _ = Nothing - eval' :: (Expr Ann, EvalState) -> StateT (ModuleName, Stack) m (Maybe (Expr Ann))- eval' (e, Done) = return (Just e)- eval' (e, _) = do- modify (\(mn, s) -> (mn, markDone i s))- eval e- 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 (Literal ann (ArrayLiteral es)) = do- es' <- traverse (\e -> fromMaybe e <$> eval e) es- return $ Just (Literal ann (ArrayLiteral es'))- eval (Literal ann (ObjectLiteral as)) = do- as' <- traverse (\(n, e) -> maybe (n,e) ((n,)) <$> eval e) as- return $ Just (Literal ann (ObjectLiteral as'))- eval e@Literal{} = return (Just e)- eval+ -- match a list of literal expressions against a case alternative+ fndCase :: [Expr Ann] -> CaseAlternative Ann -> First (CaseAlternative Ann)+ fndCase as c =+ if as `matches` caseAlternativeBinders c+ then First (Just c)+ else First Nothing+ where+ matches :: [Expr Ann] -> [Binder Ann] -> Bool+ matches [] [] = True+ matches [] _ = error "impossible happend: not matching case expressions and case alternatives"+ matches _ [] = error "impossible happend: not matching case expressions and case alternatives"+ matches (Literal _ t:ts) (LiteralBinder _ t' : bs) = t `eqLit` t' && matches ts bs+ matches (Literal _ t:ts) (NamedBinder _ _ (LiteralBinder _ t') : bs) = t `eqLit` t' && matches ts bs+ matches (Literal {}:ts) (_:bs) = matches ts bs+ matches (_:_) (_:_) = False+++-- | Evaluate an expresion+--+-- * `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 :: [Module Ann]+ -> ModuleName+ -> Stack+ -> Expr Ann+ -> Maybe (Expr Ann)++-- eval _ _ _ _ = Nothing -- TODO: testing without evaluation++eval mods mn st (Var _ (Qualified Nothing i)) = + case lookupStack i st of+ Nothing -> Nothing+ Just ((_, e), Done) -> Just e+ Just ((_, e), NotYet) -> eval mods mn (markDone i st) e++eval mods mn st (Var ann qi@(Qualified (Just imn) i)) =+ case lookupQualifiedExpr mods imn i of+ Nothing -> throw (QualifiedExpresionError ann qi (moduleName `map` mods))+ Just (FoundExpr e) -> eval mods mn st e+ Just Found -> Nothing++eval mods mn st (Literal ann (ArrayLiteral es)) =+ let es' = map (\e -> fromMaybe e $ eval mods mn st e) es+ in Just (Literal ann (ArrayLiteral es'))++eval mods mn st (Literal ann (ObjectLiteral as)) =+ let as' = map (\x@(n, e) ->+ case eval mods mn st e of+ Nothing -> x+ Just e' -> (n, e')+ ) as+ in Just (Literal ann (ObjectLiteral as'))++eval _mods _mn _st e@Literal{} = Just e++eval mods mn st (Accessor ann a (Literal _ (ObjectLiteral as))) =+ case a `lookup` as of+ -- this cannot happen, unless an unsafe usage of ffi+ Nothing -> throw (NotFoundRecordField ann a)+ Just e -> eval mods mn st e++--+-- evaluate boolean operations+--+eval mods mn st (App ann (App _ (App _@@ -204,8 +288,8 @@ (Ident "eq"))) (Var _ inst)) e1)- e2)- = if inst `elem`+ e2) =+ if inst `elem` [ Qualified (Just C.eqMod) (Ident "eqBoolean") , Qualified (Just C.eqMod) (Ident "eqInt") , Qualified (Just C.eqMod) (Ident "eqNumber")@@ -214,41 +298,39 @@ , Qualified (Just C.eqMod) (Ident "eqUnit") , Qualified (Just C.eqMod) (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- 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 C.maybeMod)- (Ident "Just")))- <$> e- -- | Eval Semigroup- eval+ then case (eval mods mn st e1, eval mods mn st e2) of+ (Just (Literal _ l1), Just (Literal _ l2))+ -> Just $ Literal ann $ BooleanLiteral (eqLit l1 l2)+ _ -> Nothing+ else Nothing++--+-- evaluate array indexing+--+eval mods mn st+ (App _+ (App _+ (Var ann@(ss, _, _, _)+ (Qualified+ (Just (ModuleName "Data.Array"))+ (Ident "index")))+ (Literal _ (ArrayLiteral as)))+ (Literal _ (NumericLiteral (Left x)))) =+ case (as `atMay` fromIntegral x) of+ Nothing -> throw (OutOfBoundArrayIndex ann)+ Just e -> case eval mods mn st e of+ Nothing -> Nothing+ Just e' ->+ Just $ App ann+ (Var (ss, [], Nothing, Just (IsConstructor SumType [Ident "value0"]))+ (Qualified+ (Just C.maybeMod)+ (Ident "Just")))+ e'+--+-- evalualte semigroup operations+--+eval _ _ms _st (App ann (App _ (App _@@ -259,19 +341,22 @@ | qi == Qualified (Just C.semigroup) (Ident "semigroupArray") , Literal _ (ArrayLiteral a1) <- e1 , Literal _ (ArrayLiteral a2) <- e2- = return $ Just $ Literal ann (ArrayLiteral $ a1 ++ a2)+ = 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) )+ = Just $ Literal ann (StringLiteral (mkString $ t1 <> t2) ) | qi == Qualified (Just C.semigroup) (Ident "semigroupUnit")- = return $ Just $ Var ann (Qualified (Just C.unit) (Ident "unit"))+ = Just $ Var ann (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- -- | Eval Semiring- eval+ = Nothing++--+-- evalulate semiring operations+--+eval _ _mn _st (App (ss, c, _, _) (App _ (App _@@ -282,60 +367,63 @@ | qi == Qualified (Just C.semiring) (Ident "semiringInt") , Literal _ (NumericLiteral (Left a1)) <- e1 , Literal _ (NumericLiteral (Left a2)) <- e2- = return $ Just $ Literal+ = 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+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (a1 + a2))) | qi == Qualified (Just C.semiring) (Ident "semiringUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _ _mn _st (App (ss, c, _, _) (Var _ (Qualified (Just C.Semiring) (Ident "zero"))) (Var _ qi)) | qi == Qualified (Just C.semiring) (Ident "semiringInt")- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left 0)) | qi == Qualified (Just C.semiring) (Ident "semiringNumber")- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right 0.0)) | qi == Qualified (Just C.semiring) (Ident "semiringUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _ _mn _st (App (ss, c, _, _) (Var _ (Qualified (Just C.Semiring) (Ident "one"))) (Var _ qi)) | qi == Qualified (Just C.semiring) (Ident "semiringInt")- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left 1)) | qi == Qualified (Just C.semiring) (Ident "semiringNumber")- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right 1.0)) | qi == Qualified (Just C.semiring) (Ident "semiringUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _ _mn _st (App (ss, c, _, _) (App _ (App _@@ -346,23 +434,26 @@ | qi == Qualified (Just C.semiring) (Ident "semiringInt") , Literal _ (NumericLiteral (Left a1)) <- e1 , Literal _ (NumericLiteral (Left a2)) <- e2- = return $ Just $ Literal+ = 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+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (a1 * a2))) | qi == Qualified (Just C.semiring) (Ident "semiringUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- -- || Eval Ring- eval+ = Nothing++--+-- evaluate ring operations+--+eval _ _mn _st (App (ss, c, _, _) (App _ (App _@@ -373,20 +464,21 @@ | qi == Qualified (Just C.ring) (Ident "ringInt") , Literal _ (NumericLiteral (Left a1)) <- e1 , Literal _ (NumericLiteral (Left a2)) <- e2- = return $ Just $ Literal+ = 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+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (a1 / a2))) | qi == Qualified (Just C.ring) (Ident "unitRing")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit"))- eval++eval _ _mn _st (App (ss, c, _, _) (App _ (Var _ (Qualified (Just C.Ring) (Ident "negate")))@@ -394,44 +486,49 @@ e) | qi == Qualified (Just C.ring) (Ident "ringInt") , Literal _ (NumericLiteral (Left a)) <- e- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Left (-a))) | qi == Qualified (Just C.ring) (Ident "ringNumber") , Literal _ (NumericLiteral (Right a)) <- e- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (NumericLiteral (Right (-a))) | qi == Qualified (Just C.ring) (Ident "unitRing")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit"))- -- | Eval HeytingAlgebra- eval++--+-- evaluate Heyting algebras operations+--+eval _ _mn _st (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)+ = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral False) | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _ _mn _st (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)+ = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral True) | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _mods _mn _st (App (ss, c, _, _) (App _ (Var _ (Qualified (Just C.HeytingAlgebra) (Ident "not")))@@ -439,16 +536,17 @@ e) | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b) <- e- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (not b)) | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _mods _mn _st (App (ss, c, _, _) (App _ (App _@@ -459,16 +557,17 @@ | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b1) <- e1 , Literal _ (BooleanLiteral b2) <- e2- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (not b1 && b2)) | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _mods _mn _st (App (ss, c, _, _) (App _ (App _@@ -479,16 +578,17 @@ | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b1) <- e1 , Literal _ (BooleanLiteral b2) <- e2- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (b1 || b2)) | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval+ = Nothing++eval _mods _mn _st (App (ss, c, _, _) (App _ (App _@@ -499,78 +599,57 @@ | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraBoolean") , Literal _ (BooleanLiteral b1) <- e1 , Literal _ (BooleanLiteral b2) <- e2- = return $ Just $ Literal+ = Just $ Literal (ss, c, Nothing, Nothing) (BooleanLiteral (b1 && b2)) | qi == Qualified (Just C.heytingAlgebra) (Ident "heytingAlgebraUnit")- = return $ Just $ Var+ = Just $ Var (ss, c, Nothing, Nothing) (Qualified (Just C.unit) (Ident "unit")) | otherwise- = return Nothing- eval _ = return Nothing+ = 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+--+-- default case (no evaluation)+--+eval _ _ _ _ = Nothing - 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+-- | Lookup result, either with or without the evidence.+--+data LookupResult =+ FoundExpr !(Expr Ann)+ | Found - 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 `Found` for+-- `Prim` values, generics and foreign imports, `Right` for found bindings.+--+lookupQualifiedExpr :: [Module Ann]+ -> ModuleName+ -> Ident+ -> Maybe LookupResult+lookupQualifiedExpr _ (ModuleName mn) _+ | "Prim" : _ <- T.splitOn "." mn+ = Just Found+lookupQualifiedExpr _ (ModuleName "Data.Generic") (Ident "anyProxy") =+ Just Found+lookupQualifiedExpr mods mn i =+ (mod >>= fmap FoundExpr+ . lookup i+ . concatMap unBind+ . moduleDecls)+ <|> (mod >>= fmap (const Found)+ . find (== i)+ . moduleForeign)+ where+ mod = find (\m -> moduleName m == mn) mods - -- |- -- 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+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
src/Language/PureScript/DCE/Foreign.hs view
@@ -2,8 +2,9 @@ -- | -- Simple dead call elimination in foreign modules.-module Language.PureScript.DCE.Foreign - ( dceForeignModule ) where+module Language.PureScript.DCE.Foreign+ ( runForeignModuleDeadCodeElimination+ ) where import Prelude.Compat import Control.Monad@@ -25,6 +26,10 @@ , JSObjectProperty(..) , JSCommaTrailingList(..) , JSCommaList(..)+ , JSMethodDefinition(..)+ , JSClassElement(..)+ , JSClassHeritage(..)+ , JSTemplatePart(..) ) import Language.PureScript.Names @@ -34,163 +39,216 @@ 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+-- | 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-+--+runForeignModuleDeadCodeElimination :: [Ident] -> [JSStatement] -> [JSStatement]+runForeignModuleDeadCodeElimination 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+ 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+ 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+ -- 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+ nonExps = filter (not . isExportStatement) stmts - (graph, _, vertexForKey) = graphFromEdges verts+ (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+ 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+ 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+ 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+ 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+ 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+ 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 if (export) identifier is used within a JSStatement.+ isUsedInStmt :: Text -> JSStatement -> Bool+ isUsedInStmt n (JSStatementBlock _ ss _ _) = any (isUsedInStmt n) ss+ isUsedInStmt n (JSLet _ es _) = isUsedInExprs n es+ isUsedInStmt n (JSClass _ _ h _ cs _ _) =+ isUsedInClassHeritage n h || any (isUsedInClassElement n) cs+ 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 (JSForLet _ _ _ es1 _ es2 _ es3 _ s) =+ isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 ||+ isUsedInStmt n s+ isUsedInStmt n (JSForLetIn _ _ _ e1 _ e2 _ s) =+ isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s+ isUsedInStmt n (JSForLetOf _ _ _ e1 _ e2 _ s) =+ isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s+ isUsedInStmt n (JSForConst _ _ _ es1 _ es2 _ es3 _ s) =+ isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s+ isUsedInStmt n (JSForConstIn _ _ _ e1 _ e2 _ s) =+ isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s+ isUsedInStmt n (JSForConstOf _ _ _ e1 _ e2 _ s) =+ isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s+ isUsedInStmt n (JSForOf _ _ e1 _ e2 _ s) =+ isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s+ isUsedInStmt n (JSForVarOf _ _ _ e1 _ e2 _ s) =+ isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s+ isUsedInStmt n (JSAsyncFunction _ _ _ _ es _ (JSBlock _ ss _) _) =+ isUsedInExprs n es || any (isUsedInStmt n) ss+ isUsedInStmt n (JSFunction _ _ _ es _ (JSBlock _ ss _) _) =+ isUsedInExprs n es || any (isUsedInStmt n) ss+ isUsedInStmt n (JSGenerator _ _ _ _ es _ (JSBlock _ ss _) _) =+ isUsedInExprs n es || 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+ -- Check if an exported identifier is used within 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 (JSAwaitExpression _ e) = isUsedInExpr n e+ 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 (JSClassExpression _ _ h _ cs _) =+ isUsedInClassHeritage n h || any (isUsedInClassElement n) cs+ 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 (JSArrowExpression _ _ s) = isUsedInStmt n s+ isUsedInExpr n (JSFunctionExpression _ _ _ _ _ (JSBlock _ ss _)) = any (isUsedInStmt n) ss+ isUsedInExpr n (JSGeneratorExpression _ _ _ _ es _ (JSBlock _ ss _)) =+ isUsedInExprs n es || 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 (JSSpreadExpression _ e) = isUsedInExpr n e+ isUsedInExpr n (JSTemplateLiteral me _ _ tps) =+ any (isUsedInExpr n) me || any (\(JSTemplatePart e _ _) -> isUsedInExpr n e) tps+ 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+ isUsedInExpr n (JSYieldExpression _ me) = any (isUsedInExpr n) me+ isUsedInExpr n (JSYieldFromExpression _ _ e) = isUsedInExpr n e - isUsedInExprs :: Text -> JSCommaList JSExpression -> Bool- isUsedInExprs n es = foldrJSCommaList fn es False- where- fn :: JSExpression -> Bool -> Bool- fn e b = isUsedInExpr n e || b+ 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 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 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 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 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+ -- |+ -- Check if (export) identifier is used withing a JSObjectProperty+ isUsedInObjectProperty :: Text -> JSObjectProperty -> Bool+ isUsedInObjectProperty n (JSPropertyNameandValue _ _ es) = any (isUsedInExpr n) es+ isUsedInObjectProperty _ JSPropertyIdentRef{} = False+ isUsedInObjectProperty n (JSObjectMethod m) = isUsedInMethodDefinition n m++ isUsedInMethodDefinition :: Text -> JSMethodDefinition -> Bool+ isUsedInMethodDefinition n (JSMethodDefinition _ _ es _ (JSBlock _ ss _))+ = isUsedInExprs n es || any (isUsedInStmt n) ss+ isUsedInMethodDefinition n (JSGeneratorMethodDefinition _ _ _ es _ (JSBlock _ ss _))+ = isUsedInExprs n es || any (isUsedInStmt n) ss+ isUsedInMethodDefinition n (JSPropertyAccessor _ _ _ es _ (JSBlock _ ss _))+ = isUsedInExprs n es || any (isUsedInStmt n) ss++ isUsedInClassElement :: Text -> JSClassElement -> Bool+ isUsedInClassElement n (JSClassInstanceMethod m) = isUsedInMethodDefinition n m+ isUsedInClassElement n (JSClassStaticMethod _ m) = isUsedInMethodDefinition n m+ isUsedInClassElement _ JSClassSemi{} = False++ isUsedInClassHeritage :: Text -> JSClassHeritage -> Bool+ isUsedInClassHeritage n (JSExtends _ e) = isUsedInExpr n e+ isUsedInClassHeritage _ JSExtendsNone = False
− test/Generators.hs
@@ -1,306 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-module Generators where--import Data.List (foldl')-import Data.String (IsString (..))-import Test.QuickCheck--import Language.PureScript.Names (Ident (..), ModuleName (..), ProperName (..), Qualified (..), moduleNameFromString)-import Language.PureScript.PSString (PSString)-import Language.PureScript.AST.SourcePos (SourceSpan (..), SourcePos (..))-import Language.PureScript.AST (Literal (..))-import Language.PureScript.CoreFn (Ann, Bind (..), Binder (..), CaseAlternative (..), Expr (..), Guard, ssAnn)--import qualified Language.PureScript.DCE.Constants as C--ann :: Ann-ann = ssAnn (SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0))--genPSString :: Gen PSString-genPSString = fromString <$> elements- ["a", "b", "c", "d", "value0"]--genProperName :: Gen (ProperName a)-genProperName = ProperName <$> elements- ["A", "B", "C", "D", "E"]--genIdent :: Gen Ident-genIdent = Ident <$> elements- ["value0", "value1", "value2"]--unusedIdents :: [Ident]-unusedIdents =- Ident <$> ["u1", "u2", "u3", "u4", "u5"]--genUnusedIdent :: Gen Ident-genUnusedIdent = elements unusedIdents--genModuleName :: Gen ModuleName-genModuleName = elements- [ moduleNameFromString "Data.Eq"- , moduleNameFromString "Data.Array"- , moduleNameFromString "Data.Maybe"- , C.semigroup- , C.unsafeCoerce- , C.unit- , C.semiring- ]--genQualifiedIdent :: Gen (Qualified Ident)-genQualifiedIdent = oneof- [ Qualified <$> liftArbitrary genModuleName <*> genIdent- , return (Qualified (Just C.unit) (Ident "unit"))- , return (Qualified (Just C.semiring) (Ident "add"))- , return (Qualified (Just C.semiring) (Ident "semiringInt"))- , return (Qualified (Just C.semiring) (Ident "semiringUnit"))- , return (Qualified (Just C.maybeMod) (Ident "Just"))- , return (Qualified (Just C.eqMod) (Ident "eq"))- , return (Qualified (Just C.ring) (Ident "negate"))- , return (Qualified (Just C.ring) (Ident "ringNumber"))- , return (Qualified (Just C.ring) (Ident "unitRing"))- ]--genQualified :: Gen a -> Gen (Qualified a)-genQualified gen = Qualified <$> liftArbitrary genModuleName <*> gen--genLiteral :: Gen (Literal (Expr Ann))-genLiteral = oneof- [ NumericLiteral <$> arbitrary- , StringLiteral <$> genPSString- , CharLiteral <$> arbitrary- , BooleanLiteral <$> arbitrary- , ArrayLiteral . map unPSExpr <$> arbitrary- , ObjectLiteral . map (\(k, v) -> (fromString k, unPSExpr v)) <$> arbitrary- ]--genLiteral' :: Gen (Expr Ann)-genLiteral' = oneof- [ Literal ann . NumericLiteral <$> arbitrary- , Literal ann . StringLiteral <$> genPSString- , Literal ann . BooleanLiteral <$> arbitrary- , Literal ann . CharLiteral <$> arbitrary- ]--genExpr :: Gen (Expr Ann)-genExpr = unPSExpr <$> arbitrary--genCaseAlternative :: Gen (CaseAlternative Ann)-genCaseAlternative = sized $ \n -> - CaseAlternative <$> vectorOf n genBinder <*> genCaseAlternativeResult n- where- genCaseAlternativeResult :: Int -> Gen (Either [(Guard Ann, Expr Ann)] (Expr Ann))- genCaseAlternativeResult n = oneof- [ Left <$> vectorOf n ((,) <$> resize n genExpr <*> resize n genExpr)- , Right <$> resize n genExpr- ]--newtype PSBinder = PSBinder { unPSBinder :: Binder Ann }- deriving Show--instance Arbitrary PSBinder where- arbitrary = resize 5 $ PSBinder <$> sized go- where- go :: Int -> Gen (Binder Ann)- go 0 = oneof- [ return $ NullBinder ann- , VarBinder ann <$> genIdent- ]- go n = frequency- [ (1, return $ NullBinder ann)- , (2, LiteralBinder ann . ArrayLiteral <$> listOf (go (n - 1)))- , (2, LiteralBinder ann . ObjectLiteral <$> listOf ((,) <$> genPSString <*> (go (n - 1))))- , (3, ConstructorBinder ann <$> genQualified genProperName <*> genQualified genProperName <*> listOf (go (n - 1)))- , (3, NamedBinder ann <$> genIdent <*> (go (n - 1)))- ]-- shrink (PSBinder (LiteralBinder _ (ArrayLiteral bs))) =- (PSBinder . LiteralBinder ann . ArrayLiteral . map unPSBinder- <$> (shrinkList shrink (PSBinder <$> bs)))- ++ map PSBinder bs- shrink (PSBinder (LiteralBinder _ (ObjectLiteral o))) =- (PSBinder . LiteralBinder ann . ObjectLiteral- <$> shrinkList (\(n, b) -> (n,) . unPSBinder <$> shrink (PSBinder b)) o)- ++ map (PSBinder . snd) o- shrink (PSBinder (ConstructorBinder _ tn cn bs)) =- (PSBinder . ConstructorBinder ann tn cn . map unPSBinder- <$> (shrinkList shrink (PSBinder <$> bs)))- ++ map PSBinder bs- shrink (PSBinder (NamedBinder _ n b)) =- PSBinder b- : (PSBinder . NamedBinder ann n . unPSBinder <$> shrink (PSBinder b))- shrink _ = []--genBinder :: Gen (Binder Ann)-genBinder = unPSBinder <$> arbitrary--prop_binderDistribution :: PSBinder -> Property-prop_binderDistribution (PSBinder c) =- classify True (show . depth $ c)- $ tabulate "Binders" (cls c) True- where- cls NullBinder{} = ["NullBinder"]- cls LiteralBinder{} = ["LiteralBinder"]- cls VarBinder{} = ["VarBinder"]- cls (ConstructorBinder _ _ _ bs) = "ConstructorBinder" : concatMap cls bs- cls (NamedBinder _ _ b) = "NamedBinder" : cls b-- depth :: Binder a -> Int- depth NullBinder{} = 1- depth (LiteralBinder _ (ArrayLiteral bs)) = foldr (\b x -> depth b `max` x) 1 bs + 1 - depth (LiteralBinder _ (ObjectLiteral o)) = foldr (\(_, b) x -> depth b `max` x) 0 o + 1- depth LiteralBinder{} = 1- depth VarBinder{} = 1- depth (ConstructorBinder _ _ _ bs) = foldr (\b x -> depth b `max` x) 1 bs + 1- depth (NamedBinder _ _ b) = depth b--genBind :: Gen (Bind Ann)-genBind = frequency- [ (3, NonRec ann <$> gen <*> genExpr)- , (1, Rec <$> listOf ((\i e -> ((ann, i), e)) <$> gen <*> genExpr))- ]- where- gen = frequency [(3, genIdent), (2, genUnusedIdent)]--newtype PSExpr a = PSExpr { unPSExpr :: Expr a }- deriving Show---- Generate simple curried functions-genApp :: Gen (PSExpr Ann)-genApp =- (\x y -> PSExpr $ App ann x y)- <$> frequency- [ (1, unPSExpr <$> genApp)- , (2, Var ann <$> genQualifiedIdent)- ]- <*> frequency- [ (2, Var ann <$> genQualifiedIdent)- , (3, genLiteral')- ]--instance Arbitrary (PSExpr Ann) where- arbitrary = resize 5 $ sized go- where- go :: Int -> Gen (PSExpr Ann)- go 0 = oneof- [ PSExpr . Literal ann <$> genLiteral- , fmap PSExpr $ Constructor ann <$> genProperName <*> genProperName <*> listOf genIdent- , fmap PSExpr $ Var ann <$> genQualifiedIdent- ]- go n = frequency- [ (3, PSExpr . Literal ann <$> genLiteral)- , (3, fmap PSExpr $ Constructor ann <$> genProperName <*> genProperName <*> listOf genIdent)- , (3, fmap PSExpr $ Var ann <$> genQualifiedIdent)- , (4, fmap PSExpr $ Accessor ann <$> genPSString <*> (unPSExpr <$> go (n - 1)))- , (1, fmap PSExpr $ ObjectUpdate ann <$> genExpr <*> resize (max 3 (n - 1)) (listOf ((,) <$> genPSString <*> (unPSExpr <$> go (n - 1)))))- , (2, fmap PSExpr $ Abs ann <$> genIdent <*> (unPSExpr <$> go (n - 1)))- , (1, fmap PSExpr $ App ann <$> (unPSExpr <$> go (n - 1)) <*> (unPSExpr <$> go (n - 1)))- , (4, genApp)- , (1, fmap PSExpr $ Case ann <$> resize (max 3 (n `div` 2)) (listOf (unPSExpr <$> go (n - 1))) <*> resize (max 2 (n `div` 2)) (listOf (resize (n - 1) genCaseAlternative)))- , (4, fmap PSExpr $ Let ann <$> listOf genBind <*> (unPSExpr <$> go (n - 1)))- ]-- shrink (PSExpr expr) = map PSExpr $ go expr- where- go :: Expr Ann -> [Expr Ann]- go (Literal ann' (ArrayLiteral es)) =- (Literal ann' . ArrayLiteral <$> shrinkList shrinkExpr es)- ++ es- go (Literal ann' (ObjectLiteral o)) =- (Literal ann' . ObjectLiteral- <$> shrinkList (\(n, e) -> (n,) <$> shrinkExpr e) o)- ++ map snd o- go (Accessor ann' n e) =- e : (Accessor ann' n <$> shrinkExpr e)- go (ObjectUpdate ann' e es) =- e : map snd es- ++- [ ObjectUpdate ann' e' es'- | e' <- shrinkExpr e- , es' <- shrinkList (\(n, f) -> map (n,) $ shrinkExpr f) es- ]- go (Abs ann' n e) =- let es = shrinkExpr e- in e : es ++ map (Abs ann' n) es- go (App ann' e f) =- e : f : [ App ann' e' f' | e' <- shrinkExpr e, f' <- shrinkExpr f ]- go Var{} = []- go (Case ann' es cs) =- es- ++ concatMap- (\(CaseAlternative _ r) ->- either- (\es' -> map fst es' ++ map snd es')- (\e' -> [e'])- r- )- cs- ++ [ Case ann' [e'] [c']- | e' <- if length es > 1 then es else []- , c' <- if length cs > 1 then cs else []- ]- ++ [ Case ann' es' cs'- | es' <- shrinkList shrinkExpr es- , cs' <- shrinkList shrinkCS cs- ]- where- shrinkCS :: CaseAlternative Ann -> [CaseAlternative Ann]- shrinkCS (CaseAlternative bs r) =- [ CaseAlternative bs' r'- | bs' <- shrinkList (\x -> [x]) bs- , r' <- rs- ]- where- rs = case r of- Right e -> Right <$> shrinkExpr e- Left es' -> Left <$> shrinkList (\(g, f) -> [(g', f') | g' <- shrinkExpr g, f' <- shrinkExpr f]) es'- go (Let ann' bs e) =- e : [ Let ann' bs' e' | bs' <- shrinkList shrinkBind bs, e' <- shrinkExpr e ]- go _ = []--shrinkExpr :: Expr Ann -> [Expr Ann]-shrinkExpr = map unPSExpr . shrink . PSExpr--shrinkBind :: Bind Ann -> [Bind Ann]-shrinkBind (NonRec ann' n e) = NonRec ann' n <$> shrinkExpr e-shrinkBind (Rec as) = Rec <$> shrinkList (\(x, e) -> map (x,) $ shrinkExpr e) as--exprDepth :: Expr a -> Int-exprDepth (Literal _ (ArrayLiteral es)) = foldr (\e x -> exprDepth e `max` x) 1 es + 1-exprDepth (Literal _ (ObjectLiteral o)) = foldr (\(_, e) x -> exprDepth e `max` x) 1 o + 1-exprDepth (Literal{}) = 1-exprDepth Constructor{} = 1-exprDepth (Accessor _ _ e) = 1 + exprDepth e-exprDepth (ObjectUpdate _ e es) = 1 + exprDepth e + foldr (\(_, f) x -> exprDepth f `max` x) 1 es-exprDepth (Abs _ _ e) = 1 + exprDepth e-exprDepth (App _ e f) = 1 + exprDepth e `max` exprDepth f-exprDepth Var{} = 1-exprDepth (Case _ es cs) = 1 + foldr (\f x -> exprDepth f `max` x) cdepth es- where- cdepth = foldr (\(CaseAlternative _ r) x -> either (foldr (\(g, e) y -> exprDepth g `max` exprDepth e `max` y) 1) exprDepth r `max` x) 1 cs-exprDepth (Let _ _ e) = 1 + exprDepth e--prop_exprDistribution :: PSExpr Ann -> Property-prop_exprDistribution (PSExpr e) =- collect (exprDepth' e)- $ tabulate "classify expressions" (cls e) True- where- cls :: Expr a -> [String]- cls Literal{} = ["Literal"]- cls Constructor{} = ["Constructor"]- cls Accessor{} = ["Accessor"]- cls ObjectUpdate{} = ["ObjectUpdate"]- cls Abs{} = ["Abs"]- cls App{} = ["App"]- cls Var{} = ["Var"]- cls (Case _ _ cs) = "Case" : foldl' (\x c -> clsCaseAlternative c ++ x) [] cs- where- clsCaseAlternative (CaseAlternative {caseAlternativeResult}) =- either (foldl' (\x (g, f) -> cls g ++ cls f ++ x) []) cls caseAlternativeResult- cls Let{} = ["Let"]-- exprDepth' expr = case exprDepth expr of- n | n < 10 -> n- | n < 100 -> 10 * (n `div` 10)- | n < 1000 -> 25 * (n `div` 25)- | otherwise -> 100 * (n `div` 100)
test/Main.hs view
@@ -1,416 +1,21 @@ {-# LANGUAGE CPP #-}-module Main- ( main- , coreLibSpec- , karmaSpec- , libSpec- ) where+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 Data.Semigroup ((<>))-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 System.Process (readProcess) import Test.Hspec-import Test.HUnit (assertEqual) -import qualified TestDCECoreFn-import qualified TestDCEEval--test_prg :: String-#ifdef TEST_WITH_CABAL-test_prg = "cabal"-#else-test_prg = "stack"+import qualified Test.CoreFn+import qualified Test.Eval+import qualified Test.Lib+-- TODO: it shouldn't be a CPP FLAG+#ifdef TEST_CORE_LIBS+import qualified Test.CoreLib #endif -test_args :: [String]-test_args = ["exec", "zephyr", "--"] -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 it should run without error, false if it should error- }--libTests :: [LibTest]-libTests =- [ LibTest ["Unsafe.Coerce.Test.unsafeX"] Nothing "require('./dce-output/Unsafe.Coerce.Test').unsafeX(1)(1);" True- , LibTest ["Foreign.Test.add"] Nothing "require('./dce-output/Foreign.Test').add(1)(1);" True- , LibTest ["Foreign.Test.add"] Nothing "require('./dce-output/Foreign.Test/foreign.js').mult(1)(1);" False- , LibTest ["Eval.makeAppQueue"] Nothing "require('./dce-output/Eval').makeAppQueue;" True- , LibTest ["Eval.evalUnderArrayLiteral"] Nothing "require('./dce-output/Eval').evalUnderArrayLiteral;" True- , LibTest ["Eval.evalUnderObjectLiteral"] Nothing "require('./dce-output/Eval').evalUnderObjectLiteral;" True- , LibTest ["Eval.evalVars"] Nothing "require('./dce-output/Eval').evalVars;" True- , LibTest ["Eval"] Nothing "require('./dce-output/Eval').evalVars;" True- , LibTest ["Eval.recordUpdate"] Nothing- ( " var eval = require('./dce-output/Eval');\n"- <> " var foo = eval.recordUpdate({foo: '', bar: 0})(eval.Foo.create('foo')).foo;\n"- <> " if (foo != 'foo') {\n"- <> " console.error(foo)\n"- <> " throw('Error: ' + foo)\n"- <> " }\n"- )- True- ]--data KarmaTest = KarmaTest- { karmaTestRepo :: Text- -- ^ git repo- , karmaTestEntry :: Text- -- ^ zephyr 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- "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 test_prg (test_args ++ 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 =- 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 "purs" ["--version"] "" >>= putStrLn . (\v -> "\npurs version: " ++ v)@@ -418,9 +23,9 @@ hSetEncoding stdout utf8 hSetEncoding stderr utf8 - TestDCECoreFn.main- TestDCEEval.main-- hspec $ changeDir "test/lib-tests" libSpec- -- hspec $ changeDir ".temp" coreLibSpec- -- hspec karmaSpec+ hspec Test.CoreFn.spec+ hspec Test.Eval.spec+ hspec Test.Lib.spec+#ifdef TEST_CORE_LIBS+ hspec Test.CoreLib.spec+#endif
+ test/Test/CoreFn.hs view
@@ -0,0 +1,188 @@+module Test.CoreFn (spec) where++import Prelude ()+import Prelude.Compat++import Data.List (concatMap, foldl', intersect)+import qualified Data.List as L++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+import Test.QuickCheck++import Test.Generators hiding (ann)+++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))++prop_exprDepth :: PSExpr Ann -> Property+prop_exprDepth (PSExpr e) =+ let b = NonRec ann (Ident "x") e+ NonRec _ _ e' = runBindDeadCodeElimination b+ d = exprDepth e+ d' = exprDepth e'+ in collect (10 * (d' * 100 `div` (10 * d)))+ $ counterexample (show e)+ $ d' <= d++prop_lets :: PSExpr Ann -> Property+prop_lets (PSExpr f) =+ let b = NonRec ann (Ident "x") f+ NonRec _ _ f' = runBindDeadCodeElimination b+ d = countLets f+ d' = countLets f'+ idents = findBindIdents f'+ in label ((if d > 0 then show (10 * ((d' * 100 `div` d) `div` 10)) ++ "%" else "-") ++ " of removed let bindings")+ $ counterexample (show f)+ $ d' <= d+ && L.null (intersect idents unusedIdents)+ where+ countLets :: Expr a -> Int+ countLets (Literal _ (ArrayLiteral es)) = foldl' (\x e -> x + countLets e) 0 es+ countLets (Literal _ (ObjectLiteral o)) = foldl' (\x (_, e) -> x + countLets e) 0 o+ countLets Literal{} = 0+ countLets Constructor{} = 0+ countLets (Accessor _ _ e) = countLets e+ countLets (ObjectUpdate _ e o) = countLets e + foldl' (\x (_, e') -> x + countLets e') 0 o+ countLets (Abs _ _ e) = countLets e+ countLets (App _ e f') = countLets e + countLets f'+ countLets Var{} = 0+ countLets (Case _ es cs) = foldl' (\x e -> x + countLets e) 0 es + foldl countLetsInCaseAlternative 0 cs+ where+ countLetsInCaseAlternative x (CaseAlternative _ r) = + x + either (foldl' (\y (g, e) -> y + countLets g + countLets e) 0) countLets r+ countLets (Let _ _ e) = 1 + countLets e++ findBindIdents :: Expr a -> [Ident]+ findBindIdents (Literal _ (ArrayLiteral es)) = concatMap findBindIdents es+ findBindIdents (Literal _ (ObjectLiteral o)) = concatMap (findBindIdents . snd) o+ findBindIdents Literal{} = []+ findBindIdents Constructor{} = []+ findBindIdents (Accessor _ _ e) = findBindIdents e+ findBindIdents (ObjectUpdate _ e o) = findBindIdents e ++ concatMap (findBindIdents . snd) o+ findBindIdents (Abs _ _ e) = findBindIdents e+ findBindIdents (App _ e f') = findBindIdents e ++ findBindIdents f'+ findBindIdents Var{} = []+ findBindIdents (Case _ es cs) = concatMap findBindIdents es ++ concatMap countLetsInCaseAlternative cs+ where+ countLetsInCaseAlternative (CaseAlternative _ r) = + either (concatMap (\(g, e1) -> findBindIdents g ++ findBindIdents e1)) findBindIdents r+ findBindIdents (Let _ bs e) = concatMap fn bs ++ findBindIdents e+ where+ fn (NonRec _ i e1) = i : findBindIdents e1+ fn (Rec as) = foldl' (\acc ((_, i), e1) -> i : findBindIdents e1 ++ acc) [] as++spec :: Spec+spec = do+ context "generators" $ do+ specify "should generate Expr" $ property $ prop_exprDistribution+ context "runBindDeadCodeElimination" $ do+ specify "should reduce the depth of the tree" $ property $ withMaxSuccess 10000 prop_exprDepth+ specify "should reduce the number of let bindings" $ property $ withMaxSuccess 10000 prop_lets+ 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 runBindDeadCodeElimination (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 runBindDeadCodeElimination (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 runBindDeadCodeElimination (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 runBindDeadCodeElimination (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 runBindDeadCodeElimination (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/Test/CoreLib.hs view
@@ -0,0 +1,156 @@+module Test.CoreLib (spec) where++import Prelude ()+import Prelude.Compat hiding (exp)+import Control.Monad (when)+import Control.Monad.Trans.Class+import Control.Monad.Except+import Data.Foldable (forM_)+import Data.Maybe (fromJust, isJust, maybe)+import Data.Text (Text)+import qualified Data.Text as T+import System.Directory (setCurrentDirectory)+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)+import Test.Hspec+import Test.HUnit (assertEqual)++import Test.Utils+++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+ ]+++runCoreLibTest :: CoreLibTest -> ExceptT TestError IO ()+runCoreLibTest CoreLibTest { coreLibTestRepo+ , coreLibTestNpmModules+ , coreLibTestEntries+ , coreLibZephyrOptions+ , coreLibTestJsCmd+ } = 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()"+++assertCoreLib+ :: CoreLibTest+ -> Expectation+assertCoreLib l = do+ res <- runExceptT . runCoreLibTest $ l+ assertEqual "core lib should run" (Right ()) res+++spec :: Spec+spec =+ changeDir ".temp" $ do+ context "test core libraries" $ + forM_ coreLibs $ \l@(CoreLibTest repo _ _ _ _) ->+ specify (T.unpack repo) $ assertCoreLib l
+ test/Test/Eval.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE NumericUnderscores #-}++module Test.Eval (spec) where++import Prelude ()+import Prelude.Compat++import Language.PureScript.AST.Literals+import Language.PureScript.AST.SourcePos+import Language.PureScript.CoreFn+import Language.PureScript.DCE+import qualified 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)+++ss :: SourceSpan+ss = SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0)++ann :: Ann+ann = ssAnn ss++eq :: Qualified Ident+eq = Qualified (Just C.eqMod) (Ident "eq")++eqBoolean :: Qualified Ident+eqBoolean = Qualified (Just eqModName) (Ident "eqBoolean")++eqModName :: ModuleName+eqModName = ModuleName "Data.Eq"++mn :: ModuleName+mn = ModuleName "Test"++mp :: FilePath+mp = "src/Test.purs"++dceEvalExpr' :: Expr Ann -> [Module Ann] -> Expr Ann+dceEvalExpr' e mods = case evaluate ([testMod , eqMod , booleanMod , arrayMod, unsafeCoerceMod] ++ mods) of+ ((Module _ _ _ _ _ _ _ [NonRec _ _ e', _]) : _) -> e'+ _ -> error "not supported"+ where+ testMod = Module ss [] mn mp [] [] []+ [ NonRec ann (Ident "v") e+ , NonRec ann (Ident "f")+ (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x"))))+ ]+ eqMod = Module ss [] C.eqMod "" [] []+ [ 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 C.eqMod) (Ident "Eq")))+ (Var ann (Qualified (Just C.eqMod) (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 "Data.Boolean") "" [] [] []+ [ NonRec ann (Ident "otherwise") (Literal ann (BooleanLiteral True)) ]+ arrayMod = Module ss [] (ModuleName "Data.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"))))+ ]++dceEvalExpr :: Expr Ann -> Expr Ann+dceEvalExpr e = dceEvalExpr' e []+++-- TODO: need to generate valid `PSExpr`s.+{-+prop_eval :: PSExpr Ann -> Property+prop_eval (PSExpr g) =+ let d = exprDepth g+ g' = dceEvalExpr g+ d' = exprDepth g'+ in+ collect (if d > 0 then 10 * (d' * 100 `div` (10 * d)) else 0)+ $ counterexample ("depth " ++ show d ++ " / " ++ show d' ++ "\n\t" ++ show g')+ $ (d' <= d)+-}+++spec :: Spec+spec =+ context "evaluate" $ do+ -- specify "should evaluate" $ property $ withMaxSuccess 100_000 prop_eval+ specify "should simplify 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+ (Literal _ (CharLiteral 't')) -> return ()+ 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+ (Literal _ (CharLiteral 't')) -> return ()+ 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+ Let _ _ (Literal _ (CharLiteral 't')) -> return ()+ x -> assertFailure $ "unexpected expression:\n" ++ showExpr x+ -- Left err -> assertFailure $ "compilation error: " ++ show err++ specify "should not simplify application" $ do+ let -- f eqBoolean True True+ e :: Expr Ann+ e =+ App ann+ (App ann+ (App ann+ (Var ann (Qualified (Just mn) (Ident "f")))+ (Var ann eqBoolean))+ (Literal ann (BooleanLiteral True)))+ (Literal ann (BooleanLiteral True))+ case dceEvalExpr e of+ e' ->+ if showExpr e' /= showExpr e -- TODO! This is a dirty hack!+ 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 "Data.Boolean")) (Ident "otherwise"))+ , (Literal ann (CharLiteral 'f'))+ )+ ])+ ]+ case dceEvalExpr e of+ (Case _+ [ Literal _ (BooleanLiteral True)]+ [ CaseAlternative+ [ VarBinder _ (Ident "x") ]+ (Left [ (Literal _ (BooleanLiteral True), Literal _ (CharLiteral 't')) ])+ ]+ ) -> return ()+ 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 "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 "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 "Main")+ "src/Main.purs"+ []+ []+ []+ [NonRec ann (Ident "main") e]+ -- TODO+ case evaluate [mm, um] of+ ((Module _ _ _ _ _ _ _ [NonRec _ (Ident "main") (Literal _ (CharLiteral 't'))]) : _) -> return ()+ 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+ (Literal _ (CharLiteral 't')) -> return ()+ 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 "Data.Array")) (Ident "index")))+ (Literal ann (ArrayLiteral [Literal ann (CharLiteral 't')])))+ (Literal ann (NumericLiteral (Left 0))))+ case dceEvalExpr e of+ (App _ (Var _ (Qualified (Just (ModuleName "Data.Maybe")) (Ident "Just"))) (Literal _ (CharLiteral 't'))) -> return ()+ x -> assertFailure $ "unexpected expression:\n" ++ showExpr x+ -- Left err -> assertFailure $ "compilation error: " ++ show err++ context "context stack" $ do+ specify "nested let bindings" $ do+ let -- let a = 'a'+ -- in let a = 'b'+ -- in a+ 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+ Let _ _ (Let _ _ (Literal _ (CharLiteral 'b'))) -> return ()+ x -> assertFailure $ "unexpected expression:\n" ++ showExpr x+ -- Left err -> assertFailure $ "compilation error: " ++ show err++ context "Var inlining" $ do+ let oModName = ModuleName "Other"+ oMod = Module ss [] oModName "" [] [] []+ [ NonRec ann (Ident "o") $ Literal ann (ObjectLiteral [(mkString "a", Var ann (Qualified (Just C.eqMod) (Ident "eq"))) ])+ , NonRec ann (Ident "a") $ Literal ann (ArrayLiteral [ Var ann (Qualified (Just C.eqMod) (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+ Var{} -> return ()+ 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+ Var{} -> return ()+ 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+ Var{} -> return ()+ 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+ (Literal _ (BooleanLiteral{})) -> return ()+ 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+ (Literal _ (CharLiteral{})) -> return ()+ 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+ (Literal _ (NumericLiteral{})) -> return ()+ e' -> assertFailure $ "wront expression: " ++ showExpr e'+ -- Left err -> assertFailure $ "compilation error: " ++ show err
+ test/Test/Generators.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}++module Test.Generators where++import Data.List (foldl')+import Data.String (IsString (..))+import Test.QuickCheck++import Language.PureScript.Names (Ident (..), ModuleName (..), ProperName (..), Qualified (..))+import Language.PureScript.PSString (PSString)+import Language.PureScript.AST.SourcePos (SourceSpan (..), SourcePos (..))+import Language.PureScript.AST (Literal (..))+import Language.PureScript.CoreFn (Ann, Bind (..), Binder (..), CaseAlternative (..), Expr (..), Guard, ssAnn)++import qualified Language.PureScript.DCE.Constants as C++ann :: Ann+ann = ssAnn (SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0))++genPSString :: Gen PSString+genPSString = fromString <$> elements+ ["a", "b", "c", "d", "value0"]++genProperName :: Gen (ProperName a)+genProperName = ProperName <$> elements+ ["A", "B", "C", "D", "E"]++genIdent :: Gen Ident+genIdent = Ident <$> elements+ ["value0", "value1", "value2"]++unusedIdents :: [Ident]+unusedIdents =+ Ident <$> ["u1", "u2", "u3", "u4", "u5"]++genUnusedIdent :: Gen Ident+genUnusedIdent = elements unusedIdents++genModuleName :: Gen ModuleName+genModuleName = elements+ [ ModuleName "Data.Eq"+ , ModuleName "Data.Array"+ , ModuleName "Data.Maybe"+ , C.semigroup+ , C.unsafeCoerce+ , C.unit+ , C.semiring+ ]++genQualifiedIdent :: Gen (Qualified Ident)+genQualifiedIdent = oneof+ [ Qualified <$> liftArbitrary genModuleName <*> genIdent+ , return (Qualified (Just C.unit) (Ident "unit"))+ , return (Qualified (Just C.semiring) (Ident "add"))+ , return (Qualified (Just C.semiring) (Ident "semiringInt"))+ , return (Qualified (Just C.semiring) (Ident "semiringUnit"))+ , return (Qualified (Just C.maybeMod) (Ident "Just"))+ , return (Qualified (Just C.eqMod) (Ident "eq"))+ , return (Qualified (Just C.ring) (Ident "negate"))+ , return (Qualified (Just C.ring) (Ident "ringNumber"))+ , return (Qualified (Just C.ring) (Ident "unitRing"))+ ]++genQualified :: Gen a -> Gen (Qualified a)+genQualified gen = Qualified <$> liftArbitrary genModuleName <*> gen++genLiteral :: Gen (Literal (Expr Ann))+genLiteral = oneof+ [ NumericLiteral <$> arbitrary+ , StringLiteral <$> genPSString+ , CharLiteral <$> arbitrary+ , BooleanLiteral <$> arbitrary+ , ArrayLiteral . map unPSExpr <$> arbitrary+ , ObjectLiteral . map (\(k, v) -> (fromString k, unPSExpr v)) <$> arbitrary+ ]++genLiteral' :: Gen (Expr Ann)+genLiteral' = oneof+ [ Literal ann . NumericLiteral <$> arbitrary+ , Literal ann . StringLiteral <$> genPSString+ , Literal ann . BooleanLiteral <$> arbitrary+ , Literal ann . CharLiteral <$> arbitrary+ ]++-- TODO: this generator is very frigile with size and at times can generate+-- huge data. We use size 4. In particual it is very sensitive on the+-- frequency of generating let expressions.+genExpr :: Gen (Expr Ann)+genExpr = sized go+ where+ go :: Int -> Gen (Expr Ann)+ go 0 = oneof+ [ Literal ann <$> genLiteral+ , Constructor ann <$> genProperName <*> genProperName <*> listOf genIdent+ , Var ann <$> genQualifiedIdent+ ]+ go n = frequency+ [ (3, Literal ann <$> genLiteral)+ , (3, Constructor ann <$> genProperName <*> genProperName <*> listOf genIdent)+ , (3, Var ann <$> genQualifiedIdent)+ , (4, Accessor ann <$> genPSString <*> scale succ genExpr)+ , (1, ObjectUpdate ann <$> genExpr <*> resize (max 3 (n - 1)) (listOf ((,) <$> genPSString <*> genExpr)))+ , (2, Abs ann <$> genIdent <*> scale succ genExpr)+ , (1, App ann <$> scale succ genExpr <*> scale succ genExpr)+ , (4, genApp)+ , (1, Case ann <$> resize (max 3 (n `div` 2)) (listOf genExpr) <*> resize (max 2 (n `div` 2)) (listOf (scale succ genCaseAlternative)))+ , (2, Let ann <$> listOf genBind <*> scale (`div` 2) genExpr)+ ]++genCaseAlternative :: Gen (CaseAlternative Ann)+genCaseAlternative = sized $ \n ->+ CaseAlternative <$> vectorOf n genBinder <*> genCaseAlternativeResult n+ where+ genCaseAlternativeResult :: Int -> Gen (Either [(Guard Ann, Expr Ann)] (Expr Ann))+ genCaseAlternativeResult n = oneof+ [ Left <$> vectorOf n ((,) <$> resize n genExpr <*> resize n genExpr)+ , Right <$> resize n genExpr+ ]++newtype PSBinder = PSBinder { unPSBinder :: Binder Ann }+ deriving Show++genBinder :: Gen (Binder Ann)+genBinder = sized go+ where+ go :: Int -> Gen (Binder Ann)+ go 0 = oneof+ [ return $ NullBinder ann+ , VarBinder ann <$> genIdent+ ]+ go _ = frequency+ [ (1, return $ NullBinder ann)+ , (2, LiteralBinder ann . ArrayLiteral <$> listOf (scale succ genBinder))+ , (2, LiteralBinder ann . ObjectLiteral <$> listOf ((,) <$> genPSString <*> (scale succ genBinder)))+ , (3, ConstructorBinder ann <$> genQualified genProperName <*> genQualified genProperName <*> listOf (scale succ genBinder))+ , (3, NamedBinder ann <$> genIdent <*> scale succ genBinder)+ ]++instance Arbitrary PSBinder where+ arbitrary = PSBinder <$> resize 5 genBinder++ shrink (PSBinder (LiteralBinder _ (ArrayLiteral bs))) =+ (PSBinder . LiteralBinder ann . ArrayLiteral . map unPSBinder+ <$> (shrinkList shrink (PSBinder <$> bs)))+ ++ map PSBinder bs+ shrink (PSBinder (LiteralBinder _ (ObjectLiteral o))) =+ (PSBinder . LiteralBinder ann . ObjectLiteral+ <$> shrinkList (\(n, b) -> (n,) . unPSBinder <$> shrink (PSBinder b)) o)+ ++ map (PSBinder . snd) o+ shrink (PSBinder (ConstructorBinder _ tn cn bs)) =+ (PSBinder . ConstructorBinder ann tn cn . map unPSBinder+ <$> (shrinkList shrink (PSBinder <$> bs)))+ ++ map PSBinder bs+ shrink (PSBinder (NamedBinder _ n b)) =+ PSBinder b+ : (PSBinder . NamedBinder ann n . unPSBinder <$> shrink (PSBinder b))+ shrink _ = []++prop_binderDistribution :: PSBinder -> Property+prop_binderDistribution (PSBinder c) =+ classify True (show . depth $ c)+ $ tabulate "Binders" (cls c) True+ where+ cls NullBinder{} = ["NullBinder"]+ cls LiteralBinder{} = ["LiteralBinder"]+ cls VarBinder{} = ["VarBinder"]+ cls (ConstructorBinder _ _ _ bs) = "ConstructorBinder" : concatMap cls bs+ cls (NamedBinder _ _ b) = "NamedBinder" : cls b++ depth :: Binder a -> Int+ depth NullBinder{} = 1+ depth (LiteralBinder _ (ArrayLiteral bs)) = foldr (\b x -> depth b `max` x) 1 bs + 1+ depth (LiteralBinder _ (ObjectLiteral o)) = foldr (\(_, b) x -> depth b `max` x) 0 o + 1+ depth LiteralBinder{} = 1+ depth VarBinder{} = 1+ depth (ConstructorBinder _ _ _ bs) = foldr (\b x -> depth b `max` x) 1 bs + 1+ depth (NamedBinder _ _ b) = depth b++genBind :: Gen (Bind Ann)+genBind = frequency+ [ (3, NonRec ann <$> gen <*> (scale (`div` 2) genExpr))+ , (1, Rec <$> listOf ((\i e -> ((ann, i), e)) <$> gen <*> (scale (`div` 2) genExpr)))+ ]+ where+ gen = frequency [(3, genIdent), (2, genUnusedIdent)]++newtype PSExpr a = PSExpr { unPSExpr :: Expr a }+ deriving Show++-- Generate simple curried functions+genApp :: Gen (Expr Ann)+genApp =+ App ann+ <$> frequency+ [ (1, genApp)+ , (2, Var ann <$> genQualifiedIdent)+ ]+ <*> frequency+ [ (2, Var ann <$> genQualifiedIdent)+ , (3, genLiteral')+ ]++instance Arbitrary (PSExpr Ann) where+ arbitrary = PSExpr <$> resize 4 genExpr++ shrink (PSExpr expr) = map PSExpr $ go expr+ where+ go :: Expr Ann -> [Expr Ann]+ go (Literal ann' (ArrayLiteral es)) =+ (Literal ann' . ArrayLiteral <$> shrinkList shrinkExpr es)+ ++ es+ go (Literal ann' (ObjectLiteral o)) =+ (Literal ann' . ObjectLiteral+ <$> shrinkList (\(n, e) -> (n,) <$> shrinkExpr e) o)+ ++ map snd o+ go (Accessor ann' n e) =+ e : (Accessor ann' n <$> shrinkExpr e)+ go (ObjectUpdate ann' e es) =+ e : map snd es+ ++ [ ObjectUpdate ann' e' es+ | e' <- shrinkExpr e+ ]+ ++ [ ObjectUpdate ann' e es'+ | es' <- shrinkList (\(n, f) -> map (n,) $ shrinkExpr f) es+ ]+ go (Abs ann' n e) =+ let es = shrinkExpr e+ in e : es ++ map (Abs ann' n) es+ go (App ann' e f) =+ e : f : [ App ann' e' f | e' <- shrinkExpr e ]+ ++ [ App ann' e f' | f' <- shrinkExpr f ]+ go Var{} = []+ go (Case ann' es cs) =+ [ Case ann' es cs'+ | cs' <- shrinkList shrinkCaseAlternative cs+ ]+ ++ [ Case ann' es' cs+ | es' <- shrinkList shrinkExpr es+ ]+ ++ es+ ++ concatMap+ (\(CaseAlternative _ r) ->+ either+ (\es' -> map fst es' ++ map snd es')+ (\e' -> [e'])+ r+ )+ cs+ go (Let ann' bs e) =+ e : [ Let ann' bs e' | e' <- shrinkExpr e ]+ ++ [ Let ann' bs' e | bs' <- shrinkList shrinkBind bs ]+ go _ = []++ shrinkCaseAlternative :: CaseAlternative Ann -> [CaseAlternative Ann]+ shrinkCaseAlternative (CaseAlternative bs r) =+ [ CaseAlternative bs r'+ | r' <-+ case r of+ Right e -> Right <$> shrinkExpr e+ Left es' -> Left <$> shrinkList+ (\(g, f) -> [(g, f') | f' <- shrinkExpr f]+ ++ [(g', f) | g' <- shrinkExpr g]) es'+ ]+ ++ [ CaseAlternative bs' r+ | bs' <- shrinkList (\x -> [x]) bs+ ]++shrinkExpr :: Expr Ann -> [Expr Ann]+shrinkExpr = map unPSExpr . shrink . PSExpr++shrinkBind :: Bind Ann -> [Bind Ann]+shrinkBind (NonRec ann' n e) = NonRec ann' n <$> shrinkExpr e+shrinkBind (Rec as) = Rec <$> shrinkList (\(x, e) -> map (x,) $ shrinkExpr e) as++exprDepth :: Expr a -> Int+exprDepth (Literal _ (ArrayLiteral es)) = foldl' (\x e -> exprDepth e `max` x) 1 es + 1+exprDepth (Literal _ (ObjectLiteral o)) = foldl' (\x (_, e) -> exprDepth e `max` x) 1 o + 1+exprDepth (Literal{}) = 1+exprDepth Constructor{} = 1+exprDepth (Accessor _ _ e) = 1 + exprDepth e+exprDepth (ObjectUpdate _ e es) = 1 + exprDepth e + foldl' (\x (_, f) -> exprDepth f `max` x) 1 es+exprDepth (Abs _ _ e) = 1 + exprDepth e+exprDepth (App _ e f) = 1 + exprDepth e `max` exprDepth f+exprDepth Var{} = 1+exprDepth (Case _ es cs) = 1 + foldl' (\x f -> exprDepth f `max` x) cdepth es+ where+ cdepth = foldl' (\x (CaseAlternative _ r) -> either (foldl' (\y (g, e) -> exprDepth g `max` exprDepth e `max` y) 1) exprDepth r `max` x) 1 cs+exprDepth (Let _ bs e) = 1 + exprDepth e `max` foldl' (\x b -> binderExprDepth b `max` x) 0 bs+ where+ binderExprDepth :: Bind a -> Int+ binderExprDepth (NonRec _ _ e') = exprDepth e'+ binderExprDepth (Rec es') = foldl' (\x (_, e') -> x `max` exprDepth e') 0 es'++prop_exprDistribution :: PSExpr Ann -> Property+prop_exprDistribution (PSExpr e) =+ collect d+ $ tabulate "classify expressions" (cls e) True+ where+ d = exprDepth' e+ cls :: Expr a -> [String]+ cls Literal{} = ["Literal"]+ cls Constructor{} = ["Constructor"]+ cls Accessor{} = ["Accessor"]+ cls ObjectUpdate{} = ["ObjectUpdate"]+ cls Abs{} = ["Abs"]+ cls App{} = ["App"]+ cls Var{} = ["Var"]+ cls (Case _ _ cs) = "Case" : foldl' (\x c -> clsCaseAlternative c ++ x) [] cs+ where+ clsCaseAlternative (CaseAlternative {caseAlternativeResult}) =+ either (foldl' (\x (g, f) -> cls g ++ cls f ++ x) []) cls caseAlternativeResult+ cls Let{} = ["Let"]++ exprDepth' expr = case exprDepth expr of+ n | n < 10 -> n+ | n < 100 -> 10 * (n `div` 10)+ | n < 1000 -> 25 * (n `div` 25)+ | otherwise -> 100 * (n `div` 100)
+ test/Test/Karma.hs view
@@ -0,0 +1,93 @@+module Test.Karma (spec) 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)+import Data.Foldable (forM_)+import Data.Text (Text)+import qualified Data.Text as T+import System.Directory (setCurrentDirectory)+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)+import Test.Hspec+import Test.HUnit (assertEqual)++import Test.Utils+++data KarmaTest = KarmaTest+ { karmaTestRepo :: Text+ -- ^ git repo+ , karmaTestEntry :: Text+ -- ^ zephyr 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"+ ]+++runKarmaTest+ :: KarmaTest+ -> ExceptT TestError IO ()+runKarmaTest KarmaTest{ karmaTestRepo, karmaTestEntry } = 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)++assertKarma+ :: KarmaTest+ -> Expectation+assertKarma l = do+ res <- runExceptT . runKarmaTest $ l+ when (either (not . isGitError) (const True) res)+ (setCurrentDirectory "..")+ assertEqual "karma should run" (Right ()) res+ where+ isGitError :: TestError -> Bool+ isGitError (GitError _ _ _) = True+ isGitError _ = False++spec :: Spec+spec = + context "karma tests" $ + forM_ karmaTests $ \l@(KarmaTest repo _) ->+ specify (T.unpack repo) $ assertKarma l
+ test/Test/Lib.hs view
@@ -0,0 +1,84 @@+module Test.Lib (spec) where++import Prelude ()+import Prelude.Compat hiding (exp)+import Control.Monad (when)+import Control.Monad.Trans.Class+import Control.Monad.Except+import Data.Foldable (forM_)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Semigroup ((<>))+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)+import Test.Hspec+import Test.HUnit (assertEqual)++import Test.Utils+++data LibTest = LibTest+ { libTestEntries :: [Text]+ , libTestZephyrOptions :: Maybe [Text]+ , libTestJsCmd :: Text+ , libTestShouldPass :: Bool+ -- ^ true if it should run without error, false if it should error+ }+++libTests :: [LibTest]+libTests =+ [ LibTest ["Unsafe.Coerce.Test.unsafeX"] Nothing "require('./dce-output/Unsafe.Coerce.Test').unsafeX(1)(1);" True+ , LibTest ["Foreign.Test.add"] Nothing "require('./dce-output/Foreign.Test').add(1)(1);" True+ , LibTest ["Foreign.Test.add"] Nothing "require('./dce-output/Foreign.Test/foreign.js').mult(1)(1);" False+ , LibTest ["Eval.makeAppQueue"] Nothing "require('./dce-output/Eval').makeAppQueue;" True+ , LibTest ["Eval.evalUnderArrayLiteral"] Nothing "require('./dce-output/Eval').evalUnderArrayLiteral;" True+ , LibTest ["Eval.evalUnderObjectLiteral"] Nothing "require('./dce-output/Eval').evalUnderObjectLiteral;" True+ , LibTest ["Eval.evalVars"] Nothing "require('./dce-output/Eval').evalVars;" True+ , LibTest ["Eval"] Nothing "require('./dce-output/Eval').evalVars;" True+ , LibTest ["Eval.recordUpdate"] Nothing+ ( " var eval = require('./dce-output/Eval');\n"+ <> " var foo = eval.recordUpdate({foo: '', bar: 0})(eval.Foo.create('foo'));\n"+ <> " if (foo.foo != 'foo') {\n"+ <> " console.error(foo)\n"+ <> " throw('Error')\n"+ <> " }\n"+ )+ True+ ]+++assertLib :: LibTest -> Expectation+assertLib l = do+ res <- runExceptT . runLibTest $ l+ assertEqual "lib should run" (Right ()) res+++runLibTest :: LibTest -> ExceptT TestError IO ()+runLibTest LibTest { libTestEntries+ , libTestZephyrOptions+ , libTestJsCmd+ , libTestShouldPass+ } = 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)+++spec :: Spec+spec =+ changeDir "test/lib-tests" $+ context "TestLib" $+ forM_ libTests $ \l ->+ specify (T.unpack $ T.intercalate (T.pack " ") $ libTestEntries l) $ assertLib l
+ test/Test/Utils.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP #-}++module Test.Utils where++import Prelude ()+import Prelude.Compat hiding (exp)+import Control.Monad (when)+import Control.Monad.Trans.Class+import Control.Monad.Except+import Data.List (last)+import Data.Maybe (fromMaybe)+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.Process (readProcessWithExitCode)+import Test.Hspec+++test_prg :: String; test_args :: [String]+#ifndef TEST_WITH_STACK+test_prg = "cabal"+test_args = ["run", "exe:zephyr", "--"]+#else+test_prg = "stack"+test_args = ["exec", "zephyr", "--"]+#endif+++changeDir :: FilePath -> Spec -> Spec+changeDir path =+ around_ $ \runTests -> do+ createDirectoryIfMissing False path+ cwd <- getCurrentDirectory+ setCurrentDirectory path+ runTests+ setCurrentDirectory cwd+++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+ "purs"+ [ "compile"+ , "--codegen" , "corefn"+ , "bower_components/purescript-*/src/**/*.purs"+ , "src/**/*.purs"+ , "test/**/*.purs"+ ]+ ""+ when (ecPurs /= ExitSuccess) (throwError $ PursError coreLibTestRepo ecPurs errPurs)+++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))+++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 test_prg+ (test_args ++ T.unpack `map` fromMaybe ["--evaluate", "--dce-foreign"] zephyrOptions ++ T.unpack `map` coreLibTestEntries)+ ""+ when (ecZephyr /= ExitSuccess) (throwError $ ZephyrError coreLibTestRepo ecZephyr errZephyr)+++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"
− test/TestDCECoreFn.hs
@@ -1,190 +0,0 @@-module TestDCECoreFn where--import Prelude ()-import Prelude.Compat--import Data.List (concatMap, foldl', intersect)-import qualified Data.List as L--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-import Test.QuickCheck--import Generators hiding (ann)--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))--prop_exprDepth :: PSExpr Ann -> Property-prop_exprDepth (PSExpr e) =- let b = NonRec ann (Ident "x") e- NonRec _ _ e' = dceExpr b- d = exprDepth e- d' = exprDepth e'- in collect (10 * (d' * 100 `div` (10 * d)))- $ counterexample (show e)- $ d' <= d--prop_lets :: PSExpr Ann -> Property-prop_lets (PSExpr f) =- let b = NonRec ann (Ident "x") f- NonRec _ _ f' = dceExpr b- d = countLets f- d' = countLets f'- idents = findBindIdents f'- in label ((if d > 0 then show (10 * ((d' * 100 `div` d) `div` 10)) ++ "%" else "-") ++ " of removed let bindings")- $ counterexample (show f)- $ d' <= d- && L.null (intersect idents unusedIdents)- where- countLets :: Expr a -> Int- countLets (Literal _ (ArrayLiteral es)) = foldl' (\x e -> x + countLets e) 0 es- countLets (Literal _ (ObjectLiteral o)) = foldl' (\x (_, e) -> x + countLets e) 0 o- countLets Literal{} = 0- countLets Constructor{} = 0- countLets (Accessor _ _ e) = countLets e- countLets (ObjectUpdate _ e o) = countLets e + foldl' (\x (_, e') -> x + countLets e') 0 o- countLets (Abs _ _ e) = countLets e- countLets (App _ e f') = countLets e + countLets f'- countLets Var{} = 0- countLets (Case _ es cs) = foldl' (\x e -> x + countLets e) 0 es + foldl countLetsInCaseAlternative 0 cs- where- countLetsInCaseAlternative x (CaseAlternative _ r) = - x + either (foldl' (\y (g, e) -> y + countLets g + countLets e) 0) countLets r- countLets (Let _ _ e) = 1 + countLets e-- findBindIdents :: Expr a -> [Ident]- findBindIdents (Literal _ (ArrayLiteral es)) = concatMap findBindIdents es- findBindIdents (Literal _ (ObjectLiteral o)) = concatMap (findBindIdents . snd) o- findBindIdents Literal{} = []- findBindIdents Constructor{} = []- findBindIdents (Accessor _ _ e) = findBindIdents e- findBindIdents (ObjectUpdate _ e o) = findBindIdents e ++ concatMap (findBindIdents . snd) o- findBindIdents (Abs _ _ e) = findBindIdents e- findBindIdents (App _ e f') = findBindIdents e ++ findBindIdents f'- findBindIdents Var{} = []- findBindIdents (Case _ es cs) = concatMap findBindIdents es ++ concatMap countLetsInCaseAlternative cs- where- countLetsInCaseAlternative (CaseAlternative _ r) = - either (concatMap (\(g, e1) -> findBindIdents g ++ findBindIdents e1)) findBindIdents r- findBindIdents (Let _ bs e) = concatMap fn bs ++ findBindIdents e- where- fn (NonRec _ i e1) = i : findBindIdents e1- fn (Rec as) = foldl' (\acc ((_, i), e1) -> i : findBindIdents e1 ++ acc) [] as--spec :: Spec-spec = do- context "generators" $ do- specify "should generate Expr" $ property $ prop_exprDistribution- context "dceExpr" $ do- specify "should reduce the depth of the tree" $ property $ withMaxSuccess 10000 prop_exprDepth- specify "should reduce the number of let bindings" $ property $ withMaxSuccess 10000 prop_lets- 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
@@ -1,359 +0,0 @@-module TestDCEEval 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 qualified 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)-import Test.QuickCheck--import Generators hiding (ann)--main :: IO ()-main = hspec spec--ss :: SourceSpan-ss = SourceSpan "src/Test.purs" (SourcePos 0 0) (SourcePos 0 0)--ann :: Ann-ann = ssAnn ss--eq :: Qualified Ident-eq = Qualified (Just C.eqMod) (Ident "eq")--eqBoolean :: Qualified Ident-eqBoolean = Qualified (Just eqModName) (Ident "eqBoolean")--eqModName :: ModuleName-eqModName = ModuleName [ProperName "Data", ProperName "Eq"]- -mn :: ModuleName-mn = ModuleName [ProperName "Test"]--mp :: FilePath-mp = "src/Test.purs"--dceEvalExpr' :: Expr Ann -> [Module Ann] -> Either (DCEError 'Error) (Expr Ann)-dceEvalExpr' e mods = case runWriterT $ dceEval ([testMod , eqMod , booleanMod , arrayMod, unsafeCoerceMod] ++ mods) of- Right ((Module _ _ _ _ _ _ _ [NonRec _ _ e', _]): _, _) -> Right e'- Right _ -> undefined- Left err -> Left err- where- testMod = Module ss [] mn mp [] [] []- [ NonRec ann (Ident "v") e- , NonRec ann (Ident "f")- (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x"))))- ]- eqMod = Module ss [] C.eqMod "" [] []- [ 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 C.eqMod) (Ident "Eq")))- (Var ann (Qualified (Just C.eqMod) (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"))))- ]--dceEvalExpr :: Expr Ann -> Either (DCEError 'Error) (Expr Ann)-dceEvalExpr e = dceEvalExpr' e []--prop_eval :: PSExpr Ann -> Property-prop_eval (PSExpr g) = - let d = exprDepth g- d' = either (const Nothing) (Just . exprDepth) $ dceEvalExpr g- in- collect ((\x -> if d > 0 then 10 * (x * 100 `div` (10 * d)) else 0) <$> d')- $ counterexample (show g)- $ maybe True (\x -> x <= d) d'--spec :: Spec-spec =- context "dceEval" $ do- specify "should evaluate" $ property $ withMaxSuccess 100000 prop_eval- specify "should simplify 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 C.eqMod) (Ident "eq"))) ])- , NonRec ann (Ident "a") $ Literal ann (ArrayLiteral [ Var ann (Qualified (Just C.eqMod) (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
@@ -1,7 +1,8 @@+cabal-version: 2.0+version: 0.3.1 name: zephyr-version: 0.2.1-synopsis: - Zephyr tree shaking for PureScript Language+synopsis:+ Zephyr, tree-shaking for the PureScript language description: Tree shaking tool and partial evaluator for PureScript CoreFn AST.@@ -14,14 +15,18 @@ build-type: Simple extra-source-files: README.md category: Development-cabal-version: >=1.10 tested-with: ghc -flag test-with-cabal- description: use `cabal exec zephyr` in tests- manual: True+flag test-with-stack+ description: use `stack exec zephyr` in tests+ manual: False default: False +flag test-core-libs+ description: test core libs+ manual: False+ default: False+ library hs-source-dirs: src default-extensions:@@ -39,7 +44,6 @@ PatternGuards PatternSynonyms RankNTypes- RecordWildCards ScopedTypeVariables TupleSections ViewPatterns@@ -54,71 +58,60 @@ , 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.9- , base >= 4.8 && < 4.11- , base-compat >=0.6.0- , bytestring- , boxes >=0.1.4 && <0.2.0+ build-depends:+ aeson >=1.0 && <1.5+ , ansi-terminal >=0.7.1 && <0.11+ , base >=4.8 && <5+ , base-compat >=0.6.0+ , boxes ^>=0.1.4 , containers- , directory >=1.2.3- , filepath , formatting- , Glob >=0.9 && <0.10- , language-javascript >=0.6.0.11 && <0.7- , mtl >=2.1.0 && <2.3.0- , optparse-applicative >=0.13.0- , purescript- , safe >=0.3.14 && <0.4+ , language-javascript ^>=0.7+ , mtl >=2.1.0 && <2.3.0+ , purescript ^>=0.13.8+ , safe ^>=0.3.9 , 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+ Command.Run+ Command.Options Paths_zephyr+ autogen-modules:+ Paths_zephyr default-extensions: DataKinds FlexibleContexts NamedFieldPuns OverloadedStrings- RecordWildCards ghc-options: -Wall- -O2 -fno-warn-unused-do-bind -threaded -rtsopts- -with-rtsopts=-N+ -with-rtsopts -N2 build-depends:- aeson >=1.0 && <1.3- , ansi-terminal >=0.7.1 && <0.9+ aeson >=1.0 && <1.5+ , async+ , ansi-terminal >=0.7.1 && <0.11 , ansi-wl-pprint , base- , base-compat >=0.6.0 , bytestring , containers- , directory >=1.2.3+ , directory >=1.2.3 , filepath , formatting- , Glob >=0.9 && <0.10- , language-javascript >=0.6.0.11 && <0.7- , mtl >=2.1.0 && <2.3.0+ , Glob >=0.9 && <0.11+ , language-javascript ^>=0.7+ , mtl >=2.1.0 && <2.3.0 , optparse-applicative >=0.13.0- , purescript >= 0.12 && < 0.13+ , purescript ^>=0.13.8 , text- , transformers >=0.3.0 && <0.6- , transformers-base >=0.4.0 && <0.5- , transformers-compat >=0.3.0- , utf8-string >=1 && <2+ , transformers >=0.3.0 && <0.6+ , utf8-string >=1 && <2 , zephyr default-language: Haskell2010 @@ -129,41 +122,45 @@ DataKinds DoAndIfThenElse FlexibleInstances+ NamedFieldPuns OverloadedStrings- RecordWildCards TupleSections main-is: Main.hs- build-depends: - aeson >=1.0 && <1.3- , ansi-terminal >=0.7.1 && < 0.9- , base >= 4.8 && < 4.11- , base-compat >=0.6.0- , bytestring+ other-modules:+ Test.CoreFn+ , Test.Eval+ , Test.Generators+ , Test.Lib+ , Test.CoreLib+ , Test.Karma+ , Test.Utils+ build-depends:+ aeson >=1.0 && <1.5+ , base >=4.8 && <5+ , base-compat >=0.6.0 , containers- , directory >=1.2.3- , filepath+ , directory >=1.2.3 , hspec , hspec-core , HUnit- , language-javascript >=0.6.0.11 && <0.7- , mtl >=2.1.0 && <2.3.0+ , language-javascript ^>=0.7+ , mtl >=2.1.0 && <2.3.0 , optparse-applicative >=0.13.0- , process < 1.7.0.0- , purescript- , QuickCheck >= 2.12.1+ , process <1.7.0.0+ , purescript ^>=0.13.8+ , QuickCheck >=2.12.1 , text- , transformers >=0.3.0 && <0.6- , transformers-base >=0.4.0 && <0.5- , transformers-compat >=0.3.0- , utf8-string >=1 && <2+ , transformers >=0.3.0 && <0.6+ , utf8-string >=1 && <2 , zephyr- other-modules:- TestDCECoreFn- , TestDCEEval- , Generators- if flag(test-with-cabal)+ build-tool-depends:+ purescript:purs+ if flag(test-with-stack) cpp-options:- -DTEST_WITH_CABAL=1+ -DTEST_WITH_STACK=1+ if flag(test-core-libs)+ cpp-options:+ -DTEST_CORE_LIBS=1 ghc-options: -Wall -threaded