Skip to content
Browse files

First commit.

  • Loading branch information...
0 parents commit d33ed99d599910bdb6c2983906cec9b136146fa6 @chrisdone chrisdone committed Jul 18, 2012
Showing with 1,804 additions and 0 deletions.
  1. +5 −0 .gitignore
  2. +30 −0 LICENSE
  3. +2 −0 Setup.hs
  4. +14 −0 examples/alert.hs
  5. +14 −0 examples/console.hs
  6. +26 −0 examples/dom.hs
  7. +38 −0 fay.cabal
  8. +13 −0 hs/stdlib.hs
  9. +342 −0 js/runtime.js
  10. +23 −0 src/Control/Monad/Extra.hs
  11. +6 −0 src/Control/Monad/IO.hs
  12. +620 −0 src/Language/Fay.hs
  13. +69 −0 src/Language/Fay/FFI.hs
  14. +52 −0 src/Language/Fay/Prelude.hs
  15. +172 −0 src/Language/Fay/Print.hs
  16. +112 −0 src/Language/Fay/Types.hs
  17. +60 −0 src/Main.hs
  18. 0 tests/1.hs
  19. +1 −0 tests/10
  20. +13 −0 tests/10.hs
  21. +1 −0 tests/11
  22. +11 −0 tests/11.hs
  23. +1 −0 tests/12
  24. +15 −0 tests/12.hs
  25. +1 −0 tests/13
  26. +7 −0 tests/13.hs
  27. +1 −0 tests/14
  28. +7 −0 tests/14.hs
  29. +1 −0 tests/15
  30. +7 −0 tests/15.hs
  31. +1 −0 tests/16
  32. +8 −0 tests/16.hs
  33. +1 −0 tests/17
  34. +9 −0 tests/17.hs
  35. +1 −0 tests/18
  36. +11 −0 tests/18.hs
  37. +1 −0 tests/19
  38. +12 −0 tests/19.hs
  39. 0 tests/2
  40. +1 −0 tests/2.hs
  41. +2 −0 tests/20
  42. +5 −0 tests/20.hs
  43. +2 −0 tests/21
  44. +5 −0 tests/21.hs
  45. +1 −0 tests/22
  46. +7 −0 tests/22.hs
  47. +1 −0 tests/23
  48. +7 −0 tests/23.hs
  49. +1 −0 tests/24
  50. +9 −0 tests/24.hs
  51. +5 −0 tests/25.hs
  52. +1 −0 tests/3
  53. +5 −0 tests/3.hs
  54. +1 −0 tests/4
  55. +3 −0 tests/4.hs
  56. +1 −0 tests/5
  57. +5 −0 tests/5.hs
  58. +1 −0 tests/6
  59. +5 −0 tests/6.hs
  60. +1 −0 tests/7
  61. +5 −0 tests/7.hs
  62. +1 −0 tests/8
  63. +9 −0 tests/8.hs
  64. +1 −0 tests/9
  65. +11 −0 tests/9.hs
