fay 0.14.5.0 → 0.15.0.0
raw patch · 23 files changed
+565/−393 lines, 23 filesdep −blaze-htmldep −blaze-markupPVP ok
version bump matches the API change (PVP)
Dependencies removed: blaze-html, blaze-markup
API changes (from Hackage documentation)
- Fay.Compiler: compileForDocs :: Module -> Compile [JsStmt]
+ Fay.Types: getCurrentExportsWithoutNewtypes :: CompileState -> Set QName
+ Fay.Types: stateModuleScopes :: CompileState -> Map ModuleName ModuleScope
- Fay.Types: CompileState :: Map ModuleName (Set QName) -> [(QName, [QName])] -> [(QName, [QName])] -> [(QName, Maybe QName, Type)] -> [(ModuleName, FilePath)] -> Integer -> Set Name -> ModuleScope -> ModuleName -> CompileState
+ Fay.Types: CompileState :: Map ModuleName (Set QName) -> [(QName, [QName])] -> [(QName, [QName])] -> [(QName, Maybe QName, Type)] -> [(ModuleName, FilePath)] -> Integer -> Set Name -> ModuleScope -> Map ModuleName ModuleScope -> ModuleName -> CompileState
- Fay.Types: CompileWriter :: [JsStmt] -> [JsStmt] -> [JsStmt] -> CompileWriter
+ Fay.Types: CompileWriter :: [JsStmt] -> [(String, JsExp)] -> [(String, JsExp)] -> CompileWriter
- Fay.Types: JsFun :: [JsName] -> [JsStmt] -> (Maybe JsExp) -> JsExp
+ Fay.Types: JsFun :: (Maybe JsName) -> [JsName] -> [JsStmt] -> (Maybe JsExp) -> JsExp
- Fay.Types: writerFayToJs :: CompileWriter -> [JsStmt]
+ Fay.Types: writerFayToJs :: CompileWriter -> [(String, JsExp)]
- Fay.Types: writerJsToFay :: CompileWriter -> [JsStmt]
+ Fay.Types: writerJsToFay :: CompileWriter -> [(String, JsExp)]
Files
- fay.cabal +5/−16
- js/runtime.js +39/−6
- src/Fay.hs +1/−1
- src/Fay/Compiler.hs +19/−82
- src/Fay/Compiler/Decl.hs +39/−53
- src/Fay/Compiler/Defaults.hs +1/−0
- src/Fay/Compiler/Exp.hs +54/−44
- src/Fay/Compiler/FFI.hs +89/−45
- src/Fay/Compiler/GADT.hs +16/−0
- src/Fay/Compiler/InitialPass.hs +132/−49
- src/Fay/Compiler/Misc.hs +46/−40
- src/Fay/Compiler/ModuleScope.hs +3/−0
- src/Fay/Compiler/Optimizer.hs +9/−9
- src/Fay/Compiler/Packages.hs +1/−1
- src/Fay/Compiler/Pattern.hs +3/−4
- src/Fay/Compiler/Print.hs +14/−8
- src/Fay/Compiler/Typecheck.hs +1/−1
- src/Fay/Convert.hs +41/−8
- src/Fay/Types.hs +11/−7
- src/System/Process/Extra.hs +3/−4
- src/Test/CommandLine.hs +2/−2
- src/Test/Convert.hs +12/−0
- src/Tests.hs +24/−13
fay.cabal view
@@ -1,5 +1,5 @@ name: fay-version: 0.14.5.0+version: 0.15.0.0 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,@@ -7,24 +7,15 @@ . /Documentation/ .- See documentation at <http://fay-lang.org/> or build your own documentation with:- .- > $ cabal unpack fay- > $ cd fay-*- > $ cabal install- > $ cabal install fay-base- .+ See <http://fay-lang.org/> . /Examples/ .- See <http://fay-lang.org/#examples>.+ See the examples directory and <https://github.com/faylang/fay/wiki#fay-in-the-wild> . /Release Notes/- * Support for newtypes (with no runtime cost!) .- * --base-path flag to specify custom location for fay-base- .- * Fix a bug where imports shadowing local bindings would prevent the local binding from being exported+ See <https://github.com/faylang/fay/wiki/Changelog> . See full history at: <https://github.com/faylang/fay/wiki/Changelog> homepage: http://fay-lang.org/@@ -97,7 +88,7 @@ library hs-source-dirs: src exposed-modules: Fay, Fay.Types, Language.Fay.FFI, Fay.Convert, Fay.Compiler, Fay.Compiler.Debug, Fay.Compiler.Config- other-modules: Fay.Compiler.Print, Control.Monad.IO, System.Process.Extra, Data.List.Extra, Paths_fay, Fay.Compiler.Misc, Fay.Compiler.FFI, Fay.Compiler.Optimizer, Fay.Compiler.Packages, Fay.Compiler.ModuleScope, Control.Monad.Extra, Fay.Compiler.InitialPass, Fay.Compiler.Decl, Fay.Compiler.Defaults, Fay.Compiler.Exp, Fay.Compiler.Pattern, Fay.Compiler.Typecheck+ other-modules: Fay.Compiler.Print, Control.Monad.IO, System.Process.Extra, Data.List.Extra, Paths_fay, Fay.Compiler.Misc, Fay.Compiler.FFI, Fay.Compiler.Optimizer, Fay.Compiler.Packages, Fay.Compiler.ModuleScope, Control.Monad.Extra, Fay.Compiler.InitialPass, Fay.Compiler.Decl, Fay.Compiler.Defaults, Fay.Compiler.Exp, Fay.Compiler.Pattern, Fay.Compiler.Typecheck, Fay.Compiler.GADT ghc-options: -O2 -Wall -fno-warn-name-shadowing build-depends: base >= 4 && < 5, aeson,@@ -125,8 +116,6 @@ -- Requirements for the executables which -- `cabal-dev ghci' needs. HUnit,- blaze-html >= 0.5,- blaze-markup, bytestring, time, optparse-applicative >= 0.5,
js/runtime.js view
@@ -1,10 +1,10 @@ // Workaround for missing functionality in IE 8 and earlier. if( Object.create === undefined ) {- Object.create = function( o ) {- function F(){}- F.prototype = o;- return new F();- };+ Object.create = function( o ) {+ function F(){}+ F.prototype = o;+ return new F();+ }; } /*******************************************************************************@@ -268,7 +268,40 @@ if(base == "action") { // Unserialize a "monadic" JavaScript return value into a monadic value. fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));-+ }+ else if(base == "function") {+ // Unserialize a function from JavaScript to a function that Fay can call.+ // So+ //+ // var f = function(x,y,z){ … }+ //+ // becomes something like:+ //+ // function(x){+ // return function(y){+ // return function(z){+ // return new Fay$$$(function(){+ // return Fay$$jsToFay(f(Fay$$fayTojs(x),+ // Fay$$fayTojs(y),+ // Fay$$fayTojs(z))+ // }}}}};+ var returnType = args[args.length-1];+ var funArgs = args.slice(0,-1);+ var makePartial = function(args){+ return function(arg){+ var i = args.length;+ var fayArg = Fay$$fayToJs(funArgs[i],arg);+ var newArgs = args.concat(fayArg);+ if(newArgs.length == funArgs.length) {+ return new Fay$$$(function(){+ return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));+ });+ } else {+ return makePartial(newArgs);+ }+ };+ };+ return makePartial([]); } else if(base == "string") { // Unserialize a JS string into Fay list (String).
src/Fay.hs view
@@ -95,7 +95,7 @@ Left err -> return (Left err) Right (PrintState{..},state,_) -> return $ Right $ (generate (concat (reverse psOutput))- (S.toList $ getCurrentExports state)+ (S.toList $ getCurrentExportsWithoutNewtypes state) (stateModuleName state), state) where generate | configNaked config = generateNaked
src/Fay/Compiler.hs view
@@ -9,7 +9,6 @@ module Fay.Compiler (runCompile ,compileViaStr- ,compileForDocs ,compileToAst ,compileModule ,compileExp@@ -18,14 +17,13 @@ ,parseFay) where -import Fay.Compiler.InitialPass (initialPass) import Fay.Compiler.Config+import Fay.Compiler.Decl import Fay.Compiler.Defaults import Fay.Compiler.Exp-import Fay.Compiler.Decl import Fay.Compiler.FFI+import Fay.Compiler.InitialPass (initialPass) import Fay.Compiler.Misc-import Fay.Compiler.ModuleScope (bindAsLocals, findTopLevelNames, moduleLocals) import Fay.Compiler.Optimizer import Fay.Compiler.Typecheck import Fay.Types@@ -33,12 +31,12 @@ import Control.Applicative import Control.Monad.Error import Control.Monad.IO-import Control.Monad.Extra import Control.Monad.State import Control.Monad.RWS import Data.Default (def)-import qualified Data.Set as S+import qualified Data.Map as M import Data.Maybe+import qualified Data.Set as S import Language.Haskell.Exts --------------------------------------------------------------------------------@@ -77,15 +75,6 @@ with (parseFay filepath from)) --- | Compile the given Fay code for the documentation. This is--- specialised because the documentation isn't really “real”--- compilation.-compileForDocs :: Module -> Compile [JsStmt]-compileForDocs mod = do- initialPass mod- -- collectRecords mod- compileModule False mod- -- | Compile the top-level Fay module. compileToplevelModule :: Module -> Compile [JsStmt] compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _) = do@@ -95,12 +84,11 @@ typecheck (configPackageConf cfg) (configWall cfg) $ fromMaybe modulename $ configFilePath cfg initialPass mod- -- collectRecords mod cs <- io defaultCompileState modify $ \s -> s { stateImported = stateImported cs } (stmts,CompileWriter{..}) <- listen $ compileModule True mod- let fay2js = if null writerFayToJs then [] else [fayToJsDispatcher writerFayToJs]- js2fay = if null writerJsToFay then [] else [jsToFayDispatcher writerJsToFay]+ let fay2js = if null writerFayToJs then [] else fayToJsDispatcher writerFayToJs+ js2fay = if null writerJsToFay then [] else jsToFayDispatcher writerJsToFay maybeOptimize = if configOptimize cfg then runOptimizer optimizeToplevel else id if configDispatcherOnly cfg then return (maybeOptimize (writerCons ++ fay2js ++ js2fay))@@ -112,20 +100,14 @@ -- | Compile Haskell module. compileModule :: Bool -> Module -> Compile [JsStmt]-compileModule toplevel (Module _ modulename _pragmas Nothing exports imports decls) =+compileModule toplevel (Module _ modulename _pragmas Nothing _exports imports decls) = withModuleScope $ do+ imported <- fmap concat (mapM compileImport imports) modify $ \s -> s { stateModuleName = modulename- , stateModuleScope = findTopLevelNames modulename decls+ , stateModuleScope = fromMaybe (error $ "Could not find stateModuleScope for " ++ show modulename) $ M.lookup modulename $ stateModuleScopes s }- imported <- fmap concat (mapM compileImport imports) current <- compileDecls True decls - case exports of- Just exps -> mapM_ emitExport exps- Nothing -> do- exps <- moduleLocals modulename <$> gets stateModuleScope- modify $ flip (foldr addCurrentExport) exps- exportStdlib <- config configExportStdlib exportStdlibOnly <- config configExportStdlibOnly if exportStdlibOnly@@ -148,79 +130,34 @@ -- | Compile the given import. compileImport :: ImportDecl -> Compile [JsStmt]-compileImport (ImportDecl _ _ _ _ Just{} _ _) = do -- warn $ "import with package syntax ignored: " ++ prettyPrint i- return []-compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) =- compileImportWithFilter name (const $ return True)-compileImport (ImportDecl _ name False _ Nothing Nothing (Just (True, specs))) =- compileImportWithFilter name (fmap not . imported specs)-compileImport (ImportDecl _ name False _ Nothing Nothing (Just (False, specs))) =- compileImportWithFilter name (imported specs)-compileImport i =- throwError $ UnsupportedImport i--imported :: [ImportSpec] -> QName -> Compile Bool-imported is qn = anyM (matching qn) is- where- matching :: QName -> ImportSpec -> Compile Bool- matching (Qual _ _) (IAbs _) = return True -- Types are always OK- matching (Qual _ name) (IVar var) = return $ name == var- matching (Qual _ name) (IThingAll typ) = do- recs <- typeToRecs $ UnQual typ- if UnQual name `elem` recs- then return True- else do- fields <- typeToFields $ UnQual typ- return $ UnQual name `elem` fields- matching (Qual _ name) (IThingWith typ cns) =- flip anyM cns $ \cn -> case cn of- ConName _ -> do- recs <- typeToRecs $ UnQual typ- return $ UnQual name `elem` recs- VarName _ -> do- fields <- typeToFields $ UnQual typ- return $ UnQual name `elem` fields- matching q is = error $ "compileImport: Unsupported QName ImportSpec combination " ++ show (q, is) ++ ", this is a bug!"---compileImportWithFilter :: ModuleName -> (QName -> Compile Bool) -> Compile [JsStmt]-compileImportWithFilter name importFilter =- unlessImported name importFilter $ \filepath contents -> do+compileImport (ImportDecl _ _ _ _ Just{} _ _) = return []+compileImport (ImportDecl _ name False _ Nothing Nothing _) =+ unlessImported name $ \filepath contents -> do state <- get reader <- ask result <- liftIO $ compileToAst filepath reader state (compileModule False) contents case result of Right (stmts,state,writer) -> do- imports <- filterM importFilter $ S.toList $ getCurrentExports state tell writer- modify $ \s -> s { stateImported = stateImported state- , stateLocalScope = S.empty- , stateModuleScope = bindAsLocals imports (stateModuleScope s)- , _stateExports = _stateExports state+ modify $ \s -> s { stateImported = stateImported state+ , stateLocalScope = S.empty } return stmts Left err -> throwError err+compileImport i = throwError $ UnsupportedImport i unlessImported :: ModuleName- -> (QName -> Compile Bool) -> (FilePath -> String -> Compile [JsStmt]) -> Compile [JsStmt]-unlessImported "Fay.Types" _ _ = return []-unlessImported name importFilter importIt = do+unlessImported "Fay.Types" _ = return []+unlessImported name importIt = do imported <- gets stateImported case lookup name imported of- Just _ -> do- exports <- gets $ getExportsFor name- imports <- filterM importFilter $ S.toList exports- modify $ \s -> s { stateModuleScope = bindAsLocals imports (stateModuleScope s) }- return []+ Just _ -> return [] Nothing -> do dirs <- configDirectoryIncludePaths <$> config id (filepath,contents) <- findImport dirs name- -- TODO stateImported is already added in initialPass so it is not needed here- -- but one Api test fails if it's removed.- modify $ \s -> s { stateImported = (name,filepath) : imported- }+ modify $ \s -> s { stateImported = (name,filepath) : imported } res <- importIt filepath contents return res
src/Fay/Compiler/Decl.hs view
@@ -10,6 +10,7 @@ import Fay.Compiler.Exp import Fay.Compiler.FFI+import Fay.Compiler.GADT import Fay.Compiler.Misc import Fay.Compiler.Pattern import Fay.Types@@ -41,15 +42,15 @@ case decl of pat@PatBind{} -> compilePatBind toplevel Nothing pat FunBind matches -> compileFunCase toplevel matches- DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl toplevel decl constructors- GDataDecl _ DataType _l _i _v _n decls _ -> compileDataDecl toplevel decl (map convertGADT decls)- DataDecl _ NewType _ _ _ constructors _ -> compileNewtypeDecl constructors+ DataDecl _ DataType _ _ tyvars constructors _ -> compileDataDecl toplevel tyvars constructors+ GDataDecl _ DataType _l _i tyvars _n decls _ -> compileDataDecl toplevel tyvars (map convertGADT decls)+ DataDecl _ NewType _ _ _ _ _ -> return [] -- Just ignore type aliases and signatures.- TypeDecl{} -> return []- TypeSig{} -> return []+ TypeDecl {} -> return []+ TypeSig {} -> return [] InfixDecl{} -> return [] ClassDecl{} -> return []- InstDecl{} -> return [] -- FIXME: Ignore.+ InstDecl {} -> return [] -- FIXME: Ignore. DerivDecl{} -> return [] _ -> throwError (UnsupportedDeclaration decl) @@ -68,11 +69,14 @@ _ -> compileUnguardedRhs srcloc toplevel ident rhs PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls -> do compileUnguardedRhs srcloc toplevel ident (Let bdecls rhs)+ PatBind srcloc pat Nothing (UnGuardedRhs rhs) _bdecls -> do+ exp <- compileExp rhs+ name <- withScopedTmpJsName return+ [JsIf t b1 []] <- compilePat (JsName name) pat []+ let err = [throw (prettyPrint srcloc ++ "Irrefutable pattern failed for pattern: " ++ prettyPrint pat) (JsList [])]+ return [JsVar name exp, JsIf t b1 err] _ -> throwError (UnsupportedDeclaration pat) - where ffiExp (App (Var (UnQual (Ident "ffi"))) (Lit (String formatstr))) = Just formatstr- ffiExp _ = Nothing- -- | Compile a normal simple pattern binding. compileUnguardedRhs :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt] compileUnguardedRhs srcloc toplevel ident rhs = do@@ -82,9 +86,9 @@ bind <- bindToplevel srcloc toplevel ident (thunk body) return [bind] --- | Compile a data declaration.-compileDataDecl :: Bool -> Decl -> [QualConDecl] -> Compile [JsStmt]-compileDataDecl toplevel _decl constructors =+-- | Compile a data declaration (or a GADT, latter is converted to former).+compileDataDecl :: Bool -> [TyVarBind] -> [QualConDecl] -> Compile [JsStmt]+compileDataDecl toplevel tyvars constructors = fmap concat $ forM constructors $ \(QualConDecl srcloc _ _ condecl) -> case condecl of@@ -93,8 +97,8 @@ fields' = (zip (map return fields) types) cons <- makeConstructor name fields func <- makeFunc name fields- emitFayToJs name fields'- emitJsToFay name fields'+ emitFayToJs name tyvars fields'+ emitJsToFay name tyvars fields' emitCons cons return [func] InfixConDecl t1 name t2 -> do@@ -102,8 +106,8 @@ fields = zip (map return slots) [t1, t2] cons <- makeConstructor name slots func <- makeFunc name slots- emitFayToJs name fields- emitJsToFay name fields+ emitFayToJs name tyvars fields+ emitJsToFay name tyvars fields emitCons cons return [func] RecDecl name fields' -> do@@ -111,8 +115,8 @@ cons <- makeConstructor name fields func <- makeFunc name fields funs <- makeAccessors srcloc fields- emitFayToJs name fields'- emitJsToFay name fields'+ emitFayToJs name tyvars fields'+ emitJsToFay name tyvars fields' emitCons cons return (func : funs) @@ -123,11 +127,12 @@ makeConstructor :: Name -> [Name] -> Compile JsStmt makeConstructor name (map (JsNameVar . UnQual) -> fields) = do qname <- qualify name- emitExport (EVar qname) return $- JsVar (JsConstructor qname) $- JsFun fields (for fields $ \field -> JsSetProp JsThis field (JsName field))- Nothing+ JsExpStmt $+ JsFun (Just $ JsConstructor qname)+ fields+ (for fields $ \field -> JsSetProp JsThis field (JsName field))+ Nothing -- Creates a function to initialize the record by regular application makeFunc :: Name -> [Name] -> Compile JsStmt@@ -135,7 +140,7 @@ let fieldExps = map JsName fields qname <- qualify name return $ JsVar (JsNameVar qname) $- foldr (\slot inner -> JsFun [slot] [] (Just inner))+ foldr (\slot inner -> JsFun Nothing [slot] [] (Just inner)) (thunk $ JsNew (JsConstructor qname) fieldExps) fields @@ -146,35 +151,13 @@ bindToplevel srcloc toplevel name- (JsFun [JsNameVar "x"]+ (JsFun Nothing+ [JsNameVar "x"] [] (Just (thunk (JsGetProp (force (JsName (JsNameVar "x"))) (JsNameVar (UnQual name)))))) --- | Compile a newtype declaration.-compileNewtypeDecl :: [QualConDecl] -> Compile [JsStmt]-compileNewtypeDecl [QualConDecl _ _ _ condecl] = do- case condecl of- -- newtype declaration without destructor- ConDecl name [ty] -> addNewtype name Nothing ty- RecDecl cname [([dname], ty)] -> addNewtype cname (Just dname) ty- x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x- return []- where- getBangTy :: BangType -> Type- getBangTy (BangedTy t) = t- getBangTy (UnBangedTy t) = t- getBangTy (UnpackedTy t) = t - addNewtype cname dname ty = do- qcname <- qualify cname- qdname <- case dname of- Nothing -> return Nothing- Just n -> qualify n >>= return . Just- modify (\cs@CompileState{stateNewtypes=nts} ->- cs{stateNewtypes=(qcname,qdname,getBangTy ty):nts})-compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q- -- | Compile a function which pattern matches (causing a case analysis). compileFunCase :: Bool -> [Match] -> Compile [JsStmt] compileFunCase _toplevel [] = return []@@ -184,7 +167,7 @@ bind <- bindToplevel srcloc toplevel name- (foldr (\arg inner -> JsFun [arg] [] (Just inner))+ (foldr (\arg inner -> JsFun Nothing [arg] [] (Just inner)) (stmtsThunk (concat pats ++ basecase)) args) return [bind]@@ -200,17 +183,20 @@ generateScope $ mapM compileLetDecl whereDecls' rhsform <- compileRhs rhs body <- if null whereDecls'- then return $ either id JsEarlyReturn rhsform+ then return [either id JsEarlyReturn rhsform] else do binds <- mapM compileLetDecl whereDecls'- return $ case rhsform of+ case rhsform of Right exp ->- (JsEarlyReturn (JsApp (JsFun [] (concat binds) (Just exp)) []))+ return [JsEarlyReturn $ JsApp (JsFun Nothing [] (concat binds) (Just exp)) []] Left stmt ->- (JsEarlyReturn (JsApp (JsFun [] (concat binds ++ [stmt]) Nothing) []))+ withScopedTmpJsName $ \n -> return+ [ JsVar n (JsApp (JsFun Nothing [] (concat binds ++ [stmt]) Nothing) [])+ , JsIf (JsNeq JsUndefined (JsName n)) [JsEarlyReturn (JsName n)] []+ ] foldM (\inner (arg,pat) -> compilePat (JsName arg) pat inner)- [body]+ body (zip args pats) whereDecls :: Match -> Compile [Decl]
src/Fay/Compiler/Defaults.hs view
@@ -39,4 +39,5 @@ , stateNameDepth = 1 , stateLocalScope = S.empty , stateModuleScope = def+ , stateModuleScopes = M.empty }
src/Fay/Compiler/Exp.hs view
@@ -9,6 +9,7 @@ import Fay.Compiler.Misc import Fay.Compiler.Pattern import Fay.Compiler.Print+import Fay.Compiler.FFI (ffiFun) import Fay.Types import Control.Applicative@@ -47,7 +48,10 @@ RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates RecUpdate rec fieldUpdates -> updateRec rec fieldUpdates ListComp exp stmts -> compileExp =<< desugarListComp exp stmts- ExpTypeSig _ e _ -> compileExp e+ ExpTypeSig srcloc exp sig ->+ case ffiExp exp of+ Nothing -> compileExp exp+ Just formatstr -> ffiFun srcloc Nothing formatstr sig exp -> throwError (UnsupportedExpression exp) @@ -57,7 +61,7 @@ -- | Compile variable. compileVar :: QName -> Compile JsExp compileVar qname = do- qname <- resolveName qname+ qname <- unsafeResolveName qname return (JsName (JsNameVar qname)) -- | Compile Haskell literal.@@ -75,40 +79,45 @@ -- | Compile simple application. compileApp :: Exp -> Exp -> Compile JsExp-compileApp exp1 exp2 = do- flattenApps <- config configFlattenApps- jsexp1 <- compileExp exp1- case jsexp1 of- JsName (JsNameVar qname) -> do- ntc <- lookupNewtypeConst qname- ntd <- lookupNewtypeDest qname- if isJust ntc || isJust ntd- then compileExp exp2- else (if flattenApps then method2 else method1) jsexp1- _ -> (if flattenApps then method2 else method1) jsexp1- where- -- Method 1:- -- In this approach code ends up looking like this:- -- 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 exp1 =- JsApp <$> (forceFlatName <$> return exp1)- <*> fmap return (compileExp exp2)- forceFlatName name = JsApp (JsName JsForce) [name]+compileApp exp1@(Con q) exp2 = do+ maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q+compileApp exp1@(Var q) exp2 = do+ maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q+compileApp exp1 exp2 =+ compileApp' exp1 exp2 - -- Method 2:- -- In this approach code ends up looking like this:- -- 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 exp1 = fmap flatten $- JsApp <$> return exp1- <*> fmap return (compileExp exp2)- flatten (JsApp op args) =- case op of- JsApp l r -> JsApp l (r ++ args)- _ -> JsApp (JsName JsApply) (op : args)- flatten x = x+compileApp' :: Exp -> Exp -> Compile JsExp+compileApp' exp1 exp2 = do+ flattenApps <- config configFlattenApps+ jsexp1 <- compileExp exp1+ (if flattenApps then method2 else method1) jsexp1 exp2+ where+ -- Method 1:+ -- In this approach code ends up looking like this:+ -- 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 -> Exp -> Compile JsExp+ method1 exp1 exp2 =+ JsApp <$> (forceFlatName <$> return exp1)+ <*> fmap return (compileExp exp2)+ where+ forceFlatName name = JsApp (JsName JsForce) [name] + -- Method 2:+ -- In this approach code ends up looking like this:+ -- 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 -> Exp -> Compile JsExp+ method2 exp1 exp2 = fmap flatten $+ JsApp <$> return exp1+ <*> fmap return (compileExp exp2)+ where+ flatten (JsApp op args) =+ case op of+ JsApp l r -> JsApp l (r ++ args)+ _ -> JsApp (JsName JsApply) (op : args)+ flatten x = x+ -- | Compile a negate application compileNegApp :: Exp -> Compile JsExp compileNegApp e = JsNegApp . force <$> compileExp e@@ -128,7 +137,7 @@ generateScope $ mapM compileLetDecl decls binds <- mapM compileLetDecl decls body <- compileExp exp- return (JsApp (JsFun [] (concat binds) (Just body)) [])+ return (JsApp (JsFun Nothing [] [] (Just $ stmtsThunk $ concat binds ++ [JsEarlyReturn body])) []) -- | Compile let declaration. compileLetDecl :: Decl -> Compile [JsStmt]@@ -161,7 +170,8 @@ withScopedTmpJsName $ \tmpName -> do pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts return $- JsApp (JsFun [tmpName]+ JsApp (JsFun Nothing+ [tmpName] (concat pats) (if any isWildCardAlt alts then Nothing@@ -223,7 +233,7 @@ generateStatements exp = foldM (\inner (param,pat) -> do stmts <- compilePat (JsName param) pat inner- return [JsEarlyReturn (JsFun [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])+ return [JsEarlyReturn (JsFun Nothing [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)]) [JsEarlyReturn exp] (reverse (zip uniqueNames pats)) @@ -241,7 +251,7 @@ compileEnumFrom :: Exp -> Compile JsExp compileEnumFrom i = do e <- compileExp i- name <- resolveName "enumFrom"+ name <- unsafeResolveName "enumFrom" return (JsApp (JsName (JsNameVar name)) [e]) -- | Compile [e1..e3] arithmetic sequences.@@ -249,7 +259,7 @@ compileEnumFromTo i i' = do f <- compileExp i t <- compileExp i'- name <- resolveName "enumFromTo"+ name <- unsafeResolveName "enumFromTo" cfg <- config id return $ case optEnumFromTo cfg f t of Just s -> s@@ -260,7 +270,7 @@ compileEnumFromThen a b = do fr <- compileExp a th <- compileExp b- name <- resolveName "enumFromThen"+ name <- unsafeResolveName "enumFromThen" return (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th]) -- | Compile [e1,e2..e3] arithmetic sequences.@@ -269,7 +279,7 @@ fr <- compileExp a th <- compileExp b to <- compileExp z- name <- resolveName "enumFromThenTo"+ name <- unsafeResolveName "enumFromThenTo" cfg <- config id return $ case optEnumFromThenTo cfg fr th to of Just s -> s@@ -280,10 +290,10 @@ compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp compileRecConstr name fieldUpdates = do -- var obj = new $_Type()- qname <- resolveName name+ qname <- unsafeResolveName name let record = JsVar (JsNameVar name) (JsNew (JsConstructor qname) []) setFields <- liftM concat (forM fieldUpdates (updateStmt name))- return $ JsApp (JsFun [] (record:setFields) (Just (JsName (JsNameVar name)))) []+ return $ JsApp (JsFun Nothing [] (record:setFields) (Just (JsName (JsNameVar name)))) [] where updateStmt :: QName -> FieldUpdate -> Compile [JsStmt] updateStmt o (FieldUpdate field value) = do exp <- compileExp value@@ -306,7 +316,7 @@ copy = JsVar (JsNameVar copyName) (JsRawExp ("Object.create(" ++ printJSString record ++ ")")) setFields <- forM fieldUpdates (updateExp copyName)- return $ JsApp (JsFun [] (copy:setFields) (Just (JsName (JsNameVar copyName)))) []+ return $ JsApp (JsFun Nothing [] (copy:setFields) (Just (JsName (JsNameVar copyName)))) [] where updateExp :: QName -> FieldUpdate -> Compile JsStmt updateExp copyName (FieldUpdate field value) = JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value
src/Fay/Compiler/FFI.hs view
@@ -10,6 +10,7 @@ (emitFayToJs ,emitJsToFay ,compileFFI+ ,ffiFun ,jsToFayDispatcher ,fayToJsDispatcher) where@@ -52,7 +53,7 @@ rmNewtys (TyApp t1 t2) = TyApp <$> rmNewtys t1 <*> rmNewtys t2 rmNewtys t@TyVar{} = return t rmNewtys (TyCon qname) = do- newty <- lookupNewtypeConst =<< qualifyQName qname+ newty <- lookupNewtypeConst qname return $ case newty of Nothing -> TyCon qname Just (_,ty) -> ty@@ -62,16 +63,25 @@ compileFFI' :: SrcLoc -> Name -> String -> Type -> Compile [JsStmt] compileFFI' srcloc name formatstr sig = do+ fun <- ffiFun srcloc (Just name) formatstr sig+ stmt <- bindToplevel srcloc True name fun+ return [stmt]++ffiFun :: SrcLoc -> Maybe Name -> String -> Type -> Compile JsExp+ffiFun srcloc nameopt formatstr sig = do+ let name = case nameopt of+ Nothing -> "<exp>"+ Just n -> n inner <- formatFFI srcloc formatstr (zip params funcFundamentalTypes) case JS.parse JS.parseExpression (prettyPrint name) (printJSString (wrapReturn inner)) of Left err -> throwError (FfiFormatInvalidJavaScript srcloc inner (show err)) Right exp -> do config' <- config id when (configGClosure config') $ warnDotUses srcloc inner exp- fmap return (bindToplevel srcloc True name (body inner))+ return (body inner) where body inner = foldr wrapParam (wrapReturn inner) params- wrapParam pname inner = JsFun [pname] [] (Just inner)+ wrapParam pname inner = JsFun Nothing [pname] [] (Just inner) params = zipWith const uniqueNames [1..typeArity sig] wrapReturn inner = thunk $ case lastMay funcFundamentalTypes of@@ -109,16 +119,18 @@ globalNames = ["Math","console","JSON"] -- | Make a Fay→JS encoder.-emitFayToJs :: Name -> [([Name],BangType)] -> Compile ()-emitFayToJs name (explodeFields -> fieldTypes) = do+emitFayToJs :: Name -> [TyVarBind] -> [([Name],BangType)] -> Compile ()+emitFayToJs name tyvars (explodeFields -> fieldTypes) = do qname <- qualify name- tell (mempty { writerFayToJs = [translator qname] })+ let ctrName = printJSString $ JsConstructor qname+ tell $ mempty { writerFayToJs = [(ctrName, translator)] } where- translator qname =- JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor qname))- (obj : fieldStmts (zip [0..] fieldTypes) ++ [ret])- []+ translator =+ JsFun Nothing+ [JsNameVar "type", argTypes, transcodingObjForced]+ (obj : fieldStmts (map (getIndex name tyvars) fieldTypes))+ (Just $ JsName obj_) obj :: JsStmt obj = JsVar obj_ $@@ -139,9 +151,6 @@ obj_ = JsNameVar (UnQual (Ident "obj_")) - ret :: JsStmt- ret = JsEarlyReturn (JsName obj_)- -- Declare/encode Fay→JS field declField :: Int -> (Name,BangType) -> (String,JsExp) declField i (fname,typ) =@@ -326,51 +335,70 @@ explodeFields = concatMap $ \(names,typ) -> map (,typ) names -- | The dispatcher for Fay->JS conversion.-fayToJsDispatcher :: [JsStmt] -> JsStmt+fayToJsDispatcher :: [(String,JsExp)] -> [JsStmt] fayToJsDispatcher cases =- JsVar (JsBuiltIn "fayToJsUserDefined")- (JsFun [JsNameVar "type",transcodingObj]- (decl ++ cases ++ [baseCase])- Nothing)+ [JsVar fayToJsHash $ JsObj cases+ ,JsExpStmt $+ JsFun (Just $ JsBuiltIn "fayToJsUserDefined")+ [JsNameVar "type",transcodingObj]+ [JsVar transcodingObjForced $ force (JsName transcodingObj)+ ,JsVar fayToJsFun $ JsLookup+ (JsName fayToJsHash)+ (JsGetProp (JsGetProp (JsName transcodingObjForced)+ (JsNameVar "constructor"))+ (JsNameVar "name"))+ ]+ (Just $ JsTernaryIf+ (JsName fayToJsFun)+ (JsApp (JsName fayToJsFun)+ [JsName $ JsNameVar "type"+ ,JsLookup (JsName JsParametrizedType) (JsLit (JsInt 2))+ ,JsName transcodingObjForced+ ])+ (JsName transcodingObj))+ ]+ where fayToJsHash = JsBuiltIn "fayToJsHash"+ fayToJsFun = JsNameVar "fayToJsFun" - where decl = [JsVar transcodingObjForced- (force (JsName transcodingObj))- ,JsVar argTypes- (JsLookup (JsName JsParametrizedType)- (JsLit (JsInt 2)))]- baseCase =- JsEarlyReturn (JsName transcodingObj) -- | The dispatcher for JS->Fay conversion.-jsToFayDispatcher :: [JsStmt] -> JsStmt+jsToFayDispatcher :: [(String,JsExp)] -> [JsStmt] jsToFayDispatcher cases =- JsVar (JsBuiltIn "jsToFayUserDefined")- (JsFun [JsNameVar "type",transcodingObj]- (decl ++ cases ++ [baseCase])- Nothing)+ [JsVar jsToFayHash $ JsObj cases+ ,JsExpStmt $+ JsFun (Just $ JsBuiltIn "jsToFayUserDefined")+ [JsNameVar "type",transcodingObj]+ [JsVar jsToFayFun $ JsLookup+ (JsName jsToFayHash)+ (JsGetPropExtern (JsName transcodingObj) "instance")+ ]+ (Just $ JsTernaryIf+ (JsName jsToFayFun)+ (JsApp (JsName jsToFayFun)+ [JsName $ JsNameVar "type"+ ,JsLookup (JsName JsParametrizedType) (JsLit (JsInt 2))+ ,JsName transcodingObj+ ])+ (JsName transcodingObj))+ ]+ where jsToFayHash = JsBuiltIn "jsToFayHash"+ jsToFayFun = JsNameVar "jsToFayFun" - where baseCase =- JsEarlyReturn (JsName transcodingObj)- decl = [JsVar argTypes- (JsLookup (JsName JsParametrizedType)- (JsLit (JsInt 2)))] -- | Make a JS→Fay decoder.-emitJsToFay :: Name -> [([Name], BangType)] -> Compile ()-emitJsToFay name (explodeFields -> fieldTypes) = do+emitJsToFay :: Name -> [TyVarBind] -> [([Name], BangType)] -> Compile ()+emitJsToFay name tyvars (explodeFields -> fieldTypes) = do qname <- qualify name- tell (mempty { writerJsToFay = [translator qname] })+ tell (mempty { writerJsToFay = [(printJSString name, translator qname)] }) where translator qname =- JsIf (JsEq (JsGetPropExtern (JsName transcodingObj) "instance")- (JsLit (JsStr (printJSString name))))- [JsEarlyReturn (JsNew (JsConstructor qname)- (zipWith decodeField fieldTypes [0..]))]- []+ JsFun Nothing [JsNameVar "type", argTypes, transcodingObj] []+ (Just $ JsNew (JsConstructor qname)+ (map decodeField (map (getIndex name tyvars) fieldTypes))) -- Decode JS→Fay field- decodeField :: (Name,BangType) -> Int -> JsExp- decodeField (fname,typ) i =+ decodeField :: (Int,(Name,BangType)) -> JsExp+ decodeField (i,(fname,typ)) = jsToFay (SerializeUserArg i) (argType (bangType typ)) (JsGetPropExtern (JsName transcodingObj)@@ -379,3 +407,19 @@ -- | The argument types used in serialization of parametrized user-defined types. argTypes :: JsName argTypes = JsNameVar "argTypes"++-- | Get the index of a name from the set of type variables bindings.+getIndex :: Name -> [TyVarBind] -> (Name,BangType) -> (Int,(Name,BangType))+getIndex name tyvars (sname,ty) =+ case bangType ty of+ TyVar tyname -> case lookup tyname (zip (map tyvar tyvars) [0..]) of+ Nothing -> error $ "unknown type variable " ++ prettyPrint tyname +++ " for " ++ prettyPrint name ++ "." ++ prettyPrint sname ++ "," +++ " vars were: " ++ unwords (map prettyPrint tyvars)+ Just i -> (i,(sname,ty))+ _ -> (0,(sname,ty))++-- | Extract the name from a possibly-kinded tyvar.+tyvar :: TyVarBind -> Name+tyvar (UnkindedVar v) = v+tyvar (KindedVar v _) = v
+ src/Fay/Compiler/GADT.hs view
@@ -0,0 +1,16 @@+module Fay.Compiler.GADT(convertGADT) where++import Language.Haskell.Exts hiding (name, binds)++-- | Convert a GADT to a normal data type.+convertGADT :: GadtDecl -> QualConDecl+convertGADT d =+ case d of+ GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context+ (ConDecl name (convertFunc typ))+ where tyvars = []+ context = []+ convertFunc (TyCon _) = []+ convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs+ convertFunc (TyParen x) = convertFunc x+ convertFunc _ = []
src/Fay/Compiler/InitialPass.hs view
@@ -1,79 +1,115 @@ {-# LANGUAGE OverloadedStrings #-} -module Fay.Compiler.InitialPass where+module Fay.Compiler.InitialPass+ (initialPass+ ) where -import Fay.Compiler.Misc-import Fay.Types-import Fay.Compiler.Config-import Fay.Compiler.Decl (compileNewtypeDecl)+import Fay.Compiler.Config+import Fay.Compiler.GADT+import Fay.Compiler.Misc+import Fay.Compiler.ModuleScope+import Fay.Types -import Control.Applicative-import Control.Monad.Error-import Control.Monad.RWS-import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.Parser+import Control.Applicative+import Control.Monad.Error+import Control.Monad.Extra+import Control.Monad.RWS+import qualified Data.Set as S+import qualified Data.Map as M+import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Syntax+import Prelude hiding (mod, read) initialPass :: Module -> Compile ()-initialPass (Module _ _ _ Nothing _ imports decls) = do- forM_ imports $ \imp ->- case imp of- ImportDecl _ _ _ _ Just{} _ _ -> return ()-- ImportDecl _ name False _ Nothing Nothing _ ->- void $ unlessImported name $ \filepath contents -> do- result <- compileWith filepath initialPass contents- case result of- Right ((),st,_) ->- -- Merges the state gotten from passing through an imported- -- module with the current state. We can assume no duplicate- -- records exist since GHC would pick that up.- modify $ \s -> s { stateRecords = stateRecords st- , stateRecordTypes = stateRecordTypes st- , stateImported = stateImported st- , stateNewtypes = stateNewtypes st- }- Left err -> throwError err-- i -> throwError $ UnsupportedImport i-- forM_ decls scanRecordDecls- forM_ decls scanNewtypeDecls-+initialPass (Module _ mod _ Nothing exports imports decls) = do+ withModuleScope $ do+ modify $ \s -> s { stateModuleName = mod+ , stateModuleScope = findTopLevelNames mod decls+ }+ forM_ imports compileImport+ forM_ decls scanRecordDecls+ forM_ decls scanNewtypeDecls+ case exports of+ Just exps -> mapM_ emitExport exps+ Nothing -> do+ exps <- moduleLocals mod <$> gets stateModuleScope+ modify $ flip (foldr addCurrentExport) exps+ modify $ \s -> s { stateModuleScopes = M.insert mod (stateModuleScope s) (stateModuleScopes s) } initialPass m = throwError (UnsupportedModuleSyntax m) +compileImport :: ImportDecl -> Compile ()+compileImport (ImportDecl _ _ _ _ Just{} _ _) = return ()+compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) =+ compileImportWithFilter name (const $ return True)+compileImport (ImportDecl _ name False _ Nothing Nothing (Just (True, specs))) =+ compileImportWithFilter name (fmap not . imported specs)+compileImport (ImportDecl _ name False _ Nothing Nothing (Just (False, specs))) =+ compileImportWithFilter name (imported specs)+compileImport i =+ throwError $ UnsupportedImport i+ compileWith :: (Show from,Parseable from) => FilePath+ -> CompileReader+ -> CompileState -> (from -> Compile ()) -> String -> Compile (Either CompileError ((),CompileState,CompileWriter))-compileWith filepath with from = do- compileReader <- ask- compileState <- get- liftIO $ runCompile compileReader- compileState+compileWith filepath r st with from = do+ liftIO $ runCompile r+ st (parseResult (throwError . uncurry ParseError) with (parseFay filepath from)) -- | Don't re-import the same modules. unlessImported :: ModuleName- -> (FilePath -> String -> Compile ())- -> Compile ()-unlessImported name importIt = do- imported <- gets stateImported- case lookup name imported of+ -> (QName -> Compile Bool)+ -> (FilePath -> String -> Compile ())+ -> Compile ()+unlessImported "Fay.Types" _ _ = return ()+unlessImported name importFilter importIt = do+ isImported <- lookup name <$> gets stateImported+ case isImported of Just _ -> return () Nothing -> do dirs <- configDirectoryIncludePaths <$> config id (filepath,contents) <- findImport dirs name- modify $ \s -> s { stateImported = (name,filepath) : imported }+ modify $ \s -> s { stateImported = (name,filepath) : stateImported s } importIt filepath contents+ exports <- gets $ getExportsFor name+ imports <- filterM importFilter $ S.toList exports+ modify $ \s -> s { stateModuleScope = bindAsLocals imports (stateModuleScope s) } +-- | Find newtype declarations scanNewtypeDecls :: Decl -> Compile ()-scanNewtypeDecls (DataDecl _ NewType _ _ _ constructors _) =- void $ compileNewtypeDecl constructors+scanNewtypeDecls (DataDecl _ NewType _ _ _ constructors _) = compileNewtypeDecl constructors scanNewtypeDecls _ = return () +-- | Add new types to the state+compileNewtypeDecl :: [QualConDecl] -> Compile ()+compileNewtypeDecl [QualConDecl _ _ _ condecl] = do+ case condecl of+ -- newtype declaration without destructor+ ConDecl name [ty] -> addNewtype name Nothing ty+ RecDecl cname [([dname], ty)] -> addNewtype cname (Just dname) ty+ x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x+ where+ getBangTy :: BangType -> Type+ getBangTy (BangedTy t) = t+ getBangTy (UnBangedTy t) = t+ getBangTy (UnpackedTy t) = t++ addNewtype cname dname ty = do+ qcname <- qualify cname+ qdname <- case dname of+ Nothing -> return Nothing+ Just n -> qualify n >>= return . Just+ modify (\cs@CompileState{stateNewtypes=nts} ->+ cs{stateNewtypes=(qcname,qdname,getBangTy ty):nts})+compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q++-- | Add record declarations to the state scanRecordDecls :: Decl -> Compile () scanRecordDecls decl = do case decl of@@ -82,7 +118,6 @@ addRecordTypeState name ns _ -> return () - case decl of DataDecl _ DataType _ _ _ constructors _ -> dataDecl constructors GDataDecl _ DataType _l _i _v _n decls _ -> dataDecl (map convertGADT decls)@@ -115,3 +150,51 @@ addRecordState :: Name -> [Name] -> Compile () addRecordState name fields = modify $ \s -> s { stateRecords = (UnQual name,map UnQual fields) : stateRecords s }++-- | Is this name imported from anywhere?+imported :: [ImportSpec] -> QName -> Compile Bool+imported is qn = anyM (matching qn) is+ where+ matching :: QName -> ImportSpec -> Compile Bool+ matching (Qual _ name) (IAbs typ) = return (name == typ)+ matching (Qual _ name) (IVar var) = return $ name == var+ matching (Qual _ name) (IThingAll typ) = do+ recs <- typeToRecs $ UnQual typ+ if UnQual name `elem` recs+ then return True+ else do+ fields <- typeToFields $ UnQual typ+ return $ UnQual name `elem` fields+ matching (Qual _ name) (IThingWith typ cns) =+ flip anyM cns $ \cn -> case cn of+ ConName _ -> do+ recs <- typeToRecs $ UnQual typ+ return $ UnQual name `elem` recs+ VarName _ -> do+ fields <- typeToFields $ UnQual typ+ return $ UnQual name `elem` fields+ matching q is' = error $ "compileImport: Unsupported QName ImportSpec combination " ++ show (q, is') ++ ", this is a bug!"++-- | Compile an import filtering the exports based on the current module's imports+compileImportWithFilter :: ModuleName -> (QName -> Compile Bool) -> Compile ()+compileImportWithFilter name importFilter =+ unlessImported name importFilter $ \filepath contents -> do+ read <- ask+ stat <- get+ result <- compileWith filepath read stat initialPass contents+ case result of+ Right ((),st,_) -> do+ imports <- filterM importFilter $ S.toList $ getCurrentExports st+ -- Merges the state gotten from passing through an imported+ -- module with the current state. We can assume no duplicate+ -- records exist since GHC would pick that up.+ modify $ \s -> s { stateRecords = stateRecords st+ , stateLocalScope = S.empty+ , stateRecordTypes = stateRecordTypes st+ , stateImported = stateImported st+ , stateNewtypes = stateNewtypes st+ , stateModuleScope = bindAsLocals imports (stateModuleScope s)+ , _stateExports = _stateExports st+ , stateModuleScopes = stateModuleScopes st+ }+ Left err -> throwError err
src/Fay/Compiler/Misc.hs view
@@ -16,6 +16,7 @@ import Control.Monad.RWS import Data.List import Data.Maybe+import qualified Data.Map as M import qualified Data.Set as S import Data.String import Data.Version (parseVersion)@@ -52,40 +53,47 @@ -- optimization. JsApp fun@JsFun{} [] -> JsNew JsThunk [fun] -- Otherwise make a regular thunk.- _ -> JsNew JsThunk [JsFun [] [] (Just expr)]+ _ -> JsNew JsThunk [JsFun Nothing [] [] (Just expr)] -- | Wrap an expression in a thunk. stmtsThunk :: [JsStmt] -> JsExp-stmtsThunk stmts = JsNew JsThunk [JsFun [] stmts Nothing]+stmtsThunk stmts = JsNew JsThunk [JsFun Nothing [] stmts Nothing] -- | Generate unique names. uniqueNames :: [JsName] uniqueNames = map JsParam [1::Integer ..] -- | Resolve a given maybe-qualified name to a fully qualifed name.-resolveName :: QName -> Compile QName-resolveName special@Special{} = return special-resolveName q@Qual{} = do- env <- gets stateModuleScope- maybe (throwError $ UnableResolveQualified q) return (ModuleScope.resolveName q env)-resolveName u@(UnQual name) = do+tryResolveName :: QName -> Compile (Maybe QName)+tryResolveName special@Special{} = return (Just special)+tryResolveName q@Qual{} = do+ ModuleScope.resolveName q <$> gets stateModuleScope+tryResolveName u@(UnQual name) = do names <- gets stateLocalScope env <- gets stateModuleScope if S.member name names- then return (UnQual name)- else maybe (qualify name) return (ModuleScope.resolveName u env)+ then return $ Just (UnQual name)+ else maybe (Just <$> qualify name) (return . Just) $ ModuleScope.resolveName u env +unsafeResolveName :: QName -> Compile QName+unsafeResolveName q = maybe (throwError $ UnableResolveQualified q) return =<< tryResolveName q+ lookupNewtypeConst :: QName -> Compile (Maybe (Maybe QName,Type))-lookupNewtypeConst name = do- newtypes <- gets stateNewtypes- case find (\(cname,_,_) -> cname == name) newtypes of+lookupNewtypeConst n = do+ mName <- tryResolveName n+ case mName of Nothing -> return Nothing- Just (_,dname,ty) -> return $ Just (dname,ty)+ Just name -> do+ newtypes <- gets stateNewtypes+ case find (\(cname,_,_) -> cname == name) newtypes of+ Nothing -> return Nothing+ Just (_,dname,ty) -> return $ Just (dname,ty) lookupNewtypeDest :: QName -> Compile (Maybe (QName,Type))-lookupNewtypeDest name = do+lookupNewtypeDest n = do+ mName <- tryResolveName n newtypes <- gets stateNewtypes- case find (\(_,dname,_) -> dname == Just name) newtypes of+ case find (\(_,dname,_) -> dname == mName) newtypes of Nothing -> return Nothing Just (cname,_,ty) -> return $ Just (cname,ty) @@ -141,25 +149,27 @@ EVar (UnQual n) -> emitVar n EVar q@Qual{} -> modify $ addCurrentExport q EThingAll (UnQual name) -> do- emitVar name- r <- lookup (UnQual name) <$> gets stateRecords- maybe (return ()) (mapM_ (emitVar . unQName)) r- EThingWith (UnQual name) ns -> do- emitVar name- mapM_ emitCName ns+ cons <- typeToRecs (UnQual name)+ fields <- typeToFields (UnQual name)+ mapM_ (emitVar . unQName) $ cons ++ fields+ EThingWith (UnQual _) ns -> mapM_ emitCName ns EAbs _ -> return () -- Type only, skip- EModuleContents mod ->- mapM_ (emitExport . EVar) =<< ModuleScope.moduleLocals mod <$> gets stateModuleScope+ EModuleContents mod -> do+ known_exports <- gets _stateExports+ current_scope <- gets stateModuleScope+ let names = case M.lookup mod known_exports of+ Just exports -> S.toList exports -- in case we're exporting other module take it's export list+ Nothing -> ModuleScope.moduleLocals mod current_scope -- in case we're exporting outselves export local names+ mapM_ (emitExport . EVar) names -- Skip qualified exports for type exports in fay-base since -- qualified imports are not supported yet an error will be thrown -- on the import so hopefully this won't be confusing. EThingAll (Qual _ _) -> return () e -> do- liftIO (print e) throwError $ UnsupportedExportSpec e where- emitVar = return . UnQual >=> resolveName >=> emitExport . EVar+ emitVar = return . UnQual >=> unsafeResolveName >=> emitExport . EVar emitCName (VarName n) = emitVar n emitCName (ConName n) = emitVar n unQName (UnQual u) = u@@ -215,6 +225,11 @@ isWildCardPat PVar{} = True isWildCardPat _ = False +-- | Return formatter string if expression is a FFI call.+ffiExp :: Exp -> Maybe String+ffiExp (App (Var (UnQual (Ident "ffi"))) (Lit (String formatstr))) = Just formatstr+ffiExp _ = Nothing+ -- | Generate a temporary, SCOPED name for testing conditions and -- such. withScopedTmpJsName :: (JsName -> Compile a) -> Compile a@@ -289,19 +304,6 @@ | mname == ModuleName "Language.Fay.FFI" = const "module Language.Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined" | otherwise = id --- | Convert a GADT to a normal data type.-convertGADT :: GadtDecl -> QualConDecl-convertGADT d =- case d of- GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context- (ConDecl name (convertFunc typ))- where tyvars = []- context = []- convertFunc (TyCon _) = []- convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs- convertFunc (TyParen x) = convertFunc x- convertFunc _ = []- -- | Run the compiler. runCompile :: CompileReader -> CompileState -> Compile a@@ -348,11 +350,15 @@ parseMode :: ParseMode parseMode = defaultParseMode { extensions = [GADTs+ ,ExistentialQuantification ,StandaloneDeriving ,PackageImports ,EmptyDataDecls ,TypeOperators ,RecordWildCards- ,NamedFieldPuns]+ ,NamedFieldPuns+ ,FlexibleContexts+ ,FlexibleInstances+ ,KindSignatures] , fixities = Just (preludeFixities ++ baseFixities) }
src/Fay/Compiler/ModuleScope.hs view
@@ -11,6 +11,8 @@ ,moduleLocals) where +import Fay.Compiler.GADT+ import Control.Arrow import Control.Monad.Reader import Control.Monad.Writer@@ -122,6 +124,7 @@ d_decl :: Decl -> ModuleScopeSt d_decl d = case d of DataDecl _ _ _ _ _ dd _ -> mapM_ d_qualCon dd+ GDataDecl _ DataType _l _i _v _n decls _ -> mapM_ d_qualCon (map convertGADT decls) PatBind _ (PVar n) _ _ _ -> bindName n FunBind (Match _ n _ _ _ _ : _) -> bindName n ClassDecl _ _ _ _ _ cds -> mapM_ d_classDecl cds
src/Fay/Compiler/Optimizer.hs view
@@ -69,7 +69,7 @@ Just x -> x -- Plumbing- JsFun names stmts mexp -> JsFun names (map go stmts) (fmap inline mexp)+ JsFun nm names stmts mexp -> JsFun nm names (map go stmts) (fmap inline mexp) JsNegApp exp -> JsNegApp (inline exp) JsTernaryIf exp1 exp2 exp3 -> JsTernaryIf (inline exp1) (inline exp2) (inline exp3)@@ -124,12 +124,12 @@ JsVar name exp -> JsVar name (inject name exp) e -> e inject name exp = case exp of- JsFun params [] (Just (JsNew JsThunk [JsFun [] stmts ret])) ->- JsFun params+ JsFun nm params [] (Just (JsNew JsThunk [JsFun _ [] stmts ret])) ->+ JsFun nm params [] (Just (JsNew JsThunk- [JsFun []+ [JsFun Nothing [] (optimize params name (stmts ++ [ JsEarlyReturn e | Just e <- [ret] ])) Nothing])) _ -> exp@@ -163,9 +163,9 @@ stripFuncForces arities exp = case exp of JsApp (JsName JsForce) [JsName (JsNameVar f)] | Just _ <- lookup f arities -> return (JsName (JsNameVar f))- JsFun ps stmts body -> do substmts <- mapM stripInStmt stmts+ JsFun nm ps stmts body -> do substmts <- mapM stripInStmt stmts sbody <- maybe (return Nothing) (fmap Just . go) body- return (JsFun ps substmts sbody)+ return (JsFun nm ps substmts sbody) JsApp a b -> do result <- walkAndStripForces arities exp case result of@@ -237,7 +237,7 @@ -- | Get the arity of an expression. expArity :: JsExp -> Int-expArity (JsFun _ _ mexp) = 1 + maybe 0 expArity mexp+expArity (JsFun _ _ _ mexp) = 1 + maybe 0 expArity mexp expArity _ = 0 -- | Change foo(x)(y) to foo$uncurried(x,y).@@ -253,8 +253,8 @@ uncurryIt = Just . go [] where go args exp = case exp of- JsFun [arg] [] (Just body) -> go (arg : args) body- inner -> JsFun (reverse args) [] (Just inner)+ JsFun _ [arg] [] (Just body) -> go (arg : args) body+ inner -> JsFun Nothing (reverse args) [] (Just inner) -- | Rename an uncurried copy of a curried function. renameUncurried :: QName -> QName
src/Fay/Compiler/Packages.hs view
@@ -59,7 +59,7 @@ describePackage db name = do result <- readAllFromProcess ghc_pkg args "" case result of- Left err -> error $ "ghc-pkg describe error:\n" ++ err+ Left (err,_out) -> error $ "ghc-pkg describe error:\n" ++ err Right (_err,out) -> return out where args = concat [["describe",name]
src/Fay/Compiler/Pattern.hs view
@@ -21,8 +21,7 @@ case pat of PVar name -> compilePVar name exp body PApp cons pats -> do- qcons <- qualifyQName cons- newty <- lookupNewtypeConst qcons+ newty <- lookupNewtypeConst cons case newty of Nothing -> compilePApp cons pats exp body Just _ -> compileNewtypePat pats exp body@@ -46,7 +45,7 @@ compilePatFields :: JsExp -> QName -> [PatField] -> [JsStmt] -> Compile [JsStmt] compilePatFields exp name pats body = do c <- liftM (++ body) (compilePats' [] pats)- qname <- resolveName name+ qname <- unsafeResolveName name return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []] where -- compilePats' collects field names that had already been matched so that -- wildcard generates code for the rest of the fields.@@ -131,7 +130,7 @@ compilePat (JsGetProp forcedExp (JsNameVar field)) pat body) body (reverse (zip recordFields pats))- qcons <- resolveName cons+ qcons <- unsafeResolveName cons return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons) substmts []]
src/Fay/Compiler/Print.hs view
@@ -165,8 +165,10 @@ printJS (JsObj assoc) = "{" +> (intercalateM "," (map cons assoc)) +> "}" where cons (key,value) = "\"" +> key +> "\": " +> value- printJS (JsFun params stmts ret) =- "function("+ printJS (JsFun nm params stmts ret) =+ "function"+ +> maybe (return ()) ((" " +>) . printJS) nm+ +> "(" +> (intercalateM "," (map printJS params)) +> "){" +> newline +> indented (stmts +>@@ -212,12 +214,16 @@ -- | Words reserved in haskell as well are not needed here: -- case, class, do, else, if, import, in, let reservedWords :: [String]-reservedWords = [- "break", "catch", "const", "continue", "debugger", "delete", "enum", "export",- "extends", "finally", "for", "function", "global", "implements", "instanceof",- "interface", "new", "null", "package", "private", "protected", "public", "return",- "static", "super", "switch", "this", "throw", "try", "typeof", "undefined",- "var", "void", "while", "window", "with", "yield","true","false"]+reservedWords =+ ["abstract","boolean","break","byte","case","catch","char","class"+ ,"comment","const","continue","debugger","default","delete","do","double"+ ,"else","enum","export","extends","false","final","finally","float"+ ,"for","function","global","goto","if","implements","import","in"+ ,"instanceOf","instanceof","int","interface","label","long","native"+ ,"new","null","package","private","protected","public","return","short"+ ,"static","super","switch","synchronized","this","throw","throws"+ ,"transient","true","try","typeof","undefined","var","void","while"+ ,"window","with","yield"] -- | Encode a Haskell name to JavaScript. encodeName :: String -> String
src/Fay/Compiler/Typecheck.hs view
@@ -36,7 +36,7 @@ , "-i" ++ concat (intersperse ":" includeDirs) , fp ] ++ ghcPackageDbArgs ++ wallF ++ map ("-package " ++) packages res <- io $ readAllFromProcess GHCPaths.ghc flags ""- either error (warn . fst) res+ either (error . fst) (warn . fst) res where wallF | wall = ["-Wall"] | otherwise = []
src/Fay/Convert.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternGuards #-} {-# OPTIONS -fno-warn-type-defaults #-} -- | Convert a Haskell value to a (JSON representation of a) Fay value.@@ -24,6 +25,7 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text+import Data.Vector (Vector) import qualified Data.Vector as Vector import Numeric import Safe@@ -46,6 +48,9 @@ Show.Rec name fields -> fmap (Object . Map.fromList . (("instance",string name) :)) (mapM (uncurry keyval) fields) + -- ()+ Show.Tuple [] -> return Null+ -- List types Show.Tuple values -> fmap (Array . Vector.fromList) (mapM convert values) Show.List values -> fmap (Array . Vector.fromList) (mapM convert values)@@ -91,27 +96,41 @@ keyval key val = fmap (Text.pack key,) (convert val) -- | Convert a value representing a Fay value to a Haskell value.- readFromFay :: Data a => Value -> Maybe a readFromFay value = do- parseData value+ parseDataOrTuple value `ext1R` parseArray value `extR` parseDouble value `extR` parseInt value `extR` parseBool value `extR` parseString value+ `extR` parseChar value `extR` parseText value+ `extR` parseUnit value --- | Parse a data type or record.-parseData :: Data a => Value -> Maybe a-parseData value = result where- result = getObject value >>= parseObject typ+-- | Parse a data type or record or tuple.+parseDataOrTuple :: Data a => Value -> Maybe a+parseDataOrTuple value = result where+ result = getAndParse value typ = dataTypeOf (fromJust result)- getObject x =+ getAndParse x = case x of- Object obj -> return obj+ Object obj -> parseObject typ obj+ Array tuple -> parseTuple typ tuple _ -> mzero +-- | Parse a tuple.+parseTuple :: Data a => DataType -> Vector Value -> Maybe a+parseTuple typ arr =+ case dataTypeConstrs typ of+ [cons] -> evalStateT (fromConstrM (do i:next <- get+ put next+ value <- lift (Vector.indexM arr i)+ lift (readFromFay value))+ cons)+ [0..]+ _ -> Nothing+ -- | Parse a data constructor from an object. parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a parseObject typ obj = listToMaybe (catMaybes choices) where@@ -183,6 +202,13 @@ String s -> return (Text.unpack s) _ -> mzero +-- | Parse a char.+parseChar :: Value -> Maybe Char+parseChar value =+ case value of+ String s | Just (c,_) <- Text.uncons s -> return c+ _ -> mzero+ -- | Parse a Text. parseText :: Value -> Maybe Text parseText value =@@ -195,4 +221,11 @@ parseArray value = case value of Array xs -> mapM readFromFay (Vector.toList xs)+ _ -> mzero++-- | Parse unit.+parseUnit :: Value -> Maybe ()+parseUnit value =+ case value of+ Null -> return () _ -> mzero
src/Fay/Types.hs view
@@ -23,6 +23,7 @@ ,CompileState(..) ,addCurrentExport ,getCurrentExports+ ,getCurrentExportsWithoutNewtypes ,getExportsFor ,faySourceDir ,FundamentalType(..)@@ -71,7 +72,6 @@ , configLibrary :: Bool -- ^ Don't invoke main in the produced JS. , configWarn :: Bool -- ^ Warn on dubious stuff, not related to typechecking. , configFilePath :: Maybe FilePath -- ^ File path to output to.- -- TODO: This flag is not used thoroughly, decide if it's needed. , configTypecheck :: Bool -- ^ Typecheck with GHC. , configWall :: Bool -- ^ Typecheck with -Wall. , configGClosure :: Bool -- ^ Run Google Closure on the produced JS.@@ -90,14 +90,15 @@ , stateNameDepth :: Integer -- ^ Depth of the current lexical scope. , stateLocalScope :: Set Name -- ^ Names in the current lexical scope. , stateModuleScope :: ModuleScope -- ^ Names in the module scope.+ , stateModuleScopes :: Map ModuleName ModuleScope , stateModuleName :: ModuleName -- ^ Name of the module currently being compiled. } deriving (Show) -- | Things written out by the compiler. data CompileWriter = CompileWriter { writerCons :: [JsStmt] -- ^ Constructors.- , writerFayToJs :: [JsStmt] -- ^ Fay to JS dispatchers.- , writerJsToFay :: [JsStmt] -- ^ JS to Fay dispatchers.+ , writerFayToJs :: [(String,JsExp)] -- ^ Fay to JS dispatchers.+ , writerJsToFay :: [(String,JsExp)] -- ^ JS to Fay dispatchers. } deriving (Show) @@ -131,9 +132,8 @@ getCurrentExports :: CompileState -> Set QName getCurrentExports cs = getExportsFor (stateModuleName cs) cs --- | Get all of the exported identifiers for the given module.-getExportsFor :: ModuleName -> CompileState -> Set QName-getExportsFor mn cs = excludeNewtypes cs $ fromMaybe S.empty $ M.lookup mn (_stateExports cs)+getCurrentExportsWithoutNewtypes :: CompileState -> Set QName+getCurrentExportsWithoutNewtypes cs = excludeNewtypes cs $ getCurrentExports cs where excludeNewtypes :: CompileState -> Set QName -> Set QName excludeNewtypes cs' names =@@ -142,6 +142,10 @@ destrs = map (\(_, d, _) -> fromJust d) . filter (\(_, d, _) -> isJust d) $ newtypes in names `S.difference` (S.fromList constrs `S.union` S.fromList destrs) +-- | Get all of the exported identifiers for the given module.+getExportsFor :: ModuleName -> CompileState -> Set QName+getExportsFor mn cs = fromMaybe S.empty $ M.lookup mn (_stateExports cs)+ -- | Compile monad. newtype Compile a = Compile { unCompile :: RWST CompileReader CompileWriter CompileState (ErrorT CompileError IO) a -- ^ Run the compiler.@@ -252,7 +256,7 @@ = JsName JsName | JsRawExp String | JsSeq [JsExp]- | JsFun [JsName] [JsStmt] (Maybe JsExp)+ | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp) | JsLit JsLit | JsApp JsExp [JsExp] | JsNegApp JsExp
src/System/Process/Extra.hs view
@@ -5,11 +5,10 @@ import System.Exit import System.Process --- | Read everything from a process, either failure or both stderr and stdout.-readAllFromProcess :: FilePath -> [String] -> String -> IO (Either String (String,String))+readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String)) readAllFromProcess program flags input = do (code,out,err) <- readProcessWithExitCode program flags input return $ case code of- ExitFailure 127 -> Left ("cannot find executable " ++ program)- ExitFailure _ -> Left err+ ExitFailure 127 -> Left ("cannot find executable " ++ program, "")+ ExitFailure _ -> Left (err, out) ExitSuccess -> Right (err, out)
src/Test/CommandLine.hs view
@@ -27,8 +27,8 @@ if exists then do r <- readAllFromProcess path flags "" return $ case r of- Left l -> Left ("Reason: " ++ l)- Right t -> Right $ snd t+ Left (l,_) -> Left ("Reason: " ++ l)+ Right (_,t) -> Right t else error $ "fay path not are existing: " ++ path case_executable :: Assertion
src/Test/Convert.hs view
@@ -57,6 +57,11 @@ ,ReadTest $ StepcutFoo' 789 ,ReadTest $ Baz (StepcutFoo' 10112) ,ReadTest $ TextConstructor $ pack "This is \"some text\n\n\""+ ,ReadTest $ (("foo",'a') :: (String,Char))+ ,ReadTest $ ((pack "foo",'a',23) :: (Text,Char,Int))+ ,ReadTest $ TupleList [(pack "foo",pack "bar")]+ ,ReadTest $ TupleList' [((pack "foo",23) :: (Text,Int))]+ ,ReadTest $ () ] -- | Test cases.@@ -71,6 +76,7 @@ ,((1,2) :: (Int,Int)) → "[1,2]" ,"abc" → "\"abc\"" ,'a' → "\"a\""+ , () → "null" -- Data records ,NullaryConstructor → "{\"instance\":\"NullaryConstructor\"}" ,NAryConstructor 123 4.5 → "{\"slot1\":123,\"slot2\":4.5,\"instance\":\"NAryConstructor\"}"@@ -142,3 +148,9 @@ data TextConstructor = TextConstructor Text deriving (Eq, Show, Read, Typeable, Data)++data TupleList = TupleList [(Text,Text)]+ deriving (Read, Typeable, Data, Show, Eq)++data TupleList' a = TupleList' [(Text,a)]+ deriving (Read, Typeable, Data, Show, Eq)
src/Tests.hs view
@@ -23,31 +23,32 @@ import qualified Test.Convert as C import Test.Framework import Test.Framework.Providers.HUnit-import Test.HUnit (assertEqual)+import Test.HUnit (assertEqual, assertFailure) -- | Main test runner. main :: IO () main = do sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs- compiler <- makeCompilerTests (packageConf <|> sandbox)+ let (basePath,args') = prefixed (=="-base-path") args+ compiler <- makeCompilerTests (packageConf <|> sandbox) basePath defaultMainWithArgs [Api.tests, Cmd.tests, compiler, C.tests]- args+ args' -- | Extract the element prefixed by the given element in the list. prefixed :: (a -> Bool) -> [a] -> (Maybe a,[a]) prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y) -- | Make the case-by-case unit tests.-makeCompilerTests :: Maybe FilePath -> IO Test-makeCompilerTests packageConf = do+makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test+makeCompilerTests packageConf basePath = do files <- fmap (map ("tests" </>) . sort . filter (isSuffixOf ".hs")) $ getDirectoryContents "tests" return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do- testFile packageConf False file- testFile packageConf True file+ testFile packageConf basePath False file+ testFile packageConf basePath True file -testFile :: Maybe FilePath -> Bool -> String -> IO ()-testFile packageConf opt file = do+testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO ()+testFile packageConf basePath opt file = do let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file out = toJsName file config =@@ -55,15 +56,25 @@ def { configOptimize = opt , configTypecheck = False , configPackageConf = packageConf+ , configBasePath = basePath } outExists <- doesFileExist root+ let partialName = root ++ "_partial"+ partialExists <- doesFileExist partialName compileFromTo config file (Just out) result <- runJavaScriptFile out if outExists then do output <- readFile root- assertEqual file output (either show id result)- else assertEqual file True (either (const True) (const False) result)+ assertEqual file output (either show snd result)+ else+ if partialExists+ then case result of+ Left (_,res) -> do+ output <- readFile partialName+ assertEqual file output res+ Right (err,res) -> assertFailure $ "Did not fail:\n stdout: " ++ res ++ "\n\nstderr: " ++ err+ else assertEqual file True (either (const True) (const False) result) -- | Run a JS file.-runJavaScriptFile :: String -> IO (Either String String)-runJavaScriptFile file = fmap (fmap snd) (readAllFromProcess "node" [file] "")+runJavaScriptFile :: String -> IO (Either (String,String) (String,String))+runJavaScriptFile file = readAllFromProcess "node" [file] ""