fay 0.22.0.0 → 0.23.0.0

raw patch · 34 files changed

+571/−406 lines, 34 filesdep +mtl-compatdep +transformers-compatdep ~basedep ~timedep ~utf8-stringPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl-compat, transformers-compat

Dependency ranges changed: base, time, utf8-string

API changes (from Hackage documentation)

Files

• CHANGELOG.md +32/−0
• fay.cabal +7/−4
• js/runtime.js +8/−5
• src/Fay.hs +14/−15
• src/Fay/Compiler.hs +2/−2
• src/Fay/Compiler/Decl.hs +1/−1
• src/Fay/Compiler/Desugar.hs +1/−1
• src/Fay/Compiler/Desugar/Types.hs +10/−6
• src/Fay/Compiler/Exp.hs +1/−1
• src/Fay/Compiler/FFI.hs +2/−1
• src/Fay/Compiler/Import.hs +1/−1
• src/Fay/Compiler/InitialPass.hs +1/−1
• src/Fay/Compiler/Misc.hs +4/−4
• src/Fay/Compiler/Optimizer.hs +1/−0
• src/Fay/Compiler/Pattern.hs +1/−1
• src/Fay/Compiler/Prelude.hs +1/−1
• src/Fay/Compiler/Print.hs +138/−209
• src/Fay/Config.hs +3/−3
• src/Fay/Convert.hs +1/−1
• src/Fay/Types.hs +41/−104
• src/Fay/Types/CompileError.hs +0/−2
• src/Fay/Types/Printer.hs +133/−0
• src/main/Main.hs +40/−35
• src/tests/Test/Compile.hs +27/−0
• tests/Compile/Pretty.hs +9/−0
• tests/Compile/Pretty.res +7/−0
• tests/Compile/StrictWrapper.hs +46/−1
• tests/Compile/StrictWrapper.res +8/−0
• tests/ImportType2I/A.hs +0/−0
• tests/ImportType2I/B.hs +0/−0
• tests/WhenUnlessRecursion.hs +22/−0
• tests/WhenUnlessRecursion.res +3/−0
• tests/serialization.hs +2/−2
• tests/serialization.res +4/−5

@@ -2,6 +2,38 @@  See full history at: <https://github.com/faylang/fay/commits> +## 0.23.0.0++New features:++* GHC 7.10 support+* Add a `--pretty-operators` flag to replace the escaped operator names with their actual names - By Michal Seweryn+* Add a `--pretty-all` flag that enables `--pretty`, `--pretty-operators`, and `--pretty-thunks` - By Michal Seweryn+* De/serialize type variables as 'automatic'. You no longer have to annotate FFI functions with Automatic, this is now the default. If you need the old behavior, use Ptr. For most existing cases this change shouldn't change anything. - By Zachary Mason++Example output with `--pretty-all`:+```javascript+Main.main = new $(function(){+  return _(_(Prelude["$"])(Prelude.print))(_(_(Prelude["++"])(Main.g))(Fay$$list("b")));+});+```+++API changes - By Michal Seweryn:++* Export CompileResult from Fay.Types+* Export PrintReader and PrintWriter, and reducing number of PrintState fields (these are moved to PrinterReader and PrintWriter)+* In the meanwhile PrintWriter field type changed - output is now stored as ShowS - tests run faster now+* Replace monadic functions (askP, getP, ...) with higher level ones: indented, askIf, newline, write, mapping. askIf is pretty much like previous askP, but works like if-then-else.+* Internally we are now using `ExceptT` instead of `ErrorT`. This fixes deprecation warnings when using `transformers 0.4.*`.++Bug fixes:+* Defer automatic_function fayToJs call until after argument application - by Zachary Mason++Dependency bumps:+* Allow `utf8-string 1.0.*`+* Allow `time == 1.5.*`+ ## 0.22.0.0  * Add a `--pretty-thunks` flag and compiler option that replaces `Fay$$_` and `Fay$$$` with `_` and `$` respectively. Consider this a development flag since it may clash with JS libraries (notably jQuery and underscore)

@@ -1,5 +1,5 @@ name:                fay-version:             0.22.0.0+version:             0.23.0.0 synopsis:            A compiler for Fay, a Haskell subset that compiles to JavaScript. description:         Fay is a proper subset of Haskell which is type-checked                      with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad,@@ -111,9 +111,10 @@     Fay.Types.FFI     Fay.Types.Js     Fay.Types.ModulePath+    Fay.Types.Printer     Paths_fay   build-depends:-      base >= 4 && < 4.8+      base >= 4 && < 4.9     , aeson > 0.6 && < 0.9     , bytestring < 0.11     , containers < 0.6@@ -126,6 +127,7 @@     , haskell-src-exts >= 1.16 && < 1.17     , language-ecmascript >= 0.15 && < 0.18     , mtl < 2.3+    , mtl-compat == 0.1.*     , process < 1.3     , safe < 0.4     , sourcemap < 0.2@@ -133,11 +135,12 @@     , spoon < 0.4     , syb < 0.5     , text < 1.3-    , time >= 1 && < 1.5+    , time >= 1 && < 1.6     , transformers >= 0.3 && < 0.4 || > 0.4.1 && < 0.5+    , transformers-compat == 0.3.*     , uniplate >= 1.6.11 && < 1.7     , unordered-containers < 0.3-    , utf8-string < 0.4+    , utf8-string < 1.1     , vector < 0.11  executable fay

