fay 0.19.1.1 → 0.19.1.2
raw patch · 11 files changed
+133/−101 lines, 11 files
Files
- CHANGELOG.md +5/−1
- examples/oscillator.hs +0/−11
- fay.cabal +2/−7
- src/Fay/Compiler/Decl.hs +4/−4
- src/Fay/Compiler/Desugar.hs +4/−5
- src/Fay/Compiler/Exp.hs +47/−51
- src/Fay/Compiler/Optimizer.hs +5/−1
- src/Fay/Compiler/Pattern.hs +11/−11
- src/Fay/Compiler/Print.hs +1/−1
- src/Fay/Types.hs +2/−2
- src/tests/Tests.hs +52/−7
CHANGELOG.md view
@@ -2,7 +2,11 @@ See full history at: <https://github.com/faylang/fay/commits> -#### 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.*`
examples/oscillator.hs view
@@ -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)
fay.cabal view
@@ -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 <https://github.com/faylang/fay/wiki#fay-in-the-wild> .- /Release Notes/- .- See <https://github.com/faylang/fay/blob/master/CHANGELOG.md>- .- See full history at: <https://github.com/faylang/fay/commits> 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
src/Fay/Compiler/Decl.hs view
@@ -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
src/Fay/Compiler/Desugar.hs view
@@ -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) ->
src/Fay/Compiler/Exp.hs view
@@ -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
src/Fay/Compiler/Optimizer.hs view
@@ -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
src/Fay/Compiler/Pattern.hs view
@@ -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))
src/Fay/Compiler/Print.hs view
@@ -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
src/Fay/Types.hs view
@@ -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
src/tests/Tests.hs view
@@ -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))