diff --git a/examples/dom.hs b/examples/dom.hs --- a/examples/dom.hs +++ b/examples/dom.hs @@ -12,9 +12,9 @@ printBody :: Fay () printBody = do result <- documentGetElements "body" - print (show result) + print result -print :: String -> Fay () +print :: Foreign a => [a] -> Fay () print = ffi "console.log(%1)" data Element diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.5.2.0 +version: 0.6.0.0 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which can be compiled (type-checked) with GHC, and compiled to JavaScript. It is lazy, pure, with a Fay monad, @@ -22,6 +22,26 @@ . /Release Notes/ . + * Added Compiler.compileFile to compile a file without writing to disk + . + * abstracted out constructorName function + . + * fix fixed RecConstr + . + * Fix RecConstr to avoid name conflicts. + . + * BREAKING CHANGES, READ THIS COMMIT. + . + * Added the new flags to the cmdline docs + . + * --output=file to specify where the result should be placed + . + * Exporting Language.Fay.Compiler + . + * Added the cmdline flag -include=dir1[,..dirN] which will look in the specified directories for imports + . + * CompileConfig now contains configDirectoryIncludes allowing imports to be located separately from where the base file + . * Add Paths_fay to cabal. . * Update docs and fix runtime regressions. @@ -78,7 +98,7 @@ library hs-source-dirs: src - exposed-modules: Language.Fay, Language.Fay.Types, Language.Fay.FFI, Language.Fay.Prelude, Language.Fay.Show + exposed-modules: Language.Fay, Language.Fay.Types, Language.Fay.FFI, Language.Fay.Prelude, Language.Fay.Show, Language.Fay.Compiler other-modules: Language.Fay.Print, Control.Monad.IO, Language.Fay.Stdlib, System.Process.Extra, Paths_fay ghc-options: -O2 build-depends: base >= 4 && < 5, @@ -112,7 +132,9 @@ process, data-default, safe, - language-javascript + language-javascript, + directory, + filepath executable fay-tests hs-source-dirs: src diff --git a/hs/stdlib.hs b/hs/stdlib.hs --- a/hs/stdlib.hs +++ b/hs/stdlib.hs @@ -3,7 +3,7 @@ | Nothing show :: (Foreign a,Show a) => a -> String -show = ffi "Fay$$encodeShow(%1)" +show = ffi "JSON.stringify(%1)" -- There is only Double in JS. fromInteger x = x diff --git a/js/runtime.js b/js/runtime.js --- a/js/runtime.js +++ b/js/runtime.js @@ -37,16 +37,7 @@ : (this.forced = true, this.value = this.value()); }; -/******************************************************************************* - * Constructors. - */ -// A constructor. -function Fay$$Constructor(){ - this.name = arguments[0]; - this.fields = Array.prototype.slice.call(arguments,1); -} - // Eval in the context of the Haskell bindings. function Fay$$eval(str){ return eval(str); @@ -88,11 +79,12 @@ } /******************************************************************************* - * FFI. + * Serialization. + * Fay <-> JS. Should be bijective. */ // Serialize a Fay object to JS. -function Fay$$serialize(type,fayObj){ +function Fay$$fayToJs(type,fayObj){ var base = type[0]; var args = type[1]; var jsObj; @@ -101,7 +93,7 @@ // A nullary monadic action. Should become a nullary JS function. // Fay () -> function(){ return ... } jsObj = function(){ - return Fay$$serialize(args[0],_(fayObj,true).value); + return Fay$$fayToJs(args[0],_(fayObj,true).value); }; break; } @@ -119,18 +111,18 @@ // passes more arguments than Haskell accepts. for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) { // Unserialize the JS values to Fay for the Fay callback. - fayFunc = _(fayFunc(Fay$$unserialize(args[i],arguments[i])),true); + fayFunc = _(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true); } // Finally, serialize the Fay return value back to JS. var return_base = return_type[0]; var return_args = return_type[1]; // If it's a monadic return value, get the value instead. if(return_base == "action") { - return Fay$$serialize(return_args[0],fayFunc.value); + return Fay$$fayToJs(return_args[0],fayFunc.value); } // Otherwise just serialize the value direct. else { - return Fay$$serialize(return_type,fayFunc); + return Fay$$fayToJs(return_type,fayFunc); } } else { throw new Error("Nullary function?"); @@ -154,7 +146,7 @@ var arr = []; fayObj = _(fayObj); while(fayObj instanceof Fay$$Cons) { - arr.push(Fay$$serialize(args[0],fayObj.car)); + arr.push(Fay$$fayToJs(args[0],fayObj.car)); fayObj = _(fayObj.cdr); } jsObj = arr; @@ -175,20 +167,20 @@ jsObj = fayObj; break; } - default: throw new Error("Unhandled serialize type: " + base); + default: throw new Error("Unhandled Fay->JS translation type: " + base); } return jsObj; } // Unserialize an object from JS to Fay. -function Fay$$unserialize(type,jsObj){ +function Fay$$jsToFay(type,jsObj){ var base = type[0]; var args = type[1]; var fayObj; switch(base){ case "action": { // Unserialize a "monadic" JavaScript return value into a monadic value. - fayObj = Fay$$return(Fay$$unserialize(args[0],jsObj)); + fayObj = Fay$$return(Fay$$jsToFay(args[0],jsObj)); break; } case "string": { @@ -201,7 +193,7 @@ var serializedList = []; for (var i = 0, len = jsObj.length; i < len; i++) { // Unserialize each JS value into a Fay value, too. - serializedList.push(Fay$$unserialize(args[0],jsObj[i])); + serializedList.push(Fay$$jsToFay(args[0],jsObj[i])); } // Pop it all in a Fay list. fayObj = Fay$$list(serializedList); @@ -222,42 +214,9 @@ fayObj = jsObj; break; } - default: throw new Error("Unhandled unserialize type: " + base); + default: throw new Error("Unhandled JS->Fay translation type: " + base); } return fayObj; -} - -// Encode a value to a Show representation -function Fay$$encodeShow(x){ - if (x instanceof $) x = _(x); - if (x instanceof Array) { - if (x.length == 0) { - return "[]"; - } else { - if (x[0] instanceof Fay$$Constructor) { - if(x[0].fields.length > 0) { - var args = x.slice(1); - var fieldNames = x[0].fields; - return "(" + x[0].name + " { " + args.map(function(x,i){ - return fieldNames[i] + ' = ' + Fay$$encodeShow(x); - }).join(", ") + " })"; - } else { - var args = x.slice(1); - return "(" + [x[0].name].concat(args.map(Fay$$encodeShow)).join(" ") + ")"; - } - } else { - return "[" + x.map(Fay$$encodeShow).join(",") + "]"; - } - } - } else if (typeof x == 'string') { - return JSON.stringify(x); - } else if(x instanceof Fay$$Cons) { - return Fay$$encodeShow(Fay$$serialize(["list",[["unknown"]]],x)); - } else if(x == null) { - return '[]'; - } else { - return x.toString(); - } } /******************************************************************************* diff --git a/src/Language/Fay.hs b/src/Language/Fay.hs --- a/src/Language/Fay.hs +++ b/src/Language/Fay.hs @@ -28,6 +28,8 @@ import Data.String import Language.Haskell.Exts import Safe +import System.FilePath (()) +import System.Directory (doesFileExist) import qualified Language.JavaScript.Parser as JS import System.Process.Extra @@ -114,18 +116,30 @@ instance CompilesTo Module [JsStmt] where compileTo = compileModule +findImport :: [FilePath] -> String -> IO String +findImport (dir:dirs) name = do + exists <- doesFileExist path + if exists + then readFile path + else findImport dirs name + where + path = dir replace '.' '/' name ++ ".hs" + replace c r = map (\x -> if x == c then r else x) +findImport [] name = + error $ "Could not find import: " ++ name + -- | Compile the given import. compileImport :: ImportDecl -> Compile [JsStmt] compileImport (ImportDecl _ (ModuleName name) _ _ _ _ _) | elem name ["Language.Fay.Prelude","Language.Fay.FFI","Language.Fay.Types"] || name == "Prelude" = return [] compileImport (ImportDecl _ (ModuleName name) False _ Nothing Nothing Nothing) = do - contents <- io (readFile (replace '.' '/' name ++ ".hs")) + dirs <- configDirectoryIncludes <$> gets stateConfig + contents <- io (findImport dirs name) cfg <- config id result <- liftIO $ compileToAst cfg compileModule contents case result of Right (stmts,_) -> return stmts Left err -> throwError err - where replace c r = map (\x -> if x == c then r else x) compileImport i = error $ "Import syntax not supported. " ++ "The compiler writer was too lazy to support that.\n" ++ @@ -194,7 +208,7 @@ wrapReturn inner = thunk $ case lastMay funcFundamentalTypes of -- Returns a “pure” value; - Just{} -> unserialize returnType (JsRawExp inner) + Just{} -> jsToFay returnType (JsRawExp inner) -- Base case: Nothing -> JsRawExp inner funcFundamentalTypes = functionTypeArgs sig @@ -228,15 +242,12 @@ case listToMaybe (drop (n-1) args) of Nothing -> throwError (FfiFormatNoSuchArg n) Just (arg,typ) -> do - return (printJS (serialize typ (JsName arg))) + return (printJS (fayToJs typ (JsName arg))) --- | Serialize a value to native JS, if possible. -serialize :: FundamentalType -> JsExp -> JsExp -serialize typ exp = - case typ of --- UnknownType -> force exp - _ -> JsApp (JsName (hjIdent "serialize")) - [typeRep typ,exp] +-- | Translate: Fay → JS. +fayToJs :: FundamentalType -> JsExp -> JsExp +fayToJs typ exp = JsApp (JsName (hjIdent "fayToJs")) + [typeRep typ,exp] -- | Get a JS-representation of a fundamental type for encoding/decoding. typeRep :: FundamentalType -> JsExp @@ -313,8 +324,6 @@ _ -> throwError (UnsupportedDeclaration decl) where - constructorName = fromString . (++ "_RecConstr") . qname - addRecordState :: QName -> [Name] -> Compile () addRecordState name fields = modify $ \s -> s { stateRecords = (Ident (qname name), fields) : stateRecords s } @@ -356,6 +365,9 @@ unname (Ident str) = str unname _ = error "Expected ident from uname." -- FIXME: +constructorName :: QName -> QName +constructorName = fromString . (++ "$_") . qname + -- | Compile a function which pattern matches (causing a case analysis). compileFunCase :: Bool -> [Match] -> Compile [JsStmt] compileFunCase _toplevel [] = return [] @@ -668,8 +680,8 @@ compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp compileRecConstr name fieldUpdates = do let o = UnQual (Ident (map toLower (qname name))) - -- var obj = new Type_RecConstr() - let record = JsVar o (JsNew (UnQual (Ident ((qname name) ++ "_RecConstr"))) []) + -- var obj = new $_Type() + let record = JsVar o (JsNew (constructorName name) []) setFields <- forM fieldUpdates $ -- obj.field = value \(FieldUpdate (UnQual field) value) -> JsSetProp o (UnQual field) <$> compileExp value @@ -708,7 +720,7 @@ compilePat (JsGetProp forcedExp (fromString field)) pat body) body (reverse (zip recordFields pats)) - return [JsIf (forcedExp `JsInstanceOf` (UnQual (Ident ((qname cons) ++ "_RecConstr")))) + return [JsIf (forcedExp `JsInstanceOf` (constructorName cons)) substmts []] @@ -849,10 +861,10 @@ stmtsThunk :: [JsStmt] -> JsExp stmtsThunk stmts = JsNew ":thunk" [JsFun [] stmts Nothing] -unserialize :: FundamentalType -> JsExp -> JsExp -unserialize typ exp = - JsApp (JsName (hjIdent "unserialize")) - [typeRep typ,exp] +-- | Translate: JS → Fay. +jsToFay :: FundamentalType -> JsExp -> JsExp +jsToFay typ exp = JsApp (JsName (hjIdent "jsToFay")) + [typeRep typ,exp] -- | Force an expression in a thunk. force :: JsExp -> JsExp diff --git a/src/Language/Fay/Compiler.hs b/src/Language/Fay/Compiler.hs --- a/src/Language/Fay/Compiler.hs +++ b/src/Language/Fay/Compiler.hs @@ -13,6 +13,13 @@ -- | Compile file program to… compileFromTo :: CompileConfig -> Bool -> FilePath -> FilePath -> IO () compileFromTo config autorun filein fileout = do + result <- compileFile config autorun filein + case result of + Right out -> writeFile fileout out + Left err -> throw err + +compileFile :: CompileConfig -> Bool -> FilePath -> IO (Either CompileError String) +compileFile config autorun filein = do runtime <- getDataFileName "js/runtime.js" stdlibpath <- getDataFileName "hs/stdlib.hs" stdlibpathprelude <- getDataFileName "src/Language/Fay/Stdlib.hs" @@ -20,14 +27,11 @@ stdlib <- readFile stdlibpath stdlibprelude <- readFile stdlibpathprelude hscode <- readFile filein - result <- compileProgram config - autorun - raw - compileModule - (hscode ++ "\n" ++ stdlib ++ "\n" ++ strip stdlibprelude) - case result of - Right out -> writeFile fileout out - Left err -> throw err + compileProgram config + autorun + raw + compileModule + (hscode ++ "\n" ++ stdlib ++ "\n" ++ strip stdlibprelude) where strip = unlines . dropWhile (/="-- START") . lines @@ -50,20 +54,18 @@ ,"// Exports" ,unlines (map printExport exports) ,"// Built-ins" - ,"this.$force = _;" + ,"this._ = _;" ,if configExportBuiltins config then unlines ["this.$ = $;" - ,"this.$list = Fay$$list;" - ,"this.$encodeShow = Fay$$encodeShow;" - ,"this.$eval = Fay$$eval;" - ,"this.$serialize = Fay$$serialize;" + ,"this.$fayToJs = Fay$$fayToJs;" + ,"this.$jsToFay = Fay$$jsToFay;" ] else "" ,"};" ,if autorun then unlines [";" ,"var main = new " ++ modulename ++ "();" - ,"main.$force(main.main);" + ,"main._(main.main);" ] else "" ])) diff --git a/src/Language/Fay/Types.hs b/src/Language/Fay/Types.hs --- a/src/Language/Fay/Types.hs +++ b/src/Language/Fay/Types.hs @@ -35,15 +35,16 @@ -- | Configuration of the compiler. data CompileConfig = CompileConfig - { configTCO :: Bool - , configInlineForce :: Bool - , configFlattenApps :: Bool - , configExportBuiltins :: Bool + { configTCO :: Bool + , configInlineForce :: Bool + , configFlattenApps :: Bool + , configExportBuiltins :: Bool + , configDirectoryIncludes :: [FilePath] } deriving (Show) -- | Default configuration. instance Default CompileConfig where - def = CompileConfig False False False True + def = CompileConfig False False False True [] -- | State of the compiler. data CompileState = CompileState diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -6,9 +6,11 @@ import Language.Fay.Compiler import Language.Fay.Types +import Control.Arrow import Control.Monad import Data.Default import Data.List +import Data.Maybe import System.Environment -- | Main entry point. @@ -16,7 +18,8 @@ main = do args <- getArgs let files = filter (not . isPrefixOf "-") args - opts = map (drop 1) $ filter (isPrefixOf "-") args + paramOpts = map ((drop 2 *** drop 1) . break (== '=')) $ filter (isPrefixOf "--") args + opts = map (drop 1) $ filter (\v -> isPrefixOf "-" v && not (isPrefixOf "--" v)) args if (elem "help" opts) || null files then putStrLn helpText else forM_ files $ \file -> do @@ -24,11 +27,16 @@ , configInlineForce = elem "inline-force" opts , configFlattenApps = elem "flatten-apps" opts , configExportBuiltins = not (elem "no-export-builtins" opts) + , configDirectoryIncludes = maybe [] (split ',') (lookup "include" paramOpts) } (elem "autorun" opts) file - (toJsName file) - + (fromMaybe (toJsName file) $ lookup "output" paramOpts) + where + -- | "12,34,5" => ["12","34","5"] + split :: Eq a => a -> [a] -> [[a]] + split _ [] = [] + split a as = takeWhile (/= a) as : split a (drop 1 $ dropWhile (/= a) as) helpText = unlines ["fay -- compiler from (a proper subset of) Haskell to JavaScript" @@ -41,4 +49,7 @@ ," -inline-force inline forcing, adds some speed for numbers, blows up code a bit" ," -flatten-apps flatten function application, can be more readable," ," no noticeable speed difference" + ," --include=dir1[, ..]" + ," looks in these additional directories for imports" + ," --output=file places the resulting file in this location" ] diff --git a/tests/29 b/tests/29 --- a/tests/29 +++ b/tests/29 @@ -1,3 +1,3 @@ -[[1,2,3],[1,2,3]] -[[1,2,3],1,[2,3]] -[[1,2,3],1,[2,3]] +{"car":{"car":1,"cdr":{"car":2,"cdr":{"car":3,"cdr":null}}},"cdr":{"car":{"car":1,"cdr":{"car":2,"cdr":{"car":3,"cdr":null}}},"cdr":null}} +{"car":{"car":1,"cdr":{"car":2,"cdr":{"car":3,"cdr":null}}},"cdr":{"car":1,"cdr":{"car":{"car":2,"cdr":{"car":3,"cdr":null}},"cdr":null}}} +{"car":{"car":1,"cdr":{"car":2,"cdr":{"car":3,"cdr":null}}},"cdr":{"car":1,"cdr":{"car":{"car":2,"cdr":{"car":3,"cdr":null}},"cdr":null}}} diff --git a/tests/29.hs b/tests/29.hs --- a/tests/29.hs +++ b/tests/29.hs @@ -23,6 +23,3 @@ print $ show $ matchSame [1,2,3] print $ show $ matchSplit [1,2,3] print $ show $ matchNested (1, [1,2,3]) - -show :: Foreign a => a -> String -show = ffi "JSON.stringify(%1)" diff --git a/tests/30.hs b/tests/30.hs --- a/tests/30.hs +++ b/tests/30.hs @@ -25,6 +25,9 @@ main :: Fay () main = do - print $ show $ (isPositive 1, isPositive 0) - print $ show $ (threeConds 3, threeConds 1, threeConds 0) - print $ show $ (withOtherwise 2, withOtherwise 0) + print $ showList $ (isPositive 1, isPositive 0) + print $ showList $ (threeConds 3, threeConds 1, threeConds 0) + print $ showList $ (withOtherwise 2, withOtherwise 0) + +showList :: Foreign a => [a] -> String +showList = ffi "JSON.stringify(%1)"