zephyr 0.1.4 → 0.2.0

raw patch · 13 files changed

+692/−179 lines, 13 filesdep +QuickCheckdep ~ansi-terminaldep ~basedep ~language-javascriptPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

Dependency ranges changed: ansi-terminal, base, language-javascript

API changes (from Hackage documentation)

Files

• README.md +6/−21
• app/Command/DCE.hs +69/−12
• app/Command/DCEOptions.hs +8/−20
• src/Language/PureScript/DCE/Constants.hs +11/−0
• src/Language/PureScript/DCE/CoreFn.hs +3/−15
• src/Language/PureScript/DCE/Errors.hs +37/−9
• src/Language/PureScript/DCE/Eval.hs +52/−22
• src/Language/PureScript/DCE/Foreign.hs +1/−0
• test/Generators.hs +306/−0
• test/Main.hs +33/−13
• test/TestDCECoreFn.hs +68/−3
• test/TestDCEEval.hs +77/−55
• zephyr.cabal +21/−9

@@ -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.

@@ -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

@@ -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   }

@@ -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"]

@@ -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    -- |

@@ -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

@@ -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

@@ -24,6 +24,7 @@                   , JSArrayElement(..)                   , JSObjectProperty(..)                   , JSCommaTrailingList(..)+                  , JSCommaList(..)                   ) import           Language.PureScript.Names 

@@ -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)

@@ -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

@@ -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

@@ -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')

@@ -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