@@ -170,9 +170,9 @@         if (args == "automatic_function")         {           for (var i = 0; i < arguments.length; i++) {-            fayFunc = Fay$$fayToJs(["automatic"], Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true));+            fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true);           }-          return fayFunc;+          return Fay$$fayToJs(["automatic"], fayFunc);         }          for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {@@ -235,8 +235,10 @@     // Bools are unboxed.     return Fay$$_(fayObj);   }-  else if(base == "ptr" || base == "unknown")+  else if(base == "ptr")     return fayObj;+  else if(base == "unknown")+    return Fay$$fayToJs(["automatic"], fayObj);   else if(base == "automatic" && fayObj instanceof Function) {     return Fay$$fayToJs(["function", "automatic_function"], fayObj);   }@@ -384,10 +386,11 @@   }   else if (base == "double" ||            base == "bool" ||-           base ==  "ptr" ||-           base ==  "unknown") {+           base ==  "ptr") {     return jsObj;   }+  else if(base == "unknown")+    return Fay$$jsToFay(["automatic"], jsObj);   else if(base == "automatic" && jsObj instanceof Function) {     var type = [["automatic"]];     for (var i = 0; i < jsObj.length; i++)

@@ -27,13 +27,10 @@ import           Fay.Compiler.Misc                      (ioWarn, printSrcSpanInfo) import           Fay.Compiler.Packages import           Fay.Compiler.Prelude-import           Fay.Compiler.Print import           Fay.Compiler.Typecheck import           Fay.Config import qualified Fay.Exts                               as F import           Fay.Types-import           Fay.Types.CompileResult- import           Data.Aeson                             (encode) import qualified Data.ByteString.Lazy                   as L import           Language.Haskell.Exts.Annotated        (prettyPrint)@@ -133,24 +130,26 @@   return $ case result of     Left err -> Left err     Right (printer,state@CompileState{ stateModuleName = (ModuleName _ modulename) },_) ->-      Right ((concat . reverse . pwOutput $ pw)+      Right ( pwOutputString pw             , if null (pwMappings pw) then Nothing else Just (pwMappings pw)             , state             )       where         pw = execPrinter (runtime <> aliases <> printer <> main) pr-        runtime = whenP (configExportRuntime config) $-          write raw-        aliases = whenP (configPrettyThunks config) $-          write . unlines $ [ "var $ = Fay$$$;"-                            , "var _ = Fay$$_;"-                            , "var __ = Fay$$__;"-                            ]-        main = whenP (not $ configLibrary config) $-          write $ "Fay$$_(" ++ modulename ++ ".main, true);\n"+        runtime = if (configExportRuntime config) then write raw else mempty+        aliases = if (configPrettyThunks config)+                  then write . unlines $ [ "var $ = Fay$$$;"+                                         , "var _ = Fay$$_;"+                                         , "var __ = Fay$$__;"+                                         ]+                  else mempty+        main = if (not $ configLibrary config)+               then write $ "Fay$$_(" ++ modulename ++ ".main, true);\n"+               else mempty         pr = defaultPrintReader-          { prPrettyThunks = configPrettyThunks config-          , prPretty       = configPrettyPrint config+          { prPrettyThunks    = configPrettyThunks config+          , prPretty          = configPrettyPrint config+          , prPrettyOperators = configPrettyOperators config           }  -- | Convert a Haskell filename to a JS filename.

@@ -42,7 +42,7 @@ import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types -import           Control.Monad.Error+import           Control.Monad.Except import           Control.Monad.RWS  import qualified Data.Set                        as S@@ -65,7 +65,7 @@   runTopCompile rs              defaultCompileState              (parseResult (throwError . uncurry ParseError)-                          (fmap printJS . with)+                          (fmap (mconcat . map printJS) . with)                           (parseFay filepath from))  -- | Compile the top-level Fay module.

@@ -21,7 +21,7 @@ import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Monad.Error+import           Control.Monad.Except import           Control.Monad.RWS import           Language.Haskell.Exts.Annotated hiding (binds, loc, name) 

@@ -18,7 +18,7 @@ import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types                       (CompileError (..)) -import           Control.Monad.Error+import           Control.Monad.Except import           Control.Monad.Reader            (asks) import qualified Data.Generics.Uniplate.Data     as U import           Language.Haskell.Exts.Annotated hiding (binds, loc, name)

@@ -1,19 +1,23 @@--- | The transformer stack used during desugaring.+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}++-- | The transformer stack used during desugaring.+ module Fay.Compiler.Desugar.Types   ( DesugarReader (..)   , Desugar   , runDesugar   ) where -import           Fay.Compiler.Prelude- import           Fay.Types            (CompileError (..)) -import           Control.Monad.Error+#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative+#endif+import           Control.Monad.Except import           Control.Monad.Reader  data DesugarReader l = DesugarReader@@ -24,7 +28,7 @@  newtype Desugar l a = Desugar   { unDesugar :: (ReaderT (DesugarReader l)-                       (ErrorT CompileError IO))+                       (ExceptT CompileError IO))                        a   } deriving ( MonadReader (DesugarReader l)              , MonadError CompileError@@ -36,4 +40,4 @@  runDesugar :: String -> l -> Desugar l a -> IO (Either CompileError a) runDesugar tmpNamePrefix emptyAnnotation m =-    runErrorT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation tmpNamePrefix))+    runExceptT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation tmpNamePrefix))

@@ -27,7 +27,7 @@ import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Monad.Error             (throwError)+import           Control.Monad.Except             (throwError) import           Control.Monad.RWS               (asks, gets) import qualified Data.Char                       as Char import           Language.Haskell.Exts.Annotated hiding (alt, binds, name, op)

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections     #-}@@ -24,7 +25,7 @@ import qualified Fay.Exts.Scoped                        as S import           Fay.Types -import           Control.Monad.Error+import           Control.Monad.Except import           Control.Monad.Writer import           Data.Generics.Schemes import           Language.ECMAScript3.Parser            as JS

@@ -20,7 +20,7 @@ import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types -import           Control.Monad.Error+import           Control.Monad.Except import           Control.Monad.RWS import           Language.Haskell.Exts.Annotated hiding (name, var) import           System.Directory

@@ -19,7 +19,7 @@ import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types -import           Control.Monad.Error+import           Control.Monad.Except import           Control.Monad.RWS import qualified Data.Map                        as M import           Language.Haskell.Exts.Annotated hiding (name, var)

@@ -19,8 +19,8 @@ import qualified Fay.Exts.Scoped                   as S import           Fay.Types -import           Control.Monad.Error-import           Control.Monad.RWS+import           Control.Monad.Except+import           Control.Monad.RWS                 (asks, gets, modify, runRWST) import qualified Data.Map                          as M import           Data.Version                      (parseVersion) import           Distribution.HaskellSuite.Modules@@ -268,11 +268,11 @@   -> CompileState   -> Compile a   -> IO (Either CompileError (a,CompileState,CompileWriter))-runTopCompile reader' state' m = fst <$> runModuleT (runErrorT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty+runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty  -- | Runs compilation for a single module. runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a-runCompileModule reader' state' m = runErrorT (runRWST (unCompile m) reader' state')+runCompileModule reader' state' m = runExceptT (runRWST (unCompile m) reader' state')  shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards     #-}

@@ -15,7 +15,7 @@ import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Monad.Error+import           Control.Monad.Except import           Control.Monad.Reader import           Language.Haskell.Exts.Annotated hiding (name) import           Language.Haskell.Names

@@ -43,7 +43,7 @@ import           Prelude             hiding (exp, mod) import           Safe -import           Control.Monad.Error+import           Control.Monad.Except import           System.Exit import           System.Process 

@@ -1,15 +1,8 @@-{-# OPTIONS -fno-warn-orphans        #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE NoImplicitPrelude    #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns         #-}+{-# OPTIONS -fno-warn-orphans     #-}+{-# LANGUAGE OverloadedStrings    #-} --- | 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.+-- | Code printers. Can be used to produce both pretty and not+-- pretty output. -- -- Special constructors and symbols in Haskell are encoded to -- JavaScript appropriately.@@ -19,192 +12,188 @@ import           Fay.Compiler.Prelude  import           Fay.Compiler.PrimOp-import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types  import           Data.Aeson.Encode import qualified Data.ByteString.Lazy.UTF8       as UTF8 import           Language.Haskell.Exts.Annotated hiding (alt, name, op, sym)-import           SourceMap.Types  -------------------------------------------------------------------------------- -- Printing  -- | Print the JS to a flat string. printJSString :: Printable a => a -> String-printJSString x = concat . reverse . pwOutput $ execPrinter (printJS x) defaultPrintReader+printJSString x = pwOutputString (execPrinter (printJS x) defaultPrintReader)  -- | Print the JS to a pretty string. printJSPretty :: Printable a => a -> String-printJSPretty x = concat . reverse . pwOutput $ execPrinter (printJS x) defaultPrintReader{ prPretty = True }+printJSPretty x = pwOutputString (execPrinter (printJS x) defaultPrintReader{ prPretty = True }) --- | Print literals. These need some special encoding for--- JS-format literals. Could use the Text.JSON library.+-- | Encode String to JS-format lterals. Could use the+-- Text.JSON library.+toJsStringLit :: String -> String+toJsStringLit = UTF8.toString . encode++-- | Print literals. instance Printable JsLit where-  printJS typ = write $-    let u8 = UTF8.toString . encode-    in case typ of-      (JsChar char)    -> u8 [char]-      (JsStr str)      -> u8 str+  printJS typ = write $ case typ of+      (JsChar char)    -> toJsStringLit [char]+      (JsStr str)      -> toJsStringLit str       (JsInt int)      -> show int       (JsFloating rat) -> show rat       (JsBool b)       -> if b then "true" else "false"  -- | Print (and properly encode to JS) a qualified name.-instance Printable N.QName where+instance Printable (QName l) where   printJS qname =     case qname of-      Qual _ (ModuleName _ "Fay$") name -> "Fay$$" +> name-      Qual _ moduleName name -> moduleName +> "." +> name+      Qual _ (ModuleName _ "Fay$") name -> "Fay$$" <> printJS name+      Qual _ moduleName name -> printJS moduleName <> printProp name       UnQual _ name -> printJS name       Special _ con -> printJS con +-- | Prints pretty operators.+-- prPrettyOperator flag determines the way of accessing operators (e.g. `($)`) and+-- identifiers with apostrophes (e.g. `length'`). If prPrettyOperators is set true,+-- then these will be accessed with square brackets (e.g. Prelude["$"] or+-- Prelude["length'"]). Otherwise special characters will be escaped and accessed+-- with dot (e.g. Prelude.$36$ or Prelude.length$39$). Alphanumeric_ identifiers are+-- always accessed with dot operator (e.g. Prelude.length)+printProp :: Name l -> Printer+printProp name = askIf prPrettyOperators pretty ugly+  where pretty = if all (`elem` allowedNameChars) nameString then dot else brackets+        ugly = dot+        dot = "." <> printJS name+        brackets = "[" <> write (toJsStringLit nameString) <> "]"+        nameString = case name of+          Ident _ s  -> s+          Symbol _ s -> s+ -- | Print module name.-instance Printable N.ModuleName where-  printJS (ModuleName _ "Fay$") =-    write "Fay$"+instance Printable (ModuleName l) where+  printJS (ModuleName _ "Fay$") = "Fay$"   printJS (ModuleName _ moduleName) = write $ go moduleName-     where go ('.':xs) = '.' : go xs           go (x:xs) = normalizeName [x] ++ go xs           go [] = [] +-- | Print (and properly encode) a name.+instance Printable (Name l) where+  printJS = write . encodeName++ -- | Print special constructors (tuples, list, etc.)-instance Printable N.SpecialCon where+instance Printable (SpecialCon l) where   printJS specialCon =     printJS $ fayBuiltin () $       case specialCon of         UnitCon _ -> "unit"         Cons    _ -> "cons"-        _       -> error $ "Special constructor not supported: " ++ show specialCon+        _         -> error $ "Special constructor not supported: " +++                   show (fmap (const ()) specialCon) --- | Print (and properly encode) a name.-instance Printable N.Name where-  printJS name = write $-    case name of-      Ident  _ idn -> encodeName idn-      Symbol _ sym -> encodeName sym  -- | Print a list of statements.-instance Printable [JsStmt] where-  printJS = mconcat . map printJS+printStmts :: [JsStmt] -> Printer+printStmts = mconcat . map printJS  -- | Print a single statement. instance Printable JsStmt where   printJS (JsExpStmt e) =-    printJS e +> ";" +> newline+    printJS e <> ";" <> newline   printJS (JsBlock stmts) =-    "{ " +> stmts +> "}"+    "{ " <> (printStmts stmts) <> "}"   printJS (JsVar name expr) =-    "var " +> name +> " = " +> expr +> ";" +> newline+    "var " <> printJS name <> " = " <> printJS expr <> ";" <> newline   printJS (JsUpdate name expr) =-    name +> " = " +> expr +> ";" +> newline+    printJS name <> " = " <> printJS expr <> ";" <> newline   printJS (JsSetProp name prop expr) =-    name +> "." +> prop +> " = " +> expr +> ";" +> newline+    printJS name <> "." <> printJS prop <> " = " <> printJS expr <> ";" <> newline   printJS (JsSetQName msrcloc name expr) =-    maybe mempty mapping msrcloc-    <> (name +> " = " +> expr +> ";" +> newline)+    maybe mempty mapping msrcloc <> printJS name <> " = " <> printJS expr <> ";" <> newline   printJS (JsSetConstructor name expr) =-    printCons name +> " = " +> expr +> ";" +> newline +>+    printCons name <> " = " <> printJS expr <> ";" <> newline <>     -- The unqualifiedness here is bad.-    printCons name +> ".prototype.instance = \"" +> printConsUnQual name +> "\";" +> newline+    printCons name <> ".prototype.instance = \"" <> printConsUnQual name <> "\";" <> newline   printJS (JsSetModule mp expr) =-    mp +> " = " +> expr +> ";" +> newline+    printJS mp <> " = " <> printJS expr <> ";" <> newline   printJS (JsSetPropExtern name prop expr) =-    name +> "['" +> prop +> "'] = " +> expr +> ";" +> newline-  printJS (JsIf exp thens elses) =-    "if (" +> exp +> ") {" +> newline +>-    indented (printJS thens) +>-    "}" +>+    printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ";" <> newline+  printJS (JsIf expr thens elses) =+    "if (" <> printJS expr <> ") {" <> newline <>+    indented (printStmts thens) <>+    "}" <>     (if (null elses)       then mempty-      else " else {" +>-           indented (printJS elses) +>-           "}") +> newline-  printJS (JsEarlyReturn exp) =-    "return " +> exp +> ";" +> newline-  printJS (JsThrow exp) =-    "throw " +> exp +> ";" +> newline+      else " else {" <> newline <>+           indented (printStmts elses) <>+           "}") <> newline+  printJS (JsEarlyReturn expr) =+    "return " <> printJS expr <> ";" <> newline+  printJS (JsThrow expr) =+    "throw " <> printJS expr <> ";" <> newline   printJS (JsWhile cond stmts) =-    "while (" +> cond +> ") {"  +> newline +>-    indented (printJS stmts) +>-    "}" +> newline-  printJS JsContinue =-    printJS "continue;" +> newline+    "while (" <> printJS cond <> ") {" <> newline <>+    indented (printStmts stmts) <>+    "}" <> newline+  printJS JsContinue = "continue;" <> newline  -- | Print a module path. instance Printable ModulePath where-  printJS (unModulePath -> l) = write $ intercalate "." l+  printJS = write . intercalate "." . unModulePath  -- | Print an expression. instance Printable JsExp where-  printJS (JsSeq es) = "(" +> mintercalate "," (map printJS es) +> ")"+  printJS (JsSeq es) = "(" <> mintercalate "," (map printJS es) <> ")"   printJS (JsRawExp e) = write e   printJS (JsName name) = printJS name-  printJS (JsThrowExp exp) =-    "(function(){ throw (" +> exp +> "); })()"-  printJS JsNull =-    printJS "null"-  printJS JsUndefined =-    printJS "undefined"-  printJS (JsLit lit) =-    printJS lit-  printJS (JsParen exp) =-    "(" +> exp +> ")"-  printJS (JsList exps) =-    "[" +> mintercalate "," (map printJS exps) +> "]"-  printJS (JsNew name args) =-    "new " +> JsApp (JsName name) args-  printJS (JsIndex i exp) =-    "(" +> exp +> ")[" +> show i +> "]"-  printJS (JsEq exp1 exp2) =-    exp1 +> " === " +> exp2-  printJS (JsNeq exp1 exp2) =-    exp1 +> " !== " +> exp2-  printJS (JsGetProp exp prop) = exp +> "." +> prop-  printJS (JsLookup exp1 exp2) =-    exp1 +> "[" +> exp2 +> "]"+  printJS (JsThrowExp expr) = "(function(){ throw (" <> printJS expr <> "); })()"+  printJS JsNull = "null"+  printJS JsUndefined = "undefined"+  printJS (JsLit lit) = printJS lit+  printJS (JsParen expr) = "(" <> printJS expr <> ")"+  printJS (JsList exprs) = "[" <> mintercalate "," (map printJS exprs) <> "]"+  printJS (JsNew name args) = "new " <> (printJS $ JsApp (JsName name) args)+  printJS (JsIndex i expr) = "(" <> printJS expr <> ")[" <> write (show i) <> "]"+  printJS (JsEq expr1 expr2) = printJS expr1 <> " === " <> printJS expr2+  printJS (JsNeq expr1 expr2) = printJS expr1 <> " !== " <> printJS expr2+  printJS (JsGetProp expr prop) = printJS expr <> "." <> printJS prop+  printJS (JsLookup expr1 expr2) = printJS expr1 <> "[" <> printJS expr2 <> "]"   printJS (JsUpdateProp name prop expr) =-    "(" +> name +> "." +> prop +> " = " +> expr +> ")"-  printJS (JsInfix op x y) =-    x +> " " +> op +> " " +> y-  printJS (JsGetPropExtern exp prop) =-    exp +> "[" +> (JsLit . JsStr) prop +> "]"+    "(" <> printJS name <> "." <> printJS prop <> " = " <> printJS expr <> ")"+  printJS (JsInfix op x y) = printJS x <> " " <> write op <> " " <> printJS y+  printJS (JsGetPropExtern expr prop) =+    printJS expr <> "[" <> write (toJsStringLit prop) <> "]"   printJS (JsUpdatePropExtern name prop expr) =-    "(" +> name +> "['" +> prop +> "'] = " +> expr +> ")"+    "(" <> printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ")"   printJS (JsTernaryIf cond conseq alt) =-    cond +> " ? " +> conseq +> " : " +> alt-  printJS (JsInstanceOf exp classname) =-    exp +> " instanceof " +> classname+    printJS cond <> " ? " <> printJS conseq <> " : " <> printJS alt+  printJS (JsInstanceOf expr classname) =+    printJS expr <> " instanceof " <> printJS classname   printJS (JsObj assoc) =-    "{" +> mintercalate "," (map cons assoc) +> "}"-      where cons (key,value) = "\"" +> key +> "\": " +> value-  printJS (JsLitObj assoc) =-    "{" +> mintercalate "," (map cons assoc) +> "}"-      where cons (key,value) = "\"" +> key +> "\": " +> value+    "{" <> mintercalate "," (map cons assoc) <> "}"+      where cons (key,value) = write (toJsStringLit key) <> ": " <> printJS value+  printJS (JsLitObj assoc) = "{" <> mintercalate "," (map cons assoc) <> "}"+      where cons (key,value) = "\"" <> printJS key <> ": " <> printJS value   printJS (JsFun nm params stmts ret) =        "function"-    +> maybe mempty ((" " +>) . printJS . ident) nm-    +> "("-    +> mintercalate "," (map printJS params)-    +> "){" +> newline-    +> indented (stmts +>+    <> maybe mempty ((" " <>) . printJS . ident) nm+    <> "("+    <> mintercalate "," (map printJS params)+    <> "){" <> newline+    <> indented (printStmts stmts <>                  case ret of-                   Just ret' -> "return " +> ret' +> ";" +> newline+                   Just ret' -> "return " <> printJS ret' <> ";" <> newline                    Nothing   -> mempty)-    +> "}"+    <> "}"   printJS (JsApp op args) =-    (if isFunc op then JsParen op else op)-    +> "("-    +> mintercalate "," (map printJS args)-    +> ")"-     where isFunc JsFun{..} = True; isFunc _ = False-  printJS (JsNegApp args) =-      "(-(" +> printJS args +> "))"-  printJS (JsAnd a b) =-      printJS a +> "&&" +> printJS b-  printJS (JsOr a b) =-      printJS a +> "||" +> printJS b+    printJS (case op of JsFun _ _ _ _ -> JsParen op; _ -> op)+    <> "("+    <> mintercalate "," (map printJS args)+    <> ")"+  printJS (JsNegApp args) = "(-(" <> printJS args <> "))"+  printJS (JsAnd a b) = printJS a <> "&&" <> printJS b+  printJS (JsOr a b) = printJS a <> "||" <> printJS b  -- | Unqualify a JsName. ident :: JsName -> JsName@@ -217,42 +206,32 @@   printJS name =     case name of       JsNameVar qname     -> printJS qname-      JsThis              -> write "this"-      JsThunk             -> writeThunkish "Fay$$$" "$"-      JsForce             -> writeThunkish "Fay$$_" "_"-      JsApply             -> writeThunkish "Fay$$__" "__"-      JsParam i           -> write ("$p" ++ show i)-      JsTmp i             -> write ("$tmp" ++ show i)+      JsThis              -> "this"+      JsThunk             -> askIf prPrettyThunks "$" "Fay$$$"+      JsForce             -> askIf prPrettyThunks "_" "Fay$$_"+      JsApply             -> askIf prPrettyThunks "__" "Fay$$__"+      JsParam i           -> "$p" <> (write $ show i)+      JsTmp i             -> "$tmp" <> (write $ show i)       JsConstructor qname -> printCons qname-      JsBuiltIn qname     -> "Fay$$" +> printJS qname-      JsParametrizedType  -> write "type"+      JsBuiltIn qname     -> "Fay$$" <> printJS qname+      JsParametrizedType  -> "type"       JsModuleName (ModuleName _ m) -> write m-    where writeThunkish ugly pretty = askP $ \pr ->-            write $ if prPrettyThunks pr then pretty else ugly  -- | Print a constructor name given a QName.-printCons :: N.QName -> Printer+printCons :: QName l -> Printer printCons (UnQual _ n) = printConsName n-printCons (Qual _ (ModuleName _ m) n) = printJS m +> "." +> printConsName n+printCons (Qual _ (ModuleName _ m) n) = write m <> "." <> printConsName n printCons (Special {}) = error "qname2String Special"  -- | Print an unqualified name.-printConsUnQual :: N.QName -> Printer+printConsUnQual :: QName l -> Printer printConsUnQual (UnQual _ x) = printJS x printConsUnQual (Qual _ _ n) = printJS n printConsUnQual (Special {}) = error "printConsUnqual Special"  -- | Print a constructor name given a Name. Helper for printCons.-printConsName :: N.Name -> Printer-printConsName = (write "_" <>) . printJS---- | Just write out strings.-instance Printable String where-  printJS = write---- | A printer is a printable.-instance Printable Printer where-  printJS = id+printConsName :: Name l -> Printer+printConsName = ("_" <>) . printJS  -------------------------------------------------------------------------------- -- Name encoding@@ -274,81 +253,31 @@   -- The problem only occurs if there is a module A.B and a constructor B in module A.    ++ ["__defineGetter__", "__defineSetter__", "__lookupGetter__", "__lookupSetter__", "constructor", "force", "forced", "hasOwnProperty", "isPrototypeOf", "propertyIsEnumerable", "toLocaleString", "toString", "value", "valueOf"] +allowedNameChars :: [Char]+allowedNameChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"  -- | Encode a Haskell name to JavaScript.-encodeName :: String -> String+encodeName :: Name l -> String+ -- | This is a hack for names generated in the Haskell AST. Should be -- removed once it's no longer needed.-encodeName ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name-encodeName name-  | name `elem` reservedWords = "$_" ++ normalizeName name-  | otherwise                 = normalizeName name+encodeName n = case n of+                 (Ident  _ idn) -> encodeString idn+                 (Symbol _ sym) -> encodeString sym+  where encodeString ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name+        encodeString name+          | name `elem` reservedWords = "$_" ++ normalizeName name+          | otherwise                 = normalizeName name  -- | Normalize the given name to JavaScript-valid names. normalizeName :: String -> String normalizeName = concatMap encodeChar   where-    encodeChar c | c `elem` allowed = [c]-                 | otherwise        = escapeChar c-    allowed = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+    encodeChar c | c `elem` allowedNameChars = [c]+                 | otherwise                 = escapeChar c     escapeChar c = "$" ++ charId c ++ "$"     charId c = show (fromEnum c) ------------------------------------------------------------------------------------- Printing----- | Print the given printer indented.-indented :: Printer -> Printer-indented p = askP $ \PrintReader{..} ->-  if prPretty-  then addToIndentLevel 1 <> p <> addToIndentLevel (-1)-  else p-  where addToIndentLevel d = modifyP (\s@PrintState{..} -> s { psIndentLevel = psIndentLevel + d } )---- | Output a newline.-newline :: Printer-newline = askP  $ \PrintReader{..} ->-  whenP prPretty $ write "\n" <> (modifyP $ \s -> s { psNewline = True })----- | Write out a string, updating the current position information.-write :: String -> Printer-write x = p <> q-  where p = getP $ \PrintState{..} -> -          let out = if psNewline -                    then replicate (2*psIndentLevel) ' ' ++ x-                    else x-          in tellP mempty { pwOutput = [out] }-        q = modifyP $ \s@PrintState{..} -> -          s { psLine    = psLine + additionalLines-            , psColumn  = if additionalLines > 0-                          then length (concat (take 1 (reverse srclines)))-                          else psColumn + length x-            , psNewline = False-            }-        srclines = lines x-        additionalLines = length (filter (=='\n') x)----- | Generate a mapping from the Haskell location to the current point in the output.-mapping :: SrcSpan -> Printer-mapping SrcSpan{..} =-  getP $ \PrintState{..} -> -    let m = Mapping { mapGenerated = Pos (fromIntegral (psLine))-                                         (fromIntegral (psColumn))-                    , mapOriginal = Just (Pos (fromIntegral srcSpanStartLine)-                                              (fromIntegral srcSpanStartColumn - 1))-                    , mapSourceFile = Just srcSpanFilename-                    , mapName = Nothing-                    }-    in tellP $ mempty { pwMappings = [m] }- -- | Intercalate monoids. mintercalate :: String -> [Printer] -> Printer mintercalate str xs = mconcat $ intersperse (write str) xs---- | Concatenate two printables.-(+>) :: (Printable a, Printable b) => a -> b -> Printer-pa +> pb = printJS pa <> printJS pb

@@ -24,6 +24,7 @@       , configRuntimePath       , configOptimizeNewtypes       , configPrettyThunks+      , configPrettyOperators       )   , defaultConfig   , defaultConfigWithSandbox@@ -74,9 +75,9 @@   , configRuntimePath        :: Maybe FilePath   , configOptimizeNewtypes   :: Bool                        -- ^ Optimize away newtype constructors?   , configPrettyThunks       :: Bool                        -- ^ Use pretty thunk names?+  , configPrettyOperators    :: Bool                        -- ^ Use pretty operators?   } deriving (Show) - defaultConfig :: Config defaultConfig = addConfigPackage "fay-base"   Config@@ -104,6 +105,7 @@     , configSourceMap          = False     , configOptimizeNewtypes   = True     , configPrettyThunks       = False+    , configPrettyOperators    = False     }  defaultConfigWithSandbox :: IO Config@@ -138,8 +140,6 @@ -- | Add several include directories without package references. addConfigDirectoryIncludePaths :: [FilePath] -> Config -> Config addConfigDirectoryIncludePaths fps cfg = foldl (flip (addConfigDirectoryInclude Nothing)) cfg fps--  -- | Reading _configPackages is safe to do. configPackages :: Config -> [String]

@@ -123,7 +123,7 @@     rec :: GenericParser     rec = decodeFay specialCases -type GenericParser = Data a => Value -> Either String a+type GenericParser = forall a. Data a => Value -> Either String a  -- | Parse a data type or record or tuple. parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a

@@ -1,60 +1,65 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies               #-}  -- | All Fay types and instances.  module Fay.Types-  (JsStmt(..)-  ,JsExp(..)-  ,JsLit(..)-  ,JsName(..)-  ,CompileError(..)-  ,Compile(..)-  ,CompileModule-  ,Printable(..)-  ,Fay-  ,CompileReader(..)-  ,CompileWriter(..)-  ,Config(..)-  ,CompileState(..)-  ,FundamentalType(..)-  ,PrintState(..)-  ,defaultPrintState-  ,PrintReader(..)-  ,defaultPrintReader-  ,PrintWriter(..)-  ,Printer(..)-  ,execPrinter-  ,askP-  ,getP-  ,modifyP-  ,tellP-  ,whenP-  ,SerializeContext(..)-  ,ModulePath (unModulePath)-  ,mkModulePath-  ,mkModulePaths-  ,mkModulePathFromQName+  ( JsStmt(..)+  , JsExp(..)+  , JsLit(..)+  , JsName(..)+  , CompileError(..)+  , Compile(..)+  , CompileModule+  , Printable(..)+  , Fay+  , CompileReader(..)+  , CompileResult(..)+  , CompileWriter(..)+  , Config(..)+  , CompileState(..)+  , FundamentalType(..)+  , PrintState(..)+  , defaultPrintState+  , PrintReader(..)+  , defaultPrintReader+  , PrintWriter(..)+  , pwOutputString+  , Printer(..)+  , execPrinter+  , indented+  , askIf+  , newline+  , write+  , mapping+  , SerializeContext(..)+  , ModulePath (unModulePath)+  , mkModulePath+  , mkModulePaths+  , mkModulePathFromQName   ) where -import           Fay.Compiler.Prelude- import           Fay.Config import qualified Fay.Exts.NoAnnotation             as N import qualified Fay.Exts.Scoped                   as S import           Fay.Types.CompileError+import           Fay.Types.CompileResult import           Fay.Types.FFI import           Fay.Types.Js import           Fay.Types.ModulePath+import           Fay.Types.Printer -import           Control.Monad.Error               (ErrorT, MonadError)+#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative+#endif+import           Control.Monad.Except              (ExceptT, MonadError) import           Control.Monad.Identity            (Identity) import           Control.Monad.RWS import           Data.Map                          (Map) import           Data.Set                          (Set) import           Distribution.HaskellSuite.Modules import           Language.Haskell.Names            (Symbols)-import           SourceMap.Types  -------------------------------------------------------------------------------- -- Compiler types@@ -97,7 +102,7 @@ -- | Compile monad. newtype Compile a = Compile   { unCompile :: RWST CompileReader CompileWriter CompileState-                      (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO))+                      (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO))                       a -- ^ Uns the compiler   } deriving     ( Applicative@@ -121,74 +126,6 @@  liftModuleT :: ModuleT Symbols IO a -> Compile a liftModuleT = Compile . lift . lift----- | Global options of the printer-data PrintReader = PrintReader-  { prPretty       :: Bool      -- ^ Are we to pretty print?-  , prPrettyThunks :: Bool      -- ^ Use pretty thunk names?-  }--defaultPrintReader :: PrintReader-defaultPrintReader = PrintReader False False----- | Output of printer-data PrintWriter = PrintWriter-  { pwMappings    :: [Mapping] -- ^ Source mappings.-  , pwOutput      :: [String]  -- ^ The current output. TODO: Make more efficient.-  }----- | Reverse concatenation (generated output need to be reversed)-instance Monoid PrintWriter where-  mempty =  PrintWriter [] []-  mappend (PrintWriter a b) (PrintWriter x y) = PrintWriter (x ++ a) (y ++ b)---- | The state of the pretty printer.-data PrintState = PrintState-  { psLine        :: Int       -- ^ The current line.-  , psColumn      :: Int       -- ^ Current column.-  , psIndentLevel :: Int       -- ^ Current indentation level.-  , psNewline     :: Bool      -- ^ Just outputted a newline?-  }---- | Default state.-defaultPrintState :: PrintState-defaultPrintState = PrintState 0 0 0 False---- | The printer.-newtype Printer = Printer-  { runPrinter :: RWS PrintReader PrintWriter PrintState ()-  }--execPrinter :: Printer -> PrintReader -> PrintWriter-execPrinter (Printer p) r = snd $ execRWS p r defaultPrintState---- | monadic functions-askP :: (PrintReader -> Printer) -> Printer-askP f = Printer $ ask >>= (\r -> runPrinter (f r))--getP :: (PrintState -> Printer) -> Printer-getP f = Printer $ get >>= (\s -> runPrinter (f s))--modifyP :: (PrintState -> PrintState) -> Printer-modifyP f = Printer $ modify f--tellP :: PrintWriter -> Printer-tellP = Printer . tell--whenP :: Bool -> Printer -> Printer-whenP b p = if b then p else mempty---instance Monoid Printer where-  mempty = Printer $ return ()-  mappend (Printer p) (Printer q) = Printer (p >> q)---- | Print some value.-class Printable a where-  printJS :: a -> Printer  -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a)

@@ -4,7 +4,6 @@ import qualified Fay.Exts.NoAnnotation           as N import qualified Fay.Exts.Scoped                 as S -import           Control.Monad.Error             (Error) import           Language.Haskell.Exts.Annotated  -- | Error type.@@ -38,4 +37,3 @@   | UnsupportedWhereInAlt S.Alt   | UnsupportedWhereInMatch S.Match   deriving (Show)-instance Error CompileError

@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleContexts #-}+module Fay.Types.Printer+  ( PrintReader(..)+  , defaultPrintReader+  , PrintWriter(..)+  , pwOutputString+  , PrintState(..)+  , defaultPrintState+  , Printer(..)+  , Printable(..)+  , execPrinter+  , indented+  , newline+  , write+  , askIf+  , mapping+  ) where++import Control.Monad.RWS+import Data.List                       (elemIndex)+import Data.String+import Language.Haskell.Exts.Annotated+import SourceMap.Types++-- | Global options of the printer+data PrintReader = PrintReader+  { prPretty          :: Bool      -- ^ Are we to pretty print?+  , prPrettyThunks    :: Bool      -- ^ Use pretty thunk names?+  , prPrettyOperators :: Bool      -- ^ Use pretty operators?+  }++-- | default printer options (non-pretty printing)+defaultPrintReader :: PrintReader+defaultPrintReader = PrintReader False False False++-- | Output of printer+data PrintWriter = PrintWriter+  { pwMappings    :: [Mapping] -- ^ Source mappings.+  , pwOutput      :: ShowS     -- ^ The current output.+  }++pwOutputString :: PrintWriter -> String+pwOutputString (PrintWriter _ out) = out ""++-- | Output concatenation+instance Monoid PrintWriter where+  mempty =  PrintWriter [] id+  mappend (PrintWriter a b) (PrintWriter x y) = PrintWriter (a ++ x) (b . y)++-- | The state of the pretty printer.+data PrintState = PrintState+  { psLine        :: Int       -- ^ The current line.+  , psColumn      :: Int       -- ^ Current column.+  , psIndentLevel :: Int       -- ^ Current indentation level.+  , psNewline     :: Bool      -- ^ Just outputted a newline?+  }++-- | Default state.+defaultPrintState :: PrintState+defaultPrintState = PrintState 0 0 0 False++-- | The printer.+newtype Printer = Printer+  { runPrinter :: RWS PrintReader PrintWriter PrintState () }++execPrinter :: Printer -> PrintReader -> PrintWriter+execPrinter (Printer p) r = snd $ execRWS p r defaultPrintState+++instance Monoid Printer where+  mempty = Printer $ return ()+  mappend (Printer p) (Printer q) = Printer (p >> q)++-- | Print some value.+class Printable a where+  printJS :: a -> Printer++-- | Print the given printer indented.+indented :: Printer -> Printer+indented (Printer p) = Printer $ asks prPretty >>= \pretty ->+    when pretty (addToIndentLevel 1) >> p >> when pretty (addToIndentLevel (-1))+  where addToIndentLevel d = modify (\ps -> ps { psIndentLevel = psIndentLevel ps + d })++-- | Output a newline and makes next line indented when prPretty is True.+--   Does nothing when prPretty is False+newline :: Printer+newline = Printer $ asks prPretty >>= flip when writeNewline+  where writeNewline = (writeRWS "\n" >> modify (\s -> s {psNewline = True}))++-- | Write out a raw string, respecting the indentation+--   Note: if you pass a string with newline characters, it will print them+--   out even if prPretty is set to False. Also next line won't be indented.+--   If you want write a smart newline (that is the one which will be written+--   out only if prPretty is true, and after which the line will be indented)+--   use `newline`)+write :: String -> Printer+write = Printer . writeRWS++writeRWS :: String -> RWS PrintReader PrintWriter PrintState ()+writeRWS x = do+  ps <- get+  let out = if psNewline ps+               then replicate (2 * psIndentLevel ps) ' ' ++ x+               else x+  tell mempty { pwOutput = (out++) }++  let newLines = length (filter (== '\n') x)+  put ps { psLine    = psLine ps + newLines+         , psColumn  = case elemIndex '\n' (reverse x) of+                        Just i  -> i+                        Nothing -> psColumn ps + length x+         , psNewline = False+         }++-- | Write out a string, updating the current position information.+instance IsString Printer where+  fromString = write++-- | exec one of Printers depending on PrintReader property.+askIf :: (PrintReader -> Bool) -> Printer -> Printer -> Printer+askIf f (Printer p) (Printer q) = Printer $ asks f >>= (\b -> if b then p else q)++-- | Generate a mapping from the Haskell location to the current point in the output.+mapping :: SrcSpan -> Printer+mapping srcSpan = Printer $ get >>= \ps ->+    let m = Mapping { mapGenerated = Pos (fromIntegral (psLine ps))+                                         (fromIntegral (psColumn ps))+                    , mapOriginal = Just (Pos (fromIntegral (srcSpanStartLine srcSpan))+                                              (fromIntegral (srcSpanStartColumn srcSpan) - 1))+                    , mapSourceFile = Just (srcSpanFilename srcSpan)+                    , mapName = Nothing+                    }+    in tell $ mempty { pwMappings = [m] }

@@ -16,33 +16,35 @@  -- | Options and help. data FayCompilerOptions = FayCompilerOptions-  { optLibrary            :: Bool+  { optBasePath           :: Maybe FilePath+  , optGClosure           :: Bool   , optFlattenApps        :: Bool-  , optHTMLWrapper        :: Bool   , optHTMLJSLibs         :: [String]+  , optHTMLWrapper        :: Bool   , optInclude            :: [String]-  , optPackages           :: [String]-  , optWall               :: Bool+  , optLibrary            :: Bool   , optNoGHC              :: Bool-  , optStdout             :: Bool-  , optVersion            :: Bool-  , optOutput             :: Maybe String-  , optPretty             :: Bool-  , optOptimize           :: Bool-  , optGClosure           :: Bool-  , optPackageConf        :: Maybe String+  , optNoOptimizeNewtypes :: Bool   , optNoRTS              :: Bool   , optNoStdlib           :: Bool+  , optOptimize           :: Bool+  , optOutput             :: Maybe String+  , optPackages           :: [String]+  , optPackageConf        :: Maybe String+  , optPrettyAll          :: Bool+  , optPretty             :: Bool+  , optPrettyOperators    :: Bool+  , optPrettyThunks       :: Bool   , optPrintRuntime       :: Bool+  , optRuntimePath        :: Maybe FilePath+  , optSourceMap          :: Bool   , optStdlibOnly         :: Bool-  , optBasePath           :: Maybe FilePath+  , optStdout             :: Bool   , optStrict             :: [String]   , optTypecheckOnly      :: Bool-  , optRuntimePath        :: Maybe FilePath-  , optSourceMap          :: Bool+  , optVersion            :: Bool+  , optWall               :: Bool   , optFiles              :: [String]-  , optNoOptimizeNewtypes :: Bool-  , optPrettyThunks       :: Bool   }  -- | Main entry point.@@ -54,7 +56,7 @@         addConfigPackages (optPackages opts) $ config'           { configOptimize         = optOptimize opts           , configFlattenApps      = optFlattenApps opts-          , configPrettyPrint      = optPretty opts+          , configPrettyPrint      = optPretty opts || optPrettyAll opts           , configLibrary          = optLibrary opts           , configHtmlWrapper      = optHTMLWrapper opts           , configHtmlJSLibs       = optHTMLJSLibs opts@@ -71,7 +73,8 @@           , configRuntimePath      = optRuntimePath opts           , configSourceMap        = optSourceMap opts           , configOptimizeNewtypes = not $ optNoOptimizeNewtypes opts-          , configPrettyThunks     = optPrettyThunks opts+          , configPrettyThunks     = optPrettyThunks opts || optPrettyAll opts+          , configPrettyOperators  = optPrettyOperators opts || optPrettyAll opts           }   if optVersion opts     then runCommandVersion@@ -93,37 +96,39 @@ -- | All Fay's command-line options. options :: Parser FayCompilerOptions options = FayCompilerOptions-  <$> switch (long "library" <> help "Don't automatically call main in generated JavaScript")+  <$> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")+  <*> switch (long "closure" <> help "Provide help with Google Closure")   <*> 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")+  <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript")   <*> 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 "library" <> help "Don't automatically call main in generated JavaScript")   <*> 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 "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"))+  <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types")   <*> switch (long "no-rts" <> short 'r' <> help "Don't export the RTS")   <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI")+  <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")+  <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))+  <*> strsOption (long "package" <> metavar "package[, ..]"+      <> help "packages to use for compilation")+  <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))+  <*> switch (long "pretty-all" <> help "Pretty print, pretty operators and pretty thunks")+  <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")+  <*> switch (long "pretty-operators" <> help "Use pretty operators")+  <*> switch (long "pretty-thunks" <> help "Use pretty thunk names")   <*> switch (long "print-runtime" <> help "Print the runtime JS source to stdout")+  <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it")+  <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map")   <*> switch (long "stdlib" <> help "Only output the stdlib")-  <*> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")+  <*> switch (long "stdout" <> short 's' <> help "Output to stdout")   <*> strsOption (long "strict" <> metavar "modulename[, ..]"       <> help "Generate strict and uncurried exports for the supplied modules. Simplifies calling Fay from JS")   <*> switch (long "typecheck-only" <> help "Only invoke GHC for typechecking, don't produce any output")-  <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it")-  <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map")+  <*> switch (long "version" <> help "Output version number")+  <*> switch (long "Wall" <> help "Typecheck with -Wall")   <*> many (argument (ReadM ask) (metavar "<hs-file>..."))-  <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types")-  <*> switch (long "pretty-thunks" <> help "Use pretty thunk names")   where     strsOption :: Mod OptionFields [String] -> Parser [String]     strsOption m = option (ReadM . fmap (wordsBy (== ',')) $ ask) (m <> value [])

