diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,11 @@ # zephyr [![Maintainer: coot](https://img.shields.io/badge/maintainer-coot-lightgrey.svg)](http://github.com/coot) -[![Travis Build Status](https://travis-ci.org/coot/zephyr.svg?branch=master)](https://travis-ci.org/coot/zephyr) -[![Appveyor Build Status](https://ci.appveyor.com/api/projects/status/32r7s2skrgm9ubva?svg=true)](https://ci.appveyor.com/project/coot/zephyr) +![zephyr](https://github.com/coot/zephyr/workflows/Haskell%20CI/badge.svg) -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. diff --git a/app/Command/DCE.hs b/app/Command/DCE.hs deleted file mode 100644 --- a/app/Command/DCE.hs +++ /dev/null @@ -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 diff --git a/app/Command/DCEOptions.hs b/app/Command/DCEOptions.hs deleted file mode 100644 --- a/app/Command/DCEOptions.hs +++ /dev/null @@ -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 - } diff --git a/app/Command/Options.hs b/app/Command/Options.hs new file mode 100644 --- /dev/null +++ b/app/Command/Options.hs @@ -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 + diff --git a/app/Command/Run.hs b/app/Command/Run.hs new file mode 100644 --- /dev/null +++ b/app/Command/Run.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 $ diff --git a/src/Language/PureScript/DCE/Constants.hs b/src/Language/PureScript/DCE/Constants.hs --- a/src/Language/PureScript/DCE/Constants.hs +++ b/src/Language/PureScript/DCE/Constants.hs @@ -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" diff --git a/src/Language/PureScript/DCE/CoreFn.hs b/src/Language/PureScript/DCE/CoreFn.hs --- a/src/Language/PureScript/DCE/CoreFn.hs +++ b/src/Language/PureScript/DCE/CoreFn.hs @@ -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 diff --git a/src/Language/PureScript/DCE/Errors.hs b/src/Language/PureScript/DCE/Errors.hs --- a/src/Language/PureScript/DCE/Errors.hs +++ b/src/Language/PureScript/DCE/Errors.hs @@ -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 ", ") diff --git a/src/Language/PureScript/DCE/Eval.hs b/src/Language/PureScript/DCE/Eval.hs --- a/src/Language/PureScript/DCE/Eval.hs +++ b/src/Language/PureScript/DCE/Eval.hs @@ -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 diff --git a/src/Language/PureScript/DCE/Foreign.hs b/src/Language/PureScript/DCE/Foreign.hs --- a/src/Language/PureScript/DCE/Foreign.hs +++ b/src/Language/PureScript/DCE/Foreign.hs @@ -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 diff --git a/test/Generators.hs b/test/Generators.hs deleted file mode 100644 --- a/test/Generators.hs +++ /dev/null @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Test/CoreFn.hs b/test/Test/CoreFn.hs new file mode 100644 --- /dev/null +++ b/test/Test/CoreFn.hs @@ -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 diff --git a/test/Test/CoreLib.hs b/test/Test/CoreLib.hs new file mode 100644 --- /dev/null +++ b/test/Test/CoreLib.hs @@ -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 diff --git a/test/Test/Eval.hs b/test/Test/Eval.hs new file mode 100644 --- /dev/null +++ b/test/Test/Eval.hs @@ -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 diff --git a/test/Test/Generators.hs b/test/Test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Generators.hs @@ -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) diff --git a/test/Test/Karma.hs b/test/Test/Karma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Karma.hs @@ -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 diff --git a/test/Test/Lib.hs b/test/Test/Lib.hs new file mode 100644 --- /dev/null +++ b/test/Test/Lib.hs @@ -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 diff --git a/test/Test/Utils.hs b/test/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Test/Utils.hs @@ -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" diff --git a/test/TestDCECoreFn.hs b/test/TestDCECoreFn.hs deleted file mode 100644 --- a/test/TestDCECoreFn.hs +++ /dev/null @@ -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 diff --git a/test/TestDCEEval.hs b/test/TestDCEEval.hs deleted file mode 100644 --- a/test/TestDCEEval.hs +++ /dev/null @@ -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 diff --git a/zephyr.cabal b/zephyr.cabal --- a/zephyr.cabal +++ b/zephyr.cabal @@ -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