diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,11 @@ See full history at: -#### 0.19.0.1 (2014-03-17) +#### 0.19.1.2 (2014-04-07) + +* Fix optimizations that were not applied and add codegen test cases. + +#### 0.19.1.1 (2014-03-17) * Allow `optparse-applicative 0.8.*` diff --git a/examples/oscillator.hs b/examples/oscillator.hs --- a/examples/oscillator.hs +++ b/examples/oscillator.hs @@ -1,12 +1,9 @@ {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE NoImplicitPrelude #-} module RingOscillator (main) where import FFI -import Prelude - -- System parameters. -- data Params = Params { alpha :: Double @@ -419,14 +416,6 @@ zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) = z a b c d e : zipWith5 z as bs cs ds es zipWith5 _ _ _ _ _ _ = [] - -mapM :: (a -> Fay b) -> [a] -> Fay [b] -mapM m (x:xs) = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs))) -mapM _ [] = return [] - -forM :: [a] -> (a -> Fay b) -> Fay [b] -forM (x:xs) m = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs))) -forM [] _ = return [] replicateM :: Int -> Fay a -> Fay [a] replicateM n x = sequence (replicate n x) diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.19.1.1 +version: 0.19.1.2 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which is type-checked with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad, @@ -13,11 +13,6 @@ . See the examples directory and . - /Release Notes/ - . - See - . - See full history at: homepage: http://fay-lang.org/ bug-reports: https://github.com/faylang/fay/issues license: BSD3 @@ -104,7 +99,7 @@ , Fay.Compiler.State , Fay.Compiler.Typecheck , Paths_fay - ghc-options: -O2 -Wall -fno-warn-name-shadowing + ghc-options: -O2 -Wall build-depends: base >= 4 && < 5 , Cabal < 1.20 , aeson < 0.8 diff --git a/src/Fay/Compiler/Decl.hs b/src/Fay/Compiler/Decl.hs --- a/src/Fay/Compiler/Decl.hs +++ b/src/Fay/Compiler/Decl.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -23,7 +22,8 @@ import Control.Applicative import Control.Monad.Error import Control.Monad.RWS -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts.Annotated hiding (binds, loc, name) +import Prelude hiding (exp) -- | Compile Haskell declaration. compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt] @@ -199,8 +199,8 @@ isWildCardMatch (InfixMatch _ pat _ pats _ _) = all isWildCardPat (pat:pats) compileCase :: S.Match -> Compile [JsStmt] - compileCase (InfixMatch l pat name pats rhs binds) = - compileCase $ Match l name (pat:pats) rhs binds + compileCase (InfixMatch l pat nm pats rhs binds) = + compileCase $ Match l nm (pat:pats) rhs binds compileCase match@(Match _ _ pats rhs _) = do whereDecls' <- whereDecls match rhsform <- compileRhs rhs diff --git a/src/Fay/Compiler/Desugar.hs b/src/Fay/Compiler/Desugar.hs --- a/src/Fay/Compiler/Desugar.hs +++ b/src/Fay/Compiler/Desugar.hs @@ -18,8 +18,8 @@ import Data.Data (Data) import Data.Maybe import Data.Typeable (Typeable) -import Language.Haskell.Exts.Annotated hiding (binds, loc) -import Prelude hiding (exp) +import Language.Haskell.Exts.Annotated hiding (binds, loc, name) +import Prelude hiding (exp, mod) import qualified Data.Generics.Uniplate.Data as U -- Types @@ -287,10 +287,9 @@ -- | Create a lookup list mapping names to types, for all the types declared -- through standalone (ie: not in an expression) type signatures at this -- scope level. - getTypeSigs decls = - [ (unname n, typ) | TypeSig _ names typ <- decls, n <- names ] + getTypeSigs ds = [ (unname n, typ) | TypeSig _ names typ <- ds, n <- names ] - go typeSigs decls = map (addTypeSig typeSigs) decls + go typeSigs ds = map (addTypeSig typeSigs) ds addTypeSig typeSigs decl = case decl of (PatBind loc pat typ rhs binds) -> diff --git a/src/Fay/Compiler/Exp.hs b/src/Fay/Compiler/Exp.hs --- a/src/Fay/Compiler/Exp.hs +++ b/src/Fay/Compiler/Exp.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -26,19 +25,21 @@ import Fay.Types import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS +import Control.Monad ((>=>), foldM, liftM, forM) +import Control.Monad.Error (throwError) +import Control.Monad.RWS (gets, asks) import qualified Data.Char as Char -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts.Annotated hiding (alt, binds, name, op) import Language.Haskell.Names +import Prelude hiding (exp) -- | Compile Haskell expression. compileExp :: S.Exp -> Compile JsExp -compileExp exp = case exp of +compileExp e = case e of Paren _ exp -> compileExp exp Var _ qname -> compileVar qname Lit _ lit -> compileLit lit - App _ (Var _ (UnQual _ (Ident _ "ffi"))) _ -> throwError (FfiNeedsTypeSig exp) + App _ (Var _ (UnQual _ (Ident _ "ffi"))) _ -> throwError $ FfiNeedsTypeSig e App _ exp1 exp2 -> compileApp exp1 exp2 NegApp _ exp -> compileNegApp exp InfixApp _ exp1 op exp2 -> compileInfixApp exp1 op exp2 @@ -48,8 +49,8 @@ Tuple _ _boxed xs -> compileList xs If _ cond conseq alt -> compileIf cond conseq alt Case _ exp alts -> compileCase exp alts - Con _ (UnQual _ (Ident _ "True")) -> return (JsLit (JsBool True)) - Con _ (UnQual _ (Ident _ "False")) -> return (JsLit (JsBool False)) + Con _ (UnQual _ (Ident _ "True")) -> return $ JsLit (JsBool True) + Con _ (UnQual _ (Ident _ "False")) -> return $ JsLit (JsBool False) Con _ qname -> compileVar qname Lambda _ pats exp -> compileLambda pats exp EnumFrom _ i -> compileEnumFrom i @@ -58,17 +59,15 @@ EnumFromThenTo _ a b z -> compileEnumFromThenTo a b z RecConstr _ name fieldUpdates -> compileRecConstr name fieldUpdates RecUpdate _ rec fieldUpdates -> compileRecUpdate rec fieldUpdates - ListComp {} -> shouldBeDesugared exp - Do {} -> shouldBeDesugared exp - LeftSection {} -> shouldBeDesugared exp - RightSection {} -> shouldBeDesugared exp - TupleSection {} -> shouldBeDesugared exp - ExpTypeSig _ exp sig -> - case ffiExp exp of - Nothing -> compileExp exp - Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig - - exp -> throwError (UnsupportedExpression exp) + ExpTypeSig _ exp sig -> case ffiExp exp of + Nothing -> compileExp exp + Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig + ListComp {} -> shouldBeDesugared e + Do {} -> shouldBeDesugared e + LeftSection {} -> shouldBeDesugared e + RightSection {} -> shouldBeDesugared e + TupleSection {} -> shouldBeDesugared e + exp -> throwError $ UnsupportedExpression exp -- | Compile variable. compileVar :: S.QName -> Compile JsExp @@ -80,16 +79,14 @@ then -- variable is either a newtype constructor or newtype destructor, -- replace it with identity function return idFun - else do - qname <- unsafeResolveName qname - return (JsName (JsNameVar qname)) + else JsName . JsNameVar <$> unsafeResolveName qname where idFun = JsFun Nothing [JsTmp 1] [] (Just (JsName $ JsTmp 1)) -- | Compile Haskell literal. compileLit :: S.Literal -> Compile JsExp compileLit lit = case lit of - Char _ ch _ -> return (JsLit (JsChar ch)) + Char _ ch _ -> return (JsLit (JsChar ch)) Int _ integer _ -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME: Frac _ rational _ -> return (JsLit (JsFloating (fromRational rational))) String _ string _ -> do @@ -97,7 +94,7 @@ if fromString then return (JsLit (JsStr string)) else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)]) - lit -> throwError (UnsupportedLiteral lit) + _ -> throwError $ UnsupportedLiteral lit -- | Compile simple application. compileApp :: S.Exp -> S.Exp -> Compile JsExp @@ -120,9 +117,9 @@ -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)}) -- Which might be OK for speed, but increases the JS stack a fair bit. method1 :: JsExp -> S.Exp -> Compile JsExp - method1 exp1 exp2 = - JsApp <$> (forceFlatName <$> return exp1) - <*> fmap return (compileExp exp2) + method1 e1 e2 = + JsApp <$> (forceFlatName <$> return e1) + <*> fmap return (compileExp e2) where forceFlatName name = JsApp (JsName JsForce) [name] @@ -131,9 +128,9 @@ -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05)) -- Which should be much better for the stack and readability, but probably not great for speed. method2 :: JsExp -> S.Exp -> Compile JsExp - method2 exp1 exp2 = fmap flatten $ - JsApp <$> return exp1 - <*> fmap return (compileExp exp2) + method2 e1 e2 = fmap flatten $ + JsApp <$> return e1 + <*> fmap return (compileExp e2) where flatten (JsApp op args) = case op of @@ -157,8 +154,8 @@ where normalApp = compileExp (App noI (App noI (Var noI op) exp1) exp2) op = getOp ap - getOp (QVarOp _ op) = op - getOp (QConOp _ op) = op + getOp (QVarOp _ o) = o + getOp (QConOp _ o) = o -- | Compile a let expression. compileLet :: [S.Decl] -> S.Exp -> Compile JsExp @@ -172,10 +169,10 @@ compileLetDecl decl = do compileDecls <- asks readerCompileDecls case decl of - decl@PatBind{} -> compileDecls False [decl] - decl@FunBind{} -> compileDecls False [decl] - TypeSig{} -> return [] - _ -> throwError (UnsupportedLetBinding decl) + PatBind{} -> compileDecls False [decl] + FunBind{} -> compileDecls False [decl] + TypeSig{} -> return [] + _ -> throwError $ UnsupportedLetBinding decl -- | Compile a list expression. compileList :: [S.Exp] -> Compile JsExp @@ -192,8 +189,8 @@ -- | Compile case expressions. compileCase :: S.Exp -> [S.Alt] -> Compile JsExp -compileCase exp alts = do - exp <- compileExp exp +compileCase e alts = do + exp <- compileExp e withScopedTmpJsName $ \tmpName -> do pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts return $ @@ -207,10 +204,10 @@ -- | Compile the given pattern against the given expression. compilePatAlt :: JsExp -> S.Alt -> Compile [JsStmt] -compilePatAlt exp alt@(Alt _ pat rhs wheres) = case wheres of - Just (BDecls _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt) - Just (IPBinds _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt) - _ -> do +compilePatAlt exp a@(Alt _ pat rhs wheres) = case wheres of + Just (BDecls _ (_ : _)) -> throwError $ UnsupportedWhereInAlt a + Just (IPBinds _ (_ : _)) -> throwError $ UnsupportedWhereInAlt a + _ -> do alt <- compileGuardedAlt rhs compilePat exp pat [alt] @@ -239,8 +236,7 @@ -- | Compile a lambda. compileLambda :: [S.Pat] -> S.Exp -> Compile JsExp -compileLambda pats exp = do - exp <- compileExp exp +compileLambda pats = compileExp >=> \exp -> do stmts <- generateStatements exp case stmts of [JsEarlyReturn fun@JsFun{}] -> return fun @@ -349,9 +345,9 @@ _ -> Nothing else Nothing where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> Maybe JsExp - strict litfn f t = - if fromEnum t - fromEnum f < maxStrictASLen - then Just . makeList . map (JsLit . litfn) $ enumFromTo f t + strict litfn fr to = + if fromEnum to - fromEnum fr < maxStrictASLen + then Just . makeList . map (JsLit . litfn) $ enumFromTo fr to else Nothing optEnumFromTo _ _ _ = Nothing @@ -365,10 +361,10 @@ _ -> Nothing else Nothing where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> a -> Maybe JsExp - strict litfn fr th to = - if (fromEnum to - fromEnum fr) `div` - (fromEnum th - fromEnum fr) + 1 < maxStrictASLen - then Just . makeList . map (JsLit . litfn) $ enumFromThenTo fr th to + strict litfn fr' th' to' = + if (fromEnum to' - fromEnum fr') `div` + (fromEnum th' - fromEnum fr') + 1 < maxStrictASLen + then Just . makeList . map (JsLit . litfn) $ enumFromThenTo fr' th' to' else Nothing optEnumFromThenTo _ _ _ _ = Nothing diff --git a/src/Fay/Compiler/Optimizer.hs b/src/Fay/Compiler/Optimizer.hs --- a/src/Fay/Compiler/Optimizer.hs +++ b/src/Fay/Compiler/Optimizer.hs @@ -120,6 +120,7 @@ tco = map inStmt where inStmt stmt = case stmt of JsVar name exp -> JsVar name (inject name exp) + JsSetQName l name exp -> JsSetQName l name (inject (JsNameVar name) exp) e -> e inject name exp = case exp of JsFun nm params [] (Just (JsNew JsThunk [JsFun _ [] stmts ret])) -> @@ -215,6 +216,7 @@ transform = f funcs uncurryInStmt stmt = case stmt of JsVar name exp -> JsVar name <$> transform exp + JsSetQName l name exp -> JsSetQName l name <$> transform exp JsEarlyReturn exp -> JsEarlyReturn <$> transform exp JsIf op ithen ielse -> JsIf <$> transform op <*> mapM uncurryInStmt ithen @@ -224,7 +226,7 @@ -- | Collect functions and their arity from the whole codeset. collectFuncs :: [JsStmt] -> [FuncArity] collectFuncs = (++ prim) . concatMap collectFunc where - collectFunc (JsVar (JsNameVar name) exp) | arity > 0 = [(name,arity)] + collectFunc (JsSetQName _ name exp) | arity > 0 = [(name,arity)] where arity = expArity exp collectFunc _ = [] prim = map (first (Qual () (ModuleName () "Fay$"))) (unary ++ binary) @@ -245,6 +247,8 @@ funBinding stmt = case stmt of JsVar (JsNameVar name) body | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body + JsSetQName l name body + | name == qname -> JsSetQName l (renameUncurried name) <$> uncurryIt body _ -> Nothing uncurryIt = Just . go [] where diff --git a/src/Fay/Compiler/Pattern.hs b/src/Fay/Compiler/Pattern.hs --- a/src/Fay/Compiler/Pattern.hs +++ b/src/Fay/Compiler/Pattern.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -16,8 +15,9 @@ import Control.Applicative import Control.Monad.Error import Control.Monad.Reader -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts.Annotated hiding (name) import Language.Haskell.Names +import Prelude hiding (exp) -- | Compile the given pattern against the given expression. compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt] @@ -31,12 +31,12 @@ PLit _ literal -> compilePLit exp literal body PParen{} -> shouldBeDesugared pat PWildCard _ -> return body - pat@PInfixApp{} -> compileInfixPat exp pat body + PInfixApp{} -> compileInfixPat exp pat body PList _ pats -> compilePList pats body exp PTuple _ _bx pats -> compilePList pats body exp - PAsPat _ name pat -> compilePAsPat exp name pat body + PAsPat _ name pt -> compilePAsPat exp name pt body PRec _ name pats -> compilePatFields exp name pats body - pat -> throwError (UnsupportedPattern pat) + _ -> throwError (UnsupportedPattern pat) -- | Compile a pattern variable e.g. x. compilePVar :: S.Name -> JsExp -> [JsStmt] -> Compile [JsStmt] @@ -123,8 +123,8 @@ Nothing -> error $ "Constructor '" ++ prettyPrint n ++ "' could not be resolved" Just _ -> do recordFields <- map (UnQual ()) <$> recToFields n - substmts <- foldM (\body (field,pat) -> - compilePat (JsGetProp forcedExp (JsNameVar field)) pat body) + substmts <- foldM (\bd (field,pat) -> + compilePat (JsGetProp forcedExp (JsNameVar field)) pat bd) body (reverse (zip recordFields pats)) qcons <- unsafeResolveName cons @@ -138,10 +138,10 @@ return [JsIf (JsEq (force exp) JsNull) body []] compilePList pats body exp = do let forcedExp = force exp - stmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index")) - [JsLit (JsInt i),forcedExp]) - pat - body) + stmts <- foldM (\bd (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index")) + [JsLit (JsInt i),forcedExp]) + pat + bd) body (reverse (zip [0..] pats)) let patsLen = JsLit (JsInt (length pats)) diff --git a/src/Fay/Compiler/Print.hs b/src/Fay/Compiler/Print.hs --- a/src/Fay/Compiler/Print.hs +++ b/src/Fay/Compiler/Print.hs @@ -27,7 +27,7 @@ import Data.Default import Data.List import Data.String -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts.Annotated hiding (alt, name, op, sym) import Prelude hiding (exp) import SourceMap.Types diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -187,7 +187,7 @@ -- | The printer monad. newtype Printer a = Printer { runPrinter :: State PrintState a } - deriving (Monad,Functor,MonadState PrintState) + deriving (Applicative,Monad,Functor,MonadState PrintState) -- | Print some value. class Printable a where @@ -228,7 +228,7 @@ -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a) - deriving Monad + deriving (Applicative,Functor,Monad) -------------------------------------------------------------------------------- -- JS AST types diff --git a/src/tests/Tests.hs b/src/tests/Tests.hs --- a/src/tests/Tests.hs +++ b/src/tests/Tests.hs @@ -34,8 +34,8 @@ sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs let (basePath,args') = prefixed (=="-base-path") args - compiler <- makeCompilerTests (packageConf <|> sandbox) basePath - defaultMainWithArgs [Compile.tests, Cmd.tests, compiler, C.tests] + (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath + defaultMainWithArgs [Compile.tests, Cmd.tests, runtime, codegen, C.tests] args' -- | Extract the element prefixed by the given element in the list. @@ -43,12 +43,31 @@ prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y) -- | Make the case-by-case unit tests. -makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test +makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO (Test,Test) makeCompilerTests packageConf basePath = do - files <- sortBy (comparing (map toLower)) . filter (\v -> not (isInfixOf "/Compile/" v) && not (isInfixOf "/regressions/" v)) . filter (isSuffixOf ".hs") <$> getRecursiveContents "tests" - return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do - testFile packageConf basePath False file - testFile packageConf basePath True file + runtimeFiles <- runtimeTestFiles + codegenFiles <- codegenTestFiles + return + (makeTestGroup "Runtime tests" + runtimeFiles + (\file -> do testFile packageConf basePath False file + testFile packageConf basePath True file) + ,makeTestGroup "Codegen tests" + codegenFiles + (\file -> do testCodegen packageConf basePath file)) + where + makeTestGroup title files inner = + testGroup title $ flip map files $ \file -> + testCase file $ inner file + runtimeTestFiles = + filter (not . nonRuntime) <$> testFiles + codegenTestFiles = + filter (isInfixOf "/codegen/") <$> testFiles + testFiles = + sortBy (comparing (map toLower)) . filter (isSuffixOf ".hs") <$> + getRecursiveContents "tests" + nonRuntime x = + any (`isInfixOf` x) ["/Compile/","/regressions/","/codegen/"] testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO () testFile packageConf basePath opt file = do @@ -78,6 +97,32 @@ assertEqual file output res Right (err,res) -> assertFailure $ "Did not fail:\n stdout: " ++ res ++ "\n\nstderr: " ++ err else assertEqual (file ++ ": Expected program to fail") True (either (const True) (const False) result) + +-- | Test the generated code output for the given file with +-- optimizations turned on. This disables runtime generation and +-- things like that; it's only concerned with the core of the program. +testCodegen :: Maybe FilePath -> Maybe FilePath -> String -> IO () +testCodegen packageConf basePath file = do + let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file + out = toJsName file + resf = root <.> "res" + config = + addConfigDirectoryIncludePaths ["tests/codegen/"] $ + def { configOptimize = True + , configTypecheck = False + , configPackageConf = packageConf + , configBasePath = basePath + , configExportStdlib = False + , configPrettyPrint = True + , configLibrary = True + , configExportRuntime = False + } + compileFromTo config file (Just out) + actual <- readStripped out + expected <- readStripped resf + assertEqual file expected actual + where readStripped = + fmap (unlines . filter (not . null) . lines) . readFile -- | Run a JS file. runJavaScriptFile :: String -> IO (Either (String,String) (String,String))