@@ -94,6 +94,33 @@     expected <- readFile "tests/Compile/StrictWrapper.res"     assertEqual "strictWrapper node stdout" expected out +assertPretty :: Config -> String -> Assertion+assertPretty cfg flagName = do+  res <- compileFile cfg "tests/Compile/Pretty.hs"+  case res of+    Left l  -> assertFailure $ "Should compile, but failed with: " ++ show l+    Right js -> do+    writeFile "tests/Compile/Pretty.js" js+    (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/Pretty.js"] ""+    when (err /= "") $ assertFailure err+    expected <- readFile "tests/Compile/Pretty.res"+    assertEqual (flagName ++ " node stdout") expected out++case_pretty :: Assertion+case_pretty = do+  cfg <- defConf+  assertPretty cfg { configPrettyPrint = True } "pretty"++case_prettyThunks :: Assertion+case_prettyThunks = do+  cfg <- defConf+  assertPretty cfg { configPrettyThunks = True } "prettyThunks"++case_prettyOperators :: Assertion+case_prettyOperators = do+  cfg <- defConf+  assertPretty cfg { configPrettyOperators = True } "prettyOperators"+ case_charEnum :: Assertion case_charEnum = do   cfg <- defConf

@@ -0,0 +1,9 @@+module Pretty where++import Prelude++main = do+  let n = 3::Int+  print . length' 0 . takeWhile (<=n) $ [0..]+  putStrLn $  if (n + 5) ^ 2 == 64 && n*8 == 26 then "T" else "F"+  forM [1..5] $ \k -> putStrLn $ if odd k then "odd" else "even"

@@ -0,0 +1,7 @@+4+F+odd+even+odd+even+odd

@@ -1,4 +1,8 @@-module StrictWrapper (f, g, h, r, clog, logInlineOnly, logSeparateOnly, logBoth) where+module StrictWrapper (+  f, g, h, r, clog, logInlineOnly, logSeparateOnly, logBoth,+  sumInt, sumIntWrapped, zipWithPlus, zipWithPlusWrapped,+  sumPair, sumPairWrapped, zipPairs, zipPairsWrapped+) where  import           FFI import           Prelude@@ -29,7 +33,36 @@ logBoth :: a -> Fay () logBoth = ffi "console.log(%1)" :: a -> Fay () +-- lists+sumInt :: [Int] -> Int+sumInt xs = sum xs +zipWithPlus :: [Int] -> [Int] -> [Int]+zipWithPlus xs ys = zipWith (+) xs ys++data IntList = IntList { list :: [Int] }++sumIntWrapped :: IntList -> Int+sumIntWrapped (IntList xs) = sumInt xs++zipWithPlusWrapped :: IntList -> IntList -> IntList+zipWithPlusWrapped (IntList x) (IntList y) = IntList $ zipWithPlus x y++-- tuples+sumPair :: (Int, Int) -> Int+sumPair (x,y) = x + y++zipPairs :: (Int, Int) -> (Int, Int) -> (Int, Int)+zipPairs (x1,y1) (x2,y2) = (x1 + x2, y1 + y2)++data IntPair = IntPair { pair :: (Int, Int) }++sumPairWrapped :: IntPair -> Int+sumPairWrapped (IntPair x) = sumPair x++zipPairsWrapped :: IntPair -> IntPair -> IntPair+zipPairsWrapped (IntPair x) (IntPair y) = IntPair $ zipPairs x y+ -- You should probably not use the strict wrapper from Fay, this is just for the sake of the test. main :: Fay () main = do@@ -41,3 +74,15 @@   ffi "Strict.StrictWrapper.logInlineOnly('inlineOnly')" :: Fay ()   ffi "Strict.StrictWrapper.logSeparateOnly('separateOnly')" :: Fay ()   ffi "Strict.StrictWrapper.logBoth('both')" :: Fay ()+  +  -- lists+  (ffi "console.log(Strict.StrictWrapper.sumInt(%1))" :: [Int] -> Fay ()) [1, 2, 3]+  (ffi "console.log(Strict.StrictWrapper.sumIntWrapped(%1))" :: IntList -> Fay ()) (IntList [1, 2, 3])+  (ffi "console.log(Strict.StrictWrapper.zipWithPlus(%1, %2))" :: [Int] -> [Int] -> Fay ()) [1, 2, 3] [1, 2, 3]+  (ffi "console.log(Strict.StrictWrapper.zipWithPlusWrapped(%1, %2))" :: IntList -> IntList -> Fay ()) (IntList [1, 2, 3]) (IntList [1, 2, 3])+  +  -- tuples+  (ffi "console.log(Strict.StrictWrapper.sumPair(%1))" :: (Int, Int) -> Fay ()) (1, 3)+  (ffi "console.log(Strict.StrictWrapper.sumPairWrapped(%1))" :: IntPair -> Fay ()) (IntPair (1, 3))+  (ffi "console.log(Strict.StrictWrapper.zipPairs(%1, %2))" :: (Int, Int) -> (Int, Int) -> Fay ()) (1, 3) (1, 3)+  (ffi "console.log(Strict.StrictWrapper.zipPairsWrapped(%1, %2))" :: IntPair -> IntPair -> Fay ()) (IntPair (1, 3)) (IntPair (1, 3))

@@ -6,3 +6,11 @@ inlineOnly separateOnly both+6+6+[ 2, 4, 6 ]+{ instance: 'IntList', list: [ 2, 4, 6 ] }+4+4+[ 2, 6 ]+{ instance: 'IntPair', pair: [ 2, 6 ] }

@@ -0,0 +1,22 @@+module WhenUnlessRecursion where++import FFI++getStackSize :: Fay Int+getStackSize = ffi "(Error.stackTraceLimit = Infinity, new Error().stack.split('\\n').length)"++checkGrowth :: Maybe Int -> Int -> Fay ()+checkGrowth Nothing _      = return ()+checkGrowth (Just old) new = if new == old then return () else (error $ "Call stack growth: " ++ show old ++ " to " ++ show new)++main = do+  putStrLn "loopIf"     >> loopIf     Nothing 0+  putStrLn "loopWhen"   >> loopWhen   Nothing 0+  putStrLn "loopUnless" >> loopUnless Nothing 0+  where+    pred = (< 5)+    step = (+ 1)+    action f s n = getStackSize >>= \s' -> checkGrowth s s' >> f (Just s') (step n)+    loopIf     s n = if          (pred n) then (action loopIf     s n) else return ()+    loopWhen   s n = when        (pred n)      (action loopWhen   s n)+    loopUnless s n = unless (not (pred n))     (action loopUnless s n)

@@ -0,0 +1,3 @@+loopIf+loopWhen+loopUnless

@@ -11,8 +11,8 @@   printMaybeConcrete (Just (ConcreteRecord 42))   printMaybeAutomatic (Just (ConcreteRecord 42))   printMaybe (Just (ConcreteRecord 42))-  printUnknown (error "do not want")-  printUnknownField (Just (error "do not want"))+  printUnknown 42+  printUnknownField (Just 42)   printAutomatic (Just (ConcreteRecord 42))  printParametricButConcreteType :: Parametric ConcreteRecord -> Fay ()

@@ -3,15 +3,14 @@ { instance: 'Parametric',   slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Parametric',-  slot1: { forced: false, value: [Function] } }+  slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Just',   slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just',   slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just',-  slot1: { forced: false, value: [Function] } }-{ forced: false, value: [Function] }-{ instance: 'Just',-  slot1: { forced: false, value: [Function] } }+  slot1: { instance: 'ConcreteRecord', concreteField: 42 } }+42+{ instance: 'Just', slot1: 42 } { instance: 'Just',   slot1: { instance: 'ConcreteRecord', concreteField: 42 } }