5 .gitignore
@@ -0,0 +1,5 @@
+cabal-dev/
+dist/
+examples/*.js
+examples/*.html
+TAGS
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Chris Done
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Chris Done nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
14 examples/alert.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Main where
+
+import Language.Fay.FFI
+import Language.Fay.Prelude hiding (show)
+
+-- | Main entry point.
+main :: Fay ()
+main = alert "Hello, World!"
+
+-- | Alert using window.alert.
+alert :: Foreign a => a -> Fay ()
+alert = foreignFay "window.alert" ""
14 examples/console.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Main where
+
+import Language.Fay.FFI
+import Language.Fay.Prelude hiding (show)
+
+-- | Main entry point.
+main :: Fay ()
+main = print "Hello, World!"
+
+-- | Alert using console.log.
+print :: Foreign a => a -> Fay ()
+print = foreignFay "console.log" ""
26 examples/dom.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Main where
+
+import Language.Fay.FFI
+import Language.Fay.Prelude hiding (show)
+
+-- | Main entry point.
+main :: Fay ()
+main = do
+ result <- documentGetElements "body"
+ head <- documentGetElements "head"
+ case result of
+ (body:_) -> print body
+ [] -> return ()
+
+-- | Alert using window.alert.
+print :: Foreign a => a -> Fay ()
+print = foreignFay "console.log" ""
+
+data Element
+instance Foreign Element
+
+documentGetElements :: String -> Fay [Element]
+documentGetElements = foreignFay "document.getElementsByTagName" "array"
38 fay.cabal
@@ -0,0 +1,38 @@
+name: fay
+version: 0.1.0.0
+synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript.
+description: Fay is a strict subset of Haskell which can be compiled (type-checked) with GHC, and compiled to JavaScript.
+homepage: http://chrisdone.com/fay
+license: BSD3
+license-file: LICENSE
+author: Chris Done
+maintainer: chrisdone@gmail.com
+copyright: 2012 Chris Done
+category: Development
+build-type: Simple
+cabal-version: >=1.8
+data-files: js/runtime.js
+ hs/stdlib.hs
+extra-source-files: examples/alert.hs
+
+library
+ hs-source-dirs: src
+ exposed-modules: Language.Fay, Language.Fay.Types, Language.Fay.FFI, Language.Fay.Prelude
+ other-modules: Language.Fay.Print, Control.Monad.IO
+ ghc-options: -O2
+ build-depends: base >= 4 && < 5,
+ mtl,
+ language-javascript,
+ haskell-src-exts,
+ json
+executable fay
+ hs-source-dirs: src
+ ghc-options: -O2
+ main-is: Main.hs
+ build-depends: base >= 4 && < 5,
+ mtl,
+ language-javascript,
+ haskell-src-exts,
+ process,
+ directory,
+ json
13 hs/stdlib.hs
@@ -0,0 +1,13 @@
+data ArgType
+ = DateType
+ | FunctionType
+ | JsType
+ | StringType
+ | DoubleType
+ | ListType
+ | BoolType
+ | UnknownType
+
+data Maybe a
+ = Just a
+ | Nothing
342 js/runtime.js
@@ -0,0 +1,342 @@
+var True = true;
+var False = false;
+
+/*******************************************************************************
+* Thunks.
+*/
+
+// Force a thunk (if it is a thunk) until WHNF.
+var Fay$$force = function(thunkish,nocache){
+ while (thunkish instanceof Fay$$Thunk) {
+ thunkish = thunkish.force(nocache);
+ }
+ return thunkish;
+};
+
+var _ = Fay$$force;
+
+// Thunk object.
+function Fay$$Thunk(value){
+ this.forced = false;
+ this.value = value;
+};
+
+// Force the thunk.
+Fay$$Thunk.prototype.force = function(nocache){
+ return nocache
+ ? this.value()
+ : this.forced
+ ? this.value
+ : (this.forced = true, this.value = this.value());
+};
+
+/*******************************************************************************
+* Constructors.
+*/
+
+// A constructor.
+function Fay$$Constructor(){
+ this.name = arguments[0];
+ this.fields = Array.prototype.slice.call(arguments,1);
+}
+
+// Eval in the context of the Haskell bindings.
+function Fay$$eval(str){
+ return eval(str);
+}
+
+/*******************************************************************************
+* Monad.
+*/
+
+function Fay$$Monad(value){
+ this.value = value;
+}
+
+// >>
+var Fay$$then = function(a){
+ return function(b){
+ return new Fay$$Thunk(function(){
+ _(a,true);
+ return b;
+ });
+ };
+};
+
+// >>=
+var Fay$$bind = function(m){
+ return function(f){
+ return new Fay$$Thunk(function(){
+ var monad = _(m,true);
+ return f(monad.value);
+ });
+ };
+};
+
+var Fay$$unit = null;
+
+// return
+var Fay$$return = function(a){
+ return new Fay$$Monad(a);
+};
+
+/*******************************************************************************
+* FFI.
+*/
+
+// Serialize a Fay object to JS.
+function Fay$$serialize(type,obj){
+ type = _(type);
+ if(type) type = type[0].name;
+ if(type == "JsType"){
+ return function(){
+ return _(obj,true).value;
+ };
+ } else {
+ obj = _(obj);
+ if(type == "StringType" ||
+ (obj instanceof Fay$$Cons && typeof obj.car == 'string')){
+ var str = "";
+ while(obj instanceof Fay$$Cons) {
+ str += obj.car;
+ obj = _(obj.cdr);
+ }
+ return str;
+ } else if(type == "FunctionType" || typeof obj == 'function'){
+ return function(){
+ var out = obj;
+ for (var len = arguments.length, i = 0; i < len; i++){
+ if(typeof out != 'function') {
+ throw "Wrong number of arguments for callback: " + arguments.toString();
+ }
+ out = out(arguments[i]);
+ }
+ return _(out,true);
+ };
+ } else if(type == "ListType" || (obj instanceof Fay$$Cons)){
+ var arr = [];
+ while(obj instanceof Fay$$Cons) {
+ arr.push(Fay$$serialize(null,obj.car));
+ obj = _(obj.cdr);
+ }
+ return arr;
+ } // else if(type == "BoolType || obj == _(True) || obj == _(False)) {
+ // return obj == _(True);
+ // }
+ else {
+ return obj;
+ }
+ }
+}
+
+// Encode a value to a Show representation
+function Fay$$encodeShow(x){
+ if (x instanceof Fay$$Thunk) x = _(x);
+ if (x instanceof Array) {
+ if (x.length == 0) {
+ return "[]";
+ } else {
+ if (x[0] instanceof Fay$$Constructor) {
+ if(x[0].fields.length > 0) {
+ var args = x.slice(1);
+ var fieldNames = x[0].fields;
+ return "(" + x[0].name + " { " + args.map(function(x,i){
+ return fieldNames[i] + ' = ' + Fay$$encodeShow(x);
+ }).join(", ") + " })";
+ } else {
+ var args = x.slice(1);
+ return "(" + [x[0].name].concat(args.map(Fay$$encodeShow)).join(" ") + ")";
+ }
+ } else {
+ return "[" + x.map(Fay$$encodeShow).join(",") + "]";
+ }
+ }
+ } else if (typeof x == 'string') {
+ return JSON.stringify(x);
+ } else if(x instanceof Fay$$Cons) {
+ return Fay$$encodeShow(Fay$$serialize(ListType,x));
+ } else if(x == null) {
+ return '[]';
+ } else {
+ return x.toString();
+ }
+}
+
+// Unserialize an object from JS to Fay.
+function Fay$$unserialize(typ,obj){
+ if(typ == 'string' || typ == 'array')
+ return Fay$$list(obj);
+ else if(typ == 'bool')
+ return obj? True : False;
+ else if(typ == 'data') {
+ alert('Time to unserialize a data record!');
+ }
+ else return obj;
+}
+
+/*******************************************************************************
+* Lists.
+*/
+
+// Cons object.
+function Fay$$Cons(car,cdr){
+ this.car = car;
+ this.cdr = cdr;
+};
+
+// Make a list.
+function Fay$$list(xs){
+ var out = null;
+ for(var i=xs.length-1; i>=0;i--)
+ out = new Fay$$Cons(xs[i],out);
+ return out;
+};
+
+// Built-in list cons.
+var Fay$$cons = function(x){
+ return function(y){
+ return new Fay$$Cons(x,y);
+ };
+};
+
+// List index.
+function Fay$$index(index){
+ return function(list){
+ for(var i = 0; i < index; i++) {
+ list = Fay$$force(list).cdr;
+ }
+ return list.car;
+ };
+}
+
+/*******************************************************************************
+* Numbers.
+*/
+
+// Built-in ×.
+var Fay$$mult = function(x){
+ return function(y){
+ return _(x) * _(y);
+ };
+};
+
+// Built-in +.
+var Fay$$add = function(x){
+ return function(y){
+ return _(x) + _(y);
+ };
+};
+
+// Built-in -.
+var Fay$$sub = function(x){
+ return function(y){
+ return _(x) - _(y);
+ };
+};
+
+// Built-in /.
+var Fay$$div = function(x){
+ return function(y){
+ return _(x) / _(y);
+ };
+};
+
+/*******************************************************************************
+* Booleans.
+*/
+
+// Are two values equal?
+function Fay$$equal(lit1,lit2){
+ // Simple case
+ lit1 = _(lit1);
+ lit2 = _(lit2);
+ if(lit1 == lit2) {
+ return true;
+ }
+ // General case
+ if(lit1 instanceof Array) {
+ if(lit1.length!=lit2.length) return false;
+ for(var len = lit1.length, i = 0; i < len; i++) {
+ if(!Fay$$equal(lit1[i],lit2[i]))
+ return false;
+ }
+ return true;
+ } else if (lit1 instanceof Fay$$Cons) {
+ while(lit1 instanceof Fay$$Cons && lit2 instanceof Fay$$Cons && Fay$$equal(lit1.car,lit2.car))
+ lit1 = lit1.cdr, lit2 = lit2.cdr;
+ return (lit1 == null && lit2 == null);
+ } else return false;
+}
+
+// Built-in ==.
+var Fay$$eq = function(x){
+ return function(y){
+ return Fay$$equal(x,y);
+ };
+};
+
+// Built-in /=.
+var Fay$$neq = function(x){
+ return function(y){
+ return !(Fay$$equal(x,y));
+ };
+};
+
+// Built-in >.
+var Fay$$gt = function(x){
+ return function(y){
+ return _(x) > _(y);
+ };
+};
+
+// Built-in <.
+var Fay$$lt = function(x){
+ return function(y){
+ return _(x) < _(y);
+ };
+};
+
+// Built-in &&.
+var Fay$$and = function(x){
+ return function(y){
+ return _(x) && _(y);
+ };
+};
+
+// Built-in ||.
+var Fay$$or = function(x){
+ return function(y){
+ return _(x) || _(y);
+ };
+};
+
+/*******************************************************************************
+* Mutable references.
+*/
+
+// Make a new mutable reference.
+function Fay$$Ref(x){
+ this.value = x;
+}
+
+// Write to the ref.
+function Fay$$writeRef(ref,x){
+ ref.value = x;
+}
+
+// Get the value from the ref.
+function Fay$$readRef(ref,x){
+ return ref.value;
+}
+
+/*******************************************************************************
+* Dates.
+*/
+function Fay$$date(str){
+ return window.Date.parse(str);
+};
+
+/*******************************************************************************
+* Application code.
+*/
+
23 src/Control/Monad/Extra.hs
@@ -0,0 +1,23 @@
+module Control.Monad.Extra where
+
+import Data.Maybe
+
+ig :: (Monad m) => m a -> m ()
@chrisdone
Fay member
chrisdone added a note Jul 23, 2012

Yup, this utils module existed way before void made it into the stdlib.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+ig m = m >> return ()
+
+bind :: (Monad m) => (a -> m b) -> m a -> m b
@chrisdone
Fay member
chrisdone added a note Jul 23, 2012

The point of bind is that it isn't an operator, like so:

foo = fmap (map abc) $ do …

easily translates to

foo = bind (mapM abc_) $ do

