fay 0.11.0.0 → 0.12.0.0
raw patch · 75 files changed
+1261/−825 lines, 75 filesdep ~basedep ~blaze-htmldep ~optparse-applicativesetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, blaze-html, optparse-applicative
API changes (from Hackage documentation)
- Language.Fay.Compiler.Misc: simpleImport :: NameScope -> Bool
- Language.Fay.Types: ScopeBinding :: NameScope
- Language.Fay.Types: ScopeImported :: ModuleName -> (Maybe Name) -> NameScope
- Language.Fay.Types: ScopeImportedAs :: Bool -> ModuleName -> Name -> NameScope
- Language.Fay.Types: data NameScope
- Language.Fay.Types: instance Eq NameScope
- Language.Fay.Types: instance Show NameScope
- Language.Fay.Types: stateConfig :: CompileState -> CompileConfig
- Language.Fay.Types: stateExportAll :: CompileState -> Bool
- Language.Fay.Types: stateScope :: CompileState -> Map Name [NameScope]
+ Language.Fay.Compiler.Misc: anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+ Language.Fay.Compiler.Misc: getGhcPackageDbFlag :: IO String
+ Language.Fay.Compiler.Misc: typeToFields :: QName -> Compile [QName]
+ Language.Fay.Compiler.Misc: typeToRecs :: QName -> Compile [QName]
+ Language.Fay.Compiler.Misc: withModuleScope :: Compile a -> Compile a
+ Language.Fay.Compiler.Packages: checkDirExists :: FilePath -> IO ()
+ Language.Fay.Compiler.Packages: describePackage :: Maybe FilePath -> String -> IO String
+ Language.Fay.Compiler.Packages: resolvePackage :: CompileConfig -> String -> IO CompileConfig
+ Language.Fay.Compiler.Packages: resolvePackages :: CompileConfig -> IO CompileConfig
+ Language.Fay.Compiler.Packages: shareDirs :: String -> Maybe [FilePath]
+ Language.Fay.FFI: type Automatic a = a
+ Language.Fay.FFI: type Ptr a = a
+ Language.Fay.ModuleScope: bindAsLocals :: [QName] -> ModuleScope -> ModuleScope
+ Language.Fay.ModuleScope: data ModuleScope
+ Language.Fay.ModuleScope: findTopLevelNames :: ModuleName -> [Decl] -> ModuleScope
+ Language.Fay.ModuleScope: instance Default ModuleScope
+ Language.Fay.ModuleScope: instance Monoid ModuleScope
+ Language.Fay.ModuleScope: instance Show ModuleScope
+ Language.Fay.ModuleScope: moduleLocals :: ModuleName -> ModuleScope -> [QName]
+ Language.Fay.ModuleScope: resolveName :: QName -> ModuleScope -> Maybe QName
+ Language.Fay.Types: Automatic :: FundamentalType
+ Language.Fay.Types: CompileReader :: CompileConfig -> CompileReader
+ Language.Fay.Types: PtrType :: FundamentalType
+ Language.Fay.Types: UnableResolveCachedImport :: ModuleName -> CompileError
+ Language.Fay.Types: addConfigPackage :: String -> CompileConfig -> CompileConfig
+ Language.Fay.Types: addConfigPackages :: [String] -> CompileConfig -> CompileConfig
+ Language.Fay.Types: configPackages :: CompileConfig -> [String]
+ Language.Fay.Types: data CompileReader
+ Language.Fay.Types: defaultCompileReader :: CompileConfig -> IO CompileReader
+ Language.Fay.Types: faySourceDir :: IO FilePath
+ Language.Fay.Types: instance MonadReader CompileReader Compile
+ Language.Fay.Types: instance Show CompileReader
+ Language.Fay.Types: readerConfig :: CompileReader -> CompileConfig
+ Language.Fay.Types: stateExportsCache :: CompileState -> Map ModuleName [QName]
+ Language.Fay.Types: stateLocalScope :: CompileState -> Set Name
+ Language.Fay.Types: stateModuleScope :: CompileState -> ModuleScope
+ Language.Fay.Types: stateRecordTypes :: CompileState -> [(QName, [QName])]
- Language.Fay.Compiler: compileToAst :: (Show from, Show to, CompilesTo from to) => FilePath -> CompileState -> (from -> Compile to) -> String -> IO (Either CompileError (to, CompileState))
+ Language.Fay.Compiler: compileToAst :: (Show from, Show to, CompilesTo from to) => FilePath -> CompileReader -> CompileState -> (from -> Compile to) -> String -> IO (Either CompileError (to, CompileState))
- Language.Fay.Compiler: runCompile :: CompileState -> Compile a -> IO (Either CompileError (a, CompileState))
+ Language.Fay.Compiler: runCompile :: CompileReader -> CompileState -> Compile a -> IO (Either CompileError (a, CompileState))
- Language.Fay.FFI: ffi :: Foreign a => String -> a
+ Language.Fay.FFI: ffi :: String -> a
- Language.Fay.Prelude: print :: Foreign a => a -> Fay ()
+ Language.Fay.Prelude: print :: Foreign a => Automatic a -> Fay ()
- Language.Fay.Prelude: show :: (Foreign a, Show a) => a -> String
+ Language.Fay.Prelude: show :: (Foreign a, Show a) => Automatic a -> String
- Language.Fay.Types: Compile :: StateT CompileState (ErrorT CompileError IO) a -> Compile a
+ Language.Fay.Types: Compile :: RWST CompileReader () CompileState (ErrorT CompileError IO) a -> Compile a
- Language.Fay.Types: CompileState :: CompileConfig -> [QName] -> Bool -> ModuleName -> FilePath -> [(QName, [QName])] -> [JsStmt] -> [JsStmt] -> [(ModuleName, FilePath)] -> Integer -> Map Name [NameScope] -> CompileState
+ Language.Fay.Types: CompileState :: [QName] -> Map ModuleName [QName] -> ModuleName -> FilePath -> [(QName, [QName])] -> [(QName, [QName])] -> [JsStmt] -> [JsStmt] -> [(ModuleName, FilePath)] -> Integer -> Set Name -> ModuleScope -> CompileState
- Language.Fay.Types: defaultCompileState :: CompileConfig -> IO CompileState
+ Language.Fay.Types: defaultCompileState :: IO CompileState
- Language.Fay.Types: unCompile :: Compile a -> StateT CompileState (ErrorT CompileError IO) a
+ Language.Fay.Types: unCompile :: Compile a -> RWST CompileReader () CompileState (ErrorT CompileError IO) a
Files
- Setup.hs +4/−0
- docs/home.hs +2/−3
- examples/canvaswater.hs +0/−4
- examples/console.hs +2/−9
- examples/data.hs +0/−3
- examples/dom.hs +0/−3
- examples/ref.hs +0/−3
- examples/tailrecursive.hs +6/−12
- fay.cabal +87/−85
- js/runtime.js +24/−10
- src/Docs.hs +19/−5
- src/Language/Fay.hs +44/−43
- src/Language/Fay/Compiler.hs +218/−115
- src/Language/Fay/Compiler/FFI.hs +91/−120
- src/Language/Fay/Compiler/Misc.hs +78/−79
- src/Language/Fay/Compiler/Optimizer.hs +76/−83
- src/Language/Fay/Compiler/Packages.hs +115/−0
- src/Language/Fay/Convert.hs +8/−0
- src/Language/Fay/FFI.hs +23/−4
- src/Language/Fay/ModuleScope.hs +140/−0
- src/Language/Fay/Stdlib.hs +2/−2
- src/Language/Fay/Types.hs +74/−64
- src/Main.hs +84/−76
- src/System/Process/Extra.hs +8/−17
- src/Test/Api.hs +44/−12
- src/Test/CommandLine.hs +25/−14
- src/Test/Convert.hs +6/−0
- src/Test/Util.hs +1/−1
- src/Tests.hs +27/−10
- tests/Api/ImportRecords.hs +3/−0
- tests/Api/Records.hs +4/−0
- tests/Bool.hs +1/−2
- tests/Double.hs +1/−1
- tests/Double2.hs +1/−1
- tests/Double3.hs +1/−1
- tests/Double4.hs +1/−1
- tests/Hierarchical/Export.hs +1/−1
- tests/Hierarchical/RecordDefined.hs +1/−1
- tests/HierarchicalImport.hs +1/−1
- tests/List.hs +2/−2
- tests/List2.hs +1/−1
- tests/Monad.hs +1/−1
- tests/Monad2.hs +1/−1
- tests/RecCon.hs +1/−1
- tests/RecDecl.hs +1/−1
- tests/RecordImport_Export.hs +1/−1
- tests/RecordImport_Import.hs +1/−1
- tests/String.hs +1/−1
- tests/asPatternMatch.hs +1/−1
- tests/basicFunctions.hs +1/−1
- tests/case.hs +1/−1
- tests/case2.hs +1/−1
- tests/caseList.hs +1/−1
- tests/caseWildcard.hs +1/−1
- tests/do.hs +1/−1
- tests/doAssingPatternMatch.hs +1/−1
- tests/doBindAssign.hs +1/−1
- tests/emptyMain.hs +1/−1
- tests/fix.hs +1/−1
- tests/fromInteger.hs +1/−1
- tests/infixDataConst.hs +1/−1
- tests/ints.hs +1/−1
- tests/mutableReference.hs +1/−1
- tests/patternGuards.hs +2/−3
- tests/patternMatchFail.hs +1/−1
- tests/recordFunctionPatternMatch.hs +1/−1
- tests/recordPatternMatch.hs +1/−1
- tests/recordPatternMatch2.hs +1/−1
- tests/recordUseBeforeDefine.hs +1/−1
- tests/records.hs +1/−1
- tests/reservedWords.hs +1/−1
- tests/tailRecursion.hs +1/−1
- tests/then.hs +1/−1
- tests/utf8.hs +1/−1
- tests/where.hs +1/−1
Setup.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE NoImplicitPrelude #-}+ module Main where +import "base" Prelude import Distribution.PackageDescription import Distribution.Simple
docs/home.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE NoImplicitPrelude #-} -- | The home page script: --@@ -15,8 +14,8 @@ module Home (main) where -import Language.Fay.FFI-import Language.Fay.Prelude+import FFI+import Prelude -- | Main entry point. main :: Fay ()
examples/canvaswater.hs view
@@ -146,9 +146,5 @@ log = ffi "console['log'](%1)" -- | Alert using window.alert.-sin :: Double -> Double-sin = ffi "window.Math['sin'](%1)"---- | Alert using window.alert. setInterval :: Fay () -> Double -> Fay () setInterval = ffi "window['setInterval'](%1,%2)"
examples/console.hs view
@@ -1,12 +1,5 @@-- module Console where -import Language.Fay.FFI-import Language.Fay.Prelude--main = print "Hello, World!"+import Prelude --- | Print using console.log.-print :: String -> Fay ()-print = ffi "console.log(%1)"+main = putStrLn "Hello, World!"
examples/data.hs view
@@ -16,6 +16,3 @@ instance Foreign Foo main = print (show (Foo 123 "abc" Bar))--print :: String -> Fay ()-print = ffi "console.log(%1)"
examples/dom.hs view
@@ -14,9 +14,6 @@ result <- documentGetElements "body" print result -print :: Foreign a => [a] -> Fay ()-print = ffi "console.log(%1)"- data Element instance Foreign Element instance Show (Element)
examples/ref.hs view
@@ -27,6 +27,3 @@ readRef :: Foreign a => Ref a -> Fay a readRef = ffi "Fay$$readRef(%1)"--print :: String -> Fay ()-print = ffi "console.log(%1)"
examples/tailrecursive.hs view
@@ -14,19 +14,13 @@ main = do benchmark $ printI (map (\x -> x+1) fibs !! 10) benchmark $ printI (fibs !! 80)- benchmark $ printD (sum 1000000 0)- benchmark $ printD (sum 1000000 0)- benchmark $ printD (sum 1000000 0)- benchmark $ printD (sum 1000000 0)+ benchmark $ printD (sum' 1000000 0)+ benchmark $ printD (sum' 1000000 0)+ benchmark $ printD (sum' 1000000 0)+ benchmark $ printD (sum' 1000000 0) fibs = 0 : 1 : zipWith (+) fibs (tail fibs) -tail (_:xs) = xs--xs !! k = go 0 xs where- go n (x:xs) | n == k = x- | otherwise = go (n+1) xs- benchmark m = do start <- getSeconds m@@ -39,8 +33,8 @@ go acc [] = acc -- tail recursive-sum 0 acc = acc-sum n acc = sum (n - 1) (acc + n)+sum' 0 acc = acc+sum' n acc = sum' (n - 1) (acc + n) getSeconds :: Fay Double getSeconds = ffi "new Date()"
fay.cabal view
@@ -1,5 +1,5 @@ name: fay-version: 0.11.0.0+version: 0.12.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,@@ -13,6 +13,7 @@ > $ cabal unpack fay > $ cd fay-* > $ cabal install+ > $ cabal install fay-base > $ dist/build/fay-docs/fay-docs . .@@ -22,33 +23,31 @@ . /Release Notes/ .- . * Restrict optparse-applicative to < 0.5.- .- . * Error on case-wheres instead of ignoring them.+ . * Updates to name resolution. .- . * Fix serialization of parametrized types when the type information is available.+ . * Added initial fay-base support. .- . * Fix recursive definition name resolving (closes #187).+ . * Basic CPP support (#136) .- . * Fix as patterns always matching (closes #186)+ . * Serialization of Text values (#136) .- . * Fix bind error (closes #178).+ . * Add Automatic serialization, export Automatic/Ptr, bump version. .- . * Check GHC version from command line instead of CPP (#174)+ . * Do not automatically serialize polymorphic values. .- . * Move Defined and Nullable to Language.Fay.FFI+ . * Support Ptr type to force the serializer to ignore things. .- . * Add Nullable.+ . * Add very dubious --package flag. .- . * Use GHC.Path for running ghc and handle flag change in GHC 7.6 (refs #174).+ . * Support type imports (IAbs) .- . * Add HASKELL_PACKAGE_SANDBOX environment variable support (closes #174).+ . * Support import X (a, b) and import X hiding (a, b). .- . * Fix Maybe serialization.+ . * Implement guards in case branches .- . * Fix serializing for doubles (i.e. also parsing ints).+ . * Fix instance declarations missing when typechecking (closes #177) .- . * Option to warn for Closure-unfriendly FFI bindings.+ . * Bump optparse-applicative to >= 0.5 (closes #195) . See full history at: <https://github.com/faylang/fay/commits> homepage: http://fay-lang.org/@@ -56,7 +55,7 @@ license-file: LICENSE author: Chris Done, Adam Bergmark maintainer: chrisdone@gmail.com, adam@edea.se-copyright: 2012 Chris Done+copyright: 2012 Chris Done, Adam Bergmark category: Development build-type: Custom cabal-version: >=1.8@@ -106,6 +105,7 @@ tests/Double2 tests/String tests/Hierarchical/Export.hs tests/Hierarchical/RecordDefined.hs+ tests/Api/Records.hs tests/Api/ImportRecords.hs -- Documentation files docs/beautify.js docs/highlight.pack.js docs/home.css docs/jquery.js docs/analytics.js@@ -128,31 +128,31 @@ library hs-source-dirs: src- exposed-modules: Language.Fay, Language.Fay.Types, Language.Fay.FFI, Language.Fay.Prelude, Language.Fay.Convert, Language.Fay.Compiler, Language.Fay.Compiler.Misc, Language.Fay.Compiler.FFI, Language.Fay.Compiler.Optimizer+ exposed-modules: Language.Fay, Language.Fay.Types, Language.Fay.FFI, Language.Fay.Prelude, Language.Fay.Convert, Language.Fay.Compiler, Language.Fay.Compiler.Misc, Language.Fay.Compiler.FFI, Language.Fay.Compiler.Optimizer, Language.Fay.Compiler.Packages, Language.Fay.ModuleScope other-modules: Language.Fay.Print, Control.Monad.IO, Language.Fay.Stdlib, System.Process.Extra, Data.List.Extra, Paths_fay ghc-options: -O2 -Wall build-depends: base >= 4 && < 5,- ghc-paths,- mtl,- haskell-src-exts, aeson,- unordered-containers,- containers, attoparsec,- vector,- text,- utf8-string, bytestring,- pretty-show,+ containers, data-default,- safe,- language-ecmascript >= 0.10,- syb,- process,- filepath, directory,+ filepath,+ ghc-paths, groom,- random+ haskell-src-exts,+ language-ecmascript >= 0.10,+ mtl,+ pretty-show,+ process,+ random,+ safe,+ syb,+ text,+ unordered-containers,+ utf8-string,+ vector if !flag(devel) build-depends:@@ -163,7 +163,7 @@ blaze-markup, bytestring, time,- optparse-applicative < 0.5,+ optparse-applicative >= 0.5, split, test-framework, test-framework-hunit,@@ -175,31 +175,32 @@ ghc-prof-options: -fprof-auto main-is: Main.hs build-depends: base >= 4 && < 5,- ghc-paths,- mtl,- haskell-src-exts, aeson,- syb,- unordered-containers,- containers, attoparsec,- vector,- text,- utf8-string, bytestring,- pretty-show,- process,+ containers, data-default,- safe,- language-ecmascript >= 0.10, directory, filepath,+ ghc-paths, groom,+ haskell-src-exts,+ language-ecmascript >= 0.10,+ mtl,+ pretty-show,+ process, random,- optparse-applicative < 0.5,- split,- haskeline+ safe,+ syb,+ text,+ unordered-containers,+ utf8-string,+ vector, + haskeline,+ optparse-applicative >= 0.5,+ split+ executable fay-tests if flag(devel) buildable: False@@ -209,28 +210,29 @@ main-is: Tests.hs other-modules: Language.Fay.Compiler Test.Convert Test.Api Test.CommandLine Test.Util build-depends: base >= 4 && < 5,- ghc-paths,- mtl,- haskell-src-exts, aeson,- syb,- unordered-containers,- containers, attoparsec,- vector,- text,- utf8-string, bytestring,- pretty-show,- HUnit,- process,- filepath,- directory,+ containers, data-default,- safe,- language-ecmascript >= 0.10,+ directory,+ filepath,+ ghc-paths, groom,+ haskell-src-exts,+ language-ecmascript >= 0.10,+ mtl,+ pretty-show,+ process, random,+ safe,+ syb,+ text,+ unordered-containers,+ utf8-string,+ vector,++ HUnit, test-framework, test-framework-hunit, test-framework-th@@ -243,29 +245,29 @@ main-is: Docs.hs other-modules: Text.Blaze.Extra build-depends: base >= 4 && < 5,+ aeson,+ attoparsec,+ bytestring,+ containers,+ data-default,+ directory,+ filepath, ghc-paths,- mtl,+ groom, haskell-src-exts,- aeson,+ language-ecmascript >= 0.10,+ mtl,+ pretty-show,+ process,+ random,+ safe, syb,- unordered-containers,- containers,- attoparsec,- vector, text,+ time,+ unordered-containers, utf8-string,- bytestring,- pretty-show,+ vector,+ HUnit,- process,- filepath,- directory, blaze-html >= 0.5,- blaze-markup,- bytestring,- time,- data-default,- safe,- language-ecmascript >= 0.10,- groom,- random+ blaze-markup
js/runtime.js view
@@ -37,6 +37,7 @@ (this.value = this.value(), this.forced = true, this.value)); }; + function Fay$$seq(x) { return function(y) { _(x,false);@@ -127,6 +128,10 @@ var args = type[1]; var jsObj; switch(base){+ case "ptr": {+ jsObj = fayObj;+ break;+ } case "action": { // A nullary monadic action. Should become a nullary JS function. // Fay () -> function(){ return ... }@@ -207,7 +212,7 @@ if (fayObj instanceof $_Language$Fay$FFI$Undefined) { jsObj = undefined; } else {- jsObj = Fay$$fayToJs(args[0],fayObj["slot1"]);+ jsObj = Fay$$fayToJsUserDefined(args[0],fayObj["slot1"]); } break; }@@ -216,7 +221,7 @@ if (fayObj instanceof $_Language$Fay$FFI$Null) { jsObj = null; } else {- jsObj = Fay$$fayToJs(args[0],fayObj["slot1"]);+ jsObj = Fay$$fayToJsUserDefined(args[0],fayObj["slot1"]); } break; }@@ -236,6 +241,8 @@ break; } case "unknown":+ return fayObj;+ case "automatic": case "user": { if(fayObj instanceof $) fayObj = _(fayObj);@@ -253,6 +260,10 @@ var args = type[1]; var fayObj; switch(base){+ case "ptr": {+ fayObj = jsObj;+ break;+ } case "action": { // Unserialize a "monadic" JavaScript return value into a monadic value. fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));@@ -320,6 +331,8 @@ break; } case "unknown":+ return jsObj;+ case "automatic": case "user": { if (jsObj && jsObj['instance']) { fayObj = Fay$$jsToFayUserDefined(type,jsObj);@@ -359,19 +372,20 @@ } // List index.-function Fay$$index(index){- return function(list){- for(var i = 0; i < index; i++) {- list = _(list).cdr;- }- return list.car;- };+// `list' is already forced by the time it's passed to this function.+// `list' cannot be null and `index' cannot be out of bounds.+function Fay$$index(index,list){+ for(var i = 0; i < index; i++) {+ list = _(list.cdr);+ }+ return list.car; } // List length.+// `list' is already forced by the time it's passed to this function. function Fay$$listLen(list,max){ for(var i = 0; list !== null && i < max + 1; i++) {- list = _(list).cdr;+ list = _(list.cdr); } return i == max; }
src/Docs.hs view
@@ -20,6 +20,7 @@ import Prelude hiding (div, head) import System.FilePath import Text.Blaze.Extra+import System.Environment import Text.Blaze.Html5 as H hiding (contents, map, style) import Text.Blaze.Html5.Attributes as A hiding (title) import Text.Blaze.Renderer.Utf8 (renderMarkup)@@ -45,10 +46,13 @@ where compile file = do contents <- readFile file putStrLn $ "Generating " ++ file ++ " ..."+ packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment result <- compileViaStr file def { configFlattenApps = True , configOptimize = True- , configTypecheck = False }+ , configTypecheck = False+ , configPackageConf = packageConf+ } compileForDocs contents case result of Right (PrintState{..},_) -> return (concat (reverse psOutput))@@ -62,7 +66,11 @@ generateJs = do putStrLn $ "Compiling " ++ inp ++ " to " ++ out ++ " ..."- compileFromTo def { configFlattenApps = True, configTypecheck = False } inp (Just out)+ packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ compileFromTo def { configFlattenApps = True+ , configTypecheck = False+ , configPackageConf = packageConf+ } inp (Just out) where docs = ("docs" </>) inp = docs "home.hs"@@ -227,12 +235,13 @@ " installed (or at least Cabal)." h3 "Cabal install from Hackage" p "To install, run:"- pre $ code "$ cabal install fay"+ pre $ code "$ cabal install fay fay-base" h3 "From Github" p "If you want to hack on the compiler, you can download the Git repo: " pre $ code "$ git clone git://github.com/faylang/fay.git" p "And then install from the directory: " pre $ code "$ cabal install"+ pre $ code "$ cabal install fay-base" h3 "Running" p "If developing, you can run the tests (you will need nodejs installed):" pre $ code "$ cabal install"@@ -241,7 +250,7 @@ pre $ code "$ fay foo.hs" p $ do "The "; code "--library"; " flag will prevent the "; code "main"; " function from being called." p "You can also install this via cabal-dev, but be sure to run the commands from the cabal-dev bin dir: "- pre $ code "$ cabal-dev install\n$ cabal-dev/bin/fay --no-ghc foo.hs"+ pre $ code "$ cabal-dev install\n$ cabal-dev install fay-base\n$ cabal-dev/bin/fay --no-ghc foo.hs" p $ do "If you only installed with cabal-dev then you will probably get a 'no" " package fay' error from GHC, so you can tell it where to get the"@@ -302,5 +311,10 @@ ", " a ! href "http://hackage.haskell.org/package/yesod-fay" $ "hackage" li $ do+ "fay-uri: "+ a ! href "https://github.com/faylang/fay-uri" $ "github"+ " Includes a tutorial to the Fay FFI"+ li $ do "fay-jquery: "- a ! href "https://github.com/faylang/fay-jquery" $ "hackage"+ a ! href "https://github.com/faylang/fay-jquery" $ "github"+ " With a lot of FFI trickery"
src/Language/Fay.hs view
@@ -18,6 +18,7 @@ import Language.Fay.Compiler (compileToplevelModule, compileViaStr) import Language.Fay.Compiler.Misc (printSrcLoc)+import Language.Fay.Compiler.Packages import Language.Fay.Print import Language.Fay.Types @@ -76,14 +77,14 @@ runtime <- getDataFileName "js/runtime.js" hscode <- readFile filein raw <- readFile runtime- compileToModule filein config raw compileToplevelModule hscode-+ config' <- resolvePackages config+ compileToModule filein config' raw compileToplevelModule hscode -- | Compile the given module to a runnable module. compileToModule :: (Show from,Show to,CompilesTo from to)- => FilePath- -> CompileConfig -> String -> (from -> Compile to) -> String- -> IO (Either CompileError (String,CompileState))+ => FilePath+ -> CompileConfig -> String -> (from -> Compile to) -> String+ -> IO (Either CompileError (String,CompileState)) compileToModule filepath config raw with hscode = do result <- compileViaStr filepath config with hscode case result of@@ -131,44 +132,44 @@ -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String toJsName x = case reverse x of- ('s':'h':'.': (reverse -> file)) -> file ++ ".js"- _ -> x+ ('s':'h':'.': (reverse -> file)) -> file ++ ".js"+ _ -> x -- | Print a compile error for human consumption. showCompileError :: CompileError -> String-showCompileError e =- case e of- ParseError _ err -> err- UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d- UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es- UnsupportedMatchSyntax m -> "unsupported match/binding syntax: " ++ prettyPrint m- UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m- UnsupportedWhereInAlt alt -> "`where' not supported here: " ++ prettyPrint alt- UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr- UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt- UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit- UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d- UnsupportedOperator qop -> "unsupported operator syntax: " ++ prettyPrint qop- UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat- UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs- UnsupportedGuardedAlts ga -> "unsupported guarded alts: " ++ prettyPrint ga- EmptyDoBlock -> "empty `do' block"- UnsupportedModuleSyntax{} -> "unsupported module syntax (may be supported later)"- LetUnsupported -> "let not supported here"- InvalidDoBlock -> "invalid `do' block"- RecursiveDoUnsupported -> "recursive `do' isn't supported"- FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d- FfiFormatBadChars cs -> "invalid characters for FFI format string: " ++ show cs- FfiFormatNoSuchArg i -> "no such argument in FFI format string: " ++ show i- FfiFormatIncompleteArg -> "incomplete `%' syntax in FFI format string"- FfiFormatInvalidJavaScript srcloc code err ->- printSrcLoc srcloc ++ ":" ++- "\ninvalid JavaScript code in FFI format string:\n"- ++ err ++ "\nin " ++ code- UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p- UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i- Couldn'tFindImport i places ->- "could not find an import in the path: " ++ prettyPrint i ++ ", \n" ++- "searched in these places: " ++ intercalate ", " places- UnableResolveUnqualified name -> "unable to resolve unqualified name " ++ prettyPrint name- UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname+showCompileError e = case e of+ ParseError _ err -> err+ UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d+ UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es+ UnsupportedMatchSyntax m -> "unsupported match/binding syntax: " ++ prettyPrint m+ UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m+ UnsupportedWhereInAlt alt -> "`where' not supported here: " ++ prettyPrint alt+ UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr+ UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt+ UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit+ UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d+ UnsupportedOperator qop -> "unsupported operator syntax: " ++ prettyPrint qop+ UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat+ UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs+ UnsupportedGuardedAlts ga -> "unsupported guarded alts: " ++ prettyPrint ga+ EmptyDoBlock -> "empty `do' block"+ UnsupportedModuleSyntax{} -> "unsupported module syntax (may be supported later)"+ LetUnsupported -> "let not supported here"+ InvalidDoBlock -> "invalid `do' block"+ RecursiveDoUnsupported -> "recursive `do' isn't supported"+ FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d+ FfiFormatBadChars cs -> "invalid characters for FFI format string: " ++ show cs+ FfiFormatNoSuchArg i -> "no such argument in FFI format string: " ++ show i+ FfiFormatIncompleteArg -> "incomplete `%' syntax in FFI format string"+ FfiFormatInvalidJavaScript srcloc code err ->+ printSrcLoc srcloc ++ ":" +++ "\ninvalid JavaScript code in FFI format string:\n"+ ++ err ++ "\nin " ++ code+ UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p+ UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i+ Couldn'tFindImport i places ->+ "could not find an import in the path: " ++ prettyPrint i ++ ", \n" +++ "searched in these places: " ++ intercalate ", " places+ UnableResolveUnqualified name -> "unable to resolve unqualified name " ++ prettyPrint name+ UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname+ UnableResolveCachedImport name -> "unable to resolve cached import " ++ prettyPrint name
src/Language/Fay/Compiler.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} -- | The Haskell→Javascript compiler.@@ -26,37 +27,41 @@ import Language.Fay.Compiler.FFI import Language.Fay.Compiler.Misc import Language.Fay.Compiler.Optimizer+import Language.Fay.ModuleScope (bindAsLocals, findTopLevelNames, moduleLocals) import Language.Fay.Print (printJSString)-import qualified Language.Fay.Stdlib as Stdlib (enumFromThenTo,enumFromTo)+import qualified Language.Fay.Stdlib as Stdlib import Language.Fay.Types - import Control.Applicative import Control.Monad.Error import Control.Monad.IO import Control.Monad.State+import Control.Monad.RWS import Data.Default (def) import Data.List import Data.List.Extra-import Data.Map (Map) import qualified Data.Map as M+import qualified Data.Set as S import Data.Maybe-import Data.Version (parseVersion)-import qualified GHC.Paths as GHCPaths+import qualified GHC.Paths as GHCPaths import Language.Haskell.Exts import System.Directory (doesFileExist) import System.FilePath ((</>))-import System.Process (readProcess) import System.Process.Extra-import Text.ParserCombinators.ReadP (readP_to_S) -------------------------------------------------------------------------------- -- Top level entry points -- | Run the compiler.-runCompile :: CompileState -> Compile a -> IO (Either CompileError (a,CompileState))-runCompile state m = runErrorT (runStateT (unCompile m) state) where+runCompile :: CompileReader -> CompileState+ -> Compile a+ -> IO (Either CompileError (a,CompileState))+runCompile reader state m =+ fmap (fmap dropWriter)+ (runErrorT (runRWST (unCompile m) reader state)) + where dropWriter (a,s,_w) = (a,s)+ -- | Compile a Haskell source string to a JavaScript source string. compileViaStr :: (Show from,Show to,CompilesTo from to) => FilePath@@ -65,8 +70,10 @@ -> String -> IO (Either CompileError (PrintState,CompileState)) compileViaStr filepath config with from = do- cs <- defaultCompileState config- runCompile (cs { stateFilePath = filepath })+ cs <- defaultCompileState+ rs <- defaultCompileReader config+ runCompile rs+ (cs { stateFilePath = filepath }) (parseResult (throwError . uncurry ParseError) (fmap (\x -> execState (runPrinter (printJS x)) printConfig) . with) (parseFay filepath from))@@ -76,24 +83,57 @@ -- | Compile a Haskell source string to a JavaScript source string. compileToAst :: (Show from,Show to,CompilesTo from to) => FilePath+ -> CompileReader -> CompileState -> (from -> Compile to) -> String -> IO (Either CompileError (to,CompileState))-compileToAst filepath state with from =- runCompile state+compileToAst filepath reader state with from =+ runCompile reader+ state (parseResult (throwError . uncurry ParseError) with (parseFay filepath from)) -- | Parse some Fay code. parseFay :: Parseable ast => FilePath -> String -> ParseResult ast-parseFay filepath = parseWithMode parseMode { parseFilename = filepath }+parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP +-- | Apply incredibly simplistic CPP handling. It only recognizes the following:+--+-- > #if FAY+-- > #ifdef FAY+-- > #ifndef FAY+-- > #else+-- > #endif+--+-- Note that this implementation replaces all removed lines with blanks, so+-- that line numbers remain accurate.+applyCPP :: String -> String+applyCPP =+ unlines . loop NoCPP . lines+ where+ loop _ [] = []+ loop state ("#if FAY":rest) = "" : loop (CPPIf True state) rest+ loop state ("#ifdef FAY":rest) = "" : loop (CPPIf True state) rest+ loop state ("#ifndef FAY":rest) = "" : loop (CPPIf False state) rest+ loop (CPPIf b oldState) ("#else":rest) = "" : loop (CPPElse (not b) oldState) rest+ loop (CPPIf _ oldState) ("#endif":rest) = "" : loop oldState rest+ loop (CPPElse _ oldState) ("#endif":rest) = "" : loop oldState rest+ loop state (x:rest) = (if toInclude state then x else "") : loop state rest++ toInclude NoCPP = True+ toInclude (CPPIf x state) = x && toInclude state+ toInclude (CPPElse x state) = x && toInclude state++data CPPState = NoCPP+ | CPPIf Bool CPPState+ | CPPElse Bool CPPState+ -- | The parse mode for Fay. parseMode :: ParseMode parseMode = defaultParseMode { extensions =- [GADTs,StandaloneDeriving,EmptyDataDecls,TypeOperators,RecordWildCards,NamedFieldPuns] }+ [GADTs,StandaloneDeriving,PackageImports,EmptyDataDecls,TypeOperators,RecordWildCards,NamedFieldPuns] } -- | Compile the given input and print the output out prettily. printCompile :: (Show from,Show to,CompilesTo from to)@@ -123,12 +163,17 @@ -- | Compile the top-level Fay module. compileToplevelModule :: Module -> Compile [JsStmt] compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _) = do- cfg <- gets stateConfig+ cfg <- config id+ -- Remove the fay source dir from the includes, -package fay is already supplied.+ -- This will prevent errors on FFI instance declarations.+ faydir <- io faySourceDir+ let includeDirs = filter (/= faydir) (configDirectoryIncludes cfg)+ when (configTypecheck cfg) $- typecheck (configPackageConf cfg) (configDirectoryIncludes cfg) [] (configWall cfg) $+ typecheck (configPackageConf cfg) includeDirs [] (configWall cfg) $ fromMaybe modulename $ configFilePath cfg initialPass mod- cs <- liftIO $ defaultCompileState def+ cs <- io defaultCompileState modify $ \s -> s { stateImported = stateImported cs } stmts <- compileModule mod fay2js <- do syms <- gets stateFayToJs@@ -143,53 +188,87 @@ initialPass :: Module -> Compile () initialPass (Module _ _ _ Nothing _ imports decls) = do- mapM_ initialPass_import (map translateModuleName imports)- mapM_ (initialPass_decl True) decls-+ mapM_ initialPass_import imports+ mapM_ initialPass_decl decls initialPass mod = throwError (UnsupportedModuleSyntax mod) initialPass_import :: ImportDecl -> Compile ()-initialPass_import (ImportDecl _ "Prelude" _ _ _ _ _) = return ()-initialPass_import (ImportDecl _ name False _ Nothing Nothing Nothing) = do- void $ unlessImported name $ \filepath contents -> do- state <- gets id- result <- liftIO $ initialPass_records filepath state initialPass contents+initialPass_import (ImportDecl _ _ _ _ Just{} _ _) = do+ return ()+-- warn $ "import with package syntax ignored: " ++ prettyPrint i+initialPass_import (ImportDecl _ name False _ Nothing Nothing _) = do+ void $ initialPass_unlessImported name $ \filepath contents -> do+ state <- get+ reader <- ask+ result <- liftIO $ initialPass_records filepath reader state initialPass contents case result of Right ((),st) -> do -- 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 } Left err -> throwError err- return []-+ return () initialPass_import i = throwError $ UnsupportedImport i +-- | Don't re-import the same modules.+initialPass_unlessImported :: ModuleName+ -> (FilePath -> String -> Compile ())+ -> Compile ()+initialPass_unlessImported name importIt = do+ imported <- gets stateImported+ case lookup name imported of+ Just _ -> return ()+ Nothing -> do+ dirs <- configDirectoryIncludes <$> config id+ (filepath,contents) <- findImport dirs name+ modify $ \s -> s { stateImported = (name,filepath) : imported }+ importIt filepath contents+ initialPass_records :: (Show from,Parseable from) => FilePath+ -> CompileReader -> CompileState -> (from -> Compile ()) -> String -> IO (Either CompileError ((),CompileState))-initialPass_records filepath compileState with from =- runCompile compileState+initialPass_records filepath compileReader compileState with from =+ runCompile compileReader+ compileState (parseResult (throwError . uncurry ParseError) with (parseFay filepath from)) -initialPass_decl :: Bool -> Decl -> Compile ()-initialPass_decl toplevel decl =+initialPass_decl :: Decl -> Compile ()+initialPass_decl decl = do case decl of- DataDecl _ DataType _ _ _ constructors _ -> initialPass_dataDecl toplevel decl constructors- GDataDecl _ DataType _l _i _v _n decls _ -> initialPass_dataDecl toplevel decl (map convertGADT decls)+ DataDecl _loc DataType _ctx name _tyvarb qualcondecls _deriv -> do+ let ns = flip map qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl)+ addRecordTypeState name ns _ -> return () ++ case decl of+ DataDecl _ DataType _ _ _ constructors _ -> initialPass_dataDecl constructors+ GDataDecl _ DataType _l _i _v _n decls _ -> initialPass_dataDecl (map convertGADT decls)+ _ -> return ()++ where+ addRecordTypeState name cons = modify $ \s -> s+ { stateRecordTypes = (UnQual name, map UnQual cons) : stateRecordTypes s }++ conDeclName (ConDecl n _) = n+ conDeclName (InfixConDecl _ n _) = n+ conDeclName (RecDecl n _) = n++ -- | Collect record definitions and store record name and field names. -- A ConDecl will have fields named slot1..slotN-initialPass_dataDecl :: Bool -> Decl -> [QualConDecl] -> Compile ()-initialPass_dataDecl _ _decl constructors =+initialPass_dataDecl :: [QualConDecl] -> Compile ()+initialPass_dataDecl constructors = do forM_ constructors $ \(QualConDecl _ _ _ condecl) -> case condecl of ConDecl name types -> do@@ -217,10 +296,9 @@ Just pk -> do flag <- liftIO getGhcPackageDbFlag return [flag ++ '=' : pk]- res <- liftIO $ readAllFromProcess' GHCPaths.ghc (+ res <- liftIO $ readAllFromProcess GHCPaths.ghc ( ["-fno-code" ,"-package fay"- ,"-XNoImplicitPrelude" ,"-main-is" ,"Language.Fay.DummyMain" ,fp]@@ -231,44 +309,29 @@ wallF | wall = ["-Wall"] | otherwise = [] -getGhcPackageDbFlag :: IO String-getGhcPackageDbFlag = do- s <- readProcess "ghc" ["--version"] ""- return $- case (mapMaybe readVersion $ words s, readVersion "7.6.0") of- (v:_, Just min) | v > min -> "-package-db"- _ -> "-package-conf"- where- readVersion = listToMaybe . filter (null . snd) . readP_to_S parseVersion- -------------------------------------------------------------------------------- -- Compilers -- | Compile Haskell module. compileModule :: Module -> Compile [JsStmt]-compileModule (Module _ modulename _pragmas Nothing exports imports decls) = do- modify $ \s -> s { stateModuleName = modulename- , stateExportAll = isNothing exports- , stateExports = []- }- imported <- fmap concat (mapM (compileImport . translateModuleName) imports)- current <- compileDecls True decls- -- If an export list is given we populate it beforehand,- -- if not then bindToplevel will export each declaration when it's visited.- mapM_ emitExport (fromMaybe [] exports)- return (imported ++ current)-compileModule mod = throwError (UnsupportedModuleSyntax mod)+compileModule (Module _ modulename _pragmas Nothing exports imports decls) =+ withModuleScope $ do+ modify $ \s -> s { stateModuleName = modulename+ , stateExports = []+ , stateModuleScope = findTopLevelNames modulename decls+ }+ imported <- fmap concat (mapM compileImport imports)+ current <- compileDecls True decls -translateModuleName :: ImportDecl -> ImportDecl--- The *.Prelude module doesn't contain actual code, but code to--- appease GHC. The real code is in Stdlib, which could also be--- imported directly, but it seems nicer to use Prelude. And maybe we--- can fix this in the future so that Prelude contains the real--- code. Doubt it, but it could happen.-translateModuleName (ImportDecl a (ModuleName "Language.Fay.Prelude") b c d e f) =- (ImportDecl a (ModuleName "Language.Fay.Stdlib") b c d e f)-translateModuleName x = x+ case exports of+ Just exps -> mapM_ emitExport exps+ Nothing -> do+ exps <- moduleLocals modulename <$> gets stateModuleScope+ modify $ \s -> s { stateExports = exps ++ stateExports s } + return (imported ++ current)+compileModule mod = throwError (UnsupportedModuleSyntax mod)+ instance CompilesTo Module [JsStmt] where compileTo = compileModule findImport :: [FilePath] -> ModuleName -> Compile (FilePath,String)@@ -291,49 +354,87 @@ -- | Compile the given import. compileImport :: ImportDecl -> Compile [JsStmt]-compileImport (ImportDecl _ "Prelude" _ _ _ _ _) = return []-compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) = do- unlessImported name $ \filepath contents -> do- state <- gets id- result <- liftIO $ compileToAst filepath state compileModule contents+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+ state <- get+ reader <- ask+ result <- liftIO $ compileToAst filepath reader state compileModule contents case result of Right (stmts,state) -> do- modify $ \s -> s { stateFayToJs = stateFayToJs state- , stateJsToFay = stateJsToFay state- , stateImported = stateImported state- , stateScope = mergeScopes (addExportsToScope (stateExports state) (stateScope s))- (stateScope state)+ imports <- filterM importFilter $ stateExports state+ modify $ \s -> s { stateFayToJs = stateFayToJs state+ , stateJsToFay = stateJsToFay state+ , stateImported = stateImported state+ , stateLocalScope = S.empty+ , stateModuleScope = bindAsLocals imports (stateModuleScope s) } return stmts Left err -> throwError err-compileImport i = throwError $ UnsupportedImport i --- | Add the new scopes to the old one, stripping out local bindings.-mergeScopes :: Map Name [NameScope] -> Map Name [NameScope] -> Map Name [NameScope]-mergeScopes old new =- M.map (filter (/=ScopeBinding))- (foldr (\(key,val) -> M.insertWith (++) key val) old (M.assocs new))---- | Add-addExportsToScope :: [QName] -> Map Name [NameScope] -> Map Name [NameScope]-addExportsToScope exports mapping = foldr copy mapping exports where- copy e =- case e of- Qual modname name -> M.insertWith (++) name [ScopeImported modname Nothing]- UnQual name -> error $ "Exports should not be unqualified: " ++ prettyPrint name- Special{} -> error $ "Don't be silly."---- | Don't re-import the same modules.-unlessImported :: ModuleName -> (FilePath -> String -> Compile [JsStmt]) -> Compile [JsStmt]-unlessImported name importIt = do+unlessImported :: ModuleName+ -> (QName -> Compile Bool)+ -> (FilePath -> String -> Compile [JsStmt])+ -> Compile [JsStmt]+unlessImported "Language.Fay.Types" _ _ = return []+unlessImported name importFilter importIt = do imported <- gets stateImported case lookup name imported of- Just _ -> return []+ Just _ -> do+ sec <- gets stateExportsCache+ case M.lookup name sec of+ Nothing -> throwError $ UnableResolveCachedImport name+ Just exports -> do+ imports <- filterM importFilter exports+ modify $ \s -> s { stateModuleScope = bindAsLocals imports (stateModuleScope s) }+ return [] Nothing -> do- dirs <- configDirectoryIncludes <$> gets stateConfig+ dirs <- configDirectoryIncludes <$> config id (filepath,contents) <- findImport dirs name- modify $ \s -> s { stateImported = (name,filepath) : imported }- importIt filepath contents+ res <- importIt filepath contents+ exportsCache <- gets stateExports+ -- 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+ , stateExportsCache = M.insert name exportsCache (stateExportsCache s)+ }+ return res -- | Compile Haskell declaration. compileDecls :: Bool -> [Decl] -> Compile [JsStmt]@@ -565,8 +666,8 @@ EnumFromTo i i' -> compileEnumFromTo i i' EnumFromThen a b -> compileEnumFromThen a b EnumFromThenTo a b z -> compileEnumFromThenTo a b z- RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates- RecUpdate rec fieldUpdates -> updateRec rec fieldUpdates+ RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates+ RecUpdate rec fieldUpdates -> updateRec rec fieldUpdates ListComp exp stmts -> compileExp =<< desugarListComp exp stmts ExpTypeSig _ e _ -> compileExp e @@ -623,7 +724,7 @@ e2 <- compileExp exp2 fn <- compileExp (Var op) return $ JsApp (JsApp (force fn) [force e1]) [force e2]- _ -> compileExp (App (App (Var qname) exp1) exp2)+ _ -> compileExp (App (App (Var op) exp1) exp2) where op = getOp ap getOp (QVarOp op) = op@@ -752,7 +853,7 @@ _ -> withScope $ do generateScope $ compilePat exp pat [] alt <- compileGuardedAlt rhs- compilePat exp pat [JsEarlyReturn alt]+ compilePat exp pat [alt] -- | Compile the given pattern against the given expression. compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]@@ -914,10 +1015,10 @@ return [JsIf (JsEq (force exp) JsNull) body []] compilePList pats body exp = do let forcedExp = force exp- stmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsApp (JsName (JsBuiltIn "index"))- [JsLit (JsInt i)])- [forcedExp])- pat body)+ stmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index"))+ [JsLit (JsInt i),forcedExp])+ pat+ body) body (reverse (zip [0..] pats)) let patsLen = JsLit (JsInt (length pats))@@ -944,11 +1045,13 @@ compileInfixPat _ pat _ = throwError (UnsupportedPattern pat) -- | Compile a guarded alt.-compileGuardedAlt :: GuardedAlts -> Compile JsExp+compileGuardedAlt :: GuardedAlts -> Compile JsStmt compileGuardedAlt alt = case alt of- UnGuardedAlt exp -> compileExp exp- alt -> throwError (UnsupportedGuardedAlts alt)+ UnGuardedAlt exp -> JsEarlyReturn <$> compileExp exp+ GuardedAlts alts -> compileGuards (map altToRhs alts)+ where+ altToRhs (GuardedAlt l s e) = GuardedRhs l s e -- | Compile a let expression. compileLet :: [Decl] -> Exp -> Compile JsExp@@ -1000,7 +1103,7 @@ f <- compileExp i t <- compileExp i' name <- resolveName "enumFromTo"- cfg <- gets stateConfig+ cfg <- config id return $ case optEnumFromTo cfg f t of Just s -> s _ -> JsApp (JsApp (JsName (JsNameVar name)) [f]) [t]@@ -1036,7 +1139,7 @@ th <- compileExp b to <- compileExp z name <- resolveName "enumFromThenTo"- cfg <- gets stateConfig+ cfg <- config id return $ case optEnumFromThenTo cfg fr th to of Just s -> s _ -> JsApp (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th]) [to]
src/Language/Fay/Compiler/FFI.hs view
@@ -28,6 +28,7 @@ import Language.Haskell.Exts (prettyPrint) import Language.Haskell.Exts.Syntax import Prelude hiding (exp)+import Data.Generics.Schemes import Safe -- | Compile an FFI call.@@ -41,7 +42,7 @@ case JS.parse JS.parseExpression (prettyPrint name) (printJSString (wrapReturn inner)) of Left err -> throwError (FfiFormatInvalidJavaScript srcloc inner (show err)) Right exp -> do- config' <- gets stateConfig+ config' <- config id when (configGClosure config') $ warnDotUses srcloc inner exp fmap return (bindToplevel srcloc True name (body inner)) @@ -58,62 +59,31 @@ returnType = last funcFundamentalTypes -- | Warn about uses of naked x.y which will not play nicely with Google Closure.-warnDotUses :: SrcLoc -> String -> JS.ParsedExpression -> Compile ()-warnDotUses srcloc string = go where- gom = maybe (return ()) go- go exp = case exp of- DotRef _ (VarRef _ (Id _ name)) _- | elem name globalNames -> return ()- DotRef _ _ _ -> warn $ printSrcLoc srcloc ++ ":\nDot ref syntax used in FFI JS code: " ++ string- -- Walk down the tree. Don't have a Traversable instance.- ArrayLit _ es -> mapM_ go es- ObjectLit _ pairs -> mapM_ go (map snd pairs)- BracketRef _ a b -> do go a; go b- NewExpr _ a xs -> do go a; mapM_ go xs- PrefixExpr _ _ e -> go e- UnaryAssignExpr _ _ lvalue -> golvalue lvalue- InfixExpr _ _ a b -> do go a; go b- CondExpr _ a b c -> do go a; go b; go c- AssignExpr _ _ lvalue e -> do golvalue lvalue; go e- ListExpr _ xs -> mapM_ go xs- CallExpr _ e xs -> do go e; mapM_ go xs- FuncExpr _ _ _ stmts -> mapM_ gostmt stmts- _ -> return ()- globalNames = ["Math","console","JSON"]- golvalue lvalue =- case lvalue of- LDot _ (VarRef _ (Id _ name)) _- | elem name globalNames -> return ()- LDot _ _ _ -> warn $ printSrcLoc srcloc ++ ":\nDot ref syntax used in FFI JS code: " ++ string- LBracket _ a b -> do go a; go b- _ -> return ()- gostmt stmt =- case stmt of- BlockStmt _ ss -> do mapM_ gostmt ss- ExprStmt _ e -> do go e- IfStmt _ e s s' -> do gostmt s; go e; gostmt s'- IfSingleStmt _ e s -> do gostmt s; go e; gostmt s- SwitchStmt _ e _ -> do go e- WhileStmt _ e s -> do gostmt s; go e; gostmt s- DoWhileStmt _ s e -> do gostmt s; go e; gostmt s- LabelledStmt _ _ s -> do gostmt s- ForInStmt _ (ForInLVal lvalue) e s -> do golvalue lvalue; gostmt s; go e; gostmt s- ForInStmt _ _ e s -> do gostmt s; go e; gostmt s- ForStmt _ _ me me' s -> do gostmt s; gostmt s; gom me; gom me'- TryStmt _ s cc ms -> do- maybe (return ()) gostmt ms- gostmt s- case cc of- Just (CatchClause _ _ s') -> gostmt s'- _ -> return ()- ThrowStmt _ e -> go e- WithStmt _ e s -> do gostmt s; go e; gostmt s- VarDeclStmt _ decls -> mapM_ godecl decls- FunctionStmt _ _ _ ss -> do mapM_ gostmt ss- ReturnStmt _ me -> gom me- _ -> return ()- godecl _ = return ()+warnDotUses :: SrcLoc -> String -> ParsedExpression -> Compile ()+warnDotUses srcloc string expr =+ when anyrefs $+ warn $ printSrcLoc srcloc ++ ":\nDot ref syntax used in FFI JS code: " ++ string + where anyrefs = not (null (listify dotref expr)) ||+ not (null (listify ldot expr))++ dotref :: ParsedExpression -> Bool+ dotref x = case x of+ DotRef _ (VarRef _ (Id _ name)) _+ | elem name globalNames -> False+ DotRef{} -> True+ _ -> False++ ldot :: LValue SourcePos -> Bool+ ldot x =+ case x of+ LDot _ (VarRef _ (Id _ name)) _+ | elem name globalNames -> False+ LDot{} -> True+ _ -> False++ globalNames = ["Math","console","JSON"]+ -- Make a Fay→JS encoder. emitFayToJs :: Name -> [([Name],BangType)] -> Compile () emitFayToJs name (explodeFields -> fieldTypes) = do@@ -174,34 +144,34 @@ -- | Convert a Haskell type to an internal FFI representation. argType :: Type -> FundamentalType-argType t =- case t of- TyCon "String" -> StringType- TyCon "Double" -> DoubleType- TyCon "Int" -> IntType- TyCon "Bool" -> BoolType- TyApp (TyCon "Defined") a -> Defined (argType a)- TyApp (TyCon "Nullable") a -> Nullable (argType a)- TyApp (TyCon "Fay") a -> JsType (argType a)- TyFun x xs -> FunctionType (argType x : functionTypeArgs xs)- TyList x -> ListType (argType x)- TyTuple _ xs -> TupleType (map argType xs)- TyParen st -> argType st- TyApp op arg -> userDefined (reverse (arg : expandApp op))- _ ->- -- No semantic point to this, merely to avoid GHC's broken- -- warning.- case t of- TyCon (UnQual user) -> UserDefined user []- _ -> UnknownType+argType t = case t of+ TyCon "String" -> StringType+ TyCon "Double" -> DoubleType+ TyCon "Int" -> IntType+ TyCon "Bool" -> BoolType+ TyApp (TyCon "Ptr") _ -> PtrType+ TyApp (TyCon "Automatic") _ -> Automatic+ TyApp (TyCon "Defined") a -> Defined (argType a)+ TyApp (TyCon "Nullable") a -> Nullable (argType a)+ TyApp (TyCon "Fay") a -> JsType (argType a)+ TyFun x xs -> FunctionType (argType x : functionTypeArgs xs)+ TyList x -> ListType (argType x)+ TyTuple _ xs -> TupleType (map argType xs)+ TyParen st -> argType st+ TyApp op arg -> userDefined (reverse (arg : expandApp op))+ _ ->+ -- No semantic point to this, merely to avoid GHC's broken+ -- warning.+ case t of+ TyCon (UnQual user) -> UserDefined user []+ _ -> UnknownType -- | Extract the type. bangType :: BangType -> Type-bangType typ =- case typ of- BangedTy ty -> ty- UnBangedTy ty -> ty- UnpackedTy ty -> ty+bangType typ = case typ of+ BangedTy ty -> ty+ UnBangedTy ty -> ty+ UnpackedTy ty -> ty -- | Expand a type application. expandApp :: Type -> [Type]@@ -227,49 +197,50 @@ -- | Get a JS-representation of a fundamental type for encoding/decoding. typeRep :: SerializeContext -> FundamentalType -> JsExp-typeRep context typ =- case typ of- FunctionType xs -> JsList [JsLit $ JsStr "function",JsList (map (typeRep context) xs)]- JsType x -> JsList [JsLit $ JsStr "action",JsList [typeRep context x]]- ListType x -> JsList [JsLit $ JsStr "list",JsList [typeRep context x]]- TupleType xs -> JsList [JsLit $ JsStr "tuple",JsList (map (typeRep context) xs)]- UserDefined name xs -> JsList [JsLit $ JsStr "user"- ,JsLit $ JsStr (unname name)- ,JsList (zipWith (\t i -> typeRep (setArg i context) t) xs [0..])]- Defined x -> JsList [JsLit $ JsStr "defined",JsList [typeRep context x]]- Nullable x -> JsList [JsLit $ JsStr "nullable",JsList [typeRep context x]]- _ -> nom+typeRep context typ = case typ of+ FunctionType xs -> JsList [JsLit $ JsStr "function",JsList (map (typeRep context) xs)]+ JsType x -> JsList [JsLit $ JsStr "action",JsList [typeRep context x]]+ ListType x -> JsList [JsLit $ JsStr "list",JsList [typeRep context x]]+ TupleType xs -> JsList [JsLit $ JsStr "tuple",JsList (map (typeRep context) xs)]+ UserDefined name xs -> JsList [JsLit $ JsStr "user"+ ,JsLit $ JsStr (unname name)+ ,JsList (zipWith (\t i -> typeRep (setArg i context) t) xs [0..])]+ Defined x -> JsList [JsLit $ JsStr "defined",JsList [typeRep context x]]+ Nullable x -> JsList [JsLit $ JsStr "nullable",JsList [typeRep context x]]+ _ -> nom - where setArg i SerializeUserArg{} = SerializeUserArg i- setArg _ c = c- ret = JsList . return . JsLit . JsStr- nom = case typ of- StringType -> ret "string"- DoubleType -> ret "double"- IntType -> ret "int"- BoolType -> ret "bool"- DateType -> ret "date"- _ ->- case context of- SerializeAnywhere -> ret "unknown"- SerializeUserArg i ->- let args = JsIndex 2 (JsName JsParametrizedType)- thisArg = JsIndex i args- unknown = ret "unknown"- in JsTernaryIf args- (JsTernaryIf thisArg- thisArg- unknown)- unknown+ where+ setArg i SerializeUserArg{} = SerializeUserArg i+ setArg _ c = c+ ret = JsList . return . JsLit . JsStr+ nom = case typ of+ StringType -> ret "string"+ DoubleType -> ret "double"+ PtrType -> ret "ptr"+ Automatic -> ret "automatic"+ IntType -> ret "int"+ BoolType -> ret "bool"+ DateType -> ret "date"+ _ ->+ case context of+ SerializeAnywhere -> ret "unknown"+ SerializeUserArg i ->+ let args = JsIndex 2 (JsName JsParametrizedType)+ thisArg = JsIndex i args+ unknown = ret "unknown"+ in JsTernaryIf args+ (JsTernaryIf thisArg+ thisArg+ unknown)+ unknown -- | Get the arity of a type. typeArity :: Type -> Int-typeArity t =- case t of- TyForall _ _ i -> typeArity i- TyFun _ b -> 1 + typeArity b- TyParen st -> typeArity st- _ -> 0+typeArity t = case t of+ TyForall _ _ i -> typeArity i+ TyFun _ b -> 1 + typeArity b+ TyParen st -> typeArity st+ _ -> 0 -- | Format the FFI format string with the given arguments. formatFFI :: String -- ^ The format string.
src/Language/Fay/Compiler/Misc.hs view
@@ -6,18 +6,23 @@ module Language.Fay.Compiler.Misc where +import qualified Language.Fay.ModuleScope as ModuleScope import Language.Fay.Types +import System.Process (readProcess)+import Text.ParserCombinators.ReadP (readP_to_S)+import Data.Version (parseVersion) import Control.Applicative import Control.Monad.Error+import Control.Monad.Reader import Control.Monad.State import Data.List-import qualified Data.Map as M+import qualified Data.Set as S import Data.Maybe import Data.String import Language.Haskell.Exts (ParseResult(..)) import Language.Haskell.Exts.Syntax-import Prelude hiding (exp)+import Prelude hiding (exp, mod) import System.IO -- | Extra the string from an ident.@@ -54,50 +59,15 @@ -- | Resolve a given maybe-qualified name to a fully qualifed name. resolveName :: QName -> Compile QName resolveName special@Special{} = return special-resolveName (UnQual name) = do--- let echo = io . putStrLn--- echo $ "Resolving name " ++ prettyPrint name- names <- gets stateScope--- echo $ "Names are: " ++ show names- case M.lookup name names of- -- Unqualified and not imported? Current module.- Nothing -> qualify name- Just scopes -> case find localBinding scopes of- Just ScopeBinding -> return (UnQual name)- _ ->- case find simpleImport scopes of- Just (ScopeImported modulename replacement) -> return (Qual modulename (fromMaybe name replacement))- _ -> case find asImport scopes of- Just (ScopeImportedAs _ modulename _) -> return (Qual modulename name)- _ -> throwError $ UnableResolveUnqualified name-- where asImport ScopeImportedAs{} = True- asImport _ = False-- localBinding ScopeBinding = True- localBinding _ = False--resolveName (Qual modulename name) = do- names <- gets stateScope- case M.lookup name names of- -- Qualified and not imported? It's correct, leave it as-is.- Nothing -> return (Qual modulename name)- Just scopes -> case find simpleImport scopes of- Just (ScopeImported _ replacement) -> return (Qual modulename (fromMaybe name replacement))- _ -> case find asMatch scopes of- Just (ScopeImported realname replacement) -> return (Qual realname (fromMaybe name replacement))- _ -> throwError $ UnableResolveQualified (Qual modulename name)-- where asMatch i = case i of- ScopeImported{} -> True- ScopeImportedAs _ _ qmodulename -> qmodulename == moduleToName modulename- ScopeBinding -> False- where moduleToName (ModuleName n) = Ident n---- | Do have have a simple "import X" import on our hands?-simpleImport :: NameScope -> Bool-simpleImport ScopeImported{} = True-simpleImport _ = False+resolveName q@Qual{} = do+ env <- gets stateModuleScope+ maybe (throwError $ UnableResolveQualified q) return (ModuleScope.resolveName q env)+resolveName 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) -- | Qualify a name for the current module. qualify :: Name -> Compile QName@@ -109,17 +79,22 @@ bindToplevel :: SrcLoc -> Bool -> Name -> JsExp -> Compile JsStmt bindToplevel srcloc toplevel name expr = do qname <- (if toplevel then qualify else return . UnQual) name- exportAll <- gets stateExportAll- -- If exportAll is set this declaration has not been added to stateExports yet.- when (toplevel && exportAll) $ emitExport (EVar qname) return (JsMappedVar srcloc (JsNameVar qname) expr) +-- | Create a temporary environment and discard it after the given computation.+withModuleScope :: Compile a -> Compile a+withModuleScope m = do+ scope <- gets stateModuleScope+ value <- m+ modify $ \s -> s { stateModuleScope = scope }+ return value+ -- | Create a temporary scope and discard it after the given computation. withScope :: Compile a -> Compile a withScope m = do- scope <- gets stateScope+ scope <- gets stateLocalScope value <- m- modify $ \s -> s { stateScope = scope }+ modify $ \s -> s { stateLocalScope = scope } return value -- | Run a compiler and just get the scope information.@@ -127,36 +102,36 @@ generateScope m = do st <- get _ <- m- scope <- gets stateScope- put st { stateScope = scope }+ scope <- gets stateLocalScope+ put st { stateLocalScope = scope } -- | Bind a variable in the current scope. bindVar :: Name -> Compile () bindVar name = do- modify $ \s -> s { stateScope = M.insertWith (++) name [ScopeBinding] (stateScope s) }+ modify $ \s -> s { stateLocalScope = S.insert name (stateLocalScope s) } -- | Emit exported names. emitExport :: ExportSpec -> Compile ()-emitExport spec =- case spec of- EVar (UnQual name) -> emitVar (UnQual name)- EVar name@Qual{} -> modify $ \s -> s { stateExports = name : stateExports s }- EThingAll (UnQual name) -> do- emitVar (UnQual name)- r <- lookup (UnQual name) <$> gets stateRecords- maybe (return ()) (mapM_ emitVar) r- EThingWith (UnQual name) ns -> do- emitVar (UnQual name)- mapM_ emitCName ns- EAbs _ -> return () -- Type only, skip- _ -> do- name <- gets stateModuleName- unless (name == "Language.Fay.Stdlib") $- throwError (UnsupportedExportSpec spec)+emitExport spec = case spec of+ EVar (UnQual n) -> emitVar n+ EVar q@Qual{} -> modify $ \s -> s { stateExports = q : stateExports s }+ 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+ EAbs _ -> return () -- Type only, skip+ EModuleContents mod ->+ mapM_ (emitExport . EVar) =<< ModuleScope.moduleLocals mod <$> gets stateModuleScope+ e -> throwError $ UnsupportedExportSpec e where- emitVar n = resolveName n >>= emitExport . EVar- emitCName (VarName n) = emitVar (UnQual n)- emitCName (ConName n) = emitVar (UnQual n)+ emitVar = return . UnQual >=> resolveName >=> emitExport . EVar+ emitCName (VarName n) = emitVar n+ emitCName (ConName n) = emitVar n+ unQName (UnQual u) = u+ unQName _ = error "unQName Qual or Special -- should never happen" -- | Force an expression in a thunk. force :: JsExp -> JsExp@@ -177,14 +152,13 @@ -- | Deconstruct a parse result (a la maybe, foldr, either). parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b-parseResult die ok result =- case result of- ParseOk a -> ok a- ParseFailed srcloc msg -> die (srcloc,msg)+parseResult die ok result = case result of+ ParseOk a -> ok a+ ParseFailed srcloc msg -> die (srcloc,msg) -- | Get a config option. config :: (CompileConfig -> a) -> Compile a-config f = gets (f . stateConfig)+config f = asks (f . readerConfig) -- | Optimize pattern matching conditions by merging conditions in common. optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]@@ -239,9 +213,34 @@ warn :: String -> Compile () warn "" = return () warn w = do- shouldWarn <- configWarn <$> gets stateConfig+ shouldWarn <- config configWarn when shouldWarn . liftIO . hPutStrLn stderr $ "Warning: " ++ w -- | Pretty print a source location. printSrcLoc :: SrcLoc -> String printSrcLoc SrcLoc{..} = srcFilename ++ ":" ++ show srcLine ++ ":" ++ show srcColumn++anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM p l = return . not . null =<< filterM p l++typeToRecs :: QName -> Compile [QName]+typeToRecs typ = fromMaybe [] . lookup typ <$> gets stateRecordTypes++typeToFields :: QName -> Compile [QName]+typeToFields typ = do+ allrecs <- gets stateRecords+ typerecs <- typeToRecs typ+ return . concatMap snd . filter ((`elem` typerecs) . fst) $ allrecs++-- | Get the flag used for GHC, this differs between GHC-7.6.0 and+-- GHC-everything-else so we need to specially test for that. It's+-- lame, but that's random flag name changes for you.+getGhcPackageDbFlag :: IO String+getGhcPackageDbFlag = do+ s <- readProcess "ghc" ["--version"] ""+ return $+ case (mapMaybe readVersion $ words s, readVersion "7.6.0") of+ (v:_, Just min') | v > min' -> "-package-db"+ _ -> "-package-conf"+ where+ readVersion = listToMaybe . filter (null . snd) . readP_to_S parseVersion
src/Language/Fay/Compiler/Optimizer.hs view
@@ -47,22 +47,20 @@ -- | Perform tail-call optimization. tco :: [JsStmt] -> [JsStmt] tco = map inStmt where- inStmt stmt =- case stmt of- JsMappedVar srcloc name exp -> JsMappedVar srcloc name (inject name exp)- 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- []- (Just- (JsNew JsThunk- [JsFun []- (optimize params name (stmts ++ [ JsEarlyReturn e | Just e <- [ret] ]))- Nothing]))- _ -> exp+ inStmt stmt = case stmt of+ JsMappedVar srcloc name exp -> JsMappedVar srcloc name (inject name exp)+ 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+ []+ (Just+ (JsNew JsThunk+ [JsFun []+ (optimize params name (stmts ++ [ JsEarlyReturn e | Just e <- [ret] ]))+ Nothing]))+ _ -> exp optimize params name stmts = result where result = let (newstmts,w) = runWriter makeWhile in if null w@@ -71,17 +69,16 @@ makeWhile = do newstmts <- fmap concat (mapM swap stmts) return [JsWhile (JsLit (JsBool True)) newstmts]- swap stmt =- case stmt of- JsEarlyReturn e- | tailCall e -> do tell [()]- return (rebind e ++ [JsContinue])- | otherwise -> return [stmt]- JsIf p ithen ielse -> do- newithen <- fmap concat (mapM swap ithen)- newielse <- fmap concat (mapM swap ielse)- return [JsIf p newithen newielse]- e -> return [e]+ swap stmt = case stmt of+ JsEarlyReturn e+ | tailCall e -> do tell [()]+ return (rebind e ++ [JsContinue])+ | otherwise -> return [stmt]+ JsIf p ithen ielse -> do+ newithen <- fmap concat (mapM swap ithen)+ newielse <- fmap concat (mapM swap ielse)+ return [JsIf p newithen newielse]+ e -> return [e] tailCall (JsApp (JsName cname) _) = cname == name tailCall _ = False rebind (JsApp _ args) = zipWith go args params where@@ -91,31 +88,31 @@ -- | Strip redundant forcing from the whole generated code. stripAndUncurry :: [JsStmt] -> Optimize [JsStmt] stripAndUncurry = applyToExpsInStmts stripFuncForces where- 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- sbody <- maybe (return Nothing) (fmap Just . go) body- return (JsFun ps substmts sbody)- JsApp a b -> do- result <- walkAndStripForces arities exp- case result of- Just strippedExp -> go strippedExp- Nothing -> JsApp <$> go a <*> mapM go b- JsNegApp e -> JsNegApp <$> go e- JsTernaryIf a b c -> JsTernaryIf <$> go a <*> go b <*> go c- JsParen e -> JsParen <$> go e- JsUpdateProp e n a -> JsUpdateProp <$> go e <*> pure n <*> go a- JsList xs -> JsList <$> mapM go xs- JsEq a b -> JsEq <$> go a <*> go b- JsInfix op a b -> JsInfix op <$> go a <*> go b- JsObj xs -> JsObj <$> mapM (\(x,y) -> (x,) <$> go y) xs- JsNew name xs -> JsNew name <$> mapM go xs- e -> return e+ 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+ sbody <- maybe (return Nothing) (fmap Just . go) body+ return (JsFun ps substmts sbody)+ JsApp a b -> do+ result <- walkAndStripForces arities exp+ case result of+ Just strippedExp -> go strippedExp+ Nothing -> JsApp <$> go a <*> mapM go b+ JsNegApp e -> JsNegApp <$> go e+ JsTernaryIf a b c -> JsTernaryIf <$> go a <*> go b <*> go c+ JsParen e -> JsParen <$> go e+ JsUpdateProp e n a -> JsUpdateProp <$> go e <*> pure n <*> go a+ JsList xs -> JsList <$> mapM go xs+ JsEq a b -> JsEq <$> go a <*> go b+ JsInfix op a b -> JsInfix op <$> go a <*> go b+ JsObj xs -> JsObj <$> mapM (\(x,y) -> (x,) <$> go y) xs+ JsNew name xs -> JsNew name <$> mapM go xs+ e -> return e - where go = stripFuncForces arities- stripInStmt = applyToExpsInStmt arities stripFuncForces+ where+ go = stripFuncForces arities+ stripInStmt = applyToExpsInStmt arities stripFuncForces -- | Strip redundant forcing from an application if possible. walkAndStripForces :: [FuncArity] -> JsExp -> Optimize (Maybe JsExp)@@ -144,15 +141,14 @@ applyToExpsInStmt :: [FuncArity] -> ([FuncArity] -> JsExp -> Optimize JsExp) -> JsStmt -> Optimize JsStmt applyToExpsInStmt funcs f stmts = uncurryInStmt stmts where transform = f funcs- uncurryInStmt stmt =- case stmt of- JsMappedVar srcloc name exp -> JsMappedVar srcloc name <$> transform exp- JsVar name exp -> JsVar name <$> transform exp- JsEarlyReturn exp -> JsEarlyReturn <$> transform exp- JsIf op ithen ielse -> JsIf <$> transform op- <*> mapM uncurryInStmt ithen- <*> mapM uncurryInStmt ielse- s -> pure s+ uncurryInStmt stmt = case stmt of+ JsMappedVar srcloc name exp -> JsMappedVar srcloc name <$> transform exp+ JsVar name exp -> JsVar name <$> transform exp+ JsEarlyReturn exp -> JsEarlyReturn <$> transform exp+ JsIf op ithen ielse -> JsIf <$> transform op+ <*> mapM uncurryInStmt ithen+ <*> mapM uncurryInStmt ielse+ s -> pure s -- | Collect functions and their arity from the whole codeset. collectFuncs :: [JsStmt] -> [FuncArity]@@ -184,30 +180,27 @@ uncurryBinding :: [JsStmt] -> QName -> Maybe JsStmt uncurryBinding stmts qname = listToMaybe (mapMaybe funBinding stmts)-- where funBinding stmt =- case stmt of- JsMappedVar srcloc (JsNameVar name) body- | name == qname -> JsMappedVar srcloc (JsNameVar (renameUncurried name)) <$> uncurryIt body- JsVar (JsNameVar name) body- | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body- _ -> Nothing+ where+ funBinding stmt = case stmt of+ JsMappedVar srcloc (JsNameVar name) body+ | name == qname -> JsMappedVar srcloc (JsNameVar (renameUncurried name)) <$> uncurryIt body+ JsVar (JsNameVar name) body+ | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body+ _ -> Nothing - uncurryIt = Just . go [] where- go args exp =- case exp of- JsFun [arg] [] (Just body) -> go (arg : args) body- inner -> JsFun (reverse args) [] (Just inner)+ uncurryIt = Just . go [] where+ go args exp = case exp of+ JsFun [arg] [] (Just body) -> go (arg : args) body+ inner -> JsFun (reverse args) [] (Just inner) -- | Rename an uncurried copy of a curried function. renameUncurried :: QName -> QName-renameUncurried q =- case q of- Qual m n -> Qual m (renameUnQual n)- UnQual n -> UnQual (renameUnQual n)- s -> s- where renameUnQual n =- case n of- Ident nom -> Ident (nom ++ postfix)- Symbol nom -> Symbol (nom ++ postfix)- postfix = "$uncurried"+renameUncurried q = case q of+ Qual m n -> Qual m (renameUnQual n)+ UnQual n -> UnQual (renameUnQual n)+ s -> s+ where+ renameUnQual n = case n of+ Ident nom -> Ident (nom ++ postfix)+ Symbol nom -> Symbol (nom ++ postfix)+ postfix = "$uncurried"
+ src/Language/Fay/Compiler/Packages.hs view
@@ -0,0 +1,115 @@+-- | Dealing with Cabal packages in Fay's own special way.++module Language.Fay.Compiler.Packages where++import Language.Fay.Types++import Control.Monad+import Data.List+import GHC.Paths+import System.Directory+import System.FilePath+import System.Process.Extra++-- | Given a configuration, resolve any packages specified to their+-- data file directories for importing the *.hs sources.+resolvePackages :: CompileConfig -> IO CompileConfig+resolvePackages config = do+ foldM resolvePackage config (configPackages config)++-- | Resolve package.+resolvePackage :: CompileConfig -> String -> IO CompileConfig+resolvePackage config name = do+ desc <- describePackage (configPackageConf config) name+ case shareDirs desc of+ Nothing -> error $ "unable to find share dir of package: " ++ name+ Just dirs -> do+ mapM_ checkDirExists dirs+ return (addConfigDirectoryIncludes dirs config)++-- | Describe package with ghc-pkg.+--+-- Weinsworth : Why are you not using the GHC API which would+-- provide you this information like in modules like+-- Packages which has functions like+--+-- collectIncludeDirs :: [PackageConfig] -> [FilePath]+--+-- and awesome stuff like that. What are you, stupid?+--+-- Batemen : Pretty much. I think this might be a little faster than+-- initializing GHC, and using the GHC API adds a lot of+-- link time when you use it.+--+-- Weinsworth : Uh huh.+--+-- Batemen: Yeah. Stop looking at me like that.+--+describePackage :: Maybe FilePath -> String -> IO String+describePackage db name = do+ result <- readAllFromProcess ghc_pkg args ""+ case result of+ Left err -> error $ "ghc-pkg describe error:\n" ++ err+ Right (_err,out) -> return out++ where args = concat [["describe",name]+ ,["-f" ++ db' | Just db' <- [db]]]++-- | Get the share dirs of the package.+--+-- Alright.+-- Stop.+-- Collaborate and listen.+--+-- You're gonna have to stop scrolling and read this.+--+-- I can't figure out how to get the data-dirs from the package+-- description.+--+-- * It doesn't seem to be in the Cabal API's PackageDescription type.+-- * It doesn't seem to be in the ghc-pkg description.+-- * I can't find out how to read the Cabal configuration. Yeah, I+-- could probably find it eventually. Shut up.+--+-- So what I'm doing is parsing the “import-dirs” flag, which+-- appears in ghc-pkg's output like this:+--+-- /home/chris/Projects/me/fay-jquery/cabal-dev//lib/fay-jquery-0.1.0.0/ghc-7.4.1+--+-- And I'm going to replace “lib” with “share” and drop the “ghc-*”+-- and that, under a *normal* configuration, gives the share+-- directory.+--+-- Under an atypical situation, we're going to throw an error and+-- you guys will just have to submit a pull request or some code to+-- do this better, because I've got better things to be doing, like+-- climbing trees, baking cookies and reading books about zombies.+--+shareDirs :: String -> Maybe [FilePath]+shareDirs desc =+ case find (isPrefixOf "import-dirs: ") (lines desc) of+ Nothing -> Nothing+ Just idirs ->+ case words idirs of+ -- I'm going to take the first one. If you've got more, just,+ -- I hate you.+ (_import_dirs:idir:_) -> Just $ [munge idir+ ,munge idir </> "src"] -- Yep.+ _ -> Nothing++ where munge = joinPath . reverse . swap . dropGhc . reverse . map dropTrailingPathSeparator . splitPath where+ dropGhc = drop 1+ swap (name_version:"lib":rest) = name_version : "share" : rest+ swap paths = error $ "unable to complete munging of the lib dir\+ \, see Language.Fay.Compiler.Packages.hs \+ \for an explanation: " +++ "\npath was: " ++ joinPath paths++-- | Might as well check the dir that we munged to death actually+-- exists. -___ -+checkDirExists :: FilePath -> IO ()+checkDirExists p = do+ don'tFlipOut <- doesDirectoryExist p+ unless don'tFlipOut $+ error $ "so the directory we munged doesn't exist:\n " ++ p +++ "\nreport a bug, we screwed up."
src/Language/Fay/Convert.hs view
@@ -100,6 +100,7 @@ `extR` parseInt value `extR` parseBool value `extR` parseString value+ `extR` parseText value -- | Parse a data type or record. parseData :: Data a => Value -> Maybe a@@ -180,6 +181,13 @@ parseString value = case value of String s -> return (Text.unpack s)+ _ -> mzero++-- | Parse a Text.+parseText :: Value -> Maybe Text+parseText value =+ case value of+ String s -> return s _ -> mzero -- | Parse an array.
src/Language/Fay/FFI.hs view
@@ -7,6 +7,8 @@ ,Foreign ,Nullable (..) ,Defined (..)+ ,Ptr+ ,Automatic ,ffi) where @@ -66,9 +68,26 @@ data Defined a = Defined a | Undefined instance Foreign a => Foreign (Defined a) +-- | Do not serialize the specified type. This is useful for, e.g.+--+-- > foo :: String -> String+-- > foo = ffi "%1"+--+-- This would normally serialize and unserialize the string, for no+-- reason, in this case. Instead:+--+-- > foo :: Ptr String -> Ptr String+--+-- Will just give an identity function.+type Ptr a = a++-- | The opposite of "Ptr". Serialize the specified polymorphic type.+--+-- > foo :: Automatic a -> String+--+type Automatic a = a+ -- | Declare a foreign action.-ffi- :: Foreign a- => String -- ^ The foreign value.- -> a -- ^ Bottom.+ffi :: String -- ^ The foreign value.+ -> a -- ^ Bottom. ffi = error "Language.Fay.FFI.foreignFay: Used foreign function not in a JS engine context."
+ src/Language/Fay/ModuleScope.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Handles variable bindings on the module level and also keeps track of+-- primitive operations that we want to treat specially.++module Language.Fay.ModuleScope+ (ModuleScope+ ,bindAsLocals+ ,findTopLevelNames+ ,resolveName+ ,moduleLocals)+ where++import Control.Arrow+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Default+import Data.Map (Map)+import qualified Data.Map as M+import Language.Haskell.Exts hiding (name, binds)+import Prelude hiding (mod)++-- | Maps names bound in the module to their real names+-- The keys are unqualified for locals and imports,+-- the values are always fully qualified+-- Example contents:+-- [ (UnQUal "main" , Qual "Main" "main")+-- , (UnQual "take" , Qual "Prelude" "take")+-- , ( Qual "M" "insertWith", Qual "Data.Map" "insertWith") ]+newtype ModuleScope = ModuleScope (Map QName QName)+ deriving Show++instance Monoid ModuleScope where+ mempty = ModuleScope M.empty+ mappend (ModuleScope a) (ModuleScope b) = ModuleScope $ a `M.union` b++instance Default ModuleScope where+ def = mempty++-- | Find the path of a locally bound name+-- Returns special values in the "Fay$" module for primOps+resolveName :: QName -> ModuleScope -> Maybe QName+resolveName q (ModuleScope binds) = case M.lookup q binds of -- lookup in the module environment.++ -- something pointing to prelude, is it a primop?+ Just q'@(Qual (ModuleName "Prelude") n) -> case M.lookup n envPrimOpsMap of+ Just x -> Just x -- A primop which looks like it's imported from prelude.+ Nothing -> Just q' -- Regular prelude import, leave it as is.++ -- No matches in the current environment, so it may be a primop if it's unqualified.+ -- If Nothing is returned from either of the branches it means that there is+ -- no primop and nothing in env scope so GHC would have given an error.+ Nothing -> case q of+ UnQual n -> M.lookup n envPrimOpsMap+ _ -> Nothing+ j -> j -- Non-prelude import that was found in the env++-- | Bind a list of names into the local scope+-- Right now all bindings are made unqualified+bindAsLocals :: [QName] -> ModuleScope -> ModuleScope+bindAsLocals qs (ModuleScope binds) =+ -- This needs to be changed to not use unqual to support qualified imports.+ ModuleScope $ M.fromList (map (unqual &&& id) qs) `M.union` binds+ where unqual (Qual _ n) = (UnQual n)+ unqual u@UnQual{} = u+ unqual Special{} = error "fay: ModuleScope.bindAsLocals: Special"++-- | Find all names that are bound locally in this module, which excludes imports.+moduleLocals :: ModuleName -> ModuleScope -> [QName]+moduleLocals mod (ModuleScope binds) = filter isLocal . M.elems $ binds+ where+ isLocal (Qual m _) = mod == m+ isLocal _ = False++--------------------------------------------------------------------------------+-- Primitive Operations++-- | The built-in operations that aren't actually compiled from+-- anywhere, they come from runtime.js.+--+-- They're in the names list so that they can be overriden by the user+-- in e.g. let a * b = a - b in 1 * 2.+--+-- So we resolve them to Fay$, i.e. the prefix used for the runtime+-- support. $ is not allowed in Haskell module names, so there will be+-- no conflicts if a user decicdes to use a module named Fay.+--+-- So e.g. will compile to (*) Fay$$mult, which is in runtime.js.+envPrimOpsMap :: Map Name QName+envPrimOpsMap = M.fromList+ [ (Symbol ">>", (Qual (ModuleName "Fay$") (Ident "then")))+ , (Symbol ">>=", (Qual (ModuleName "Fay$") (Ident "bind")))+ , (Ident "return", (Qual (ModuleName "Fay$") (Ident "return")))+ , (Ident "force", (Qual (ModuleName "Fay$") (Ident "force")))+ , (Ident "seq", (Qual (ModuleName "Fay$") (Ident "seq")))+ , (Symbol "*", (Qual (ModuleName "Fay$") (Ident "mult")))+ , (Symbol "+", (Qual (ModuleName "Fay$") (Ident "add")))+ , (Symbol "-", (Qual (ModuleName "Fay$") (Ident "sub")))+ , (Symbol "/", (Qual (ModuleName "Fay$") (Ident "div")))+ , (Symbol "==", (Qual (ModuleName "Fay$") (Ident "eq")))+ , (Symbol "/=", (Qual (ModuleName "Fay$") (Ident "neq")))+ , (Symbol ">", (Qual (ModuleName "Fay$") (Ident "gt")))+ , (Symbol "<", (Qual (ModuleName "Fay$") (Ident "lt")))+ , (Symbol ">=", (Qual (ModuleName "Fay$") (Ident "gte")))+ , (Symbol "<=", (Qual (ModuleName "Fay$") (Ident "lte")))+ , (Symbol "&&", (Qual (ModuleName "Fay$") (Ident "and")))+ , (Symbol "||", (Qual (ModuleName "Fay$") (Ident "or")))+ ]++--------------------------------------------------------------------------------+-- AST++type ModuleScopeSt = ReaderT ModuleName (Writer ModuleScope) ()++-- | Get module level names from a haskell module AST.+findTopLevelNames :: ModuleName -> [Decl] -> ModuleScope+findTopLevelNames mod decls = snd . runWriter $ runReaderT (mapM_ d_decl decls) mod++bindName :: Name -> ModuleScopeSt+bindName k = ask >>= \mod -> tell (ModuleScope $ M.singleton (UnQual k) (Qual mod k))++d_decl :: Decl -> ModuleScopeSt+d_decl d = case d of+ DataDecl _ _ _ _ _ dd _ -> mapM_ d_qualCon dd+ PatBind _ (PVar n) _ _ _ -> bindName n+ FunBind (Match _ n _ _ _ _ : _) -> bindName n+ ClassDecl _ _ _ _ _ cds -> mapM_ d_classDecl cds+ TypeSig _ ns _ -> mapM_ bindName ns+ _ -> return ()++d_classDecl :: ClassDecl -> ModuleScopeSt+d_classDecl cd = case cd of+ ClsDecl d -> d_decl d+ _ -> return ()++d_qualCon :: QualConDecl -> ModuleScopeSt+d_qualCon (QualConDecl _ _ _ cd) = case cd of+ ConDecl n _ -> bindName n+ InfixConDecl _ n _ -> bindName n+ RecDecl n ns -> bindName n >> mapM_ bindName (concatMap fst ns)
src/Language/Fay/Stdlib.hs view
@@ -161,7 +161,7 @@ undefined :: a undefined = error "Prelude.undefined" -show :: (Foreign a, Show a) => a -> String+show :: (Foreign a, Show a) => Automatic a -> String show = ffi "JSON.stringify(%1)" data Either a b = Left a | Right b@@ -728,7 +728,7 @@ break :: (a -> Bool) -> [a] -> ([a], [a]) break p = span (not . p) -print :: (Foreign a) => a -> Fay ()+print :: (Foreign a) => Automatic a -> Fay () print = ffi "(function(x) { if (console && console.log) console.log(x) })(%1)" putStrLn :: String -> Fay ()
src/Language/Fay/Types.hs view
@@ -17,6 +17,7 @@ ,CompilesTo(..) ,Printable(..) ,Fay+ ,CompileReader(..) ,CompileConfig( configFlattenApps ,configOptimize@@ -35,12 +36,16 @@ ,configDirectoryIncludes ,addConfigDirectoryInclude ,addConfigDirectoryIncludes+ ,configPackages+ ,addConfigPackage+ ,addConfigPackages ,CompileState(..) ,defaultCompileState+ ,defaultCompileReader+ ,faySourceDir ,FundamentalType(..) ,PrintState(..) ,Printer(..)- ,NameScope(..) ,Mapping(..) ,SerializeContext(..)) where@@ -49,13 +54,17 @@ import Control.Monad.Error (Error, ErrorT, MonadError) import Control.Monad.Identity (Identity) import Control.Monad.State+import Control.Monad.RWS import Data.Default-import Data.Map (Map)-import qualified Data.Map as M+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S import Data.String import Language.Haskell.Exts import System.FilePath +import Language.Fay.ModuleScope (ModuleScope) import Paths_fay --------------------------------------------------------------------------------@@ -77,14 +86,19 @@ , configWall :: Bool , configGClosure :: Bool , configPackageConf :: Maybe FilePath+ , _configPackages :: [String] } deriving (Show) -- | Default configuration. instance Default CompileConfig where- def = CompileConfig False False True [] False False [] False True Nothing True False False Nothing+ def =+ addConfigPackage "fay-base" $+ CompileConfig False False True [] False False [] False True Nothing True False False Nothing [] +-- Restrict these setters so elements aren't accidentally removed.+ configDirectoryIncludes :: CompileConfig -> [FilePath]-configDirectoryIncludes cfg = _configDirectoryIncludes cfg+configDirectoryIncludes = _configDirectoryIncludes addConfigDirectoryInclude :: FilePath -> CompileConfig -> CompileConfig addConfigDirectoryInclude fp cfg = cfg { _configDirectoryIncludes = fp : _configDirectoryIncludes cfg }@@ -92,83 +106,75 @@ addConfigDirectoryIncludes :: [FilePath] -> CompileConfig -> CompileConfig addConfigDirectoryIncludes fps cfg = foldl (flip addConfigDirectoryInclude) cfg fps +configPackages :: CompileConfig -> [String]+configPackages = _configPackages++addConfigPackage :: String -> CompileConfig -> CompileConfig+addConfigPackage pkg cfg = cfg { _configPackages = pkg : _configPackages cfg }++addConfigPackages :: [String] -> CompileConfig -> CompileConfig+addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps+ -- | State of the compiler. data CompileState = CompileState- { stateConfig :: CompileConfig- , stateExports :: [QName]- , stateExportAll :: Bool- , stateModuleName :: ModuleName- , stateFilePath :: FilePath- , stateRecords :: [(QName,[QName])]- , stateFayToJs :: [JsStmt]- , stateJsToFay :: [JsStmt]- , stateImported :: [(ModuleName,FilePath)]- , stateNameDepth :: Integer- , stateScope :: Map Name [NameScope]+ { stateExports :: [QName]+ , stateExportsCache :: Map ModuleName [QName] -- Collects exports from modules+ , stateModuleName :: ModuleName+ , stateFilePath :: FilePath+ , stateRecordTypes :: [(QName,[QName])] -- Map types to constructors+ , stateRecords :: [(QName,[QName])] -- Map constructors to fields+ , stateFayToJs :: [JsStmt]+ , stateJsToFay :: [JsStmt]+ , stateImported :: [(ModuleName,FilePath)]+ , stateNameDepth :: Integer+ , stateLocalScope :: Set Name+ , stateModuleScope :: ModuleScope } deriving (Show) --- | A name's scope, either imported or bound locally.-data NameScope = ScopeImported ModuleName (Maybe Name)- | ScopeImportedAs Bool ModuleName Name- | ScopeBinding+data CompileReader = CompileReader+ { readerConfig :: CompileConfig+ } deriving (Show) - deriving (Show,Eq)+faySourceDir :: IO FilePath+faySourceDir = fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs") +-- | The default compiler reader value.+defaultCompileReader :: CompileConfig -> IO CompileReader+defaultCompileReader config = do+ srcdir <- faySourceDir+ return CompileReader+ { readerConfig = addConfigDirectoryInclude srcdir config+ }+ -- | The default compiler state.-defaultCompileState :: CompileConfig -> IO CompileState-defaultCompileState config = do- srcdir <- fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs")+defaultCompileState :: IO CompileState+defaultCompileState = do types <- getDataFileName "src/Language/Fay/Types.hs"- prelude <- getDataFileName "src/Language/Fay/Prelude.hs" return $ CompileState {- stateConfig = addConfigDirectoryInclude srcdir config- , stateExports = []- , stateExportAll = True+ stateExports = []+ , stateExportsCache = M.empty , stateModuleName = ModuleName "Main"- , stateRecords = [("Nothing",[]),("Just",["slot1"])]+ , stateRecordTypes = []+ , stateRecords = [] , stateFayToJs = [] , stateJsToFay = []- , stateImported = [("Language.Fay.Types",types),("Prelude",prelude)]+ , stateImported = [("Language.Fay.Types",types)] , stateNameDepth = 1 , stateFilePath = "<unknown>"- , stateScope = M.fromList primOps+ , stateLocalScope = S.empty+ , stateModuleScope = def } --- | The built-in operations that aren't actually compiled from--- anywhere, they come from runtime.js.------ They're in the names list so that they can be overriden by the user--- in e.g. let a * b = a - b in 1 * 2.------ So we resolve them to Fay$, i.e. the prefix used for the runtime--- support. $ is not allowed in Haskell module names, so there will be--- no conflicts if a user decicdes to use a module named Fay.------ So e.g. will compile to (*) Fay$$mult, which is in runtime.js.-primOps :: [(Name, [NameScope])]-primOps =- [(Symbol ">>",[ScopeImported "Fay$" (Just "then")])- ,(Symbol ">>=",[ScopeImported "Fay$" (Just "bind")])- ,(Ident "return",[ScopeImported "Fay$" (Just "return")])- ,(Ident "force",[ScopeImported "Fay$" (Just "force")])- ,(Ident "seq",[ScopeImported "Fay$" (Just "seq")])- ,(Symbol "*",[ScopeImported "Fay$" (Just "mult")])- ,(Symbol "+",[ScopeImported "Fay$" (Just "add")])- ,(Symbol "-",[ScopeImported "Fay$" (Just "sub")])- ,(Symbol "/",[ScopeImported "Fay$" (Just "div")])- ,(Symbol "==",[ScopeImported "Fay$" (Just "eq")])- ,(Symbol "/=",[ScopeImported "Fay$" (Just "neq")])- ,(Symbol ">",[ScopeImported "Fay$" (Just "gt")])- ,(Symbol "<",[ScopeImported "Fay$" (Just "lt")])- ,(Symbol ">=",[ScopeImported "Fay$" (Just "gte")])- ,(Symbol "<=",[ScopeImported "Fay$" (Just "lte")])- ,(Symbol "&&",[ScopeImported "Fay$" (Just "and")])- ,(Symbol "||",[ScopeImported "Fay$" (Just "or")])]- -- | Compile monad.-newtype Compile a = Compile { unCompile :: StateT CompileState (ErrorT CompileError IO) a }+newtype Compile a = Compile+ { unCompile :: RWST CompileReader+ ()+ CompileState (ErrorT CompileError IO)+ a+ } deriving (MonadState CompileState ,MonadError CompileError+ ,MonadReader CompileReader ,MonadIO ,Monad ,Functor@@ -236,6 +242,7 @@ | FfiFormatInvalidJavaScript SrcLoc String String | UnableResolveUnqualified Name | UnableResolveQualified QName+ | UnableResolveCachedImport ModuleName deriving (Show) instance Error CompileError @@ -332,7 +339,10 @@ | DoubleType | IntType | BoolType- -- | Unknown.+ | PtrType+ -- Automatically serialize this type.+ | Automatic+ -- Unknown. | UnknownType deriving (Show)
src/Main.hs view
@@ -23,21 +23,23 @@ -- | Options and help. data FayCompilerOptions = FayCompilerOptions- { optLibrary :: Bool- , optFlattenApps :: Bool- , optHTMLWrapper :: Bool- , optHTMLJSLibs :: [String]- , optInclude :: [String]- , optWall :: Bool- , optNoGHC :: Bool- , optStdout :: Bool- , optVersion :: Bool- , optOutput :: Maybe String- , optPretty :: Bool- , optFiles :: [String]- , optOptimize :: Bool- , optGClosure :: Bool- }+ { optLibrary :: Bool+ , optFlattenApps :: Bool+ , optHTMLWrapper :: Bool+ , optHTMLJSLibs :: [String]+ , optInclude :: [String]+ , optPackages :: [String]+ , optWall :: Bool+ , optNoGHC :: Bool+ , optStdout :: Bool+ , optVersion :: Bool+ , optOutput :: Maybe String+ , optPretty :: Bool+ , optFiles :: [String]+ , optOptimize :: Bool+ , optGClosure :: Bool+ , optPackageConf :: Maybe String+ } -- | Main entry point. main :: IO ()@@ -46,31 +48,32 @@ opts <- execParser parser if optVersion opts then runCommandVersion- else do let config = flip (foldl (flip addConfigDirectoryInclude)) ("." : optInclude opts) $ def- { configOptimize = optOptimize opts- , configFlattenApps = optFlattenApps opts- , configExportBuiltins = True -- optExportBuiltins opts- , configPrettyPrint = optPretty opts- , configLibrary = optLibrary opts- , configHtmlWrapper = optHTMLWrapper opts- , configHtmlJSLibs = optHTMLJSLibs opts- , configTypecheck = not $ optNoGHC opts- , configWall = optWall opts- , configGClosure = optGClosure opts- , configPackageConf = packageConf- }- void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"- case optFiles opts of- ["-"] -> do- hGetContents stdin >>= printCompile config compileModule- [] -> runInteractive- files -> forM_ files $ \file -> do- if optStdout opts- then compileFromTo config file Nothing- else compileFromTo config file (Just (outPutFile opts file))+ else do+ let config = addConfigDirectoryIncludes ("." : optInclude opts) $+ addConfigPackages (optPackages opts) $ def+ { configOptimize = optOptimize opts+ , configFlattenApps = optFlattenApps opts+ , configExportBuiltins = True -- optExportBuiltins opts+ , configPrettyPrint = optPretty opts+ , configLibrary = optLibrary opts+ , configHtmlWrapper = optHTMLWrapper opts+ , configHtmlJSLibs = optHTMLJSLibs opts+ , configTypecheck = not $ optNoGHC opts+ , configWall = optWall opts+ , configGClosure = optGClosure opts+ , configPackageConf = optPackageConf opts <|> packageConf+ }+ void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"+ case optFiles opts of+ ["-"] -> hGetContents stdin >>= printCompile config compileModule+ [] -> runInteractive+ files -> forM_ files $ \file -> do+ if optStdout opts+ then compileFromTo config file Nothing+ else compileFromTo config file (Just (outPutFile opts file)) where- parser = info (helper <*> options) (fullDesc & header helpTxt)+ parser = info (helper <*> options) (fullDesc <> header helpTxt) outPutFile :: FayCompilerOptions -> String -> FilePath outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts@@ -78,32 +81,37 @@ -- | All Fay's command-line options. options :: Parser FayCompilerOptions options = FayCompilerOptions- <$> switch (long "library" & help "Don't automatically call main in generated JavaScript")- <*> switch (long "flatten-apps" & help "flatten function applicaton")- <*> switch (long "html-wrapper" & help "Create an html file that loads the javascript")- <*> strsOption (long "html-js-lib" & metavar "file1[, ..]"- & help "javascript files to add to <head> if using option html-wrapper")- <*> strsOption (long "include" & metavar "dir1[, ..]"- & help "additional directories for include")- <*> switch (long "Wall" & help "Typecheck with -Wall")- <*> switch (long "no-ghc" & help "Don't typecheck, specify when not working with files")- <*> switch (long "stdout" & short 's' & help "Output to stdout")- <*> switch (long "version" & help "Output version number")- <*> optional (strOption (long "output" & short 'o' & metavar "file" & help "Output to specified file"))- <*> switch (long "pretty" & short 'p' & help "Pretty print the output")+ <$> switch (long "library" <> help "Don't automatically call main in generated JavaScript")+ <*> switch (long "flatten-apps" <> help "flatten function applicaton")+ <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript")+ <*> strsOption (long "html-js-lib" <> metavar "file1[, ..]"+ <> help "javascript files to add to <head> if using option html-wrapper")+ <*> strsOption (long "include" <> metavar "dir1[, ..]"+ <> help "additional directories for include")+ <*> strsOption (long "package" <> metavar "package[, ..]"+ <> help "packages to use for compilation")+ <*> switch (long "Wall" <> help "Typecheck with -Wall")+ <*> switch (long "no-ghc" <> help "Don't typecheck, specify when not working with files")+ <*> switch (long "stdout" <> short 's' <> help "Output to stdout")+ <*> switch (long "version" <> help "Output version number")+ <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))+ <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output") <*> arguments Just (metavar "- | <hs-file>...")- <*> switch (long "optimize" & short 'O' & help "Apply optimizations to generated code")- <*> switch (long "closure" & help "Provide help with Google Closure")+ <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")+ <*> switch (long "closure" <> help "Provide help with Google Closure")+ <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file")) where strsOption m =- nullOption (m & reader (Just . wordsBy (== ',')) & value [])+ nullOption (m <> reader (Right . wordsBy (== ',')) <> value []) + -- | Make incompatible options.-incompatible :: Monad m => (FayCompilerOptions -> Bool)- -> FayCompilerOptions -> String -> m Bool+incompatible :: Monad m+ => (FayCompilerOptions -> Bool)+ -> FayCompilerOptions -> String -> m Bool incompatible test opts message = case test opts of- True -> E.throw $ userError message- False -> return True+ True -> E.throw $ userError message+ False -> return True -- | The basic help text. helpTxt :: String@@ -127,22 +135,22 @@ runInteractive :: IO () runInteractive = runInputT defaultSettings loop where loop = do- minput <- getInputLine "> "- case minput of- Nothing -> return ()- Just "" -> loop- Just input -> do- result <- liftIO $ compileViaStr "<interactive>" config compileExp input- case result of- Left err -> do- -- an error occured, maybe input was not an expression,- -- but a declaration, try compiling the input as a declaration- outputStrLn ("can't parse input as expression: " ++ show err)- result' <- liftIO $ compileViaStr "<interactive>" config (compileDecl True) input- case result' of- Right (PrintState{..},_) -> outputStr (concat (reverse psOutput))- Left err' ->- outputStrLn ("can't parse input as declaration: " ++ show err')- Right (PrintState{..},_) -> outputStr (concat (reverse psOutput))- loop+ minput <- getInputLine "> "+ case minput of+ Nothing -> return ()+ Just "" -> loop+ Just input -> do+ result <- liftIO $ compileViaStr "<interactive>" config compileExp input+ case result of+ Left err -> do+ -- an error occured, maybe input was not an expression,+ -- but a declaration, try compiling the input as a declaration+ outputStrLn ("can't parse input as expression: " ++ show err)+ result' <- liftIO $ compileViaStr "<interactive>" config (compileDecl True) input+ case result' of+ Right (PrintState{..},_) -> outputStr (concat (reverse psOutput))+ Left err' ->+ outputStrLn ("can't parse input as declaration: " ++ show err')+ Right (PrintState{..},_) -> outputStr (concat (reverse psOutput))+ loop config = def { configPrettyPrint = True }
src/System/Process/Extra.hs view
@@ -2,23 +2,14 @@ module System.Process.Extra where --import System.Exit-import System.IO-import System.Process---- | Read all stuff from a process.-readAllFromProcess :: FilePath -> String -> IO (Either String String)-readAllFromProcess program file = do- (_,out,err,pid) <- runInteractiveProcess program [file] Nothing Nothing- code <- waitForProcess pid- case code of- ExitSuccess -> fmap Right (hGetContents out)- ExitFailure _ -> fmap Left (hGetContents err)+import System.Exit+import System.Process -readAllFromProcess' :: FilePath -> [String] -> String -> IO (Either String (String,String))-readAllFromProcess' program flags input = do+-- | Read everything from a process, either failure or both stderr and stdout.+readAllFromProcess :: FilePath -> [String] -> String -> IO (Either String (String,String))+readAllFromProcess program flags input = do (code,out,err) <- readProcessWithExitCode program flags input return $ case code of- ExitFailure _ -> Left err- ExitSuccess -> Right (err, out)+ ExitFailure 127 -> Left ("cannot find executable " ++ program)+ ExitFailure _ -> Left err+ ExitSuccess -> Right (err, out)
src/Test/Api.hs view
@@ -3,35 +3,67 @@ module Test.Api (tests) where -import Language.Fay+import Language.Fay -import Data.Default-import Data.Maybe-import Language.Haskell.Exts.Syntax-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.TH-import Test.HUnit (Assertion, assertBool)-import Test.Util+import Data.Default+import Data.Maybe+import Language.Haskell.Exts.Syntax+import System.Environment+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.TH+import Test.HUnit (Assertion, assertBool, assertEqual)+import Test.Util tests :: Test tests = $testGroupGenerator case_imports :: Assertion case_imports = do- res <- compileFile defConf fp+ whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ res <- compileFile defConf { configPackageConf = whatAGreatFramework } fp assertBool "Could not compile file with imports" (isRight res) case_importedList :: Assertion case_importedList = do- res <- compileFileWithState defConf fp+ whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } fp case res of Left err -> error (show err) Right (_,r) -> assertBool "RecordImport_Export was not added to stateImported" . isJust . lookup (ModuleName "RecordImport_Export") $ stateImported r +case_stateRecordTypes :: Assertion+case_stateRecordTypes = do+ whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Api/Records.hs"+ case res of+ Left err -> error (show err)+ Right (_,r) -> do+ -- TODO order should not matter+ assertEqual "stateRecordTypes mismatch"+ [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])+ , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])+ ]+ (stateRecordTypes r)++case_importStateRecordTypes :: Assertion+case_importStateRecordTypes = do+ whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Api/ImportRecords.hs"+ case res of+ Left err -> error (show err)+ Right (_,r) -> do+ -- TODO order should not matter+ assertEqual "stateRecordTypes mismatch"+ [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])+ , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])+ ]+ (stateRecordTypes r)+ fp :: FilePath fp = "tests/RecordImport_Import.hs" defConf :: CompileConfig-defConf = addConfigDirectoryInclude "tests/" $ def { configTypecheck = False }+defConf = addConfigDirectoryInclude "tests/"+ $ def { configTypecheck = False }
src/Test/CommandLine.hs view
@@ -2,25 +2,34 @@ module Test.CommandLine (tests) where -import Control.Applicative-import Data.Maybe-import System.Process.Extra-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.TH-import Test.HUnit (Assertion, assertBool)-import Test.Util+import Control.Applicative+import Data.Maybe+import System.Directory+import System.Environment+import System.FilePath+import System.Process.Extra+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.TH+import Test.HUnit (Assertion, assertBool)+import Test.Util tests :: Test tests = $testGroupGenerator compileFile :: [String] -> IO (Either String String) compileFile flags = do- fay <- fromJust <$> fayPath- r <- readAllFromProcess' fay flags ""- return $ case r of- Left l -> Left l- Right t -> Right $ snd t+ whatAGreatFramework <- fmap (fmap (\x -> x</>"bin"</>"fay") . (lookup "HASKELL_SANDBOX"))+ getEnvironment+ fay <- fayPath+ let path = fromMaybe "couldn't find fay" (whatAGreatFramework <|> fay)+ exists <- doesFileExist path+ if exists+ then do r <- readAllFromProcess path flags ""+ return $ case r of+ Left l -> Left ("Reason: " ++ l)+ Right t -> Right $ snd t+ else error $ "fay path not are existing: " ++ path case_executable :: Assertion case_executable = do@@ -29,5 +38,7 @@ case_compile :: Assertion case_compile = do- res <- compileFile ["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"]+ whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ res <- compileFile (["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"] +++ ["--package-conf=" ++ packageConf | Just packageConf <- [whatAGreatFramework] ]) assertBool (fromLeft res) (isRight res)
src/Test/Convert.hs view
@@ -9,6 +9,7 @@ import qualified Data.ByteString.UTF8 as UTF8 import Data.Data import Data.Ratio+import Data.Text (Text, pack) import Language.Fay.Convert import Test.Framework import Test.Framework.Providers.HUnit@@ -55,6 +56,7 @@ ,ReadTest $ StepcutBar (StepcutFoo 456) ,ReadTest $ StepcutFoo' 789 ,ReadTest $ Baz (StepcutFoo' 10112)+ ,ReadTest $ TextConstructor $ pack "This is \"some text\n\n\"" ] -- | Test cases.@@ -75,6 +77,7 @@ ,LabelledRecord { barInt = 123, barDouble = 4.5 } → "{\"barDouble\":4.5,\"barInt\":123,\"instance\":\"LabelledRecord\"}" ,Bar (Foo "one" "two") → "{\"slot1\":{\"slot1\":\"one\",\"slot2\":\"two\",\"instance\":\"Foo\"},\"instance\":\"Bar\"}"+ ,TextConstructor (pack "foo bar baz") → "{\"slot1\":\"foo bar baz\",\"instance\":\"TextConstructor\"}" -- Unicode ,"¡ ¢ £ ¤ ¥ " → "\"¡ ¢ £ ¤ ¥ \"" ,"Ā ā Ă ă Ą " → "\"Ā ā Ă ă Ą \""@@ -135,4 +138,7 @@ deriving (Eq, Show, Read, Typeable, Data) data Baz = Baz StepcutFoo'+ deriving (Eq, Show, Read, Typeable, Data)++data TextConstructor = TextConstructor Text deriving (Eq, Show, Read, Typeable, Data)
src/Test/Util.hs view
@@ -14,7 +14,7 @@ dist <- doesFileExist distPath if dist then return (Just distPath)- else either (const Nothing) (Just . concat . lines . snd) <$> readAllFromProcess' "which" ["fay"] ""+ else either (const Nothing) (Just . concat . lines . snd) <$> readAllFromProcess "which" ["fay"] "" where cabalDevPath = "./cabal-dev/bin/fay" distPath = "./dist/build/fay/fay"
src/Tests.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ViewPatterns #-}+ -- | Generate the web site/documentation for the Fay project. -- -- This depends on the Fay compiler to generate examples and the@@ -5,10 +7,13 @@ module Main where +import Control.Applicative import Data.Default import Data.List+import Data.Maybe import Language.Fay import System.Directory+import System.Environment import System.FilePath import System.Process.Extra import qualified Test.Api as Api@@ -21,22 +26,34 @@ -- | Main test runner. main :: IO () main = do- compiler <- makeCompilerTests- defaultMain [Api.tests, Cmd.tests, compiler, C.tests]+ sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+ (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs+ compiler <- makeCompilerTests (packageConf <|> sandbox)+ defaultMainWithArgs [Api.tests, Cmd.tests, compiler, C.tests]+ 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 :: IO Test-makeCompilerTests = do+makeCompilerTests :: Maybe FilePath -> IO Test+makeCompilerTests packageConf = do files <- fmap (map ("tests" </>) . sort . filter (isSuffixOf ".hs")) $ getDirectoryContents "tests" return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do- testFile False file- testFile True file+ testFile packageConf False file+ testFile packageConf True file -testFile :: Bool -> String -> IO ()-testFile opt file = do+testFile :: Maybe FilePath -> Bool -> String -> IO ()+testFile packageConf opt file = do let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file out = toJsName file- config = addConfigDirectoryInclude "tests/" $ def { configOptimize = opt, configTypecheck = False }+ config =+ addConfigDirectoryInclude "tests/" $+ def { configOptimize = opt+ , configTypecheck = False+ , configPackageConf = packageConf+ } outExists <- doesFileExist root compileFromTo config file (Just out) result <- runJavaScriptFile out@@ -47,4 +64,4 @@ -- | Run a JS file. runJavaScriptFile :: String -> IO (Either String String)-runJavaScriptFile file = readAllFromProcess "node" file+runJavaScriptFile file = fmap (fmap snd) (readAllFromProcess "node" [file] "")
+ tests/Api/ImportRecords.hs view
@@ -0,0 +1,3 @@+module Api.ImportRecords where++import Api.Records
+ tests/Api/Records.hs view
@@ -0,0 +1,4 @@+module Api.Records where++data R = R Int Int | S { x :: Int, y :: Int }+data T = Int :+ Int
tests/Bool.hs view
@@ -1,5 +1,4 @@-import Language.Fay.Prelude+import Prelude main :: Fay () main = print True-
tests/Double.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = print (2 * 4 / 2)
tests/Double2.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = print (10 + (2 * (4 / 2)))
tests/Double3.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = print (5 * 3 / 2)
tests/Double4.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = print 1
tests/Hierarchical/Export.hs view
@@ -3,7 +3,7 @@ module Hierarchical.Export where import Language.Fay.FFI-import Language.Fay.Prelude+import Prelude exported :: String exported = "exported"
tests/Hierarchical/RecordDefined.hs view
@@ -3,7 +3,7 @@ module Hierarchical.RecordDefined where import Language.Fay.FFI-import Language.Fay.Prelude+import Prelude data Callback a = Callback Double
tests/HierarchicalImport.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude import Hierarchical.Export main :: Fay ()
tests/List.hs view
@@ -1,5 +1,5 @@ import Language.Fay.FFI-import Language.Fay.Prelude+import Prelude main = putStrLn (showList (take 5 (let ns = 1 : map' (\x -> x + 1) ns in ns))) @@ -9,5 +9,5 @@ map' f [] = [] map' f (x:xs) = f x : map' f xs -showList :: [a] -> String+showList :: [Int] -> String showList = ffi "JSON.stringify(%1)"
tests/List2.hs view
@@ -1,5 +1,5 @@ import Language.Fay.FFI-import Language.Fay.Prelude+import Prelude main = putStrLn (showList (take 5 (let ns = 1 : map' (foo 123) ns in ns)))
tests/Monad.hs view
@@ -2,7 +2,7 @@ -- | Monads test. -import Language.Fay.Prelude+import Prelude main :: Fay () main = do
tests/Monad2.hs view
@@ -4,7 +4,7 @@ -- | Monads test. -import Language.Fay.Prelude+import Prelude main :: Fay () main = do
tests/RecCon.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude data Bool = True | False
tests/RecDecl.hs view
@@ -1,5 +1,5 @@ import Language.Fay.FFI-import Language.Fay.Prelude+import Prelude data R = R { i :: Double, c :: Char } instance Foreign R
tests/RecordImport_Export.hs view
@@ -2,7 +2,7 @@ module RecordImport_Export where -import Language.Fay.Prelude+import Prelude data R = R Integer data Fields = Fields { fieldFoo :: Integer, fieldBar :: Integer }
tests/RecordImport_Import.hs view
@@ -1,6 +1,6 @@ {- NOTE: This file is also used in the Api tests. -} -import Language.Fay.Prelude+import Prelude import RecordImport_Export f :: R -> R
tests/String.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn "Hello, World!"
tests/asPatternMatch.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude matchSame :: [a] -> ([a],[a]) matchSame x@y = (x,y)
tests/basicFunctions.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn (concat' ["Hello, ","World!"])
tests/case.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn (case True of True -> "Hello!"
tests/case2.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn (case False of True -> "Hello!"
tests/caseList.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn (case [1,2,3,4,5] of [1,2,3,4,6] -> "6!"
tests/caseWildcard.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn (case False of True -> "Hello!"
tests/do.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = do putStrLn "Hello,"; putStrLn "World!"
tests/doAssingPatternMatch.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = do [1,2] <- return [1,2]
tests/doBindAssign.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = do x <- return "Hello, World!" >>= return
tests/emptyMain.hs view
@@ -1,3 +1,3 @@-import Language.Fay.Prelude+import Prelude main = return ()
tests/fix.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = print (head (tail (fix (\xs -> 123 : xs))))
tests/fromInteger.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main :: Fay () main = putStrLn $ show $ fromInteger 5
tests/infixDataConst.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude data Ty1 = Integer `InfixConst1` Integer instance Foreign Ty1
tests/ints.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = do print 123
tests/mutableReference.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE EmptyDataDecls #-} import Language.Fay.FFI-import Language.Fay.Prelude+import Prelude main :: Fay () main = do
tests/patternGuards.hs view
@@ -2,7 +2,7 @@ -- | As pattern matches -import Language.Fay.Prelude+import Prelude import Language.Fay.FFI isPositive :: Double -> Bool@@ -25,6 +25,5 @@ putStrLn $ showList [threeConds 3, threeConds 1, threeConds 0] putStrLn $ showList [withOtherwise 2, withOtherwise 0] -showList :: [a] -> String+showList :: [Double] -> String showList = ffi "JSON.stringify(%1)"-
tests/patternMatchFail.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn ((\a 'a' -> "OK.") 0 'b')
tests/recordFunctionPatternMatch.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude data Person = Person String String Int
tests/recordPatternMatch.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude data Person = Person String String Int
tests/recordPatternMatch2.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude data Person = Person String String Int
tests/recordUseBeforeDefine.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude import Hierarchical.RecordDefined
tests/records.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude data Person1 = Person1 String String Int data Person2 = Person2 { fname :: String, sname :: String, age :: Int }
tests/reservedWords.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE EmptyDataDecls #-} -import Language.Fay.Prelude+import Prelude main = do -- All reserved words
tests/tailRecursion.hs view
@@ -1,5 +1,5 @@ -- | This is to test tail-recursive calls are iterative.-import Language.Fay.Prelude+import Prelude main = do print (sumTo 100000 0 :: Double)
tests/then.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn "Hello," >> putStrLn "World!"
tests/utf8.hs view
@@ -2,7 +2,7 @@ -- | Unicode test. -import Language.Fay.Prelude+import Prelude main :: Fay () main = do
tests/where.hs view
@@ -1,4 +1,4 @@-import Language.Fay.Prelude+import Prelude main = putStrLn $ "Hello " ++ friends ++ family where friends = "my friends"