fay 0.5.2.0 → 0.6.0.0

raw patch · 11 files changed

+118/−111 lines, 11 filesdep ~blaze-htmlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: blaze-html

API changes (from Hackage documentation)

Files

• examples/dom.hs +2/−2
• fay.cabal +25/−3
• hs/stdlib.hs +1/−1
• js/runtime.js +13/−54
• src/Language/Fay.hs +32/−20
• src/Language/Fay/Compiler.hs +16/−14
• src/Language/Fay/Types.hs +6/−5
• src/Main.hs +14/−3
• tests/29 +3/−3
• tests/29.hs +0/−3
• tests/30.hs +6/−3

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

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

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

@@ -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();-    } }  /*******************************************************************************

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

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

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

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

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

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

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