diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,13 @@ # zephyr [![Maintainer: coot](https://img.shields.io/badge/maintainer-coot-lightgrey.svg)](http://github.com/coot) -[![Build Status](https://travis-ci.org/coot/zephyr.svg?branch=master)](https://travis-ci.org/coot/zephyr) +[![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) Experimental tree shaking tool for [PureScript](https://github.com/purescript/purescript). # Usage ``` -# compile your project (or use `pulp build -- --dump-corefn`) +# compile your project (or use `pulp build -- -g corefn`) purs compile -g corefn bower_components/purescript-*/src/**/*.purs src/**/*.purs # run `zephyr` @@ -16,6 +17,9 @@ webpack ``` +You can also specify modules as entry points, which is the same as specifying +all exported identifiers. + `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. @@ -61,22 +65,3 @@ It is good to run `webpack` or `rollup` to run a javascript tree shaking algorithm on the javascript code that is pulled in your bundle by your by your foreign imports. - -# Tests - -It is tested on dozeon of various projects of -[@alexmingoia](https://github.com/alexmingoia), -[@bodil](https://github.com/bodil), [@coot](https://github.com/coot), -[@purescript-contrib](https://github.com/purescript-contrib) and -[@slamdata](https://github.com/slamdata) including: -* [purescript-pux](https://github.com/alexmingoia/purescript-pux) -* [purescript-smolder](https://github.com/bodil/purescript-smolder) -* [purescript-signal](https://github.com/bodil/purescript-signal) -* [purescript-aff](https://github.com/slamdata/purescript-aff) -* [purescript-matryoshka](https://github.com/slamdata/purescript-matryoshka) -* [purescript-argonaout](https://github.com/purescript-contrib/purescript-argonaut) -* [purescript-profunctor-lenses](https://github.com/purescript-contrib/purescript-profunctor-lenses) -* [purescript-react-hocs](https://github.com/coot/purescript-react-hocs) (_karma tests_) -* [purescript-react-redox](https://github.com/coot/purescript-react-redox) (_karma test_) - -Checkout unit test suite to see all of them. diff --git a/app/Command/DCE.hs b/app/Command/DCE.hs --- a/app/Command/DCE.hs +++ b/app/Command/DCE.hs @@ -17,11 +17,11 @@ import qualified Data.Aeson.Internal as A import Data.Aeson.Parser (eitherDecodeWith, json) import Data.Bifunctor (first) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as B (fromStrict, toStrict) -import qualified Data.ByteString.UTF8 as BU8 +import 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) +import Data.Either (Either, lefts, rights, partitionEithers) import Data.Foldable (traverse_) import Data.List (intercalate, null) import qualified Data.Map as M @@ -30,9 +30,11 @@ 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 @@ -42,10 +44,12 @@ 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 $ @@ -66,7 +70,7 @@ entryPointOpt :: Opts.Parser EntryPoint entryPointOpt = Opts.argument (Opts.auto >>= checkIfQualified) $ Opts.metavar "entry-point" - <> Opts.help "Qualified identifier. All code which is not a transitive dependency of an entry point will be removed. You can pass multiple entry points." + <> 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) ++ "'" @@ -162,10 +166,10 @@ <*> jsonErrors readInput :: [FilePath] -> IO [Either (FilePath, JSONPath, String) (Version, CoreFn.Module CoreFn.Ann)] -readInput inputFiles = forM inputFiles (\f -> addPath f . decodeCoreFn <$> B.readFile f) +readInput inputFiles = forM inputFiles (\f -> addPath f . decodeCoreFn <$> BSL.readFile f) where - decodeCoreFn :: B.ByteString -> Either (JSONPath, String) (Version, CoreFn.Module CoreFn.Ann) - decodeCoreFn = eitherDecodeWith json (A.iparse CoreFn.moduleFromJSON) . B.fromStrict + decodeCoreFn :: BSL.ByteString -> Either (JSONPath, String) (Version, CoreFn.Module CoreFn.Ann) + decodeCoreFn = eitherDecodeWith json (A.iparse CoreFn.moduleFromJSON) addPath :: FilePath @@ -188,7 +192,7 @@ exitFailure Right _ -> return () printWarningsAndErrors verbose True warnings errors = do - hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $ + 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 @@ -226,6 +230,36 @@ 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 @@ -234,8 +268,7 @@ throwError (InputNotDirectory dceInputDir) -- read files, parse errors - let entryPoints = runEntryPoint <$> dceEntryPoints - cfnGlb = compile "**/corefn.json" + let cfnGlb = compile "**/corefn.json" inpts <- liftIO $ globDir1 cfnGlb dceInputDir >>= readInput let errs = lefts inpts unless (null errs) $ @@ -245,10 +278,18 @@ 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 - $ dceEval (snd `map` rights inpts) >>= flip dce entryPoints + $ 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 @@ -258,6 +299,22 @@ liftIO $ P.runMake dcePureScriptOptions $ runSupplyT 0 $ traverse (\m -> P.codegen makeActions m P.initEnvironment mempty) mods + 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 diff --git a/app/Command/DCEOptions.hs b/app/Command/DCEOptions.hs --- a/app/Command/DCEOptions.hs +++ b/app/Command/DCEOptions.hs @@ -2,28 +2,16 @@ -- Helper module for `zephyr`. module Command.DCEOptions where -import qualified Data.Text as T import qualified Language.PureScript as P - -newtype EntryPoint = EntryPoint { runEntryPoint :: P.Qualified P.Ident } - -instance Read EntryPoint where - readsPrec _ s = case unsnoc (T.splitOn "." (T.pack s)) of - Just (as, a) | not (null as) -> [(EntryPoint (P.mkQualified (P.Ident a) (P.ModuleName $ P.ProperName <$> as)), "")] - | otherwise -> [(EntryPoint (P.Qualified Nothing (P.Ident a)), "")] - Nothing -> [] - where - unsnoc :: [a] -> Maybe ([a], a) - unsnoc [] = Nothing - unsnoc as = Just (init as, last as) +import Language.PureScript.DCE.Errors (EntryPoint) data DCEOptions = DCEOptions - { dceEntryPoints :: [EntryPoint] - , dceInputDir :: FilePath - , dceOutputDir :: FilePath - , dceVerbose :: Bool - , dceForeign :: Bool + { dceEntryPoints :: [EntryPoint] + , dceInputDir :: FilePath + , dceOutputDir :: FilePath + , dceVerbose :: Bool + , dceForeign :: Bool , dcePureScriptOptions :: P.Options - , dceUsePrefix :: Bool - , dceJsonErrors :: Bool + , dceUsePrefix :: Bool + , dceJsonErrors :: Bool } 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 @@ -2,6 +2,8 @@ -- Various constants used by zephyr. module Language.PureScript.DCE.Constants where +import Prelude hiding (maybe) + import Language.PureScript.Names unit :: ModuleName @@ -13,6 +15,9 @@ semigroup :: ModuleName semigroup = ModuleName [ProperName "Data", ProperName "Semigroup"] +maybeMod :: ModuleName +maybeMod = ModuleName [ProperName "Data", ProperName "Maybe"] + pattern Semigroup :: ModuleName pattern Semigroup = ModuleName [ProperName "Data", ProperName "Semigroup"] @@ -39,3 +44,9 @@ unsafeCoerce :: ModuleName unsafeCoerce = ModuleName [ProperName "Unsafe", ProperName "Coerce"] + +eqMod :: ModuleName +eqMod = ModuleName [ProperName "Data", ProperName "Eq"] + +pattern Eq :: ModuleName +pattern Eq = ModuleName [ProperName "Data", ProperName "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 @@ -8,15 +8,12 @@ import Prelude.Compat import Control.Arrow ((***)) import Control.Monad -import Control.Monad.Except -import Control.Monad.Writer import Data.Graph import Data.Foldable (foldl', foldr') import Data.List (any, elem, filter, groupBy, sortBy) import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Set as S import Language.PureScript.CoreFn -import Language.PureScript.DCE.Errors import Language.PureScript.DCE.Utils (bindIdents, unBind) import Language.PureScript.Names @@ -29,20 +26,11 @@ -- | -- Dead code elimination of a list of modules module dce - :: forall m - . (MonadError (DCEError 'Error) m, MonadWriter [DCEError 'Warning] m) - => [Module Ann] -- ^ modules to dce + :: [Module Ann] -- ^ modules to dce -> [Qualified Ident] -- ^ entry points used to build the graph of -- dependencies across module boundaries - -> m [Module Ann] -- ^ dead code eliminated modules -dce _ [] = throwError NoEntryPointFound -dce modules entryPoints = - if null entryPointVertices then throwError NoEntryPointFound else do - let found = ((\(_, qi, _) -> qi) . keyForVertex) `map` entryPointVertices - notFound = filter (not . (`elem` found)) entryPoints - unless (null notFound) - (tell [EntryPointsNotFound notFound]) - return (uncurry runDCE `map` reachableInModule) + -> [Module Ann] -- ^ dead code eliminated modules +dce modules entryPoints = uncurry runDCE `map` reachableInModule where -- | 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 @@ -1,7 +1,9 @@ -- | -- Errors used in dead call elimination. module Language.PureScript.DCE.Errors - ( DCEError(..) + ( EntryPoint (..) + , showEntryPoint + , DCEError(..) , displayDCEError , displayDCEWarning , Level(..) @@ -15,7 +17,7 @@ import Prelude.Compat -import Data.Char (isSpace) +import Data.Char (isLower, isSpace) import Data.List (intersperse, dropWhileEnd) import Data.Monoid ((<>)) import Data.Text (Text) @@ -31,18 +33,44 @@ import qualified Text.PrettyPrint.Boxes as Box import qualified System.Console.ANSI as ANSI -data Level = Error | Warning deriving (Show) +data EntryPoint + = EntryPoint (Qualified Ident) + | EntryModule ModuleName + deriving Show +showEntryPoint :: EntryPoint -> Text +showEntryPoint (EntryPoint qi) = showQualified showIdent qi +showEntryPoint (EntryModule mn) = runModuleName mn + +instance Read EntryPoint where + 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)), "")] + | True <- not (T.null a) + -> [(EntryModule $ ModuleName $ ProperName <$> as ++ [a], "")] + | otherwise + -> [] + Nothing -> [] + where + 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) = IdentifierNotFound ModuleName Ann (Qualified Ident) | ArrayIdxOutOfBound ModuleName Ann Integer | AccessorNotFound ModuleName Ann PSString - | NoEntryPointFound - | EntryPointsNotFound [Qualified Ident] + | NoEntryPoint + | EntryPointsNotFound [EntryPoint] deriving (Show) +data Level = Error | Warning deriving (Show) + getAnn :: DCEError a -> Maybe (ModuleName, SourceSpan) getAnn (IdentifierNotFound mn (ss, _, _, _) _) = Just (mn, ss) getAnn (ArrayIdxOutOfBound mn (ss, _, _, _) _) = Just (mn, ss) @@ -62,11 +90,11 @@ Box.text "Object literal lacks required label" Box.<+> colorBox codeColor (T.unpack $ prettyPrintString acc) Box.<> "." -formatDCEError NoEntryPointFound = "No entry point found." -formatDCEError (EntryPointsNotFound qis) = - Box.text ("Entry point" ++ if length qis > 1 then "s:" else "") +formatDCEError NoEntryPoint = "No entry point given." +formatDCEError (EntryPointsNotFound eps) = + Box.text ("Entry point" ++ if length eps > 1 then "s:" else "") Box.<+> foldr1 (Box.<>) (intersperse (Box.text ", ") - $ map (colorBox codeColor . T.unpack . showQualified runIdent) qis) + $ map (colorBox codeColor . T.unpack . showEntryPoint) eps) Box.<+> "not found." renderDCEError :: FilePath -> DCEError a -> Box.Box 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 @@ -8,6 +8,7 @@ import Control.Monad.State import Control.Monad.Writer import Data.Functor (($>)) +import Data.Maybe (fromMaybe) import Language.PureScript.AST.Literals import Language.PureScript.CoreFn import Language.PureScript.DCE.Errors @@ -19,12 +20,32 @@ import Control.Arrow (second) import Data.Maybe (Maybe(..), fromJust, isJust, maybeToList) import Data.Monoid (First(..)) -import Language.PureScript.DCE.Constants as C +import qualified Language.PureScript.DCE.Constants as C import Prelude.Compat hiding (mod) import Safe (atMay) -type Stack = [[(Ident, Expr Ann)]] +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))) + +-- 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 + where + fn (i', v) (is, done) + | i == i' = ((i', (fst v, Done)) : is, True) + | otherwise = ((i', v) : is, done) + -- | -- Evaluate expressions in a module: -- @@ -61,7 +82,7 @@ -- pop recent value in the stack (it was added in `onBinders`) onBind :: Bind Ann -> StateT (ModuleName, Stack) m (Bind Ann) - onBind b = modify (second (unBind b :)) $> b + onBind b = modify (second (initStack (unBind b) :)) $> b -- | -- Track local identifiers in case binders, push them onto the stack. @@ -71,7 +92,7 @@ -> StateT (ModuleName, Stack) m [Binder Ann] onBinders es bs = do let bes = concatMap fn (zip bs es) - modify (second (bes :)) + modify (second (initStack bes :)) return bs where fn :: (Binder Ann, Expr Ann) -> [(Ident, Expr Ann)] @@ -123,12 +144,12 @@ | otherwise -- guard expression must evaluate to a Boolean -> fltGuards rest _ -> ((g,e) :) <$> fltGuards rest - onExpr l@Let {} = modify (second (drop 1)) $> l + 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 _ CharLiteral{}) -> return l Just l@(Literal _ BooleanLiteral{}) -> return l -- preserve string, array and object literals Just _ -> return e @@ -150,16 +171,28 @@ eval :: Expr Ann -> StateT (ModuleName, Stack) m (Maybe (Expr Ann)) eval (Var _ (Qualified Nothing i)) = do (_, s) <- get - join <$> traverse eval (fnd i s) + join <$> traverse eval' (fnd i s) where - fnd :: Ident -> Stack -> Maybe (Expr Ann) + fnd :: Ident -> Stack -> Maybe (Expr Ann, EvalState) fnd j s = getFirst $ foldMap (First . lookup j) s + + 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 (App ann @@ -167,31 +200,28 @@ (App _ (Var _ (Qualified - (Just (ModuleName [ProperName "Data", ProperName "Eq"])) + (Just C.Eq) (Ident "eq"))) (Var _ inst)) e1) e2) = if inst `elem` - [ Qualified (Just mn) (Ident "eqBoolean") - , Qualified (Just mn) (Ident "eqInt") - , Qualified (Just mn) (Ident "eqNumber") - , Qualified (Just mn) (Ident "eqChar") - , Qualified (Just mn) (Ident "eqString") - , Qualified (Just mn) (Ident "eqUnit") - , Qualified (Just mn) (Ident "eqVoid") + [ Qualified (Just C.eqMod) (Ident "eqBoolean") + , Qualified (Just C.eqMod) (Ident "eqInt") + , Qualified (Just C.eqMod) (Ident "eqNumber") + , Qualified (Just C.eqMod) (Ident "eqChar") + , Qualified (Just C.eqMod) (Ident "eqString") + , 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 + -> return $ Just $ Literal ann $ BooleanLiteral (eqLit l1 l2) + _ -> return Nothing else return Nothing - where - mn = ModuleName [ProperName "Data", ProperName "Eq"] eval (Accessor ann a (Literal _ (ObjectLiteral as))) = do (mn, _) <- get e <- maybe (throwError (AccessorNotFound mn ann a)) return (a `lookup` as) @@ -214,7 +244,7 @@ $ App ann (Var (ss, [], Nothing, Just (IsConstructor SumType [Ident "value0"])) (Qualified - (Just (ModuleName [ProperName "Data", ProperName "Maybe"])) + (Just C.maybeMod) (Ident "Just"))) <$> e -- | Eval Semigroup 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 @@ -24,6 +24,7 @@ , JSArrayElement(..) , JSObjectProperty(..) , JSCommaTrailingList(..) + , JSCommaList(..) ) import Language.PureScript.Names diff --git a/test/Generators.hs b/test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Generators.hs @@ -0,0 +1,306 @@ +{-# 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,4 +1,10 @@ -module Main (main) where +{-# LANGUAGE CPP #-} +module Main + ( main + , coreLibSpec + , karmaSpec + , libSpec + ) where import Prelude () import Prelude.Compat hiding (exp) @@ -27,6 +33,16 @@ import qualified TestDCECoreFn import qualified TestDCEEval +test_prg :: String +#ifdef TEST_WITH_CABAL +test_prg = "cabal" +#else +test_prg = "stack" +#endif + +test_args :: [String] +test_args = ["exec", "zephyr", "--"] + data CoreLibTest = CoreLibTest { coreLibTestRepo :: Text -- ^ git repo @@ -119,19 +135,26 @@ , libTestZephyrOptions :: Maybe [Text] , libTestJsCmd :: Text , libTestShouldPass :: Bool - -- ^ true if should run without error, false if should error + -- ^ 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 ] data KarmaTest = KarmaTest { karmaTestRepo :: Text -- ^ git repo , karmaTestEntry :: Text - -- ^ `zephyre entry point + -- ^ zephyr entry point } karmaTests :: [KarmaTest] @@ -218,11 +241,8 @@ when (not outputDirExists) $ do (ecPurs, _, errPurs) <- lift $ readProcessWithExitCode - "stack" - [ "exec" - , "purs" - , "--" - , "compile" + "purs" + [ "compile" , "--codegen" , "corefn" , "bower_components/purescript-*/src/**/*.purs" , "src/**/*.purs" @@ -240,7 +260,7 @@ outputDirExists <- lift $ doesDirectoryExist "dce-output" when outputDirExists $ lift $ removeDirectoryRecursive "dce-output" - (ecZephyr, _, errZephyr) <- lift $ readProcessWithExitCode "stack" (["exec", "zephyr", "--"] ++ T.unpack `map` fromMaybe ["-f"] zephyrOptions ++ T.unpack `map` coreLibTestEntries) "" + (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) @@ -361,7 +381,7 @@ specify (T.unpack repo) $ assertCoreLib l libSpec :: Spec -libSpec = do +libSpec = context "TestLib" $ forM_ libTests $ \l -> specify (T.unpack $ T.intercalate (T.pack " ") $ libTestEntries l) $ assertLib l @@ -383,7 +403,7 @@ main :: IO () main = do - readProcess "stack" ["exec", "purs", "--", "--version"] "" >>= putStrLn . (\v -> "\npurs version: " ++ v) + readProcess "purs" ["--version"] "" >>= putStrLn . (\v -> "\npurs version: " ++ v) hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -392,5 +412,5 @@ TestDCEEval.main hspec $ changeDir "test/tests" libSpec - hspec $ changeDir ".temp" coreLibSpec - hspec karmaSpec + -- hspec $ changeDir ".temp" coreLibSpec + -- hspec karmaSpec diff --git a/test/TestDCECoreFn.hs b/test/TestDCECoreFn.hs --- a/test/TestDCECoreFn.hs +++ b/test/TestDCECoreFn.hs @@ -1,9 +1,10 @@ -module TestDCECoreFn (main) where +module TestDCECoreFn where import Prelude () import Prelude.Compat -import Data.List (concatMap) +import Data.List (concatMap, foldl', intersect) +import qualified Data.List as L import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos @@ -13,7 +14,10 @@ import Language.PureScript.PSString import Test.Hspec +import Test.QuickCheck +import Generators hiding (ann) + main :: IO () main = hspec spec @@ -27,9 +31,70 @@ 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 = +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 diff --git a/test/TestDCEEval.hs b/test/TestDCEEval.hs --- a/test/TestDCEEval.hs +++ b/test/TestDCEEval.hs @@ -1,4 +1,4 @@ -module TestDCEEval (main) where +module TestDCEEval where import Prelude () import Prelude.Compat @@ -9,7 +9,7 @@ import Language.PureScript.AST.SourcePos import Language.PureScript.CoreFn import Language.PureScript.DCE -import Language.PureScript.DCE.Constants as C +import qualified Language.PureScript.DCE.Constants as C import Language.PureScript.Names import Language.PureScript.PSString @@ -17,7 +17,10 @@ import Test.Hspec import Test.HUnit (assertFailure) +import Test.QuickCheck +import Generators hiding (ann) + main :: IO () main = hspec spec @@ -27,61 +30,80 @@ ann :: Ann ann = ssAnn ss -spec :: Spec -spec = - context "dceEval" $ do - let eqModName = ModuleName [ProperName "Data", ProperName "Eq"] - eq = Qualified (Just eqModName) (Ident "eq") - eqBoolean = Qualified (Just eqModName) (Ident "eqBoolean") - eqMod = Module ss [] eqModName "" [] [] - [ Ident "refEq" ] - [ NonRec ann (Ident "eq") - (Abs ann (Ident "dictEq") - (Abs ann (Ident "x") - (Abs ann (Ident "y") - (Literal ann (BooleanLiteral True))))) - , NonRec ann (Ident "eqBoolean") - (App ann - (Var ann (Qualified (Just eqModName) (Ident "Eq"))) - (Var ann (Qualified (Just eqModName) (Ident "refEq")))) - , NonRec ann (Ident "Eq") - (Abs ann (Ident "eq") - (Literal ann (ObjectLiteral [(mkString "eq", Var ann (Qualified Nothing (Ident "eq")))]))) - ] - booleanMod = Module ss [] (ModuleName [ProperName "Data", ProperName "Boolean"]) "" [] [] [] - [ NonRec ann (Ident "otherwise") (Literal ann (BooleanLiteral True)) ] - arrayMod = Module ss [] (ModuleName [ProperName "Data", ProperName "Array"]) "" - [] [] [] - [ NonRec ann (Ident "index") - (Abs ann (Ident "as") - (Abs ann (Ident "ix") - (Literal ann (CharLiteral 'f')))) - ] - unsafeCoerceMod = Module ss [] C.unsafeCoerce "" - [] [] [] - [ NonRec ann (Ident "unsafeCoerce") - (Abs ann (Ident "x") - (Var ann (Qualified Nothing (Ident "x")))) - ] - testMod e = Module ss [] mn mp [] [] [] - [ NonRec ann (Ident "v") e - , NonRec ann (Ident "f") - (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x")))) - ] +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 [ProperName "Test"] - mp = "src/Test.purs" +mn :: ModuleName +mn = ModuleName [ProperName "Test"] - dceEvalExpr' :: Expr Ann -> [Module Ann] -> Either (DCEError 'Error) (Expr Ann) - dceEvalExpr' e mods = case runWriterT $ dceEval ([testMod e , eqMod , booleanMod , arrayMod, unsafeCoerceMod] ++ mods) of - Right (((Module _ _ _ _ _ _ _ [NonRec _ _ e', _]): _), _) -> Right e' - Right _ -> undefined - Left err -> Left err +mp :: FilePath +mp = "src/Test.purs" - dceEvalExpr :: Expr Ann -> Either (DCEError 'Error) (Expr Ann) - dceEvalExpr e = dceEvalExpr' e [] +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")))) + ] - specify "should simplify if when comparing two literal values" $ do +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 @@ -281,8 +303,8 @@ context "Var inlining" $ do let oModName = ModuleName [ProperName "Other"] oMod = Module ss [] oModName "" [] [] [] - [ NonRec ann (Ident "o") $ Literal ann (ObjectLiteral [(mkString "a", Var ann (Qualified (Just eqModName) (Ident "eq"))) ]) - , NonRec ann (Ident "a") $ Literal ann (ArrayLiteral [ Var ann (Qualified (Just eqModName) (Ident "eq")) ]) + [ NonRec ann (Ident "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') diff --git a/zephyr.cabal b/zephyr.cabal --- a/zephyr.cabal +++ b/zephyr.cabal @@ -1,5 +1,5 @@ name: zephyr -version: 0.1.4 +version: 0.2.0 synopsis: Zephyr tree shaking for PureScript Language description: @@ -17,6 +17,11 @@ cabal-version: >=1.10 tested-with: ghc +flag test-with-cabal + description: use `cabal exec zephyr` in tests + manual: True + default: False + library hs-source-dirs: src default-extensions: @@ -29,6 +34,7 @@ LambdaCase MultiParamTypeClasses NoImplicitPrelude + NamedFieldPuns OverloadedStrings PatternGuards PatternSynonyms @@ -50,8 +56,8 @@ , Language.PureScript.DCE.Utils build-depends: aeson >=1.0 && <1.3 - , ansi-terminal >=0.7.1 && <0.8 - , base >= 4.7 && < 5 + , 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 @@ -60,7 +66,7 @@ , filepath , formatting , Glob >=0.9 && <0.10 - , language-javascript >=0.6.0.9 && <0.7 + , language-javascript >=0.6.0.11 && <0.7 , mtl >=2.1.0 && <2.3.0 , optparse-applicative >=0.13.0 , purescript @@ -82,6 +88,7 @@ default-extensions: DataKinds FlexibleContexts + NamedFieldPuns OverloadedStrings RecordWildCards ghc-options: @@ -93,7 +100,7 @@ -with-rtsopts=-N build-depends: aeson >=1.0 && <1.3 - , ansi-terminal >=0.7.1 && <0.8 + , ansi-terminal >=0.7.1 && <0.9 , ansi-wl-pprint , base , base-compat >=0.6.0 @@ -103,7 +110,7 @@ , filepath , formatting , Glob >=0.9 && <0.10 - , language-javascript >=0.6.0.9 && <0.7 + , language-javascript >=0.6.0.11 && <0.7 , mtl >=2.1.0 && <2.3.0 , optparse-applicative >=0.13.0 , purescript >= 0.12 && < 0.13 @@ -128,8 +135,8 @@ main-is: Main.hs build-depends: aeson >=1.0 && <1.3 - , ansi-terminal >=0.7.1 && <0.8 - , base >=4.8 && <5 + , ansi-terminal >=0.7.1 && < 0.9 + , base >= 4.8 && < 4.11 , base-compat >=0.6.0 , bytestring , containers @@ -138,11 +145,12 @@ , hspec , hspec-core , HUnit - , language-javascript >=0.6.0.9 && <0.7 + , language-javascript >=0.6.0.11 && <0.7 , mtl >=2.1.0 && <2.3.0 , optparse-applicative >=0.13.0 , process < 1.7.0.0 , purescript + , QuickCheck >= 2.12.1 , text , transformers >=0.3.0 && <0.6 , transformers-base >=0.4.0 && <0.5 @@ -152,6 +160,10 @@ other-modules: TestDCECoreFn , TestDCEEval + , Generators + if flag(test-with-cabal) + cpp-options: + -DTEST_WITH_CABAL=1 ghc-options: -Wall -threaded