which often happens in my code.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+bind = flip (>>=)
+
+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenJust (Just a) m = m a
+whenJust Nothing _ = return ()
+
+-- | Wrap up a form in a Maybe.
+just :: Functor m => m a -> m (Maybe a)
+just = fmap Just
+
+forMaybe :: [a] -> (a -> Maybe b) -> [b]
+forMaybe = flip mapMaybe
+
+maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a
+maybeM nil cons a = maybe (return nil) cons a
6 src/Control/Monad/IO.hs
@@ -0,0 +1,6 @@
+module Control.Monad.IO where
+
+import Control.Monad.Trans
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
620 src/Language/Fay.hs
@@ -0,0 +1,620 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS -fno-warn-orphans #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+
+-- | The Haskell→Javascript compiler.
+
+module Language.Fay where
+
+import Language.Fay.Print ()
+import Language.Fay.Types
+
+import Control.Applicative
+import Control.Monad.Error
+import Control.Monad.IO
+import Data.List
+import Data.String
+import Language.Haskell.Exts
+
+--------------------------------------------------------------------------------
+-- Top level entry points
+
+-- | Compile something that compiles to something else.
+compile :: CompilesTo from to => from -> IO (Either CompileError to)
+compile = runCompile . compileTo
+
+-- | Run the compiler.
+runCompile :: Compile a -> IO (Either CompileError a)
+runCompile m = runErrorT m
+
+-- | Compile a Haskell source string to a JavaScript source string.
+compileViaStr :: (Show from,Show to,CompilesTo from to)
+ => (from -> Compile to)
+ -> String
+ -> IO (Either CompileError String)
+compileViaStr with from =
+ runCompile (parseResult (throwError . uncurry ParseError)
+ (fmap printJS . with)
+ (parse from))
+
+compileFromStr with from =
+ parseResult (throwError . uncurry ParseError)
+ (with)
+ (parse from)
+
+--------------------------------------------------------------------------------
+-- Compilers
+
+-- | Compile Haskell module.
+compileModule :: Module -> Compile [JsStmt]
+compileModule (Module _ modulename pragmas Nothing exports imports decls) = do
+ imported <- fmap concat (mapM compileImport imports)
+ current <- compileDecls decls
+ return (imported ++ current)
+compileModule mod = throwError (UnsupportedModuleSyntax mod)
+
+instance CompilesTo Module [JsStmt] where compileTo = compileModule
+
+-- | Compile the given import.
+compileImport :: ImportDecl -> Compile [JsStmt]
+compileImport (ImportDecl _ (ModuleName name) _ _ _ _ _)
+ | isPrefixOf "Language.Fay." name || name == "Prelude" = return []
+compileImport (ImportDecl _ (ModuleName name) False _ Nothing Nothing Nothing) = do
+ contents <- io (readFile (replace '.' '/' name ++ ".hs"))
+ compileFromStr compileModule contents
+ where replace c r = map (\x -> if x == c then r else x)
+compileImport i =
+ error $ "Import syntax not supported. " ++
+ "The compiler writer was too lazy to support that.\n" ++
+ "It was: " ++ show i
+
+-- | Compile Haskell declaration.
+compileDecls :: [Decl] -> Compile [JsStmt]
+compileDecls decls = do
+ case decls of
+ [] -> return []
+ (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind (Just sig) bind)
+ (compileDecls decls)
+ (decl:decls) -> appendM (compileDecl decl)
+ (compileDecls decls)
+
+ where appendM m n = do x <- m
+ xs <- n
+ return (x ++ xs)
+
+compileDecl :: Decl -> Compile [JsStmt]
+compileDecl decl =
+ case decl of
+ pat@PatBind{} -> compilePatBind Nothing pat
+ FunBind matches -> compileFunCase matches
+ DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl decl constructors
+ -- Just ignore type aliases and signatures.
+ TypeDecl{} -> return []
+ TypeSig{} -> return []
+ InfixDecl{} -> return []
+ ClassDecl{} -> return []
+ InstDecl{} -> return [] -- FIXME: Ignore.
+ _ -> throwError (UnsupportedDeclaration decl)
+
+compilePatBind :: Maybe Type -> Decl -> ErrorT CompileError IO [JsStmt]
+compilePatBind sig pat =
+ case pat of
+ PatBind _ (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->
+ case ffiExp rhs of
+ Just detail@(binding,_,_) ->
+ case sig of
+ Nothing -> compileNormalPatBind ident rhs
+ Just sig -> case () of
+ () | func binding -> compileFFIFunc sig ident detail
+ | method binding -> compileFFIMethod sig ident detail
+ | otherwise -> throwError (FfiNeedsTypeSig pat)
+ _ -> compileNormalPatBind ident rhs
+ _ -> throwError (UnsupportedDeclaration pat)
+
+ where func = flip elem ["foreignFay","foreignPure"]
+ method = flip elem ["foreignMethodFay","foreignMethod"]
+ ffiExp (App (App (Var (UnQual (Ident ident)))
+ (Lit (String name)))
+ (Lit (String typ)))
+ = Just (ident,name,typ)
+ ffiExp _ = Nothing
+
+compileNormalPatBind :: Name -> Exp -> Compile [JsStmt]
+compileNormalPatBind ident rhs = do
+ body <- compileExp rhs
+ return [JsVar (UnQual ident) (thunk body)]
+
+compileFFIFunc :: Type -> Name -> (String,String,String) -> Compile [JsStmt]
+compileFFIFunc sig ident detail@(_,name,_) = do
+ let args = zipWith const uniqueNames [1..typeArity sig]
+ compileFFI sig ident detail (JsRawName name) args args
+
+compileFFIMethod :: Type -> Name -> (String,String,String) -> Compile [JsStmt]
+compileFFIMethod sig ident detail@(_,name,_) = do
+ let args = zipWith const uniqueNames [1..typeArity sig]
+ jsargs = drop 1 args
+ obj = head args
+ compileFFI sig ident detail (JsGetProp (force (JsName obj)) (fromString name)) args jsargs
+
+-- | Compile an FFI call.
+compileFFI :: Type
+ -> Name
+ -> (String,String,String)
+ -> JsExp
+ -> [JsName]
+ -> [JsName]
+ -> Compile [JsStmt]
+compileFFI sig ident (binding,_,typ) exp params args = do
+ return [JsVar (UnQual ident)
+ (foldr (\name inner -> JsFun [name] [] (Just inner))
+ (thunk
+ (maybeMonad
+ (unserialize typ
+ (JsApp exp
+ (map (\(typ,name) -> serialize typ (JsName name))
+ (zip types args))))))
+ params)]
+
+ where (maybeMonad,types) | binding == "foreignFay" = (monad,funcTypes)
+ | binding == "foreignMethodFay" = (monad,drop 1 funcTypes)
+ | binding == "foreignMethod" = (id,drop 1 funcTypes)
+ | otherwise = (id,funcTypes)
+ funcTypes = functionTypeArgs sig
+
+-- | These are the data types that are serializable directly to native
+-- JS data types. Strings, floating points and arrays. The others are:
+-- actiosn in the JS monad, which are thunks that shouldn't be forced
+-- when serialized but wrapped up as JS zero-arg functions, and
+-- unknown types can't be converted but should at least be forced.
+data ArgType = FunctionType | JsType | StringType | DoubleType | ListType | BoolType | UnknownType
+ deriving (Show,Eq)
+
+-- | Serialize a value to native JS, if possible.
+serialize :: ArgType -> JsExp -> JsExp
+serialize typ exp =
+ JsApp (JsName (hjIdent "serialize"))
+ [JsName (fromString (show typ)),exp]
+
+-- | Get arg types of a function type.
+functionTypeArgs :: Type -> [ArgType]
+functionTypeArgs t =
+ case t of
+ TyForall _ _ i -> functionTypeArgs i
+ TyFun a b -> argType a : functionTypeArgs b
+ TyParen st -> functionTypeArgs st
+ _ -> []
+
+ where argType t =
+ case t of
+ TyApp (TyCon "Fay") _ -> JsType
+ TyCon "String" -> StringType
+ TyCon "Double" -> DoubleType
+ TyCon "Bool" -> BoolType
+ TyFun{} -> FunctionType
+ TyList _ -> ListType
+ _ -> UnknownType
+
+-- | Get the arity of a type.
+typeArity :: Type -> Integer
+typeArity t =
+ case t of
+ TyForall _ _ i -> typeArity i
+ TyFun _ b -> 1 + typeArity b
+ TyParen st -> typeArity st
+ _ -> 0
+
+compileDataDecl :: Decl -> [QualConDecl] -> Compile [JsStmt]
+compileDataDecl decl constructors = do
+ fmap concat $
+ forM constructors $ \(QualConDecl _ _ _ condecl) ->
+ case condecl of
+ ConDecl (UnQual -> name) types -> fmap return (makeDataCons name types [])
+ RecDecl (UnQual -> name) fields -> do
+ cons <- makeDataCons name (map snd fields) (map fst fields)
+ funs <- makeAccessors (zip [1..] (map fst fields))
+ return (cons : funs)
+ _ -> throwError (UnsupportedDeclaration decl)
+
+ where makeDataCons name types fields = do
+ let slots = (map (fromString . ("slot"++) . show . fst)
+ (zip [1 :: Integer ..] types))
+ return $
+ JsVar name
+ (foldr (\slot inner -> JsFun [slot] [] (Just inner))
+ (thunk (JsList ((JsNew (hjIdent "Constructor")
+ (JsLit (JsStr (qname name)) :
+ concat (map (map (JsLit . JsStr . unname)) fields)))
+ : map JsName slots)))
+ slots)
+ makeAccessors fields = do
+ fmap concat $
+ forM fields $ \(i,field) ->
+ forM field $ \name ->
+ return (JsVar (UnQual name)
+ (JsFun ["x"]
+ []
+ (Just (thunk (JsIndex i (force (JsName "x")))))))
+
+qname (UnQual (Ident str)) = str
+qname _ = error "qname: Expected unqualified ident."
+
+unname (Ident str) = str
+
+-- | Compile a function which pattern matches (causing a case analysis).
+compileFunCase :: [Match] -> Compile [JsStmt]
+compileFunCase [] = return []
+compileFunCase matches@(Match _ name argslen _ _ _:_) = do
+ pats <- fmap optimizePatConditions $ forM matches $ \(Match _ _ pats _ rhs _) -> do
+ exp <- compileRhs rhs
+ foldM (\inner (arg,pat) -> do
+ compilePat (JsName arg) pat inner)
+ [JsEarlyReturn exp]
+ (zip args pats)
+ return [JsVar (UnQual name)
+ (foldr (\arg inner -> JsFun [arg] [] (Just inner))
+ (stmtsThunk (concat pats ++ basecase))
+ args)]
+ where args = zipWith const uniqueNames argslen
+ basecase = if any isWildCardMatch matches
+ then []
+ else [throw ("unhandled case in " ++ show name)
+ (JsList (map JsName args))]
+ isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats
+
+-- | Compile a right-hand-side expression.
+compileRhs :: Rhs -> Compile JsExp
+compileRhs (UnGuardedRhs exp) = compileExp exp
+compileRhs rhs = throwError (UnsupportedRhs rhs)
+
+-- | Compile a pattern match binding.
+compileFunMatch :: Match -> Compile [JsStmt]
+compileFunMatch match =
+ case match of
+ (Match _ name args Nothing (UnGuardedRhs rhs) _) -> do
+ body <- compileExp rhs
+ args <- mapM patToArg args
+ return [JsVar (UnQual name)
+ (foldr (\arg inner -> JsFun [arg] [] (Just inner))
+ (thunk body)
+ args)]
+ match -> throwError (UnsupportedMatchSyntax match)
+
+ where patToArg (PVar name) = return (UnQual name)
+ patToArg _ = throwError (UnsupportedMatchSyntax match)
+
+instance CompilesTo Decl [JsStmt] where compileTo = compileDecl
+
+-- | Compile Haskell expression.
+compileExp :: Exp -> Compile JsExp
+compileExp exp =
+ case exp of
+ Paren exp -> compileExp exp
+ Var (UnQual (Ident "return")) -> return (JsName (hjIdent "return"))
+ Var qname -> return (JsName qname)
+ Lit lit -> compileLit lit
+ App exp1 exp2 -> compileApp exp1 exp2
+ InfixApp exp1 op exp2 -> compileInfixApp exp1 op exp2
+ Let (BDecls decls) exp -> compileLet decls exp
+ List [] -> return JsNull
+ List xs -> compileList xs
+ Tuple xs -> compileList xs
+ If cond conseq alt -> compileIf cond conseq alt
+ Case exp alts -> compileCase exp alts
+ Con (UnQual (Ident "True")) -> return (JsName "true")
+ Con (UnQual (Ident "False")) -> return (JsName "false")
+ Con exp -> return (JsName exp)
+ Do stmts -> compileDoBlock stmts
+ Lambda _ pats exp -> compileLambda pats exp
+ EnumFrom i -> do e <- compileExp i
+ return (JsApp (JsName "enumFrom") [e])
+ EnumFromTo i i' -> do f <- compileExp i
+ t <- compileExp i'
+ return (JsApp (JsName "enumFromTo") [f,t])
+ ExpTypeSig _ e _ -> compileExp e
+
+ exp -> throwError (UnsupportedExpression exp)
+
+instance CompilesTo Exp JsExp where compileTo = compileExp
+
+compileApp :: Exp -> Exp -> Compile JsExp
+compileApp exp1 exp2 =
+ JsApp <$> (forceFlatName <$> compileExp exp1)
+ <*> fmap return (compileExp exp2)
+ where forceFlatName name = JsApp (JsName "_") [name]
+
+compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp
+compileInfixApp exp1 op exp2 = do
+ var <- resolveOpToVar op
+ compileExp (App (App var exp1) exp2)
+
+compileList :: [Exp] -> Compile JsExp
+compileList xs = do
+ exps <- mapM compileExp xs
+ return (JsApp (JsName (hjIdent "list")) [JsList exps])
+
+compileIf :: Exp -> Exp -> Exp -> Compile JsExp
+compileIf cond conseq alt =
+ JsTernaryIf <$> fmap force (compileExp cond)
+ <*> compileExp conseq
+ <*> compileExp alt
+
+compileLambda :: [Pat] -> Exp -> Compile JsExp
+compileLambda pats exp = do
+ exp <- compileExp exp
+ stmts <- foldM (\inner (param,pat) -> do
+ stmts <- compilePat (JsName param) pat inner
+ return [JsEarlyReturn (JsFun [param] (stmts ++ [unhandledcase param]) Nothing)])
+ [JsEarlyReturn exp]
+ (reverse (zip uniqueNames pats))
+ return (JsApp (JsFun [] (stmts) Nothing) [])
+
+ where unhandledcase = throw "unhandled case" . JsName
+
+compileCase :: Exp -> [Alt] -> Compile JsExp
+compileCase exp alts = do
+ exp <- compileExp exp
+ pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts
+ return $
+ (JsApp (JsFun [tmpName]
+ (concat pats)
+ (if any isWildCardAlt alts
+ then Nothing
+ else Just (throwExp "unhandled case" (JsName tmpName))))
+ [exp])
+
+compileDoBlock :: [Stmt] -> Compile JsExp
+compileDoBlock stmts = do
+ doblock <- foldM compileStmt Nothing (reverse stmts)
+ maybe (throwError EmptyDoBlock) compileExp doblock
+
+compileStmt :: Maybe Exp -> Stmt -> Compile (Maybe Exp)
+compileStmt inner stmt =
+ case inner of
+ Nothing -> initStmt
+ Just inner -> subsequentStmt inner
+
+ where initStmt =
+ case stmt of
+ Qualifier exp -> return (Just exp)
+ LetStmt{} -> throwError LetUnsupported
+ _ -> throwError InvalidDoBlock
+
+ subsequentStmt inner =
+ case stmt of
+ Generator loc pat exp -> compileGenerator loc pat inner exp
+ Qualifier exp -> return (Just (InfixApp exp
+ (QVarOp (UnQual (Symbol ">>")))
+ inner))
+ LetStmt{} -> throwError LetUnsupported
+ RecStmt{} -> throwError RecursiveDoUnsupported
+
+ compileGenerator srcloc pat inner exp = do
+ let body = (Lambda srcloc [pat] inner)
+ return (Just (InfixApp exp
+ (QVarOp (UnQual (Symbol ">>=")))
+ body))
+
+-- | Compile the given pattern against the given expression.
+compilePatAlt :: JsExp -> Alt -> Compile [JsStmt]
+compilePatAlt exp (Alt _ pat rhs _) = do
+ alt <- compileGuardedAlt rhs
+ compilePat exp pat [JsEarlyReturn alt]
+
+-- | Compile the given pattern against the given expression.
+compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
+compilePat exp pat body = do
+ case pat of
+ PVar name -> return ([JsVar (UnQual name) exp] ++ body)
+ PApp cons pats -> compilePApp cons pats exp body
+ PLit literal -> compilePLit exp literal body
+ PParen pat -> compilePat exp pat body
+ PWildCard -> return body
+ pat@PInfixApp{} -> compileInfixPat exp pat body
+ PList pats -> compilePList pats body exp
+ PTuple pats -> compilePList pats body exp
+ pat -> throwError (UnsupportedPattern pat)
+
+compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt]
+compilePLit exp literal body = do
+ lit <- compileLit literal
+ return [JsIf (JsApp (JsName (hjIdent "equal"))
+ [exp,lit])
+ body
+ []]
+
+compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
+compilePApp cons pats exp body = do
+ let forcedExp = force exp
+ substmts <- foldM (\body (i,pat) -> compilePat (JsIndex i forcedExp) pat body)
+ body
+ (reverse (zip [1..] pats))
+ return [JsIf (JsEq (JsGetProp (JsIndex 0 forcedExp) "name") (JsLit (JsStr (qname cons))))
+ substmts
+ []]
+
+compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
+compilePList [] body exp =
+ return [JsIf (JsEq (force exp) JsNull) body []]
+compilePList pats body exp = do
+ let forcedExp = force exp
+ substmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsApp (JsName (hjIdent "index"))
+ [JsLit (JsInt i)])
+ [forcedExp])
+ pat body)
+ body
+ (reverse (zip [0..] pats))
+ return substmts
+
+compileInfixPat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
+compileInfixPat exp pat@(PInfixApp left (Special cons) right) body =
+ case cons of
+ Cons -> do
+ let forcedExp = JsName tmpName
+ x = (JsGetProp forcedExp "car")
+ xs = (JsGetProp forcedExp "cdr")
+ rightMatch <- compilePat xs right body
+ leftMatch <- compilePat x left rightMatch
+ return [JsVar tmpName (force exp)
+ ,JsIf (JsInstanceOf forcedExp (hjIdent "Cons"))
+ leftMatch
+ []]
+ _ -> throwError (UnsupportedPattern pat)
+compileInfixPat _ pat _ = throwError (UnsupportedPattern pat)
+
+-- | Compile a guarded alt.
+compileGuardedAlt :: GuardedAlts -> Compile JsExp
+compileGuardedAlt alt =
+ case alt of
+ UnGuardedAlt exp -> compileExp exp
+ alt -> throwError (UnsupportedGuardedAlts alt)
+
+-- | Compile a let expression.
+compileLet :: [Decl] -> Exp -> Compile JsExp
+compileLet decls exp = do
+ body <- compileExp exp
+ binds <- mapM compileLetDecl decls
+ return (JsApp (JsFun [] (concat binds) (Just body)) [])
+
+-- | Compile let declaration.
+compileLetDecl :: Decl -> Compile [JsStmt]
+compileLetDecl decl =
+ case decl of
+ decl@PatBind{} -> compileDecls [decl]
+ decl@FunBind{} -> compileDecls [decl]
+ _ -> throwError (UnsupportedLetBinding decl)
+
+-- | Compile Haskell literal.
+compileLit :: Literal -> Compile JsExp
+compileLit lit =
+ case lit of
+ Char ch -> return (JsLit (JsChar ch))
+ Int integer -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME:
+ Frac rational -> return (JsLit (JsFloating (fromRational rational)))
+ -- TODO: Use real JS strings instead of array, probably it will
+ -- lead to the same result.
+ String string -> return (JsApp (JsName (hjIdent "list"))
+ [JsLit (JsStr string)])
+ lit -> throwError (UnsupportedLiteral lit)
+
+--------------------------------------------------------------------------------
+-- Compilation utilities
+
+-- | Generate unique names.
+uniqueNames :: [JsParam]
+uniqueNames = map (fromString . ("$_" ++))
+ $ map return "abcxyz" ++
+ zipWith (:) (cycle "v")
+ (map show [1 :: Integer ..])
+
+thenm :: JsExp -> JsExp -> JsExp
+thenm e inner =
+ JsApp (JsApp (JsName (hjIdent "then"))
+ [e])
+ [inner]
+
+-- | Optimize pattern matching conditions by merging conditions in common.
+optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]
+optimizePatConditions = concat . map merge . groupBy sameIf where
+ sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2
+ sameIf _ _ = False
+ merge xs@([JsIf cond _ _]:_) =
+ [[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]]
+ merge noifs = noifs
+ getIfConsequent [JsIf _ cons _] = cons
+ getIfConsequent other = other
+
+-- | Throw a JS exception.
+throw :: String -> JsExp -> JsStmt
+throw msg exp = JsThrow (JsList [JsLit (JsStr msg),exp])
+
+-- | Throw a JS exception (in an expression).
+throwExp :: String -> JsExp -> JsExp
+throwExp msg exp = JsThrowExp (JsList [JsLit (JsStr msg),exp])
+
+-- | Is an alt a wildcard?
+isWildCardAlt :: Alt -> Bool
+isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat
+
+-- | Is a pattern a wildcard?
+isWildCardPat :: Pat -> Bool
+isWildCardPat PWildCard{} = True
+isWildCardPat PVar{} = True
+isWildCardPat _ = False
+
+-- | A temporary name for testing conditions and such.
+tmpName :: JsName
+tmpName = ":tmp"
+
+-- | Wrap an expression in a thunk.
+thunk :: JsExp -> JsExp
+thunk exp = JsNew (hjIdent "Thunk") [JsFun [] [] (Just exp)]
+
+-- | Wrap an expression in a thunk.
+monad :: JsExp -> JsExp
+monad exp = JsNew (hjIdent "Monad") [exp]
+
+-- | Wrap an expression in a thunk.
+stmtsThunk :: [JsStmt] -> JsExp
+stmtsThunk stmts = JsNew (hjIdent "Thunk") [JsFun [] stmts Nothing]
+
+unserialize :: String -> JsExp -> JsExp
+unserialize typ exp =
+ JsApp (JsName (hjIdent "unserialize")) [JsLit (JsStr typ),exp]
+
+-- | Force an expression in a thunk.
+force :: JsExp -> JsExp
+force exp =
+ JsApp (JsName "_") [exp]
+
+-- | Force an expression in a thunk.
+monadValue :: JsExp -> JsExp
+monadValue exp =
+ JsGetProp (forceNoMemoize exp) "value"
+
+-- | Force an expression in a thunk.
+forceNoMemoize :: JsExp -> JsExp
+forceNoMemoize exp =
+ JsApp (JsName (hjIdent "force")) [exp,JsLit (JsBool True)]
+
+-- | Resolve operators to only built-in (for now) functions.
+resolveOpToVar :: QOp -> Compile Exp
+resolveOpToVar op =
+ case getOp op of
+ UnQual (Symbol symbol)
+ | symbol == "*" -> return (Var (hjIdent "mult"))
+ | symbol == "+" -> return (Var (hjIdent "add"))
+ | symbol == "-" -> return (Var (hjIdent "sub"))
+ | symbol == "/" -> return (Var (hjIdent "div"))
+ | symbol == "==" -> return (Var (hjIdent "eq"))
+ | symbol == "/=" -> return (Var (hjIdent "neq"))
+ | symbol == ">" -> return (Var (hjIdent "gt"))
+ | symbol == "<" -> return (Var (hjIdent "lt"))
+ | symbol == "&&" -> return (Var (hjIdent "and"))
+ | symbol == "||" -> return (Var (hjIdent "or"))
+ | symbol == ">>=" -> return (Var (hjIdent "bind"))
+ | symbol == ">>" -> return (Var (hjIdent "then"))
+ | otherwise -> return (Var (fromString symbol))
+ Special Cons -> return (Var (hjIdent "cons"))
+ _ -> throwError (UnsupportedOperator op)
+
+ where getOp (QVarOp op) = op
+ getOp (QConOp op) = op
+
+-- | Make an identifier from the built-in HJ module.
+hjIdent :: String -> QName
+hjIdent = Qual (ModuleName "Fay") . Ident
+
+--------------------------------------------------------------------------------
+-- Utilities
+
+-- | Parse result.
+parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b
+parseResult fail ok result =
+ case result of
+ ParseOk a -> ok a
+ ParseFailed srcloc msg -> fail (srcloc,msg)
69 src/Language/Fay/FFI.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Fay.FFI where
+
+import Language.Fay.Types (Fay)
+import Prelude (Bool,String,Double,Char,error)
+
+data JsPtr a
+
+-- | Contains allowed foreign function types.
+class Foreign a
+
+-- | Unit is OK.
+instance Foreign ()
+
+-- | All numbers in JS are double.
+instance Foreign Double
+
+-- | Characters are OK.
+instance Foreign Char
+
+-- | Bools are OK.
+instance Foreign Bool
+
+-- | Listsarrays are OK.
+instance Foreign a => Foreign [a]
+
+-- | Pointers to arbitrary objects are OK.
+instance Foreign (JsPtr a)
+
+-- | JS values are foreignable.
+instance Foreign a => Foreign (Fay a)
+
+-- | Functions are foreignable.
+instance (Foreign a,Foreign b) => Foreign (a -> b)
+
+-- | Declare a foreign action.
+foreignFay
+ :: Foreign a
+ => String -- ^ The foreign function name.
+ -> String -- ^ JS return type.
+ -> a -- ^ Bottom.
+foreignFay = error "Language.Fay.FFI.foreignFay: Used foreign function not in a JS engine context."
+
+-- | Declare a foreign function.
+foreignPure
+ :: Foreign a
+ => String -- ^ The foreign function name.
+ -> String -- ^ JS return type.
+ -> a -- ^ Bottom.
+foreignPure = error "Language.Fay.FFI.foreign: Used foreign function not in a JS engine context."
+
+-- | Declare a foreign action.
+foreignMethodFay
+ :: Foreign a
+ => String -- ^ The foreign function name.
+ -> String -- ^ JS return type.
+ -> a -- ^ Bottom.
+foreignMethodFay = error "Language.Fay.FFI.foreignMethodFay: Used foreign function not in a JS engine context."
+
+-- | Declare a foreign function.
+foreignMethod
+ :: Foreign a
+ => String -- ^ The foreign function name.
+ -> String -- ^ JS return type.
+ -> a -- ^ Bottom.
+foreignMethod = error "Language.Fay.FFI.foreignMethod: Used foreign function not in a JS engine context."
52 src/Language/Fay/Prelude.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Language.Fay.Prelude
+ (Fay
+ ,Char
+ ,String
+ ,Integer
+ ,Double
+ ,Bool(..)
+ ,Show(show)
+ ,Read,read
+ ,fromInteger
+ ,fromRational
+ ,(>>)
+ ,(>>=)
+ ,(==)
+ ,(/=)
+ ,(+)
+ ,(*)
+ ,(-)
+ ,(>)
+ ,(<)
+ ,(||)
+ ,(&&)
+ ,fail
+ ,return)
+ where
+
+import Language.Fay.Types (Fay)
+
+import Prelude hiding ((>>),(>>=),fromInteger,fromRational,fail,return)
+import GHC.Real (Ratio)
+
+-- | Just to satisfy GHC.
+fromInteger :: Integer -> Double
+fromInteger = error "Language.Fay.Prelude.fromInteger: Used fromInteger outside JS."
+
+-- | Just to satisfy GHC.
+fromRational :: Ratio Integer -> Double
+fromRational = error "Language.Fay.Prelude.fromRational Used fromRational outside JS."
+
+(>>) :: Fay a -> Fay b -> Fay b
+(>>) = error "Language.Fay.Prelude.(>>): Used (>>) outside JS."
+
+(>>=) :: Fay a -> (a -> Fay b) -> Fay b
+(>>=) = error "Language.Fay.Prelude.(>>=): Used (>>=) outside JS."
+
+fail :: String -> Fay a
+fail = error "Language.Fay.Prelude.fail: Used fail outside JS."
+
+return :: a -> Fay a
+return = error "Language.Fay.Prelude.return: Used return outside JS."
172 src/Language/Fay/Print.hs
@@ -0,0 +1,172 @@
+{-# OPTIONS -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Simple code (non-pretty) printing.
+--
+-- No clever printing is done here. If you want pretty printing, use a
+-- JS pretty printer. The output should be passed directly to a JS
+-- compressor, anyway.
+--
+-- Special constructors and symbols in Haskell are encoded to
+-- JavaScript appropriately.
+
+module Language.Fay.Print where
+
+import Language.Fay.Types
+
+import Data.List
+import Data.String
+import Language.Haskell.Exts.Syntax
+import Prelude hiding (exp)
+import Text.JSON
+
+--------------------------------------------------------------------------------
+-- Printing
+
+-- | Print literals. These need some special encoding for
+-- JS-format literals. Could use the Text.JSON library.
+instance Printable JsLit where
+ printJS (JsChar char) = encode [char] -- FIXME:
+ printJS (JsStr str) = encode str -- FIXME:
+ printJS (JsInt int) = show int -- FIXME:
+ printJS (JsFloating rat) = show rat -- FIXME:
+ printJS (JsBool b) = if b then "true" else "false"
+
+-- | Print (and properly encode to JS) a qualified name.
+instance Printable QName where
+ printJS qname =
+ case qname of
+ Qual moduleName name -> printJS moduleName ++ "$$" ++ printJS name
+ UnQual name -> printJS name
+ Special con -> printJS con
+
+-- | Print special constructors (tuples, list, etc.)
+instance Printable SpecialCon where
+ printJS specialCon =
+ case specialCon of
+ UnitCon -> printJS (Qual "Fay" (Ident "unit"))
+ ListCon -> printJS (Qual "Fay" (Ident "emptyList"))
+ FunCon -> printJS (Qual "Fay" (Ident "funCon"))
+ TupleCon boxed n -> printJS (Qual "Fay"
+ (Ident (if boxed == Boxed
+ then "boxed"
+ else "unboxed" ++
+ "TupleOf" ++ show n)))
+ Cons -> printJS (Qual "Fay" (Ident "cons"))
+ UnboxedSingleCon -> printJS (Qual "Fay" (Ident "unboxedSingleCon"))
+
+-- | Print module name.
+instance Printable ModuleName where
+ printJS (ModuleName moduleName) =
+ jsEncodeName moduleName
+
+-- | Print (and properly encode) a name.
+instance Printable Name where
+ printJS name =
+ case name of
+ Ident ident -> jsEncodeName ident
+ Symbol sym -> jsEncodeName sym
+
+-- | Print a list of statements.
+instance Printable [JsStmt] where
+ printJS = concat . map (printJS)
+
+-- | Print a single statement.
+instance Printable JsStmt where
+ printJS (JsVar name expr) =
+ (unwords ["var",printJS name,"=",printJS expr ++ ";"])
+ printJS (JsIf exp thens elses) =
+ concat
+ [("if (" ++ printJS exp ++ ") {")
+ ,printJS thens] ++
+ if (length elses > 0)
+ then concat ["} else {"
+ ,printJS elses ++ "}"]
+ else "}"
+ printJS (JsEarlyReturn exp) =
+ ("return (" ++ printJS exp ++ ");")
+ printJS (JsThrow exp) =
+ ("throw (" ++ printJS exp ++ ");")
+
+-- | Print an expression.
+instance Printable JsExp where
+ printJS (JsRawName name) = name
+ printJS (JsThrowExp exp) =
+ "(function(){ throw (" ++ printJS exp ++ "); })()"
+ printJS (JsFun params stmts ret) =
+ concat ["function("
+ ,intercalate "," (map (printJS) params)
+ ,"){"
+ ,printJS stmts
+ ] ++
+ case ret of
+ Just ret' ->
+ concat ["return "
+ ,printJS ret'
+ ,";"
+ ,"}"]
+ Nothing -> "}"
+ printJS JsNull = "null"
+ printJS (JsSequence exprs) =
+ intercalate "," (map (printJS) exprs)
+ printJS (JsName name) = printJS name
+ printJS (JsApp op args) =
+ printJS (if isFunc op then JsParen op else op) ++
+ "(" ++
+ intercalate "," (map (printJS) args) ++
+ ")"
+ where isFunc JsFun{..} = True; isFunc _ = False
+ printJS (JsLit lit) = printJS lit
+ printJS (JsParen exp) = "(" ++ printJS exp ++ ")"
+ printJS (JsTernaryIf cond conseq alt) =
+ concat [printJS cond ++ " ? "
+ , (printJS conseq) ++ " : "
+ , (printJS alt)]
+ printJS (JsList exps) =
+ "[" ++
+ intercalate "," (map (printJS) exps) ++
+ "]"
+ printJS (JsNew name args) =
+ "new " ++ printJS (JsApp (JsName name) args)
+ printJS (JsInstanceOf exp classname) =
+ printJS exp ++ " instanceof " ++ printJS classname
+ printJS (JsIndex i exp) =
+ "(" ++ printJS exp ++ ")[" ++ show i ++ "]"
+ printJS (JsEq exp1 exp2) =
+ "(" ++ printJS exp1 ++ " == " ++ printJS exp2 ++ ")"
+ printJS (JsGetProp exp prop) =
+ printJS exp ++ "." ++ printJS prop
+
+--------------------------------------------------------------------------------
+-- Utilities
+
+-- | Encode a Haskell name to JavaScript.
+jsEncodeName :: String -> String
+-- Special symbols:
+jsEncodeName ":tmp" = "$tmp"
+-- Used keywords:
+jsEncodeName "null" = "_null"
+-- Anything else.
+jsEncodeName name =
+ if isPrefixOf "$_" name
+ then name
+ else concat . map encode $ name
+
+ where
+ encode c | elem c allowed = [c]
+ | otherwise = escapeChar c
+ allowed = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
+ escapeChar c = "$" ++ charId c ++ "$"
+ charId c = show (fromEnum c)
+
+-- | Helpful for writing qualified symbols (Fay.*).
+instance IsString ModuleName where
+ fromString = ModuleName
+
+-- | Helpful for writing variable names.
+instance IsString JsName where
+ fromString = UnQual . Ident
112 src/Language/Fay/Types.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | All Fay types and instances.
+
+module Language.Fay.Types
+ (JsStmt(..)
+ ,JsExp(..)
+ ,JsLit(..)
+ ,JsParam
+ ,JsName
+ ,CompileError(..)
+ ,Compile
+ ,CompilesTo(..)
+ ,Printable(..)
+ ,Fay)
+ where
+
+import Control.Exception
+import Control.Monad.Error (Error,ErrorT)
+import Control.Monad.Identity (Identity)
+import Data.Data
+import Language.Haskell.Exts
+
+--------------------------------------------------------------------------------
+-- Compiler types
+
+-- | Convenience/doc type.
+type Compile = ErrorT CompileError IO
+
+-- | Convenience type for function parameters.
+type JsParam = JsName
+
+-- | To be used to force name sanitization eventually.
+type JsName = QName -- FIXME: Force sanitization at this point.
+
+-- | Just a convenience class to generalize the parsing/printing of
+-- various types of syntax.
+class (Parseable from,Printable to) => CompilesTo from to | from -> to where
+ compileTo :: from -> Compile to
+
+-- | Print some value.
+class Printable a where
+ printJS :: a -> String
+
+-- | Error type.
+data CompileError
+ = ParseError SrcLoc String
+ | UnsupportedDeclaration Decl
+ | UnsupportedMatchSyntax Match
+ | UnsupportedExpression Exp
+ | UnsupportedLiteral Literal
+ | UnsupportedLetBinding Decl
+ | UnsupportedOperator QOp
+ | UnsupportedPattern Pat
+ | UnsupportedRhs Rhs
+ | UnsupportedGuardedAlts GuardedAlts
+ | EmptyDoBlock
+ | UnsupportedModuleSyntax Module
+ | LetUnsupported
+ | InvalidDoBlock
+ | RecursiveDoUnsupported
+ | FfiNeedsTypeSig Decl
+ deriving (Show,Eq,Data,Typeable)
+instance Error CompileError
+instance Exception CompileError
+
+-- | The JavaScript FFI interfacing monad.
+newtype Fay a = Fay (Identity a)
+ deriving Monad
+
+--------------------------------------------------------------------------------
+-- JS AST types
+
+-- | Statement type.
+data JsStmt
+ = JsVar JsName JsExp
+ | JsIf JsExp [JsStmt] [JsStmt]
+ | JsEarlyReturn JsExp
+ | JsThrow JsExp
+ deriving (Show,Eq)
+
+-- | Expression type.
+data JsExp
+ = JsName JsName
+ | JsRawName String
+ | JsFun [JsParam] [JsStmt] (Maybe JsExp)
+ | JsLit JsLit
+ | JsApp JsExp [JsExp]
+ | JsTernaryIf JsExp JsExp JsExp
+ | JsNull
+ | JsSequence [JsExp]
+ | JsParen JsExp
+ | JsGetProp JsExp JsName
+ | JsList [JsExp]
+ | JsNew JsName [JsExp]
+ | JsThrowExp JsExp
+ | JsInstanceOf JsExp JsName
+ | JsIndex Int JsExp
+ | JsEq JsExp JsExp
+ deriving (Show,Eq)
+
+-- | Literal value type.
+data JsLit
+ = JsChar Char
+ | JsStr String
+ | JsInt Int
+ | JsFloating Double
+ | JsBool Bool
+ deriving (Show,Eq)
60 src/Main.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Main compiler executable.
+
+module Main where
+
+import Language.Fay hiding (throw)
+import Paths_fay
+
+import Control.Exception (throw)
+import Control.Monad
+import Data.List
+import System.Environment
+
+-- | Main entry point.
+main :: IO ()
+main = do
+ args <- getArgs
+ let files = filter (not . isPrefixOf "-") args
+ opts = map (drop 1) $ filter (isPrefixOf "-") args
+ forM_ files $ \file -> do
+ compileFromTo (elem "autorun" opts) file (toJsName file)
+
+ where toJsName x = case reverse x of
+ ('s':'h':'.': (reverse -> file)) -> file ++ ".js"
+ _ -> x
+
+-- | Compile file program to…
+compileFromTo autorun filein fileout = do
+ runtime <- getDataFileName "js/runtime.js"
+ stdlibpath <- getDataFileName "hs/stdlib.hs"
+ raw <- readFile runtime
+ stdlib <- readFile stdlibpath
+ hscode <- readFile filein
+ result <- compileProgram autorun raw compileModule (hscode ++ stdlib)
+ case result of
+ Right out -> writeFile fileout out
+ Left err -> throw err
+
+-- | Compile the given module to a runnable program.
+compileProgram autorun raw with hscode = do
+ result <- compileViaStr with hscode
+ case result of
+ Left err -> return (Left err)
+ Right jscode -> return (Right (unlines ["var Fay = function(){"
+ ,raw
+ ,jscode
+ ,"return {"
+ ," force:_,"
+ ," thunk:Fay$$Thunk,"
+ ," list:Fay$$list,"
+ ," encodeShow:Fay$$encodeShow,"
+ ," main:main,"
+ ," eval:Fay$$eval"
+ ," };"
+ ,"};"
+ ,if autorun
+ then ";\nvar fay = new Fay();fay.force(fay.main);"
+ else ""
+ ]))
0 tests/1.hs
No changes.
1 tests/10
@@ -0,0 +1 @@
+Hello, World!
13 tests/10.hs
@@ -0,0 +1,13 @@
+data Bool = True | False
+
+main = print (concat ["Hello, ","World!"])
+
+print = foreignJS 1 "console.log" ""
+
+concat = foldr append []
+
+foldr f z [] = z
+foldr f z (x:xs) = f x (foldr f z xs)
+
+append (x:xs) ys = x : append xs ys
+append [] ys = ys
1 tests/11
@@ -0,0 +1 @@
+[ 1, 2, 3, 4, 5 ]
11 tests/11.hs
@@ -0,0 +1,11 @@
+data Bool = True | False
+
+main = print (take 5 (let ns = 1 : map (\x -> x + 1) ns in ns))
+
+print = foreignJS 1 "console.log" ""
+
+take 0 _ = []
+take n (x:xs) = x : take (n - 1) xs
+
+map f [] = []
+map f (x:xs) = f x : map f xs
1 tests/12
@@ -0,0 +1 @@
+[1,{"forced":true,"value":61.5},{"forced":true,"value":3782.25},{"forced":true,"value":232608.375},{"forced":true,"value":14305415.0625}]
15 tests/12.hs
@@ -0,0 +1,15 @@
+data Bool = True | False
+
+main = print (show (take 5 (let ns = 1 : map (foo 123) ns in ns)))
+
+print = foreignJS 1 "console.log" ""
+
+show = foreignPure 1 "JSON.stringify" ""
+
+foo x y = x * y / 2
+
+take 0 _ = []
+take n (x:xs) = x : take (n - 1) xs
+
+map f [] = []
+map f (x:xs) = f x : map f xs
1 tests/13
@@ -0,0 +1 @@
+Hello!
7 tests/13.hs
@@ -0,0 +1,7 @@
+data Bool = True | False
+
+main = print (case True of
+ True -> "Hello!"
+ False -> "Ney!")
+
+print = foreignJS 1 "console.log" ""
1 tests/14
@@ -0,0 +1 @@
+Ney!
7 tests/14.hs
@@ -0,0 +1,7 @@
+data Bool = True | False
+
+main = print (case False of
+ True -> "Hello!"
+ False -> "Ney!")
+
+print = foreignJS 1 "console.log" ""
1 tests/15
@@ -0,0 +1 @@
+Ney!
7 tests/15.hs
@@ -0,0 +1,7 @@
+data Bool = True | False
+
+main = print (case False of
+ True -> "Hello!"
+ _ -> "Ney!")
+
+print = foreignJS 1 "console.log" ""
1 tests/16
@@ -0,0 +1 @@
+Hello!
8 tests/16.hs
@@ -0,0 +1,8 @@
+data Bool = True | False
+
+data Person = Person String String Int
+
+main = print (case Person "Chris" "Done" 13 of
+ Person "Chris" "Done" 13 -> "Hello!")
+
+print = foreignJS 1 "console.log" ""
1 tests/17
@@ -0,0 +1 @@
+World!
9 tests/17.hs
@@ -0,0 +1,9 @@
+data Bool = True | False
+
+data Person = Person String String Int
+
+main = print (case Person "Chris" "Done" 14 of
+ Person "Chris" "Done" 13 -> "Hello!"
+ _ -> "World!")
+
+print = foreignJS 1 "console.log" ""
1 tests/18
@@ -0,0 +1 @@
+Hello!
11 tests/18.hs
@@ -0,0 +1,11 @@
+data Bool = True | False
+
+data Person = Person String String Int
+
+main = print (case Person "Chris" "Done" 14 of
+ Person "Chris" "Done" 13 -> "Foo!"
+ Person "Chris" "Barf" 14 -> "Bar!"
+ Person "Chris" "Done" 14 -> "Hello!"
+ _ -> "World!")
+
+print = foreignJS 1 "console.log" ""
1 tests/19
@@ -0,0 +1 @@
+Hello!
12 tests/19.hs
@@ -0,0 +1,12 @@
+data Bool = True | False
+
+data Person = Person String String Int
+
+main = print (foo (Person "Chris" "Done" 14))
+
+foo (Person "Chris" "Done" 13) = "Foo!"
+foo (Person "Chris" "Barf" 14) = "Bar!"
+foo (Person "Chris" "Done" 14) = "Hello!"
+foo _ = "World!"
+
+print = foreignJS 1 "console.log" ""
0 tests/2
No changes.
1 tests/2.hs
@@ -0,0 +1 @@
+main = return ()
2 tests/20
@@ -0,0 +1,2 @@
+Hello,
+World!
5 tests/20.hs
@@ -0,0 +1,5 @@
+data Bool = True | False
+
+main = print "Hello," >> print "World!"
+
+print = foreignJS 1 "console.log" ""
2 tests/21
@@ -0,0 +1,2 @@
+Hello,
+World!
5 tests/21.hs
@@ -0,0 +1,5 @@
+data Bool = True | False
+
+main = do print "Hello,"; print "World!"
+
+print = foreignJS 1 "console.log" ""
1 tests/22
@@ -0,0 +1 @@
+Hello, World!
7 tests/22.hs
@@ -0,0 +1,7 @@
+data Bool = True | False
+
+main = do
+ x <- return "Hello, World!" >>= return
+ print x
+
+print = foreignJS 1 "console.log" ""
1 tests/23
@@ -0,0 +1 @@
+OK.
7 tests/23.hs
@@ -0,0 +1,7 @@
+data Bool = True | False
+
+main = do
+ [1,2] <- return [1,2]
+ print "OK."
+
+print = foreignJS 1 "console.log" ""
1 tests/24
@@ -0,0 +1 @@
+OK.
9 tests/24.hs
@@ -0,0 +1,9 @@
+data Bool = True | False
+
+main = print (case [1,2,3,4,5] of
+ [1,2,3,4,6] -> "6!"
+ [1,2,4,2,4] -> "a!"
+ [1,2,3,4,5] -> "OK."
+ _ -> "Broken.")
+
+print = foreignJS 1 "console.log" ""
5 tests/25.hs
@@ -0,0 +1,5 @@
+data Bool = True | False
+
+main = print ((\a 'a' -> "OK.") 0 'b')
+
+print = foreignJS 1 "console.log" ""
1 tests/3
@@ -0,0 +1 @@
+1
5 tests/3.hs
@@ -0,0 +1,5 @@
+data Bool = True | False
+
+main = print 1
+
+print = foreignJS 1 "console.log" ""
1 tests/4
@@ -0,0 +1 @@
+Hello, World!
3 tests/4.hs
@@ -0,0 +1,3 @@
+main = print "Hello, World!"
+
+print = foreignJS 1 "console.log" ""
1 tests/5
@@ -0,0 +1 @@
+4
5 tests/5.hs
@@ -0,0 +1,5 @@
+data Bool = True | False
+
+main = print (2 * 4 / 2)
+
+print = foreignJS 1 "console.log" ""
1 tests/6
@@ -0,0 +1 @@
+14
5 tests/6.hs
@@ -0,0 +1,5 @@
+data Bool = True | False
+
+main = print (10 + (2 * (4 / 2)))
+
+print = foreignJS 1 "console.log" ""
1 tests/7
@@ -0,0 +1 @@
+true
5 tests/7.hs
@@ -0,0 +1,5 @@
+data Bool = True | False
+
+main = print True
+
+print = foreignJS 1 "console.log" ""
1 tests/8
@@ -0,0 +1 @@
+123
9 tests/8.hs
@@ -0,0 +1,9 @@
+data Bool = True | False
+
+main = print (head (fix (\xs -> 123 : xs)))
+
+print = foreignJS 1 "console.log" ""
+
+head (x:xs) = x
+
+fix f = let x = f x in x
1 tests/9
@@ -0,0 +1 @@
+123
11 tests/9.hs
@@ -0,0 +1,11 @@
+data Bool = True | False
+
+main = print (head (tail (fix (\xs -> 123 : xs))))
+
+print = foreignJS 1 "console.log" ""
+
+head (x:xs) = x
+
+fix f = let x = f x in x
+
+tail (_:xs) = xs

0 comments on commit d33ed99

Please sign in to comment.
Something went wrong with that request. Please try again.