fay 0.19.2.1 → 0.20.0.0

raw patch · 55 files changed

+1507/−1092 lines, 55 filesdep +groomdep +spoondep +tastydep −Cabaldep −HUnitdep −cpphsdep ~attoparsecdep ~basedep ~data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies added: groom, spoon, tasty, tasty-hunit, tasty-th, transformers

Dependencies removed: Cabal, HUnit, cpphs, pretty-show, scientific, test-framework, test-framework-hunit, test-framework-th, time

Dependency ranges changed: attoparsec, base, data-default, haskell-src-exts, language-ecmascript

API changes (from Hackage documentation)

Files

• CHANGELOG.md +41/−0
• fay.cabal +97/−91
• src/Fay.hs +55/−36
• src/Fay/Compiler.hs +7/−8
• src/Fay/Compiler/Config.hs +0/−70
• src/Fay/Compiler/Decl.hs +4/−4
• src/Fay/Compiler/Defaults.hs +6/−6
• src/Fay/Compiler/Desugar.hs +93/−71
• src/Fay/Compiler/Desugar/Name.hs +29/−0
• src/Fay/Compiler/Desugar/Types.hs +39/−0
• src/Fay/Compiler/Exp.hs +24/−41
• src/Fay/Compiler/FFI.hs +3/−9
• src/Fay/Compiler/GADT.hs +1/−1
• src/Fay/Compiler/Import.hs +7/−6
• src/Fay/Compiler/InitialPass.hs +5/−4
• src/Fay/Compiler/Misc.hs +14/−76
• src/Fay/Compiler/Optimizer.hs +4/−8
• src/Fay/Compiler/Packages.hs +5/−10
• src/Fay/Compiler/Parse.hs +69/−0
• src/Fay/Compiler/Pattern.hs +21/−24
• src/Fay/Compiler/Prelude.hs +69/−0
• src/Fay/Compiler/PrimOp.hs +3/−1
• src/Fay/Compiler/Print.hs +19/−24
• src/Fay/Compiler/State.hs +5/−5
• src/Fay/Compiler/Typecheck.hs +5/−5
• src/Fay/Config.hs +146/−0
• src/Fay/Control/Monad/Extra.hs +0/−31
• src/Fay/Control/Monad/IO.hs +0/−9
• src/Fay/Convert.hs +171/−176
• src/Fay/Data/List/Extra.hs +0/−14
• src/Fay/Exts.hs +1/−1
• src/Fay/Exts/NoAnnotation.hs +2/−3
• src/Fay/System/Directory/Extra.hs +0/−21
• src/Fay/System/Process/Extra.hs +0/−15
• src/Fay/Types.hs +40/−233
• src/Fay/Types/CompileError.hs +41/−0
• src/Fay/Types/CompileResult.hs +9/−0
• src/Fay/Types/FFI.hs +40/−0
• src/Fay/Types/Js.hs +91/−0
• src/Fay/Types/ModulePath.hs +32/−0
• src/main/Main.hs +5/−9
• src/tests/Test/CommandLine.hs +6/−9
• src/tests/Test/Compile.hs +13/−17
• src/tests/Test/Convert.hs +9/−9
• src/tests/Test/Desugar.hs +161/−0
• src/tests/Test/Util.hs +29/−10
• src/tests/Tests.hs +36/−35
• tests/LambdaCase.hs +11/−0
• tests/LambdaCase.res +1/−0
• tests/MultiWayIf.hs +13/−0
• tests/MultiWayIf.res +3/−0
• tests/PrefixOpPat.hs +7/−0
• tests/PrefixOpPat.res +1/−0
• tests/case3.hs +11/−0
• tests/case3.res +3/−0

@@ -2,6 +2,47 @@  See full history at: <https://github.com/faylang/fay/commits> +## 0.20.0.0 (2014-04-29)++* Adds support for LambdaCase and MultiWayIf++* Modules have moved around a lot and several modules have been un-exposed. From now on you will probably only need to deal with at most `Fay` (which re-exports a lot of things), `Fay.Config`, `Fay.Types.CompileError`, `Fay.Convert`, and `Fay.Types.CompileResult`. Please let us know if you would like us to expose more things++* Config:+  * `CompileConfig` has been renamed to `Config` and is now located in `Fay.Config`.+  * `CompileConfig` has become a temporary type alias for `Config`.+  * `Fay.Compiler.Config` is deprecated, import `Fay` or `Fay.Config` instead.+  * The `data-default` instance for `Config` is deprecated, use `defaultConfig` instead.++* compiling+  * `compileFileWithState` is deprecated, use `compileFileWithResult` which returns a `Fay.Types.CompileResult` instead. As a consequence `CompileState` is also deprecated from public consumption.+  * `compileFile`, `compileFromToAndGenerateHtml` no longer return a triple with the sourcemap, use `compileFileWithResult` if you want access to this.++* Importing `Fay.Types` has been deprecated, import `Fay` instead.++* `readFromFay` has been rewritten using `syb` instead of `pretty-show` (Thanks to Michael Sloan and Chris Done)+  * This introduces the following breaking changes:+    * `readFromFay` has a `Data` constraint instead of `Show`.+    * Drops support for Rational and Integer (see below for migration steps). The reason is that neither was serialized in a way that would roundtrip for all values. Also, for similar reasons, fromRational is potentially divergent for aeson's new use of the Scientific type.+  * And adds the following features:+    * You can now write custom `Show` instances targeting GHC for types shared with Fay.+    * Better performance.+    * Allows the serialization and deserialization to be customized on a per-type basis, via encodeFay and decodeFay.+  * To migrate code using Rational or Integer, use encodeFay and pass an argument e.g. `(\f x -> maybe (f x) myIntegerToValueConversion (cast x))` and likewise to decodeFay.++Bugfixes:++* Mltiple guards on a pattern in a case expression skipped everything but the first guard. To fix this an optimization we had on pattern conditions was disabled.++Dependency bumps:++* Allow Cabal 1.20 and 1.21++Internal:++* Test cases are now using `tasty` instead of `test-framework`. To run cases in parallel use `fay-tests --num-threads=N` (see `fay-tests --help` for more info).+* Added a test group for desugaring.+ #### 0.19.2.1 (2014-04-14)  * Allow `haskell-src-exts 1.15.*`

@@ -1,5 +1,5 @@ name:                fay-version:             0.19.2.1+version:             0.20.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,@@ -23,12 +23,13 @@ category:            Development, Web, Fay build-type:          Custom cabal-version:       >=1.8-data-files:          js/runtime.js-                     src/Fay/FFI.hs+data-files:+  js/runtime.js+  src/Fay/FFI.hs extra-source-files:+  CHANGELOG.md   LICENSE   README.md-  CHANGELOG.md   -- Examples   examples/*.hs   examples/*.html@@ -66,102 +67,107 @@   location: https://github.com/faylang/fay.git  library-  hs-source-dirs:    src-  exposed-modules:     Fay-                     , Fay.Compiler-                     , Fay.Compiler.Config-                     , Fay.Control.Monad.Extra-                     , Fay.Control.Monad.IO-                     , Fay.Convert-                     , Fay.Data.List.Extra-                     , Fay.Exts-                     , Fay.Exts.Scoped-                     , Fay.Exts.NoAnnotation-                     , Fay.FFI-                     , Fay.System.Directory.Extra-                     , Fay.System.Process.Extra-                     , Fay.Types-  other-modules:       Fay.Compiler.Decl-                     , Fay.Compiler.Defaults-                     , Fay.Compiler.Desugar-                     , Fay.Compiler.Exp-                     , Fay.Compiler.FFI-                     , Fay.Compiler.GADT-                     , Fay.Compiler.Import-                     , Fay.Compiler.InitialPass-                     , Fay.Compiler.Misc-                     , Fay.Compiler.Optimizer-                     , Fay.Compiler.Packages-                     , Fay.Compiler.Pattern-                     , Fay.Compiler.PrimOp-                     , Fay.Compiler.Print-                     , Fay.Compiler.QName-                     , Fay.Compiler.State-                     , Fay.Compiler.Typecheck-                     , Paths_fay   ghc-options:       -O2 -Wall-  build-depends:     base                 >= 4       && < 5-                   , Cabal                              < 1.20-                   , aeson                              < 0.8-                   , attoparsec                         < 0.12-                   , bytestring                         < 0.11-                   , containers                         < 0.6-                   , cpphs                              < 1.19-                   , data-default                       < 0.6-                   , directory                          < 1.3-                   , filepath                           < 1.4-                   , ghc-paths                          < 0.2-                   , haskell-names        >= 0.3.1   && < 0.4-                   , haskell-packages     == 0.2.3.1 || > 0.2.3.2 && < 0.3-                   , haskell-src-exts     >= 1.14    && < 1.16-                   , language-ecmascript  >= 0.15    && < 1.0-                   , mtl                                < 2.2-                   , pretty-show          >= 1.6     && < 1.7-                   , process                            < 1.3-                   , safe                               < 0.4-                   , split                              < 0.3-                   , syb                                < 0.5-                   , text                               < 1.2-                   , time                               < 1.5-                   , uniplate             >= 1.6.11  && < 1.7-                   , unordered-containers               < 0.3-                   , utf8-string                        < 0.4-                   , vector                             < 0.11-                   , sourcemap                          < 0.2-                   , scientific                         < 0.3+  hs-source-dirs:    src+  exposed-modules:+    Fay+    Fay.Compiler+    Fay.Compiler.Desugar+    Fay.Compiler.Parse+    Fay.Compiler.Prelude+    Fay.Config+    Fay.Convert+    Fay.FFI+    Fay.Types+    Fay.Types.CompileError+    Fay.Types.CompileResult+  other-modules:+    Fay.Compiler.Decl+    Fay.Compiler.Defaults+    Fay.Compiler.Desugar.Name+    Fay.Compiler.Desugar.Types+    Fay.Compiler.Exp+    Fay.Compiler.FFI+    Fay.Compiler.GADT+    Fay.Compiler.Import+    Fay.Compiler.InitialPass+    Fay.Compiler.Misc+    Fay.Compiler.Optimizer+    Fay.Compiler.Packages+    Fay.Compiler.Pattern+    Fay.Compiler.PrimOp+    Fay.Compiler.Print+    Fay.Compiler.QName+    Fay.Compiler.State+    Fay.Compiler.Typecheck+    Fay.Exts+    Fay.Exts.NoAnnotation+    Fay.Exts.Scoped+    Fay.Types.FFI+    Fay.Types.Js+    Fay.Types.ModulePath+    Paths_fay+  build-depends:+      base >= 4 && < 4.8+    , aeson < 0.8+    , bytestring < 0.11+    , containers < 0.6+    , data-default < 0.6+    , directory < 1.3+    , filepath < 1.4+    , ghc-paths < 0.2+    , haskell-names >= 0.3.1 && < 0.4+    , haskell-packages == 0.2.3.1 || > 0.2.3.2 && < 0.3+    , haskell-src-exts >= 1.15.0.1 && < 1.16+    , language-ecmascript >= 0.15 && < 0.17+    , mtl < 2.2+    , process < 1.3+    , safe < 0.4+    , sourcemap < 0.2+    , split < 0.3+    , spoon < 0.4+    , syb < 0.5+    , text < 1.2+    , transformers == 0.3.*+    , uniplate >= 1.6.11 && < 1.7+    , unordered-containers < 0.3+    , utf8-string < 0.4+    , vector < 0.11  executable fay   hs-source-dirs:    src/main   ghc-options:       -O2 -Wall   ghc-prof-options:  -fprof-auto   main-is:           Main.hs-  build-depends:     base-                   , fay-                   , data-default-                   , optparse-applicative >= 0.6     && < 0.9-                   , split+  build-depends:+      base+    , fay+    , optparse-applicative >= 0.6 && < 0.9+    , split  executable fay-tests-  hs-source-dirs:    src/tests   ghc-options:       -O2 -Wall -threaded -with-rtsopts=-N   ghc-prof-options:  -fprof-auto+  hs-source-dirs:    src/tests   main-is:           Tests.hs-  other-modules:     Test.CommandLine-                     Test.Compile-                     Test.Convert-                     Test.Util-  build-depends:     base-                   , fay-                   , HUnit                              < 1.3-                   , aeson-                   , attoparsec-                   , bytestring-                   , data-default-                   , directory-                   , filepath-                   , haskell-src-exts-                   , test-framework                     < 0.9-                   , test-framework-hunit               < 0.4-                   , test-framework-th                  < 0.3-                   , text-                   , utf8-string+  other-modules:+    Test.CommandLine+    Test.Compile+    Test.Convert+    Test.Desugar+    Test.Util+  build-depends:+      base+    , aeson+    , attoparsec+    , bytestring+    , directory+    , fay+    , filepath+    , groom == 0.1.*+    , haskell-src-exts+    , tasty == 0.8.*+    , tasty-hunit == 0.8.*+    , tasty-th == 0.1.*+    , text+    , utf8-string

@@ -8,9 +8,13 @@ -- | Main library entry point.  module Fay-  (module Fay.Types+  (module Fay.Config+  ,CompileError (..)+  ,CompileState (..)+  ,CompileResult (..)   ,compileFile   ,compileFileWithState+  ,compileFileWithResult   ,compileFromTo   ,compileFromToAndGenerateHtml   ,toJsName@@ -22,16 +26,15 @@ import           Fay.Compiler import           Fay.Compiler.Misc                      (ioWarn, printSrcSpanInfo) import           Fay.Compiler.Packages+import           Fay.Compiler.Prelude import           Fay.Compiler.Typecheck+import           Fay.Config import qualified Fay.Exts                               as F import           Fay.Types+import           Fay.Types.CompileResult -import           Control.Applicative-import           Control.Monad import           Data.Aeson                             (encode) import qualified Data.ByteString.Lazy                   as L-import           Data.Default-import           Data.List import           Language.Haskell.Exts.Annotated        (prettyPrint) import           Language.Haskell.Exts.Annotated.Syntax import           Language.Haskell.Exts.SrcLoc@@ -42,7 +45,7 @@  -- | Compile the given file and write the output to the given path, or -- if nothing given, stdout.-compileFromTo :: CompileConfig -> FilePath -> Maybe FilePath -> IO ()+compileFromTo :: Config -> FilePath -> Maybe FilePath -> IO () compileFromTo cfg filein fileout =   if configTypecheckOnly cfg   then do@@ -54,15 +57,15 @@                       (compileFromToAndGenerateHtml cfg filein)                       fileout     case result of-      Right (out,_) -> maybe (putStrLn out) (`writeFile` out) fileout+      Right out -> maybe (putStrLn out) (`writeFile` out) fileout       Left err -> error $ showCompileError err --- | Compile the given file and write to the output, also generate any HTML.-compileFromToAndGenerateHtml :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError (String,[Mapping]))+-- | Compile the given file and write to the output, also generates HTML and sourcemap files if configured.+compileFromToAndGenerateHtml :: Config -> FilePath -> FilePath -> IO (Either CompileError String) compileFromToAndGenerateHtml config filein fileout = do-  result <- compileFile config { configFilePath = Just filein } filein-  case result of-    Right (out,mappings) -> do+  mres <- compileFileWithResult config { configFilePath = Just filein } filein+  case mres of+    Right res -> do       when (configHtmlWrapper config) $         writeFile (replaceExtension fileout "html") $ unlines [             "<!doctype html>"@@ -76,16 +79,18 @@           , "  </body>"           , "</html>"] -      when (configSourceMap config) $ do-        L.writeFile (replaceExtension fileout "map") $-          encode $-            generate SourceMapping-              { smFile = fileout-              , smSourceRoot = Nothing-              , smMappings = mappings-              }+      case (configSourceMap config, resSourceMappings res) of+        (True, Just mappings) ->+          L.writeFile (replaceExtension fileout "map") $+            encode $+              generate SourceMapping+                { smFile       = fileout+                , smSourceRoot = Nothing+                , smMappings   = mappings+                }+        _ -> return () -      return (Right (if configSourceMap config then sourceMapHeader ++ out else out,mappings))+      return $ Right (if configSourceMap config then sourceMapHeader ++ resOutput res else resOutput res)             where relativeJsPath = makeRelative (dropFileName fileout) fileout                   makeScriptTagSrc :: FilePath -> String                   makeScriptTagSrc s = "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"@@ -93,11 +98,24 @@     Left err -> return (Left err)  -- | Compile the given file.-compileFile :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping]))-compileFile config filein = fmap (\(src,maps,_) -> (src,maps)) <$> compileFileWithState config filein+compileFile :: Config -> FilePath -> IO (Either CompileError String)+compileFile config filein = fmap (\(src,_,_) -> src) <$> compileFileWithState config filein --- | Compile a file returning the state.-compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping],CompileState))+-- | Compile a file returning additional generated metadata.+compileFileWithResult :: Config -> FilePath -> IO (Either CompileError CompileResult)+compileFileWithResult config filein = do+  res <- compileFileWithState config filein+  return $ do+    (s,m,st) <- res+    return CompileResult+      { resOutput         = s+      , resImported       = map (first F.moduleNameString) $ stateImported st+      , resSourceMappings = m+      }++-- | Compile a file returning the resulting internal state of the compiler.+-- Don't use this directly, it's only exposed for the test suite.+compileFileWithState :: Config -> FilePath -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileFileWithState config filein = do   runtime <- getConfigRuntime config   hscode <- readFile filein@@ -107,16 +125,16 @@  -- | Compile the given module to a runnable module. compileToModule :: FilePath-                -> CompileConfig -> String -> (F.Module -> Compile [JsStmt]) -> String-                -> IO (Either CompileError (String,[Mapping],CompileState))+                -> Config -> String -> (F.Module -> Compile [JsStmt]) -> String+                -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileToModule filepath config raw with hscode = do   result <- compileViaStr filepath config printState with hscode   return $ case result of     Left err -> Left err-    Right (PrintState{..},state,_) ->-      Right ( generateWrapped (concat $ reverse psOutput)+    Right (ps,state,_) ->+      Right ( generateWrapped (concat . reverse $ psOutput ps)                               (stateModuleName state)-            , psMappings+            , if null (psMappings ps) then Nothing else Just (psMappings ps)             , state             )   where@@ -130,9 +148,10 @@                        ]           else ""       ]-    printState = def { psPretty = configPrettyPrint config-                     , psLine = length (lines raw) + 3-                     }+    printState = defaultPrintState+      { psPretty = configPrettyPrint config+      , psLine = length (lines raw) + 3+      }  -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String@@ -162,13 +181,13 @@     err ++ " at line: " ++ show (srcLine pos) ++ " column:" ++     "\n" ++ show (srcColumn pos)   ShouldBeDesugared s              -> "Expected this to be desugared (this is a bug): " ++ s-  UnableResolveQualified qname     -> "unable to resolve qualified names " ++ prettyPrint qname+  UnableResolveQualified qname     -> "unable to resolve qualified names (this might be a bug):" ++ prettyPrint qname   UnsupportedDeclaration d         -> "unsupported declaration: " ++ prettyPrint d   UnsupportedEnum{}                -> "only Int is allowed in enum expressions"   UnsupportedExportSpec es         -> "unsupported export specification: " ++ prettyPrint es   UnsupportedExpression expr       -> "unsupported expression syntax: " ++ prettyPrint expr   UnsupportedFieldPattern p        -> "unsupported field pattern: " ++ prettyPrint p-  UnsupportedImport i              -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i+  UnsupportedImport i              -> "unsupported import syntax: " ++ prettyPrint i   UnsupportedLet                   -> "let not supported here"   UnsupportedLetBinding d          -> "unsupported let binding: " ++ prettyPrint d   UnsupportedLiteral lit           -> "unsupported literal syntax: " ++ prettyPrint lit@@ -182,7 +201,7 @@  -- | Get the JS runtime source. -- This will return the user supplied runtime if it exists.-getConfigRuntime :: CompileConfig -> IO String+getConfigRuntime :: Config -> IO String getConfigRuntime cfg = maybe getRuntime return $ configRuntimePath cfg  -- | Get the default JS runtime source.

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-}@@ -19,7 +20,8 @@   ,parseFay)   where -import           Fay.Compiler.Config+import           Fay.Compiler.Prelude+ import           Fay.Compiler.Decl import           Fay.Compiler.Defaults import           Fay.Compiler.Desugar@@ -29,26 +31,23 @@ import           Fay.Compiler.InitialPass        (initialPass) import           Fay.Compiler.Misc import           Fay.Compiler.Optimizer+import           Fay.Compiler.Parse import           Fay.Compiler.PrimOp             (findPrimOp) import           Fay.Compiler.QName import           Fay.Compiler.State import           Fay.Compiler.Typecheck-import           Fay.Control.Monad.IO+import           Fay.Config import qualified Fay.Exts                        as F import           Fay.Exts.NoAnnotation           (unAnn) import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types -import           Control.Applicative import           Control.Monad.Error import           Control.Monad.RWS import           Control.Monad.State--import           Data.Maybe import qualified Data.Set                        as S import           Language.Haskell.Exts.Annotated hiding (name) import           Language.Haskell.Names-import           Prelude                         hiding (mod)  -------------------------------------------------------------------------------- -- Top level entry points@@ -57,7 +56,7 @@ compileViaStr    :: FilePath-  -> CompileConfig+  -> Config   -> PrintState   -> (F.Module -> Compile [JsStmt])   -> String@@ -123,7 +122,7 @@ -- | Compile a parse HSE module. compileModuleFromAST :: ([JsStmt], [JsStmt]) -> F.Module -> Compile ([JsStmt], [JsStmt]) compileModuleFromAST (hstmts0, fstmts0) mod'@Module{} = do-  mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions $ mod'+  mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod'   let modName = unAnn $ F.moduleName mod   modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas                    }

@@ -1,70 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}---- | Configuration functions.--module Fay.Compiler.Config where--import           Fay.Types--import           Data.Default-import           Data.Maybe-import           Language.Haskell.Exts.Annotated (ModuleName (..))---- | Get all include directories without the package mapping.-configDirectoryIncludePaths :: CompileConfig -> [FilePath]-configDirectoryIncludePaths = map snd . configDirectoryIncludes---- | Get all include directories not included through packages.-nonPackageConfigDirectoryIncludePaths :: CompileConfig -> [FilePath]-nonPackageConfigDirectoryIncludePaths = map snd . filter (isJust . fst) . configDirectoryIncludes---- | Add a mapping from (maybe) a package to a source directory-addConfigDirectoryInclude :: Maybe String -> FilePath -> CompileConfig -> CompileConfig-addConfigDirectoryInclude pkg fp cfg = cfg { configDirectoryIncludes = (pkg, fp) : configDirectoryIncludes cfg }---- | Add several include directories.-addConfigDirectoryIncludes :: [(Maybe String,FilePath)] -> CompileConfig -> CompileConfig-addConfigDirectoryIncludes pkgFps cfg = foldl (\c (pkg,fp) -> addConfigDirectoryInclude pkg fp c) cfg pkgFps---- | Add several include directories without package references.-addConfigDirectoryIncludePaths :: [FilePath] -> CompileConfig -> CompileConfig-addConfigDirectoryIncludePaths fps cfg = foldl (flip (addConfigDirectoryInclude Nothing)) cfg fps---- | Add a package to compilation-addConfigPackage :: String -> CompileConfig -> CompileConfig-addConfigPackage pkg cfg = cfg { configPackages = pkg : configPackages cfg }---- | Add several packages to compilation-addConfigPackages :: [String] -> CompileConfig -> CompileConfig-addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps--shouldExportStrictWrapper :: ModuleName a -> CompileConfig -> Bool-shouldExportStrictWrapper (ModuleName _ m) cs = m `elem` configStrict cs---- | Default configuration.-instance Default CompileConfig where-  def = addConfigPackage "fay-base"-    CompileConfig-    { configOptimize           = False-    , configFlattenApps        = False-    , configExportRuntime      = True-    , configExportStdlib       = True-    , configExportStdlibOnly   = False-    , configDirectoryIncludes  = []-    , configPrettyPrint        = False-    , configHtmlWrapper        = False-    , configHtmlJSLibs         = []-    , configLibrary            = False-    , configWarn               = True-    , configFilePath           = Nothing-    , configTypecheck          = True-    , configWall               = False-    , configGClosure           = False-    , configPackageConf        = Nothing-    , configPackages           = []-    , configBasePath           = Nothing-    , configStrict             = []-    , configTypecheckOnly      = False-    , configRuntimePath        = Nothing-    , configSourceMap          = False-    }

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ViewPatterns          #-} @@ -7,27 +8,26 @@  module Fay.Compiler.Decl where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Exp import           Fay.Compiler.FFI import           Fay.Compiler.GADT import           Fay.Compiler.Misc import           Fay.Compiler.Pattern import           Fay.Compiler.State-import           Fay.Data.List.Extra import           Fay.Exts                        (convertFieldDecl, fieldDeclNames) import           Fay.Exts.NoAnnotation           (unAnn) import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Applicative import           Control.Monad.Error import           Control.Monad.RWS import           Language.Haskell.Exts.Annotated hiding (binds, loc, name)-import           Prelude                         hiding (exp)  -- | Compile Haskell declaration. compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]-compileDecls toplevel = fmap concat . sequence . map (compileDecl toplevel)+compileDecls toplevel = fmap concat . mapM (compileDecl toplevel)  -- | Compile a declaration. compileDecl :: Bool -> S.Decl -> Compile [JsStmt]

@@ -4,21 +4,21 @@  module Fay.Compiler.Defaults where -import           Fay.Compiler.Config-import           Fay.Compiler.Decl   (compileDecls)-import           Fay.Compiler.Exp    (compileLit)+import           Fay.Compiler.Decl (compileDecls)+import           Fay.Compiler.Exp  (compileLit)+import           Fay.Config import           Fay.Types import           Paths_fay -import           Data.Map            as M-import           Data.Set            as S+import           Data.Map          as M+import           Data.Set          as S  -- | The data-files source directory. faySourceDir :: IO FilePath faySourceDir = getDataFileName "src/"  -- | The default compiler reader value.-defaultCompileReader :: CompileConfig -> IO CompileReader+defaultCompileReader :: Config -> IO CompileReader defaultCompileReader config = do   srcdir <- faySourceDir   return CompileReader

@@ -1,65 +1,40 @@-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-+-- | Desugars a reasonable amount of syntax to reduce duplication in code generation.+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} module Fay.Compiler.Desugar-  (desugar+  ( desugar+  , desugar'+  , desugarExpParen+  , desugarPatParen   ) where +import           Fay.Compiler.Prelude++import           Fay.Compiler.Desugar.Name+import           Fay.Compiler.Desugar.Types+import           Fay.Compiler.Misc               (ffiExp, hasLanguagePragma) import           Fay.Compiler.QName              (unname)-import           Fay.Compiler.Misc               (hasLanguagePragma, ffiExp) import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types                       (CompileError (..)) -import           Control.Applicative import           Control.Monad.Error-import           Control.Monad.Reader-import           Data.Data                       (Data)-import           Data.Maybe-import           Data.Typeable                   (Typeable)-import           Language.Haskell.Exts.Annotated hiding (binds, loc, name)-import           Prelude                         hiding (exp, mod)+import           Control.Monad.Reader            (asks) import qualified Data.Generics.Uniplate.Data     as U---- Types--data DesugarReader l = DesugarReader-  { readerNameDepth :: Int-  , readerNoInfo    :: l-  }--newtype Desugar l a = Desugar-  { unDesugar :: (ReaderT (DesugarReader l)-                       (ErrorT CompileError IO))-                       a-  } deriving ( MonadReader (DesugarReader l)-             , MonadError CompileError-             , MonadIO-             , Monad-             , Functor-             , Applicative-             )--runDesugar :: l -> Desugar l a -> IO (Either CompileError a)-runDesugar emptyAnnotation m =-    runErrorT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation))---- | Generate a temporary, SCOPED name for testing conditions and--- such. We don't have name tracking yet, so instead we use this.-withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar l a) -> Desugar l a-withScopedTmpName l f = do-  n <- asks readerNameDepth-  local (\r -> r { readerNameDepth = n + 1 }) $-   f $ Ident l $ "$gen" ++ show n+import           Language.Haskell.Exts.Annotated hiding (binds, loc, name)  -- | Top level, desugar a whole module possibly returning errors desugar :: (Data l, Typeable l) => l -> Module l -> IO (Either CompileError (Module l))-desugar emptyAnnotation md = runDesugar emptyAnnotation $+desugar = desugar' "$gen"++-- | Desugar with the option to specify a prefix for generated names.+-- Useful if you want to provide valid haskell name that HSE can print.+desugar' :: (Data l, Typeable l) => String -> l -> Module l -> IO (Either CompileError (Module l))+desugar' prefix emptyAnnotation md = runDesugar prefix emptyAnnotation $       checkEnum md   >>  desugarSection md   >>= desugarListComp-  >>= return . desugarTupleCon+  >>= desugarTupleCon   >>= return . desugarPatParen   >>= return . desugarFieldPun   >>= return . desugarPatFieldPun@@ -67,9 +42,14 @@   >>= desugarTupleSection   >>= desugarImplicitPrelude   >>= desugarFFITypeSigs---- | Desugaring+  >>= desugarLCase+  >>= return . desugarMultiIf+  >>= return . desugarInfixOp+  >>= return . desugarInfixPat+  >>= return . desugarExpParen +-- | (a `f`) => \b -> a `f` b+--   (`f` b) => \a -> a `f` b desugarSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarSection = transformBiM $ \ex -> case ex of   LeftSection  l e q -> withScopedTmpName l $ \tmp ->@@ -78,13 +58,13 @@       return $ Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e)   _ -> return ex +-- | Convert do notation into binds and thens. desugarDo :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarDo = transformBiM $ \ex -> case ex of   Do _ stmts -> maybe (throwError EmptyDoBlock) return $ foldl desugarStmt' Nothing (reverse stmts)   _ -> return ex --- | Convert do notation into binds and thens.-desugarStmt' :: Maybe (Exp l) -> (Stmt l) -> Maybe (Exp l)+desugarStmt' :: Maybe (Exp l) -> Stmt l -> Maybe (Exp l) desugarStmt' inner stmt =   maybe initStmt subsequentStmt inner   where@@ -107,37 +87,54 @@       Just $ InfixApp s                       exp                       (QVarOp s $ UnQual s $ Symbol s ">>=")-                      (Lambda s [pat] (inner'))+                      (Lambda s [pat] inner')  -- | (,)  => \x y   -> (x,y) --   (,,) => \x y z -> (x,y,z) -- etc-desugarTupleCon :: (Data l, Typeable l) => Module l -> Module l-desugarTupleCon = transformBi $ \ex -> case ex of-  Var _ (Special _ t@TupleCon{}) -> fromTupleCon ex t-  Con _ (Special _ t@TupleCon{}) -> fromTupleCon ex t-  _ -> ex+desugarTupleCon :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarTupleCon md = do+  prefix <- asks readerTmpNamePrefix+  return $ flip transformBi md $ \ex -> case ex of+    Var _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t+    Con _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t+    _ -> ex   where-    fromTupleCon :: Exp l -> SpecialCon l -> Exp l-    fromTupleCon e s = fromMaybe e $ case s of+    fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l+    fromTupleCon prefix e s = fromMaybe e $ case s of       TupleCon l b n -> Just $ Lambda l params body         where           -- It doesn't matter if these variable names shadow anything since           -- this lambda won't have inner scopes.-          names  = take n $ map (Ident l . ("$gen" ++) . show) [(1::Int)..]+          names  = take n $ unscopedTmpNames l prefix           params = PVar l <$> names           body   = Tuple l b (Var l . UnQual l <$> names)       _ -> Nothing -desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l)-desugarTupleSection = transformBiM $ \ex -> case ex of-  TupleSection l _ mes -> do-    (names, lst) <- genSlotNames l mes (varNames l)-    return $ Lambda l (map (PVar l) names) (Tuple l Unboxed lst)+-- | \case { ... } => \foo -> case foo of { ... }+desugarLCase :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarLCase = transformBiM $ \ex -> case ex of+  LCase l alts -> withScopedTmpName l $ \n -> return $ Lambda l [PVar l n] (Case l (Var l (UnQual l n)) alts)   _ -> return ex++-- | if | p -> x | q -> y => case () of _ | p -> x | q -> y+desugarMultiIf :: (Data l, Typeable l) => Module l -> Module l+desugarMultiIf = transformBi $ \ex -> case ex of+  MultiIf l alts -> Case l (Con l (Special l (UnitCon l)))+                           [Alt l (PWildCard l) (GuardedAlts l gas) Nothing]+    where gas = map (\(IfAlt l' p a) -> GuardedAlt l' [Qualifier l' p] a) alts+  _ -> ex++-- | (a,) => \b -> (a,b)+desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarTupleSection md = do+  prefix <- asks readerTmpNamePrefix+  flip transformBiM md $ \ex -> case ex of+    TupleSection l _ mes -> do+      (names, lst) <- genSlotNames l mes (unscopedTmpNames l prefix)+      return $ Lambda l (map (PVar l) names) (Tuple l Boxed lst)+    _ -> return ex   where-    varNames :: l -> [Name l]-    varNames l = map (\i -> Ident l ("$gen_" ++ show i)) [0::Int ..]      genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])     genSlotNames _ [] _ = return ([], [])@@ -155,14 +152,15 @@   PParen _ p -> p   _ -> pt +-- | {a} => {a=a} for R{a} expressions desugarFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarFieldPun = transformBi $ \f -> case f of   FieldPun l n -> let dn = UnQual l n in FieldUpdate l dn (Var l dn)   _ -> f +-- | {a} => {a=a} for R{a} patterns desugarPatFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarPatFieldPun = transformBi $ \pf -> case pf of-  -- {a} => {a=a} for R{a}   PFieldPun l n -> PFieldPat l (UnQual l n) (PVar l n)   _             -> pf @@ -204,7 +202,7 @@       _ -> return ()      checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar l ()-    checkIntOrUnknown exp es = when (not $ any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp)+    checkIntOrUnknown exp es = unless (any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp)     isIntOrUnknown :: Exp l -> Bool     isIntOrUnknown e = case e of       Con            {} -> False@@ -218,6 +216,7 @@       EnumFromThenTo {} -> False       _                 -> True +-- | Adds an explicit import Prelude statement when appropriate. desugarImplicitPrelude :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarImplicitPrelude m =     if preludeNotNeeded@@ -266,7 +265,7 @@ --  foo = ffi "3" -- becomes --  foo :: Int---  foo = (ffi "3" :: Int)+--  foo = ffi "3" :: Int desugarToplevelFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarToplevelFFITypeSigs m = case m of   Module a b c d decls -> do@@ -289,7 +288,7 @@   -- scope level.   getTypeSigs ds = [ (unname n, typ) | TypeSig _ names typ <- ds, n <- names ] -  go typeSigs ds = map (addTypeSig typeSigs) ds+  go typeSigs = map (addTypeSig typeSigs)    addTypeSig typeSigs decl = case decl of     (PatBind loc pat typ rhs binds) ->@@ -325,6 +324,29 @@   getTypeFor typeSigs decl = case decl of     (PatBind _ (PVar _ name) _ _ _) -> lookup (unname name) typeSigs     _ -> Nothing++-- | a `op` b => op a b+-- a + b => (+) a b+-- for expressions+desugarInfixOp :: (Data l, Typeable l) => Module l -> Module l+desugarInfixOp = transformBi $ \ex -> case ex of+  InfixApp l e1 oper e2 -> App l (App l (getOp oper) e1) e2+    where+      getOp (QVarOp l' o) = Var l' o+      getOp (QConOp l' o) = Con l' o+  _ -> ex++-- | a : b => (:) a b for patterns+desugarInfixPat :: (Data l, Typeable l) => Module l -> Module l+desugarInfixPat = transformBi $ \pt -> case pt of+  PInfixApp l p1 iop p2 -> PApp l iop [p1, p2]+  _ -> pt++-- | (a) => a for patterns+desugarExpParen :: (Data l, Typeable l) => Module l -> Module l+desugarExpParen = transformBi $ \ex -> case ex of+  Paren _ e -> e+  _ -> ex  transformBi :: U.Biplate (from a) (to a) => (to a -> to a) -> from a -> from a transformBi = U.transformBi

@@ -0,0 +1,29 @@+-- | Generate names while desugaring.+module Fay.Compiler.Desugar.Name+  ( withScopedTmpName+  , unscopedTmpNames+  ) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.Desugar.Types++import           Control.Monad.Reader            (asks, local)+import           Language.Haskell.Exts.Annotated (Name (..))++-- | Generate a temporary, SCOPED name for testing conditions and+-- such. We don't have name tracking yet, so instead we use this.+withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar l a) -> Desugar l a+withScopedTmpName l f = do+  prefix <- asks readerTmpNamePrefix+  n <- asks readerNameDepth+  local (\r -> r { readerNameDepth = n + 1 }) $+    f $ tmpName l prefix n++-- | Generates temporary names where the scope doesn't matter.+unscopedTmpNames :: l -> String -> [Name l]+unscopedTmpNames l prefix = map (tmpName l prefix) [0..]++-- | Don't call this directly, use withScopedTmpName or unscopedTmpNames instead.+tmpName :: l -> String -> Int -> Name l+tmpName l prefix n = Ident l $ prefix ++ show n

@@ -0,0 +1,39 @@+-- | The transformer stack used during desugaring.+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+module Fay.Compiler.Desugar.Types+  ( DesugarReader (..)+  , Desugar+  , runDesugar+  ) where++import           Fay.Compiler.Prelude++import           Fay.Types            (CompileError (..))++import           Control.Monad.Error+import           Control.Monad.Reader++data DesugarReader l = DesugarReader+  { readerNameDepth     :: Int+  , readerNoInfo        :: l+  , readerTmpNamePrefix :: String+  }++newtype Desugar l a = Desugar+  { unDesugar :: (ReaderT (DesugarReader l)+                       (ErrorT CompileError IO))+                       a+  } deriving ( MonadReader (DesugarReader l)+             , MonadError CompileError+             , MonadIO+             , Monad+             , Functor+             , Applicative+             )++runDesugar :: String -> l -> Desugar l a -> IO (Either CompileError a)+runDesugar tmpNamePrefix emptyAnnotation m =+    runErrorT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation tmpNamePrefix))

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE ViewPatterns          #-}@@ -13,36 +14,33 @@   ,compileLit   ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.FFI                (compileFFIExp) import           Fay.Compiler.Misc import           Fay.Compiler.Pattern import           Fay.Compiler.Print import           Fay.Compiler.QName-import           Fay.Data.List.Extra+import           Fay.Config import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Exts.Scoped                 (noI) import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Applicative-import           Control.Monad                   ((>=>), foldM, liftM, forM) import           Control.Monad.Error             (throwError)-import           Control.Monad.RWS               (gets, asks)+import           Control.Monad.RWS               (asks, gets) import qualified Data.Char                       as Char import           Language.Haskell.Exts.Annotated hiding (alt, binds, name, op) import           Language.Haskell.Names-import           Prelude                         hiding (exp)  -- | Compile Haskell expression. compileExp :: S.Exp -> Compile JsExp compileExp e = case e of-  Paren _ exp                        -> compileExp exp   Var _ qname                        -> compileVar qname   Lit _ lit                          -> compileLit lit   App _ (Var _ (UnQual _ (Ident _ "ffi"))) _ -> throwError $ FfiNeedsTypeSig e   App _ exp1 exp2                    -> compileApp exp1 exp2   NegApp _ exp                       -> compileNegApp exp-  InfixApp _ exp1 op exp2            -> compileInfixApp exp1 op exp2   Let _ (BDecls _ decls) exp         -> compileLet decls exp   List _ []                          -> return JsNull   List _ xs                          -> compileList xs@@ -57,8 +55,8 @@   EnumFromTo _ i i'                  -> compileEnumFromTo i i'   EnumFromThen _ a b                 -> compileEnumFromThen a b   EnumFromThenTo _ a b z             -> compileEnumFromThenTo a b z-  RecConstr _ name fieldUpdates      -> compileRecConstr name fieldUpdates-  RecUpdate _ rec  fieldUpdates      -> compileRecUpdate rec fieldUpdates+  RecConstr _ name fieldUpdates      -> compileRecConstr e name fieldUpdates+  RecUpdate _ rec  fieldUpdates      -> compileRecUpdate e rec fieldUpdates   ExpTypeSig _ exp sig               -> case ffiExp exp of     Nothing -> compileExp exp     Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig@@ -67,6 +65,8 @@   LeftSection {}                     -> shouldBeDesugared e   RightSection {}                    -> shouldBeDesugared e   TupleSection {}                    -> shouldBeDesugared e+  Paren {}                           -> shouldBeDesugared e+  InfixApp {}                        -> shouldBeDesugared e   exp -> throwError $ UnsupportedExpression exp  -- | Compile variable.@@ -75,7 +75,7 @@ compileVar qname = do     nc <- lookupNewtypeConst qname     nd <- lookupNewtypeDest qname-    if (nc /= Nothing || nd /= Nothing)+    if isJust nc || isJust nd       then -- variable is either a newtype constructor or newtype destructor,            -- replace it with identity function            return idFun@@ -91,9 +91,9 @@   Frac _ rational _ -> return (JsLit (JsFloating (fromRational rational)))   String _ string _ -> do     fromString <- gets stateUseFromString-    if fromString-      then return (JsLit (JsStr string))-      else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)])+    return $ if fromString+      then JsLit (JsStr string)+      else JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)]   _                 -> throwError $ UnsupportedLiteral lit  -- | Compile simple application.@@ -142,21 +142,6 @@ compileNegApp :: S.Exp -> Compile JsExp compileNegApp e = JsNegApp . force <$> compileExp e --- | Compile an infix application, optimizing the JS cases.-compileInfixApp :: S.Exp -> S.QOp -> S.Exp -> Compile JsExp-compileInfixApp exp1 ap exp2 = case exp1 of-  Con _ q -> do-    newtypeConst <- lookupNewtypeConst q-    case newtypeConst of-      Just _ -> compileExp exp2-      Nothing -> normalApp-  _ -> normalApp-  where-    normalApp = compileExp (App noI (App noI (Var noI op) exp1) exp2)-    op = getOp ap-    getOp (QVarOp _ o) = o-    getOp (QConOp _ o) = o- -- | Compile a let expression. compileLet :: [S.Decl] -> S.Exp -> Compile JsExp compileLet decls exp = do@@ -192,7 +177,7 @@ compileCase e alts = do   exp <- compileExp e   withScopedTmpJsName $ \tmpName -> do-    pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts+    pats <- optimizePatConditions <$> mapM (compilePatAlt (JsName tmpName)) alts     return $       JsApp (JsFun Nothing                    [tmpName]@@ -222,8 +207,6 @@  -- | Compile guards compileGuards :: [S.GuardedRhs] -> Compile JsStmt-compileGuards ((GuardedRhs _ (Qualifier _ (Var _ (UnQual _ (Ident _ "otherwise"))):_) exp):_) =-  (\e -> JsIf (JsLit $ JsBool True) [JsEarlyReturn e] []) <$> compileExp exp compileGuards (GuardedRhs _ (Qualifier _ guard:_) exp : rest) =   makeIf <$> fmap force (compileExp guard)          <*> compileExp exp@@ -287,8 +270,8 @@  -- | Compile a record construction with named fields -- | GHC will warn on uninitialized fields, they will be undefined in JS.-compileRecConstr :: S.QName -> [S.FieldUpdate] -> Compile JsExp-compileRecConstr name fieldUpdates = do+compileRecConstr :: S.Exp -> S.QName -> [S.FieldUpdate] -> Compile JsExp+compileRecConstr origExp name fieldUpdates = do   -- var obj = new $_Type()   let unQualName = withIdent lowerFirst . unQualify $ unAnn name   qname <- unsafeResolveName name@@ -300,23 +283,23 @@     updateStmt (unAnn -> o) (FieldUpdate _ (unAnn -> field) value) = do       exp <- compileExp value       return [JsSetProp (JsNameVar $ withIdent lowerFirst $ unQualify o) (JsNameVar $ unQualify field) exp]-    updateStmt o (FieldWildcard (wildcardFields -> fields)) = do+    updateStmt o (FieldWildcard (wildcardFields -> fields)) =       return $ for fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o)                                                     (JsNameVar fieldName)                                                     (JsName $ JsNameVar fieldName)     -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))-    updateStmt _ u = error ("updateStmt: " ++ show u)+    updateStmt _ _ = throwError $ UnsupportedExpression origExp      wildcardFields l = case l of-      Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName) . map fst $ es+      Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName . fst) es       _ -> []     lowerFirst :: String -> String     lowerFirst "" = ""     lowerFirst (x:xs) = '_' : Char.toLower x : xs  -- | Compile a record update.-compileRecUpdate :: S.Exp -> [S.FieldUpdate] -> Compile JsExp-compileRecUpdate rec fieldUpdates = do+compileRecUpdate :: S.Exp -> S.Exp -> [S.FieldUpdate] -> Compile JsExp+compileRecUpdate origExp rec fieldUpdates = do   record <- force <$> compileExp rec   let copyName = UnQual () $ Ident () "$_record_to_update"       copy = JsVar (JsNameVar copyName)@@ -329,14 +312,14 @@       JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value     updateExp _ f@FieldPun{} = shouldBeDesugared f     -- I also couldn't find a code that generates (FieldUpdate FieldWildCard)-    updateExp _ FieldWildcard{} = error "unsupported update: FieldWildcard"+    updateExp _ FieldWildcard{} = throwError $ UnsupportedExpression origExp  -- | Make a Fay list. makeList :: [JsExp] -> JsExp makeList exps = JsApp (JsName $ JsBuiltIn "list") [JsList exps]  -- | Optimize short literal [e1..e3] arithmetic sequences.-optEnumFromTo :: CompileConfig -> JsExp -> JsExp -> Maybe JsExp+optEnumFromTo :: Config -> JsExp -> JsExp -> Maybe JsExp optEnumFromTo cfg (JsLit f) (JsLit t) =   if configOptimize cfg   then case (f,t) of@@ -352,7 +335,7 @@ optEnumFromTo _ _ _ = Nothing  -- | Optimize short literal [e1,e2..e3] arithmetic sequences.-optEnumFromThenTo :: CompileConfig -> JsExp -> JsExp -> JsExp -> Maybe JsExp+optEnumFromThenTo :: Config -> JsExp -> JsExp -> JsExp -> Maybe JsExp optEnumFromThenTo cfg (JsLit fr) (JsLit th) (JsLit to) =   if configOptimize cfg   then case (fr,th,to) of

@@ -1,8 +1,8 @@ {-# LANGUAGE CPP               #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections     #-} {-# LANGUAGE ViewPatterns      #-}-{-# OPTIONS -Wall #-}  -- | Compile FFI definitions. @@ -15,6 +15,8 @@   ,typeArity   ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc import           Fay.Compiler.Print                     (printJSString) import           Fay.Compiler.QName@@ -23,21 +25,13 @@ import qualified Fay.Exts.Scoped                        as S import           Fay.Types -import           Control.Applicative                    ((<$>), (<*>))-import           Control.Arrow                          ((***)) import           Control.Monad.Error import           Control.Monad.Writer-import           Data.Char import           Data.Generics.Schemes-import           Data.List-import           Data.Maybe-import           Data.String import           Language.ECMAScript3.Parser            as JS import           Language.ECMAScript3.Syntax import           Language.Haskell.Exts.Annotated        (SrcSpanInfo, prettyPrint) import           Language.Haskell.Exts.Annotated.Syntax-import           Prelude                                hiding (exp, mod)-import           Safe  -- | Compile an FFI expression (also used when compiling top level definitions). compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> S.Type -> Compile JsExp

@@ -4,7 +4,7 @@   (convertGADT   ) where -import           Language.Haskell.Exts.Annotated hiding (binds, name)+import           Language.Haskell.Exts.Annotated hiding (name)  -- | Convert a GADT to a normal data type. convertGADT :: GadtDecl a -> QualConDecl a

@@ -1,5 +1,6 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Handles finding imports and compiling them recursively. -- This is done for each full AST traversal the copmiler does@@ -10,18 +11,18 @@   ,compileWith   ) where -import           Fay.Compiler.Config+import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc-import           Fay.Control.Monad.IO+import           Fay.Compiler.Parse+import           Fay.Config import qualified Fay.Exts                        as F import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types -import           Control.Applicative import           Control.Monad.Error import           Control.Monad.RWS import           Language.Haskell.Exts.Annotated hiding (name, var)-import           Prelude                         hiding (mod, read) import           System.Directory import           System.FilePath 

@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-} @@ -7,23 +8,23 @@   (initialPass   ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Desugar import           Fay.Compiler.GADT import           Fay.Compiler.Import import           Fay.Compiler.Misc-import           Fay.Data.List.Extra+import           Fay.Compiler.Parse import qualified Fay.Exts                        as F import           Fay.Exts.NoAnnotation           (unAnn) import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types -import           Control.Applicative import           Control.Monad.Error import           Control.Monad.RWS import qualified Data.Map                        as M import           Language.Haskell.Exts.Annotated hiding (name, var) import qualified Language.Haskell.Names          as HN-import           Prelude                         hiding (mod, read)  -- | Preprocess and collect all information needed during code generation. initialPass :: FilePath -> Compile ()@@ -115,7 +116,7 @@     -- | Collect record definitions and store record name and field names.     -- A ConDecl will have fields named slot1..slotN     dataDecl :: [F.QualConDecl] -> Compile ()-    dataDecl constructors = do+    dataDecl constructors =       forM_ constructors $ \(QualConDecl _ _ _ condecl) ->         case condecl of           ConDecl _ name types -> do

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE ViewPatterns      #-}@@ -7,28 +8,24 @@  module Fay.Compiler.Misc where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.PrimOp-import           Fay.Control.Monad.IO+import           Fay.Compiler.QName                (unname)+import           Fay.Config import qualified Fay.Exts                          as F import           Fay.Exts.NoAnnotation             (unAnn) import qualified Fay.Exts.NoAnnotation             as N import qualified Fay.Exts.Scoped                   as S import           Fay.Types-import           Fay.Compiler.QName                (unname) -import           Control.Applicative import           Control.Monad.Error import           Control.Monad.RWS-import           Data.Char                         (isAlpha)-import           Data.List import qualified Data.Map                          as M-import           Data.Maybe-import           Data.String import           Data.Version                      (parseVersion) import           Distribution.HaskellSuite.Modules import           Language.Haskell.Exts.Annotated   hiding (name) import           Language.Haskell.Names-import           Prelude                           hiding (exp, mod) import           System.IO import           System.Process                    (readProcess) import           Text.ParserCombinators.ReadP      (readP_to_S)@@ -114,7 +111,7 @@     Just (cname,_,ty) -> return $ Just (cname,ty)  -- | Qualify a name for the current module.-qualify :: Name a -> Compile (N.QName)+qualify :: Name a -> Compile N.QName qualify (Ident _ name) = do   modulename <- gets stateModuleName   return (Qual () modulename (Ident () name))@@ -154,19 +151,21 @@   ParseFailed srcloc msg -> die (srcloc,msg)  -- | Get a config option.-config :: (CompileConfig -> a) -> Compile a+config :: (Config -> a) -> Compile a config f = asks (f . readerConfig)  -- | Optimize pattern matching conditions by merging conditions in common.+-- TODO This is buggy and no longer used. Fails on tests/case3 optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]-optimizePatConditions = concatMap merge . groupBy sameIf where+optimizePatConditions = id+  {- concatMap 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+  getIfConsequent other = other -}  -- | Throw a JS exception. throw :: String -> JsExp -> JsStmt@@ -216,7 +215,7 @@ warn "" = return () warn w = config id >>= io . (`ioWarn` w) -ioWarn :: CompileConfig -> String -> IO ()+ioWarn :: Config -> String -> IO () ioWarn _ "" = return () ioWarn cfg w =   when (configWall cfg) $@@ -238,7 +237,7 @@ typeToRecs (unAnn -> typ) = fromMaybe [] . lookup typ <$> gets stateRecordTypes  recToFields :: S.QName -> Compile [N.Name]-recToFields con = do+recToFields con =   case tryResolveName con of     Nothing -> return []     Just c -> fromMaybe [] . lookup c <$> gets stateRecords@@ -275,76 +274,15 @@ runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a runCompileModule reader' state' m = runErrorT (runRWST (unCompile m) reader' state') --- | Parse some Fay code.-parseFay :: Parseable ast => FilePath -> String -> ParseResult ast-parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP---- | Apply incredibly simplistic CPP handling. It only recognizes the following:------ > #if FAY--- > #ifdef FAY--- > #ifndef FAY--- > #else--- > #endif------ Note that this implementation replaces all removed lines with blanks, so--- that line numbers remain accurate.-applyCPP :: String -> String-applyCPP =-    unlines . loop NoCPP . lines-  where-    loop _ [] = []-    loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest-    loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest-    loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest-    loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest-    loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest-    loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest-    loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest--    toInclude NoCPP = True-    toInclude (CPPIf x state') = x && toInclude state'-    toInclude (CPPElse x state') = x && toInclude state'---- | The CPP's parsing state.-data CPPState = NoCPP-              | CPPIf Bool CPPState-              | CPPElse Bool CPPState---- | The parse mode for Fay.-parseMode :: ParseMode-parseMode = defaultParseMode-  { extensions = defaultExtensions-  , fixities = Just (preludeFixities ++ baseFixities)-  }- shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn -defaultExtensions :: [Extension]-defaultExtensions = map EnableExtension-  [EmptyDataDecls-  ,ExistentialQuantification-  ,FlexibleContexts-  ,FlexibleInstances-  ,GADTs-  ,ImplicitPrelude-  ,KindSignatures-  ,NamedFieldPuns-  ,PackageImports-  ,RecordWildCards-  ,StandaloneDeriving-  ,TupleSections-  ,TypeFamilies-  ,TypeOperators-  ]- -- | Check if the given language pragmas are all present. hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas   where     flattenPragmas :: [ModulePragma l] -> [String]-    flattenPragmas ps = concat $ map pragmaName ps+    flattenPragmas ps = concatMap pragmaName ps     pragmaName (LanguagePragma _ q) = map unname q     pragmaName _ = [] 

@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards     #-} {-# LANGUAGE TupleSections     #-}@@ -6,21 +7,16 @@  module Fay.Compiler.Optimizer where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc import           Fay.Types -import           Control.Applicative-import           Control.Arrow                   (first)-import           Control.Monad.Error import           Control.Monad.State import           Control.Monad.Writer-import           Data.List-import           Data.Maybe import qualified Fay.Exts.NoAnnotation           as N import           Language.Haskell.Exts.Annotated hiding (app, name, op) -import           Prelude                         hiding (exp)- -- | The arity of a function. Arity here is defined to be the number -- of arguments that can be directly uncurried from a curried lambda -- abstraction. So \x y z -> if x then (\a -> a) else (\a -> a) has an@@ -212,7 +208,7 @@ -- | Apply the given function to the top-level expressions in the -- given statement. applyToExpsInStmt :: [FuncArity] -> ([FuncArity] -> JsExp -> Optimize JsExp) -> JsStmt -> Optimize JsStmt-applyToExpsInStmt funcs f stmts = uncurryInStmt stmts where+applyToExpsInStmt funcs f = uncurryInStmt where   transform = f funcs   uncurryInStmt stmt = case stmt of     JsVar name exp              -> JsVar name <$> transform exp

@@ -4,16 +4,11 @@  module Fay.Compiler.Packages where -import           Fay.Compiler.Config-import           Fay.Control.Monad.Extra-import           Fay.System.Process.Extra-import           Fay.Types+import           Fay.Compiler.Prelude++import           Fay.Config import           Paths_fay -import           Control.Applicative-import           Control.Monad-import           Data.List-import           Data.Maybe import           Data.Version import           GHC.Paths import           System.Directory@@ -21,12 +16,12 @@  -- | Given a configuration, resolve any packages specified to their -- data file directories for importing the *.hs sources.-resolvePackages :: CompileConfig -> IO CompileConfig+resolvePackages :: Config -> IO Config resolvePackages config =   foldM resolvePackage config (configPackages config)  -- | Resolve package.-resolvePackage :: CompileConfig -> String -> IO CompileConfig+resolvePackage :: Config -> String -> IO Config resolvePackage config name = do   desc <- describePackage (configPackageConf config) name   case packageVersion desc of

@@ -0,0 +1,69 @@+module Fay.Compiler.Parse+  ( parseFay+  , defaultExtensions+  ) where++import           Language.Haskell.Exts.Annotated hiding (name)++-- | Parse some Fay code.+parseFay :: Parseable ast => FilePath -> String -> ParseResult ast+parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP++-- | Apply incredibly simplistic CPP handling. It only recognizes the following:+--+-- > #if FAY+-- > #ifdef FAY+-- > #ifndef FAY+-- > #else+-- > #endif+--+-- Note that this implementation replaces all removed lines with blanks, so+-- that line numbers remain accurate.+applyCPP :: String -> String+applyCPP =+    unlines . loop NoCPP . lines+  where+    loop _ [] = []+    loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest+    loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest+    loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest+    loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest+    loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest+    loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest+    loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest++    toInclude NoCPP = True+    toInclude (CPPIf x state') = x && toInclude state'+    toInclude (CPPElse x state') = x && toInclude state'++-- | The CPP's parsing state.+data CPPState = NoCPP+              | CPPIf Bool CPPState+              | CPPElse Bool CPPState++-- | The parse mode for Fay.+parseMode :: ParseMode+parseMode = defaultParseMode+  { extensions = defaultExtensions+  , fixities = Just (preludeFixities ++ baseFixities)+  }++defaultExtensions :: [Extension]+defaultExtensions = map EnableExtension+  [EmptyDataDecls+  ,ExistentialQuantification+  ,FlexibleContexts+  ,FlexibleInstances+  ,GADTs+  ,ImplicitPrelude+  ,KindSignatures+  ,LambdaCase+  ,MultiWayIf+  ,NamedFieldPuns+  ,PackageImports+  ,RecordWildCards+  ,StandaloneDeriving+  ,TupleSections+  ,TypeFamilies+  ,TypeOperators+  ]

@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-} @@ -5,6 +6,8 @@  module Fay.Compiler.Pattern where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc import           Fay.Compiler.QName import           Fay.Exts.NoAnnotation           (unAnn)@@ -12,12 +15,10 @@ import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Applicative import           Control.Monad.Error import           Control.Monad.Reader import           Language.Haskell.Exts.Annotated hiding (name) import           Language.Haskell.Names-import           Prelude hiding (exp)  -- | Compile the given pattern against the given expression. compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]@@ -26,16 +27,16 @@   PApp _ cons pats  -> do     newty <- lookupNewtypeConst cons     case newty of-      Nothing -> compilePApp cons pats exp body+      Nothing -> compilePApp pat cons pats exp body       Just _  -> compileNewtypePat pats exp body   PLit _ literal    -> compilePLit exp literal body-  PParen{}          -> shouldBeDesugared pat   PWildCard _       -> return body-  PInfixApp{}       -> compileInfixPat exp pat body   PList _ pats      -> compilePList pats body exp   PTuple _ _bx pats -> compilePList pats body exp   PAsPat _ name pt  -> compilePAsPat exp name pt body   PRec _ name pats  -> compilePatFields exp name pats body+  PParen{}          -> shouldBeDesugared pat+  PInfixApp{}       -> shouldBeDesugared pat   _                 -> throwError (UnsupportedPattern pat)  -- | Compile a pattern variable e.g. x.@@ -107,13 +108,26 @@ compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps  -- | Compile a pattern application.-compilePApp :: S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]-compilePApp cons pats exp body = do+compilePApp :: S.Pat -> S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]+compilePApp origPat cons pats exp body = do   let forcedExp = force exp   let boolIf b = return [JsIf (JsEq forcedExp (JsLit (JsBool b))) body []]   case cons of     -- Special-casing on the booleans.     Special _ (UnitCon _) -> return (JsExpStmt forcedExp : body)+    Special _ Cons{} -> case pats of+      [left, right] ->+        withScopedTmpJsName $ \tmpName -> do+          let forcedList = JsName tmpName+              x = JsGetProp forcedList (JsNameVar "car")+              xs = JsGetProp forcedList (JsNameVar "cdr")+          rightMatch <- compilePat xs right body+          leftMatch <- compilePat x left rightMatch+          return [JsVar tmpName (force exp)+                 ,JsIf (JsInstanceOf forcedList (JsBuiltIn "Cons"))+                       leftMatch+                       []]+      _ -> throwError $ UnsupportedPattern origPat     UnQual _ (Ident _ "True")   -> boolIf True     UnQual _ (Ident _ "False")  -> boolIf False     -- Everything else, generic:@@ -148,20 +162,3 @@   return [JsIf (JsApp (JsName (JsBuiltIn "listLen")) [forcedExp,patsLen])                stmts                []]---- | Compile an infix pattern (e.g. cons and tuples.)-compileInfixPat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]-compileInfixPat exp pat@(PInfixApp _ left (Special _ cons) right) body = case cons of-  Cons _ ->-    withScopedTmpJsName $ \tmpName -> do-      let forcedExp = JsName tmpName-          x = JsGetProp forcedExp (JsNameVar "car")-          xs = JsGetProp forcedExp (JsNameVar "cdr")-      rightMatch <- compilePat xs right body-      leftMatch <- compilePat x left rightMatch-      return [JsVar tmpName (force exp)-             ,JsIf (JsInstanceOf forcedExp (JsBuiltIn "Cons"))-                   leftMatch-                   []]-  _ -> throwError (UnsupportedPattern pat)-compileInfixPat _ pat _ = throwError (UnsupportedPattern pat)

@@ -0,0 +1,69 @@+-- | Re-exports of base functionality. Note that this module is just+-- used inside the compiler. It's not compiled to JavaScript.+-- Based on the base-extended package (c) 2013 Simon Meier, licensed as BSD3.+module Fay.Compiler.Prelude+  ( module Prelude       -- Partial++  -- * Control modules+  , module Control.Applicative+  , module Control.Arrow -- Partial+  , module Control.Monad++  -- * Data modules+  , module Data.Char     -- Partial+  , module Data.Data     -- Partial+  , module Data.Either+  , module Data.Function+  , module Data.List     -- Partial+  , module Data.Maybe+  , module Data.Monoid   -- Partial+  , module Data.Ord++  -- * Safe+  , module Safe++  -- * Additions+  , anyM+  , for+  , io+  , readAllFromProcess+  ) where++import           Control.Applicative+import           Control.Arrow       (first, second, (&&&), (***), (+++), (|||))+import           Control.Monad       hiding (guard)+import           Data.Char           hiding (GeneralCategory (..))+import           Data.Data           (Data (..), Typeable)+import           Data.Either+import           Data.Function       (on)+import           Data.List           hiding (delete)+import           Data.Maybe+import           Data.Monoid         (Monoid (..), (<>))+import           Data.Ord+import           Prelude             hiding (exp, mod)+import           Safe++import           Control.Monad.Error+import           System.Exit+import           System.Process++-- | Alias of liftIO, I hate typing it. Hate reading it.+io :: MonadIO m => IO a -> m a+io = liftIO++-- | Do any of the (monadic) predicates match?+anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM p l = return . not . null =<< filterM p l++-- | Flip of map.+for :: (Functor f) => f a -> (a -> b) -> f b+for = flip fmap++-- | Read from a process returning both std err and out.+readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String))+readAllFromProcess program flags input = do+  (code,out,err) <- readProcessWithExitCode program flags input+  return $ case code of+    ExitFailure 127 -> Left ("cannot find executable " ++ program, "")+    ExitFailure _   -> Left (err, out)+    ExitSuccess     -> Right (err, out)

@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-} @@ -21,13 +22,14 @@   , resolvePrimOp   ) where +import           Fay.Compiler.Prelude+ import           Fay.Exts.NoAnnotation           (unAnn) import qualified Fay.Exts.NoAnnotation           as N  import           Data.Map                        (Map) import qualified Data.Map                        as M import           Language.Haskell.Exts.Annotated hiding (binds, name)-import           Prelude                         hiding (mod)  -- | Make an identifier from the built-in HJ module. fayBuiltin :: a -> String -> QName a

@@ -1,6 +1,6 @@ {-# OPTIONS -fno-warn-orphans        #-}-{-# OPTIONS -fno-warn-unused-do-bind #-} {-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE NoImplicitPrelude    #-} {-# LANGUAGE RecordWildCards      #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns         #-}@@ -16,19 +16,16 @@  module Fay.Compiler.Print where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.PrimOp-import qualified Fay.Exts.NoAnnotation                  as N+import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types -import           Control.Monad import           Control.Monad.State import           Data.Aeson.Encode-import qualified Data.ByteString.Lazy.UTF8              as UTF8-import           Data.Default-import           Data.List-import           Data.String-import           Language.Haskell.Exts.Annotated        hiding (alt, name, op, sym)-import           Prelude                                hiding (exp)+import qualified Data.ByteString.Lazy.UTF8       as UTF8+import           Language.Haskell.Exts.Annotated hiding (alt, name, op, sym) import           SourceMap.Types  --------------------------------------------------------------------------------@@ -36,11 +33,11 @@  -- | Print the JS to a flat string. printJSString :: Printable a => a -> String-printJSString x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def+printJSString x = concat . reverse . psOutput $ execState (runPrinter (printJS x)) defaultPrintState  -- | Print the JS to a pretty string. printJSPretty :: Printable a => a -> String-printJSPretty x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def { psPretty = True }+printJSPretty x = concat . reverse . psOutput $ execState (runPrinter (printJS x)) defaultPrintState { psPretty = True }  -- | Print literals. These need some special encoding for -- JS-format literals. Could use the Text.JSON library.@@ -120,12 +117,12 @@     "if (" +> exp +> ") {" +> newline +>     indented (printJS thens) +>     "}" +>-    (when (length elses > 0) $ " else {" +>+    (unless (null elses) $ " else {" +>     indented (printJS elses) +>     "}") +> newline   printJS (JsEarlyReturn exp) =     "return " +> exp +> ";" +> newline-  printJS (JsThrow exp) = do+  printJS (JsThrow exp) =     "throw " +> exp +> ";" +> newline   printJS (JsWhile cond stmts) =     "while (" +> cond +> ") {"  +> newline +>@@ -156,7 +153,7 @@   printJS (JsList exps) =     "[" +> intercalateM "," (map printJS exps) +> printJS "]"   printJS (JsNew name args) =-    "new " +> (JsApp (JsName name) args)+    "new " +> JsApp (JsName name) args   printJS (JsIndex i exp) =     "(" +> exp +> ")[" +> show i +> "]"   printJS (JsEq exp1 exp2) =@@ -179,10 +176,10 @@   printJS (JsInstanceOf exp classname) =     exp +> " instanceof " +> classname   printJS (JsObj assoc) =-    "{" +> (intercalateM "," (map cons assoc)) +> "}"+    "{" +> intercalateM "," (map cons assoc) +> "}"       where cons (key,value) = "\"" +> key +> "\": " +> value   printJS (JsLitObj assoc) =-    "{" +> (intercalateM "," (map cons assoc)) +> "}"+    "{" +> intercalateM "," (map cons assoc) +> "}"       where         cons :: (N.Name, JsExp) -> Printer ()         cons (key,value) = "\"" +> key +> "\": " +> value@@ -190,7 +187,7 @@        "function"     +> maybe (return ()) ((" " +>) . printJS . ident) nm     +> "("-    +> (intercalateM "," (map printJS params))+    +> intercalateM "," (map printJS params)     +> "){" +> newline     +> indented (stmts +>                  case ret of@@ -288,9 +285,7 @@  -- | Normalize the given name to JavaScript-valid names. normalizeName :: String -> String-normalizeName name =-  concatMap encodeChar name-+normalizeName = concatMap encodeChar   where     encodeChar c | c `elem` allowed = [c]                  | otherwise        = escapeChar c@@ -309,9 +304,9 @@   PrintState{..} <- get   if psPretty      then do modify $ \s -> s { psIndentLevel = psIndentLevel + 1 }-             p+             void p              modify $ \s -> s { psIndentLevel = psIndentLevel }-     else p >> return ()+     else void p  -- | Output a newline. newline :: Printer ()@@ -355,9 +350,9 @@ -- | Intercalate monadic action. intercalateM :: String -> [Printer a] -> Printer () intercalateM _ [] = return ()-intercalateM _ [x] = x >> return ()+intercalateM _ [x] = void x intercalateM str (x:xs) = do-  x+  void x   write str   intercalateM str xs 

@@ -40,10 +40,10 @@ -- | Is this *resolved* name a new type constructor or destructor? isNewtype :: SymValueInfo OrigName -> CompileState -> Bool isNewtype s cs = case s of-  SymValue{}                     -> False-  SymMethod{}                    -> False-  SymSelector    { sv_typeName } -> not . (`isNewtypeDest` cs) . origName2QName $ sv_typeName-  SymConstructor { sv_typeName } -> not . (`isNewtypeCons` cs) . origName2QName $ sv_typeName+  SymValue{}                          -> False+  SymMethod{}                         -> False+  SymSelector    { sv_typeName = tn } -> not . (`isNewtypeDest` cs) . origName2QName $ tn+  SymConstructor { sv_typeName = tn } -> not . (`isNewtypeCons` cs) . origName2QName $ tn  -- | Is this *resolved* name a new type destructor? isNewtypeDest :: N.QName -> CompileState -> Bool@@ -61,6 +61,6 @@ addedModulePath :: ModulePath -> CompileState -> Bool addedModulePath mp CompileState { stateJsModulePaths } = mp `S.member` stateJsModulePaths -+-- | Find the type signature of a top level name findTypeSig :: N.QName -> CompileState -> Maybe N.Type findTypeSig n  = M.lookup n . stateTypeSigs

@@ -2,17 +2,17 @@  module Fay.Compiler.Typecheck where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Defaults import           Fay.Compiler.Misc-import           Fay.System.Process.Extra+import           Fay.Config import           Fay.Types -import           Data.List-import           Data.Maybe-import qualified GHC.Paths                as GHCPaths+import qualified GHC.Paths             as GHCPaths  -- | Call out to GHC to type-check the file.-typecheck :: CompileConfig -> FilePath -> IO (Either CompileError String)+typecheck :: Config -> FilePath -> IO (Either CompileError String) typecheck cfg fp = do   faydir <- faySourceDir   let includes = configDirectoryIncludes cfg

@@ -0,0 +1,146 @@+-- | Configuring the compiler++module Fay.Config+  ( Config+      ( configOptimize+      , configFlattenApps+      , configExportRuntime+      , configExportStdlib+      , configExportStdlibOnly+      , configPrettyPrint+      , configHtmlWrapper+      , configSourceMap+      , configHtmlJSLibs+      , configLibrary+      , configWarn+      , configFilePath+      , configTypecheck+      , configWall+      , configGClosure+      , configPackageConf+      , configBasePath+      , configStrict+      , configTypecheckOnly+      , configRuntimePath+      )+  , defaultConfig+  , configDirectoryIncludes+  , configDirectoryIncludePaths+  , nonPackageConfigDirectoryIncludePaths+  , addConfigDirectoryInclude+  , addConfigDirectoryIncludes+  , addConfigDirectoryIncludePaths+  , configPackages+  , addConfigPackage+  , addConfigPackages+  , shouldExportStrictWrapper+  ) where++import           Fay.Compiler.Prelude++import           Data.Default+import           Data.Maybe                      ()+import           Language.Haskell.Exts.Annotated (ModuleName (..))++-- | Configuration of the compiler.+-- The fields with a leading underscore+data Config = Config+  { configOptimize           :: Bool                        -- ^ Run optimizations+  , configFlattenApps        :: Bool                        -- ^ Flatten function application?+  , configExportRuntime      :: Bool                        -- ^ Export the runtime?+  , configExportStdlib       :: Bool                        -- ^ Export the stdlib?+  , configExportStdlibOnly   :: Bool                        -- ^ Export /only/ the stdlib?+  , _configDirectoryIncludes :: [(Maybe String, FilePath)]  -- ^ Possibly a fay package name, and a include directory.+  , configPrettyPrint        :: Bool                        -- ^ Pretty print the JS output?+  , configHtmlWrapper        :: Bool                        -- ^ Output a HTML file including the produced JS.+  , configSourceMap          :: Bool                        -- ^ Output a source map file as outfile.map.+  , configHtmlJSLibs         :: [FilePath]                  -- ^ Any JS files to link to in the HTML.+  , configLibrary            :: Bool                        -- ^ Don't invoke main in the produced JS.+  , configWarn               :: Bool                        -- ^ Warn on dubious stuff, not related to typechecking.+  , configFilePath           :: Maybe FilePath              -- ^ File path to output to.+  , configTypecheck          :: Bool                        -- ^ Typecheck with GHC.+  , configWall               :: Bool                        -- ^ Typecheck with -Wall.+  , configGClosure           :: Bool                        -- ^ Run Google Closure on the produced JS.+  , configPackageConf        :: Maybe FilePath              -- ^ The package config e.g. packages-6.12.3.+  , _configPackages          :: [String]                    -- ^ Included Fay packages.+  , configBasePath           :: Maybe FilePath              -- ^ Custom source location for fay-base+  , configStrict             :: [String]                    -- ^ Produce strict and uncurried JavaScript callable wrappers for all+                                                            --   exported functions with type signatures in the given module+  , configTypecheckOnly      :: Bool                        -- ^ Only invoke GHC for typechecking, don't produce any output+  , configRuntimePath        :: Maybe FilePath+  } deriving (Show)+++defaultConfig :: Config+defaultConfig = addConfigPackage "fay-base"+  Config+    { configOptimize           = False+    , configFlattenApps        = False+    , configExportRuntime      = True+    , configExportStdlib       = True+    , configExportStdlibOnly   = False+    , _configDirectoryIncludes = []+    , configPrettyPrint        = False+    , configHtmlWrapper        = False+    , configHtmlJSLibs         = []+    , configLibrary            = False+    , configWarn               = True+    , configFilePath           = Nothing+    , configTypecheck          = True+    , configWall               = False+    , configGClosure           = False+    , configPackageConf        = Nothing+    , _configPackages          = []+    , configBasePath           = Nothing+    , configStrict             = []+    , configTypecheckOnly      = False+    , configRuntimePath        = Nothing+    , configSourceMap          = False+    }++-- | Default configuration.+instance Default Config where+  def = defaultConfig++-- | Reading _configDirectoryIncludes is safe to do.+configDirectoryIncludes :: Config -> [(Maybe String, FilePath)]+configDirectoryIncludes = _configDirectoryIncludes++-- | Get all include directories without the package mapping.+configDirectoryIncludePaths :: Config -> [FilePath]+configDirectoryIncludePaths = map snd . _configDirectoryIncludes++-- | Get all include directories not included through packages.+nonPackageConfigDirectoryIncludePaths :: Config -> [FilePath]+nonPackageConfigDirectoryIncludePaths = map snd . filter (isJust . fst) . _configDirectoryIncludes++-- | Add a mapping from (maybe) a package to a source directory+addConfigDirectoryInclude :: Maybe String -> FilePath -> Config -> Config+addConfigDirectoryInclude pkg fp cfg = cfg { _configDirectoryIncludes = (pkg, fp) : _configDirectoryIncludes cfg }++-- | Add several include directories.+addConfigDirectoryIncludes :: [(Maybe String,FilePath)] -> Config -> Config+addConfigDirectoryIncludes pkgFps cfg = foldl (\c (pkg,fp) -> addConfigDirectoryInclude pkg fp c) cfg pkgFps++-- | 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]+configPackages = _configPackages++-- | Add a package to compilation+addConfigPackage :: String -> Config -> Config+addConfigPackage pkg cfg = cfg { _configPackages = pkg : _configPackages cfg }++-- | Add several packages to compilation+addConfigPackages :: [String] -> Config -> Config+addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps+++-- | Should a strict wrapper be generated for this module?+shouldExportStrictWrapper :: ModuleName a -> Config -> Bool+shouldExportStrictWrapper (ModuleName _ m) cs = m `elem` configStrict cs

@@ -1,31 +0,0 @@--- | Extra monadic functions.--module Fay.Control.Monad.Extra where--import           Control.Monad-import           Data.Maybe---- | Word version of flip (>>=).-bind :: (Monad m) => (a -> m b) -> m a -> m b-bind = flip (>>=)---- | When the value is Just.-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---- | Flip of mapMaybe.-forMaybe :: [a] -> (a -> Maybe b) -> [b]-forMaybe = flip mapMaybe---- | Monadic version of maybe.-maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a-maybeM nil cons a = maybe (return nil) cons a---- | Do any of the (monadic) predicates match?-anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool-anyM p l = return . not . null =<< filterM p l

@@ -1,9 +0,0 @@--- | Alias of MonadIO.--module Fay.Control.Monad.IO where--import           Control.Monad.Trans---- | Alias of liftIO, I hate typing it. Hate reading it.-io :: MonadIO m => IO a -> m a-io = liftIO

@@ -1,252 +1,247 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE PatternGuards      #-}-{-# LANGUAGE TupleSections      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE ViewPatterns        #-} {-# OPTIONS -fno-warn-type-defaults #-}  -- | Convert a Haskell value to a (JSON representation of a) Fay value.  module Fay.Convert   (showToFay-  ,readFromFay)+  ,readFromFay+  ,readFromFay'+  ,encodeFay+  ,decodeFay)   where -import           Control.Applicative-import           Control.Monad+import           Fay.Compiler.Prelude+ import           Control.Monad.State+import           Control.Spoon import           Data.Aeson-import           Data.Attoparsec.Number-import           Data.Char+import           Data.Aeson.Types      (parseEither) import           Data.Data-import           Data.Function import           Data.Generics.Aliases-import           Data.HashMap.Strict    (HashMap)-import qualified Data.HashMap.Strict    as Map-import           Data.Maybe-import           Data.Text              (Text)-import qualified Data.Text              as Text-import           Data.Vector            (Vector)-import qualified Data.Vector            as Vector-import           Numeric-import           Safe-import qualified Text.Show.Pretty       as Show-#if MIN_VERSION_aeson(0,7,0)-import Data.Scientific-#endif+import           Data.HashMap.Strict   (HashMap)+import qualified Data.HashMap.Strict   as Map+import           Data.Text             (Text)+import qualified Data.Text             as Text+import           Data.Vector           (Vector)+import qualified Data.Vector           as Vector  -------------------------------------------------------------------------------- -- The conversion functions. --- | Convert a Haskell value to a value representing a Fay value.-showToFay :: Show a => a -> Maybe Value-showToFay = Show.reify >=> convert where-  convert value = case value of-    -- Special cases-    Show.Con "True" _    -> return (Bool True)-    Show.Con "False" _   -> return (Bool False)--    -- Objects/records-    Show.Con name values -> fmap (Object . Map.fromList . (("instance",string name) :))-                                 (slots values)-    Show.Rec name fields -> fmap (Object . Map.fromList . (("instance",string name) :))-                                 (mapM (uncurry keyval) fields)-    Show.InfixCons _ _ -> Nothing -- TODO https://github.com/faylang/fay/issues/316--    -- ()-    Show.Tuple [] -> return Null--    -- List types-    Show.Tuple values -> fmap (Array . Vector.fromList) (mapM convert values)-    Show.List values  -> fmap (Array . Vector.fromList) (mapM convert values)--    -- Text types-    Show.String chars -> fmap string (readMay chars)-    Show.Char char    -> fmap (string.return) (readMay char)+-- | Convert a Haskell value to a Fay json value.  This can fail when primitive+--   values aren't handled by explicit cases.  'encodeFay' can be used to+--   resolve this issue.+showToFay :: Data a => a -> Maybe Value+showToFay = encodeFay (\x -> x) -    -- Numeric types (everything treated as a double)-    Show.Neg{}     -> double <|> int-    Show.Integer{} -> int-    Show.Float{}   -> double-    Show.Ratio{}   -> double-    where double = convertDouble value-          int = convertInt value+-- | Convert a Haskell value to a Fay json value.  This can fail when primitive+--   values aren't handled by explicit cases.  When this happens, you can add+--   additional cases via the first parameter.+--+--   The first parameter is a function that can be used to override the+--   conversion.  This usually looks like using 'extQ' to additional type-+--   specific cases.+encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ (Maybe Value)+encodeFay specialCases = spoon . encodeFayInternal specialCases -  -- Number converters+encodeFayInternal :: (GenericQ Value -> GenericQ Value) -> GenericQ Value+encodeFayInternal specialCases = specialCases $+    encodeGeneric rec+    `extQ` unit+    `extQ` Bool+    `extQ` (toJSON :: Int -> Value)+    `extQ` (toJSON :: Float -> Value)+    `extQ` (toJSON :: Double -> Value)+    `ext1Q` list+    `extQ` string+    `extQ` char+    `extQ` text+  where+    rec :: GenericQ Value+    rec = encodeFayInternal specialCases+    unit () = Null+    list :: Data a => [a] -> Value+    list = Array . Vector.fromList . map rec+    string = String . Text.pack+    char = String . Text.pack . (:[])+    text = String -#if MIN_VERSION_aeson(0,7,0)-  convertDouble = fmap (Number . fromFloatDigits) . pDouble-  convertInt = fmap (Number . fromInteger) . pInt-#else-  convertDouble = fmap (Number . D) . pDouble-  convertInt = fmap (Number . I) . pInt-#endif+encodeGeneric :: GenericQ Value -> GenericQ Value+encodeGeneric rec x =+    case constrName of+      '(':(dropWhile (==',') -> ")") ->+        Array $ Vector.fromList $ gmapQ rec x+      _ -> Object $ Map.fromList $ map (first Text.pack) fields+  where+    fields =+      ("instance", String $ Text.pack constrName) :+      zip labels (gmapQ rec x)+    constrName = showConstr constr+    constr = toConstr x+    -- Note: constrFields can throw errors for non-algebraic datatypes.  These+    -- ought to be taken care of in the other cases of encodeFay.+    labels = case constrFields constr of+      [] -> map (("slot"++).show) [1::Int ..]+      ls -> ls -  -- Number parsers-  pDouble :: Show.Value -> Maybe Double-  pDouble value = case value of-    Show.Float str   -> getDouble str-    Show.Ratio x y   -> liftM2 (on (/) fromIntegral) (pInt x) (pInt y)-    Show.Neg str     -> fmap (* (-1)) (pDouble str)-    _ -> Nothing-  pInt value = case value of-    Show.Integer str -> getInt str-    Show.Neg str     -> fmap (* (-1)) (pInt str)-    _ -> Nothing+-- | Convert a Fay json value to a Haskell value.+readFromFay :: Data a => Value -> Maybe a+readFromFay = either (\_ -> Nothing) Just . decodeFay (\_ -> id) -  -- Number readers-  getDouble :: String -> Maybe Double-  getDouble = fmap fst . listToMaybe . readFloat-  getInt :: String -> Maybe Integer-  getInt = fmap fst . listToMaybe . readInt 10 isDigit charToInt-    where charToInt c = fromEnum c - fromEnum '0'+-- | Convert a Fay json value to a Haskell value.  This is like readFromFay,+--   except it yields helpful error messages on failure.+readFromFay' :: Data a => Value -> Either String a+readFromFay' = decodeFay (\_ -> id) -  -- Utilities-  string = String . Text.pack-  slots = zipWithM keyval (map (("slot"++).show) [1::Int ..])-  keyval key val = fmap (Text.pack key,) (convert val)+-- | Convert a Fay json value to a Haskell value.+--+--   The first parameter is a function that can be used to override the+--   conversion.  This usually looks like using 'extR' to additional type-+--   specific cases.+decodeFay :: Data b+          => (forall a. Data a => Value -> Either String a -> Either String a)+          -> Value+          -> Either String b+decodeFay specialCases value = specialCases value $+    parseDataOrTuple rec value+    `extR` parseUnit value+    `extR` parseBool value+    `extR` parseInt value+    `extR` parseFloat value+    `extR` parseDouble value+    `ext1R` parseArray rec value+    `extR` parseString value+    `extR` parseChar value+    `extR` parseText value+  where+    rec :: GenericParser+    rec = decodeFay specialCases --- | Convert a value representing a Fay value to a Haskell value.-readFromFay :: Data a => Value -> Maybe a-readFromFay value =-  parseDataOrTuple value-  `ext1R` parseArray value-  `extR` parseDouble value-  `extR` parseInt value-  `extR` parseInteger value-  `extR` parseBool value-  `extR` parseString value-  `extR` parseChar value-  `extR` parseText value-  `extR` parseUnit value+type GenericParser = Data a => Value -> Either String a  -- | Parse a data type or record or tuple.-parseDataOrTuple :: Data a => Value -> Maybe a-parseDataOrTuple value = result where+parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a+parseDataOrTuple rec value = result where   result = getAndParse value-  typ = dataTypeOf (fromJust result)+  typ = dataTypeOf (undefined :: a)   getAndParse x =     case x of-      Object obj -> parseObject typ obj-      Array tuple -> parseTuple typ tuple-      _ -> mzero+      Object obj -> parseObject rec typ obj+      Array tuple -> parseTuple rec typ tuple+      _ -> badData value  -- | Parse a tuple.-parseTuple :: Data a => DataType -> Vector Value -> Maybe a-parseTuple typ arr =+parseTuple :: Data a => GenericParser -> DataType -> Vector Value -> Either String a+parseTuple rec typ arr =   case dataTypeConstrs typ of     [cons] -> evalStateT (fromConstrM (do i:next <- get                                           put next                                           value <- lift (Vector.indexM arr i)-                                          lift (readFromFay value))+                                          lift (rec value))                                       cons)                          [0..]-    _ -> Nothing+    _ -> badData (Array arr)  -- | Parse a data constructor from an object.-parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a-parseObject typ obj = listToMaybe (catMaybes choices) where-  choices = map makeConstructor constructors-  constructors = dataTypeConstrs typ-  makeConstructor cons = do-    name <- Map.lookup (Text.pack "instance") obj >>= parseString-    guard (showConstr cons == name)-    if null fields-      then makeSimple obj cons-      else makeRecord obj cons fields--      where fields = constrFields cons+parseObject :: Data a => GenericParser -> DataType -> HashMap Text Value -> Either String a+parseObject rec typ obj =+  case Map.lookup (Text.pack "instance") obj of+    Just (parseString -> Right name) ->+      case filter (\con -> showConstr con == name) (dataTypeConstrs typ) of+        [con] ->+          let fields = constrFields con+           in if null fields+                then makeSimple rec obj con+                else makeRecord rec obj con fields+        _ -> badData (Object obj)+    _ -> badData (Object obj)  -- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2-makeSimple :: Data a => HashMap Text Value -> Constr -> Maybe a-makeSimple obj cons =+makeSimple :: Data a => GenericParser -> HashMap Text Value -> Constr -> Either String a+makeSimple rec obj cons =   evalStateT (fromConstrM (do i:next <- get                               put next-                              value <- lift (Map.lookup (Text.pack ("slot" ++ show i)) obj)-                              lift (readFromFay value))+                              value <- lift (lookupField obj (Text.pack ("slot" ++ show i)))+                              lift (rec value))                           cons)              [1..]  -- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 }-makeRecord :: Data a => HashMap Text Value -> Constr -> [String] -> Maybe a-makeRecord obj cons fields =+makeRecord :: Data a => GenericParser -> HashMap Text Value -> Constr -> [String] -> Either String a+makeRecord rec obj cons fields =   evalStateT (fromConstrM (do key:next <- get                               put next-                              value <- lift (Map.lookup (Text.pack key) obj)-                              lift (readFromFay value))+                              value <- lift (lookupField obj (Text.pack key))+                              lift (rec value))                           cons)              fields --- | Parse a double.-parseDouble :: Value -> Maybe Double-parseDouble value = do-  number <- parseNumber value-  case number of-    I n -> return (fromIntegral n)-    D n -> return n+lookupField :: HashMap Text Value -> Text -> Either String Value+lookupField obj key =+  justRight ("Missing field " ++ Text.unpack key ++ " in " ++ show (Object obj)) $+  Map.lookup key obj --- | Parse an int.-parseInt :: Value -> Maybe Int-parseInt value = do-  number <- parseNumber value-  case number of-    I n -> return (fromIntegral n)-    _ -> mzero+-- | Parse a float.+parseFloat :: Value -> Either String Float+parseFloat = parseEither parseJSON --- | Parse an integer.-parseInteger :: Value -> Maybe Integer-parseInteger value = do-  number <- parseNumber value-  case number of-    I n -> return n-    _ -> mzero+-- | Parse a double.+parseDouble :: Value -> Either String Double+parseDouble = parseEither parseJSON --- | Parse a number.-parseNumber :: Value -> Maybe Number-#if MIN_VERSION_aeson(0,7,0)-parseNumber value = case value of-  Number n-    | base10Exponent n >= 0 -> return . I . round $ n-    | otherwise             -> return . D . fromRational . toRational $ n-  _ -> mzero-#else-parseNumber value = case value of-  Number n -> return n-  _ -> mzero-#endif+-- | Parse an int.+parseInt :: Value -> Either String Int+parseInt = parseEither parseJSON  -- | Parse a bool.-parseBool :: Value -> Maybe Bool+parseBool :: Value -> Either String Bool parseBool value = case value of   Bool n -> return n-  _ -> mzero+  _ -> badData value  -- | Parse a string.-parseString :: Value -> Maybe String+parseString :: Value -> Either String String parseString value = case value of   String s -> return (Text.unpack s)-  _ -> mzero+  _ -> badData value  -- | Parse a char.-parseChar :: Value -> Maybe Char+parseChar :: Value -> Either String Char parseChar value = case value of   String s | Just (c,_) <- Text.uncons s -> return c-  _ -> mzero+  _ -> badData value  -- | Parse a Text.-parseText :: Value -> Maybe Text+parseText :: Value -> Either String Text parseText value = case value of   String s -> return s-  _ -> mzero+  _ -> badData value  -- | Parse an array.-parseArray :: Data a => Value -> Maybe [a]-parseArray value = case value of-  Array xs -> mapM readFromFay (Vector.toList xs)-  _ -> mzero+parseArray :: Data a => GenericParser -> Value -> Either String [a]+parseArray rec value = case value of+  Array xs -> mapM rec (Vector.toList xs)+  _ -> badData value  -- | Parse unit.-parseUnit :: Value -> Maybe ()+parseUnit :: Value -> Either String () parseUnit value = case value of   Null -> return ()-  _ -> mzero+  _ -> badData value++badData :: forall a. Data a => Value -> Either String a+badData value = Left $+  "Bad data in decodeFay - expected valid " +++  show (typeOf (undefined :: a)) +++  ", but got:\n" +++  show value++justRight :: b -> Maybe a -> Either b a+justRight x Nothing = Left x+justRight _ (Just y) = Right y

@@ -1,14 +0,0 @@--- | Extra list functions.--module Fay.Data.List.Extra where--import           Data.List hiding (map)-import           Prelude   hiding (map)---- | Get the union of a list of lists.-unionOf :: (Eq a) => [[a]] -> [a]-unionOf = foldr union []---- | Flip of map.-for :: (Functor f) => f a -> (a -> b) -> f b-for = flip fmap

@@ -46,7 +46,7 @@ moduleExports :: A.Module X -> Maybe (A.ExportSpecList X) moduleExports (A.Module _ (Just (A.ModuleHead _ _ _ e)) _ _ _) = e moduleExports (A.Module _ Nothing                     _ _ _) = Nothing-moduleExports m = error $ ("moduleExports: " ++ A.prettyPrint m)+moduleExports m = error $ "moduleExports: " ++ A.prettyPrint m  moduleNameString :: A.ModuleName t -> String moduleNameString (A.ModuleName _ n) = n

@@ -2,9 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} module Fay.Exts.NoAnnotation where +import           Fay.Compiler.Prelude -import           Data.Char                       (isAlpha)-import           Data.List                       (intercalate) import           Data.List.Split                 (splitOn) import           Data.String import qualified Language.Haskell.Exts.Annotated as A@@ -46,7 +45,7 @@ type Type = A.Type ()  unAnn :: Functor f => f a -> f ()-unAnn = fmap (const ())+unAnn = void  -- | Helpful for some things. instance IsString (A.Name ()) where

@@ -1,21 +0,0 @@--- | Extra directory functions.-module Fay.System.Directory.Extra where--import           Control.Monad    (forM)-import           System.Directory (doesDirectoryExist, getDirectoryContents)-import           System.FilePath  ((</>))---- | Get all files in a folder and its subdirectories.--- Taken from Real World Haskell--- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html-getRecursiveContents :: FilePath -> IO [FilePath]-getRecursiveContents topdir = do-  names <- getDirectoryContents topdir-  let properNames = filter (`notElem` [".", ".."]) names-  paths <- forM properNames $ \name -> do-    let path = topdir </> name-    isDirectory <- doesDirectoryExist path-    if isDirectory-      then getRecursiveContents path-      else return [path]-  return (concat paths)

@@ -1,15 +0,0 @@--- | Extra process functions.--module Fay.System.Process.Extra where--import           System.Exit-import           System.Process---- | Read from a process returning both std err and out.-readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String))-readAllFromProcess program flags input = do-  (code,out,err) <- readProcessWithExitCode program flags input-  return $ case code of-    ExitFailure 127 -> Left ("cannot find executable " ++ program, "")-    ExitFailure _   -> Left (err, out)-    ExitSuccess     -> Right (err, out)

@@ -10,16 +10,16 @@   ,JsName(..)   ,CompileError(..)   ,Compile(..)-  ,CompileResult   ,CompileModule   ,Printable(..)   ,Fay   ,CompileReader(..)   ,CompileWriter(..)-  ,CompileConfig(..)+  ,Config(..)   ,CompileState(..)   ,FundamentalType(..)   ,PrintState(..)+  ,defaultPrintState   ,Printer(..)   ,SerializeContext(..)   ,ModulePath (unModulePath)@@ -28,75 +28,29 @@   ,mkModulePathFromQName   ) where -import           Fay.Compiler.QName-import qualified Fay.Exts                          as F+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.FFI+import           Fay.Types.Js+import           Fay.Types.ModulePath -import           Control.Applicative-import           Control.Monad.Error               (Error, ErrorT, MonadError)+import           Control.Monad.Error               (ErrorT, MonadError) import           Control.Monad.Identity            (Identity) import           Control.Monad.RWS import           Control.Monad.State-import           Data.Default-import           Data.List-import           Data.List.Split import           Data.Map                          (Map) import           Data.Set                          (Set)-import           Data.String import           Distribution.HaskellSuite.Modules-import           Language.Haskell.Exts.Annotated import           Language.Haskell.Names            (Symbols) import           SourceMap.Types  -------------------------------------------------------------------------------- -- Compiler types --- | Configuration of the compiler.-data CompileConfig = CompileConfig-  { configOptimize          :: Bool                        -- ^ Run optimizations-  , configFlattenApps       :: Bool                        -- ^ Flatten function application?-  , configExportRuntime     :: Bool                        -- ^ Export the runtime?-  , configExportStdlib      :: Bool                        -- ^ Export the stdlib?-  , configExportStdlibOnly  :: Bool                        -- ^ Export /only/ the stdlib?-  , configDirectoryIncludes :: [(Maybe String, FilePath)]  -- ^ Possibly a fay package name, and a include directory.-  , configPrettyPrint       :: Bool                        -- ^ Pretty print the JS output?-  , configHtmlWrapper       :: Bool                        -- ^ Output a HTML file including the produced JS.-  , configSourceMap         :: Bool                        -- ^ Output a source map file as outfile.map.-  , configHtmlJSLibs        :: [FilePath]                  -- ^ Any JS files to link to in the HTML.-  , configLibrary           :: Bool                        -- ^ Don't invoke main in the produced JS.-  , configWarn              :: Bool                        -- ^ Warn on dubious stuff, not related to typechecking.-  , configFilePath          :: Maybe FilePath              -- ^ File path to output to.-  , configTypecheck         :: Bool                        -- ^ Typecheck with GHC.-  , configWall              :: Bool                        -- ^ Typecheck with -Wall.-  , configGClosure          :: Bool                        -- ^ Run Google Closure on the produced JS.-  , configPackageConf       :: Maybe FilePath              -- ^ The package config e.g. packages-6.12.3.-  , configPackages          :: [String]                    -- ^ Included Fay packages.-  , configBasePath          :: Maybe FilePath              -- ^ Custom source location for fay-base-  , configStrict            :: [String]                    -- ^ Produce strict and uncurried wrappers for all functions with type signatures in the given module-  , configTypecheckOnly     :: Bool                        -- ^ Only invoke GHC for typechecking, don't produce any output-  , configRuntimePath       :: Maybe FilePath-  } deriving (Show)---- | The name of a module split into a list for code generation.-newtype ModulePath = ModulePath { unModulePath :: [String] }-  deriving (Eq, Ord, Show)---- | Construct the complete ModulePath from a ModuleName.-mkModulePath :: ModuleName a -> ModulePath-mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m---- | Construct intermediate module paths from a ModuleName.--- mkModulePaths "A.B" => [["A"], ["A","B"]]-mkModulePaths :: ModuleName a -> [ModulePath]-mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m---- | Converting a QName to a ModulePath is only relevant for constructors since--- they can conflict with module names.-mkModulePathFromQName :: QName a -> ModulePath-mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n-mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name"- -- | State of the compiler. data CompileState = CompileState   -- TODO Change N.QName to GName? They can never be special so it would simplify.@@ -117,8 +71,7 @@   { writerCons    :: [JsStmt]         -- ^ Constructors.   , writerFayToJs :: [(String,JsExp)] -- ^ Fay to JS dispatchers.   , writerJsToFay :: [(String,JsExp)] -- ^ JS to Fay dispatchers.-  }-  deriving (Show)+  } deriving (Show)  -- | Simple concatenating instance. instance Monoid CompileWriter where@@ -128,43 +81,34 @@  -- | Configuration and globals for the compiler. data CompileReader = CompileReader-  { readerConfig       :: CompileConfig -- ^ The compilation configuration.+  { readerConfig       :: Config -- ^ The compilation configuration.   , readerCompileLit   :: S.Literal -> Compile JsExp   , readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]   }  -- | Compile monad. newtype Compile a = Compile-  { unCompile :: (RWST CompileReader-                      CompileWriter-                      CompileState-                      (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO)))-                   a -- ^ Uns the compiler-  }-  deriving (MonadState CompileState-           ,MonadError CompileError-           ,MonadReader CompileReader-           ,MonadWriter CompileWriter-           ,MonadIO-           ,Monad-           ,Functor-           ,Applicative-           )--type CompileResult a-  = Either CompileError-           (a, CompileState, CompileWriter)+  { unCompile :: RWST CompileReader CompileWriter CompileState+                      (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO))+                      a -- ^ Uns the compiler+  } deriving+    ( Applicative+    , Functor+    , Monad+    , MonadError CompileError+    , MonadIO+    , MonadReader CompileReader+    , MonadState CompileState+    , MonadWriter CompileWriter+    ) -type CompileModule a-  = ModuleT Symbols-            IO-            (CompileResult a)+type CompileModule a = ModuleT Symbols IO (Either CompileError (a, CompileState, CompileWriter))  instance MonadModule Compile where   type ModuleInfo Compile = Symbols   lookupInCache        = liftModuleT . lookupInCache   insertInCache n m    = liftModuleT $ insertInCache n m-  getPackages          = liftModuleT $ getPackages+  getPackages          = liftModuleT getPackages   readModuleInfo fps n = liftModuleT $ readModuleInfo fps n  liftModuleT :: ModuleT Symbols IO a -> Compile a@@ -182,163 +126,26 @@   }  -- | Default state.-instance Default PrintState where-  def = PrintState False 0 0 [] 0 [] False+defaultPrintState :: PrintState+defaultPrintState = PrintState False 0 0 [] 0 [] False  -- | The printer monad. newtype Printer a = Printer { runPrinter :: State PrintState a }-  deriving (Applicative,Monad,Functor,MonadState PrintState)+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadState PrintState+    )  -- | Print some value. class Printable a where   printJS :: a -> Printer () --- | Error type.-data CompileError-  = Couldn'tFindImport N.ModuleName [FilePath]-  | EmptyDoBlock-  | FfiFormatBadChars SrcSpanInfo String-  | FfiFormatIncompleteArg SrcSpanInfo-  | FfiFormatInvalidJavaScript SrcSpanInfo String String-  | FfiFormatNoSuchArg SrcSpanInfo Int-  | FfiNeedsTypeSig S.Exp-  | GHCError String-  | InvalidDoBlock-  | ParseError S.SrcLoc String-  | ShouldBeDesugared String-  | UnableResolveQualified N.QName-  | UnsupportedDeclaration S.Decl-  | UnsupportedEnum N.Exp-  | UnsupportedExportSpec N.ExportSpec-  | UnsupportedExpression S.Exp-  | UnsupportedFieldPattern S.PatField-  | UnsupportedImport F.ImportDecl-  | UnsupportedLet-  | UnsupportedLetBinding S.Decl-  | UnsupportedLiteral S.Literal-  | UnsupportedModuleSyntax String F.Module-  | UnsupportedPattern S.Pat-  | UnsupportedQualStmt S.QualStmt-  | UnsupportedRecursiveDo-  | UnsupportedRhs S.Rhs-  | UnsupportedWhereInAlt S.Alt-  | UnsupportedWhereInMatch S.Match-  deriving (Show)-instance Error CompileError- -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a)-  deriving (Applicative,Functor,Monad)------------------------------------------------------------------------------------- JS AST types---- | Statement type.-data JsStmt-  = JsVar JsName JsExp-  | JsIf JsExp [JsStmt] [JsStmt]-  | JsEarlyReturn JsExp-  | JsThrow JsExp-  | JsWhile JsExp [JsStmt]-  | JsUpdate JsName JsExp-  | JsSetProp JsName JsName JsExp-  | JsSetQName (Maybe SrcSpan) N.QName JsExp-  | JsSetModule ModulePath JsExp-  | JsSetConstructor N.QName JsExp-  | JsSetPropExtern JsName JsName JsExp-  | JsContinue-  | JsBlock [JsStmt]-  | JsExpStmt JsExp-  deriving (Show,Eq)---- | Expression type.-data JsExp-  = JsName JsName-  | JsRawExp String-  | JsSeq [JsExp]-  | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp)-  | JsLit JsLit-  | JsApp JsExp [JsExp]-  | JsNegApp JsExp-  | JsTernaryIf JsExp JsExp JsExp-  | JsNull-  | JsParen JsExp-  | JsGetProp JsExp JsName-  | JsLookup JsExp JsExp-  | JsUpdateProp JsExp JsName JsExp-  | JsGetPropExtern JsExp String-  | JsUpdatePropExtern JsExp JsName JsExp-  | JsList [JsExp]-  | JsNew JsName [JsExp]-  | JsThrowExp JsExp-  | JsInstanceOf JsExp JsName-  | JsIndex Int JsExp-  | JsEq JsExp JsExp-  | JsNeq JsExp JsExp-  | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc-  | JsObj [(String,JsExp)]-  | JsLitObj [(N.Name,JsExp)]-  | JsUndefined-  | JsAnd JsExp JsExp-  | JsOr  JsExp JsExp-  deriving (Show,Eq)---- | A name of some kind.-data JsName-  = JsNameVar N.QName-  | JsThis-  | JsParametrizedType-  | JsThunk-  | JsForce-  | JsApply-  | JsParam Integer-  | JsTmp Integer-  | JsConstructor N.QName-  | JsBuiltIn N.Name-  | JsModuleName N.ModuleName-  deriving (Eq,Show)---- | Literal value type.-data JsLit-  = JsChar Char-  | JsStr String-  | JsInt Int-  | JsFloating Double-  | JsBool Bool-  deriving (Show,Eq)---- | Just handy to have.-instance IsString JsLit where fromString = JsStr---- | These are the data types that are serializable directly to native--- JS data types. Strings, floating points and arrays. The others are:--- actions 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 FundamentalType-   -- Recursive types.- = FunctionType [FundamentalType]- | JsType FundamentalType- | ListType FundamentalType- | TupleType [FundamentalType]- | UserDefined N.Name [FundamentalType]- | Defined FundamentalType- | Nullable FundamentalType- -- Simple types.- | DateType- | StringType- | DoubleType- | IntType- | BoolType- | PtrType- --  Automatically serialize this type.- | Automatic- -- Unknown.- | UnknownType-   deriving (Show)---- | The serialization context indicates whether we're currently--- serializing some value or a particular field in a user-defined data--- type.-data SerializeContext = SerializeAnywhere | SerializeUserArg Int-  deriving (Read,Show,Eq)+  deriving+    ( Applicative+    , Functor+    , Monad+    )

@@ -0,0 +1,41 @@+module Fay.Types.CompileError (CompileError (..)) where++import qualified Fay.Exts                        as F+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.+data CompileError+  = Couldn'tFindImport N.ModuleName [FilePath]+  | EmptyDoBlock+  | FfiFormatBadChars SrcSpanInfo String+  | FfiFormatIncompleteArg SrcSpanInfo+  | FfiFormatInvalidJavaScript SrcSpanInfo String String+  | FfiFormatNoSuchArg SrcSpanInfo Int+  | FfiNeedsTypeSig S.Exp+  | GHCError String+  | InvalidDoBlock+  | ParseError S.SrcLoc String+  | ShouldBeDesugared String+  | UnableResolveQualified N.QName+  | UnsupportedDeclaration S.Decl+  | UnsupportedEnum N.Exp+  | UnsupportedExportSpec N.ExportSpec+  | UnsupportedExpression S.Exp+  | UnsupportedFieldPattern S.PatField+  | UnsupportedImport F.ImportDecl+  | UnsupportedLet+  | UnsupportedLetBinding S.Decl+  | UnsupportedLiteral S.Literal+  | UnsupportedModuleSyntax String F.Module+  | UnsupportedPattern S.Pat+  | UnsupportedQualStmt S.QualStmt+  | UnsupportedRecursiveDo+  | UnsupportedRhs S.Rhs+  | UnsupportedWhereInAlt S.Alt+  | UnsupportedWhereInMatch S.Match+  deriving (Show)+instance Error CompileError

@@ -0,0 +1,9 @@+module Fay.Types.CompileResult (CompileResult (..)) where++import           SourceMap.Types++data CompileResult = CompileResult+  { resOutput         :: String+  , resImported       :: [(String, FilePath)]+  , resSourceMappings :: Maybe [Mapping]+  } deriving Show

@@ -0,0 +1,40 @@++module Fay.Types.FFI+  ( FundamentalType (..)+  , SerializeContext (..)+  ) where++import qualified Fay.Exts.NoAnnotation as N++-- | These are the data types that are serializable directly to native+-- JS data types. Strings, floating points and arrays. The others are:+-- actions 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 FundamentalType+   -- Recursive types.+ = FunctionType [FundamentalType]+ | JsType FundamentalType+ | ListType FundamentalType+ | TupleType [FundamentalType]+ | UserDefined N.Name [FundamentalType]+ | Defined FundamentalType+ | Nullable FundamentalType+ -- Simple types.+ | DateType+ | StringType+ | DoubleType+ | IntType+ | BoolType+ | PtrType+ --  Automatically serialize this type.+ | Automatic+ -- Unknown.+ | UnknownType+   deriving (Show)++-- | The serialization context indicates whether we're currently+-- serializing some value or a particular field in a user-defined data+-- type.+data SerializeContext = SerializeAnywhere | SerializeUserArg Int+  deriving (Eq, Read, Show)

@@ -0,0 +1,91 @@+-- | JS AST types++module Fay.Types.Js+  ( JsStmt (..)+  , JsExp (..)+  , JsLit (..)+  , JsName (..)+  ) where++import qualified Fay.Exts.NoAnnotation           as N+import           Fay.Types.ModulePath++import           Data.String+import           Language.Haskell.Exts.Annotated++-- | Statement type.+data JsStmt+  = JsVar JsName JsExp+  | JsIf JsExp [JsStmt] [JsStmt]+  | JsEarlyReturn JsExp+  | JsThrow JsExp+  | JsWhile JsExp [JsStmt]+  | JsUpdate JsName JsExp+  | JsSetProp JsName JsName JsExp+  | JsSetQName (Maybe SrcSpan) N.QName JsExp+  | JsSetModule ModulePath JsExp+  | JsSetConstructor N.QName JsExp+  | JsSetPropExtern JsName JsName JsExp+  | JsContinue+  | JsBlock [JsStmt]+  | JsExpStmt JsExp+  deriving (Show,Eq)++-- | Expression type.+data JsExp+  = JsName JsName+  | JsRawExp String+  | JsSeq [JsExp]+  | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp)+  | JsLit JsLit+  | JsApp JsExp [JsExp]+  | JsNegApp JsExp+  | JsTernaryIf JsExp JsExp JsExp+  | JsNull+  | JsParen JsExp+  | JsGetProp JsExp JsName+  | JsLookup JsExp JsExp+  | JsUpdateProp JsExp JsName JsExp+  | JsGetPropExtern JsExp String+  | JsUpdatePropExtern JsExp JsName JsExp+  | JsList [JsExp]+  | JsNew JsName [JsExp]+  | JsThrowExp JsExp+  | JsInstanceOf JsExp JsName+  | JsIndex Int JsExp+  | JsEq JsExp JsExp+  | JsNeq JsExp JsExp+  | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc+  | JsObj [(String,JsExp)]+  | JsLitObj [(N.Name,JsExp)]+  | JsUndefined+  | JsAnd JsExp JsExp+  | JsOr  JsExp JsExp+  deriving (Eq, Show)++-- | A name of some kind.+data JsName+  = JsNameVar N.QName+  | JsThis+  | JsParametrizedType+  | JsThunk+  | JsForce+  | JsApply+  | JsParam Integer+  | JsTmp Integer+  | JsConstructor N.QName+  | JsBuiltIn N.Name+  | JsModuleName N.ModuleName+  deriving (Eq, Show)++-- | Literal value type.+data JsLit+  = JsChar Char+  | JsStr String+  | JsInt Int+  | JsFloating Double+  | JsBool Bool+  deriving (Eq, Show)++-- | Just handy to have.+instance IsString JsLit where fromString = JsStr

@@ -0,0 +1,32 @@+module Fay.Types.ModulePath+  ( ModulePath (..)+  , mkModulePath+  , mkModulePaths+  , mkModulePathFromQName+  ) where++import           Fay.Compiler.QName+import qualified Fay.Exts                        as F++import           Data.List+import           Data.List.Split+import           Language.Haskell.Exts.Annotated++-- | The name of a module split into a list for code generation.+newtype ModulePath = ModulePath { unModulePath :: [String] }+  deriving (Eq, Ord, Show)++-- | Construct the complete ModulePath from a ModuleName.+mkModulePath :: ModuleName a -> ModulePath+mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m++-- | Construct intermediate module paths from a ModuleName.+-- mkModulePaths "A.B" => [["A"], ["A","B"]]+mkModulePaths :: ModuleName a -> [ModulePath]+mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m++-- | Converting a QName to a ModulePath is only relevant for constructors since+-- they can conflict with module names.+mkModulePathFromQName :: QName a -> ModulePath+mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n+mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name"

@@ -1,19 +1,15 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards  #-} -- | Main compiler executable.  module Main where  import           Fay-import           Fay.Compiler.Config-import           Paths_fay           (version)+import           Paths_fay                 (version) -import qualified Control.Exception   as E+import qualified Control.Exception         as E import           Control.Monad-import           Data.Default-import           Data.List.Split     (wordsBy)+import           Data.List.Split           (wordsBy) import           Data.Maybe-import           Data.Version        (showVersion)+import           Data.Version              (showVersion) import           Options.Applicative import           Options.Applicative.Types import           System.Environment@@ -53,7 +49,7 @@   packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment   opts <- execParser parser   let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $-        addConfigPackages (optPackages opts) $ def+        addConfigPackages (optPackages opts) $ defaultConfig           { configOptimize         = optOptimize opts           , configFlattenApps      = optFlattenApps opts           , configPrettyPrint      = optPretty opts

@@ -2,20 +2,17 @@  module Test.CommandLine (tests) where -import           Fay.System.Process.Extra+import           Fay.Compiler.Prelude+import           Test.Util -import           Control.Applicative-import           Data.Maybe import           System.Directory import           System.Environment import           System.FilePath-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.Framework.TH-import           Test.HUnit                     (Assertion, assertBool)-import           Test.Util+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH -tests :: Test+tests :: TestTree tests = $testGroupGenerator  compileFile :: [String] -> IO (Either String String)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-}@@ -5,23 +6,18 @@ module Test.Compile (tests) where  import           Fay-import           Fay.Compiler.Config-import           Fay.System.Process.Extra-import           Fay.Types                       ()+import           Fay.Compiler.Prelude+#if !MIN_VERSION_base(4,7,0)+import           Test.Util                       (isRight)+#endif -import           Control.Applicative-import           Control.Monad-import           Data.Default-import           Data.Maybe import           Language.Haskell.Exts.Annotated import           System.Environment-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.Framework.TH-import           Test.HUnit                      (Assertion, assertBool, assertEqual, assertFailure)-import           Test.Util+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH -tests :: Test+tests :: TestTree tests = $testGroupGenerator  case_imports :: Assertion@@ -92,16 +88,16 @@ case_strictWrapper = do   whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment   res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs"-  (\a b -> either a b res) (assertFailure . show) $ \(js,_) -> do+  (\a b -> either a b res) (assertFailure . show) $ \js -> do     writeFile "tests/Compile/StrictWrapper.js" js     (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/StrictWrapper.js"] ""     when (err /= "") $ assertFailure err     expected <- readFile "tests/Compile/StrictWrapper.res"     assertEqual "strictWrapper node stdout" expected out -defConf :: CompileConfig+defConf :: Config defConf = addConfigDirectoryIncludePaths ["tests/"]-        $ def { configTypecheck = False }+        $ defaultConfig { configTypecheck = False }  case_charEnum :: Assertion case_charEnum = do@@ -110,4 +106,4 @@   case res of     Left UnsupportedEnum{} -> return ()     Left l  -> assertFailure $ "Should have failed with UnsupportedEnum, but failed with: " ++ show l-    Right _ -> assertFailure $ "Should have failed with UnsupportedEnum, but compiled"+    Right _ -> assertFailure "Should have failed with UnsupportedEnum, but compiled"

@@ -3,19 +3,18 @@  module Test.Convert (tests) where +import           Fay.Convert+ import qualified Data.Aeson.Parser              as Aeson import           Data.Attoparsec.ByteString import qualified Data.ByteString                as Bytes import qualified Data.ByteString.UTF8           as UTF8 import           Data.Data-import           Data.Ratio import           Data.Text                      (Text, pack)-import           Fay.Convert-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit                     (assertEqual)+import           Test.Tasty+import           Test.Tasty.HUnit -tests :: Test+tests :: TestTree tests = testGroup "Test.Convert" [reading, showing]   where reading = testGroup "reading" $           flip map readTests $ \(ReadTest value) ->@@ -35,7 +34,7 @@ -- Test cases  -- | A test.-data Testcase = forall x. Show x => Testcase x Bytes.ByteString+data Testcase = forall x. (Show x,Data x) => Testcase x Bytes.ByteString  -- | A read test. data ReadTest = forall x. (Data x,Show x,Eq x,Read x) => ReadTest x@@ -69,9 +68,10 @@ showTests =    -- Fundamental data types   [(1 :: Int) → "1"+  ,(1 :: Float) → "1.0"+  ,(1/2 :: Float) → "0.5"   ,(1 :: Double) → "1.0"   ,(1/2 :: Double) → "0.5"-  ,(1%2 :: Rational) → "0.5"   ,([1,2] :: [Int]) → "[1,2]"   ,((1,2) :: (Int,Int)) → "[1,2]"   ,"abc" → "\"abc\""@@ -122,7 +122,7 @@  -- | Labelled record. data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double }-                    | LabelledRecord2 { bar :: Int, bob :: Double }+                    | LabelledRecord2 { bar :: Int, bob :: Float }   deriving (Show,Data,Typeable,Read,Eq)  -- | Order matters in unlabelled constructors.

@@ -0,0 +1,161 @@+module Test.Desugar+  ( tests+  , devTest+  , parseE+  , parseM+  , des+  ) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.Desugar+import           Fay.Compiler.Parse              (parseFay)+import           Fay.Types.CompileError          (CompileError (..))++import           Language.Haskell.Exts.Annotated hiding (alt, binds, loc, name)+import           Test.Tasty+import           Test.Tasty.HUnit+import           Text.Groom++tests :: TestTree+tests = testGroup "desugar" $ map (\(T k a b) -> testCase k $ doDesugar k a b) testDeclarations++data DesugarTest = T String String String++testDeclarations :: [DesugarTest]+testDeclarations =+  [T "LambdaCase"+     "import Prelude; f = \\gen0 -> case gen0 of { _ -> 2 }"+     "import Prelude; f = \\case { _ -> 2 }"+  ,T "MultiWayIf"+     "import Prelude; f = case () of { _ | True -> 1 | False -> 2 }"+     "import Prelude; f = if | True -> 1 | False -> 2"+  ,T "TupleCon"+     "import Prelude; f = \\gen0 gen1 gen2 -> (gen0, gen1, gen2)"+     "import Prelude; f = (,,)"+  ,T "Do"+     "import Prelude; f = (>>=) x (\\gen0 -> (>>) y z)"+     "import Prelude; f = do { gen0 <- x; y; z }"+  ,T "TupleSection"+     "import Prelude; f = \\gen0 gen1 -> (gen0,2,gen1)"+     "import Prelude; f = (,2,)"+  ,T "ImplicitPrelude1" -- Add missing Prelude import+     "import Prelude"+     ""+  ,T "ImplicitPrelude2" -- Keep existing Prelude import+     "import Prelude ()"+     "import Prelude ()"+  ,T "ImplicitPrelude3" -- Keep existing qualified import+     "import qualified Prelude"+     "import qualified Prelude"+  ,T "NoImplicitPrelude"+     "{-# LANGUAGE NoImplicitPrelude #-}"+     "{-# LANGUAGE NoImplicitPrelude #-}"+  ,T "OperatorSectionRight"+     "import Prelude; f = \\gen0 -> g gen0 x"+     "import Prelude; f = (`g` x)"+  ,T "OperatorSectionLeft"+     "import Prelude; f = \\gen0 -> g x gen0"+     "import Prelude; f = (x `g`)"+  ,T "InfixOpOp"+     "import Prelude; f = (+) x y"+     "import Prelude; f = x + y"+  ,T "InfixOpFun"+     "import Prelude; f = g x y"+     "import Prelude; f = x `g` y"+  ,T "InfixOpCons"+     "import Prelude; f = (:) x y"+     "import Prelude; f = x : y"+  ,T "ExpParen"+     "import Prelude; f = x y"+     "import Prelude; f = (x (y))"+  ,T "PatParen"+     "import Prelude; f x = y"+     "import Prelude; f (x) = y"+  ,T "PatInfixOp"+     "import Prelude; f ((:) x y) = z"+     "import Prelude; f (x : y) = z"+  ,T "PatFieldPun"+     "import Prelude; f R { x = x } = y"+     "import Prelude; f R { x } = y"+  ,T "PatField"+     "import Prelude; f = R { x = x }"+     "import Prelude; f = R { x }"+  ,T "FFITopLevel"+     "import Prelude; f :: Int; f = ffi \"1\" :: Int"+     "import Prelude; f :: Int; f = ffi \"1\""+  ,T "FFIWhere"+     "import Prelude; f = () where x :: Int; x = ffi \"1\" :: Int"+     "import Prelude; f = () where x :: Int; x = ffi \"1\""+  ]++parseAndDesugar :: String -> String -> IO (Module SrcLoc, Either CompileError (Module SrcLoc))+parseAndDesugar name s =+  case parseFay "test" s :: ParseResult (Module SrcLoc) of+    ParseFailed a b -> error $ show (name, a, b)+    ParseOk m -> do+      d <- desugar' "gen" noLoc m+      return (m,d)++doDesugar :: String -> String -> String -> Assertion+doDesugar testName a b = do+  (originalExpected, desugaredExpected, desugared) <- parseAndDesugarAll testName a b+  assertEqual "identity"  (unAnn originalExpected) (unAnn desugaredExpected)+  assertEqual "desugared" (unAnn originalExpected) (unAnn desugared        )+  assertEqual "both"      (unAnn desugared       ) (unAnn desugaredExpected)++parseAndDesugarAll :: String -> String -> String -> IO (Module SrcLoc, Module SrcLoc, Module SrcLoc)+parseAndDesugarAll testName a b = do+  (originalExpected',Right desugaredExpected) <- parseAndDesugar (testName ++ " expected")   a+  (_                ,Right desugared        ) <- parseAndDesugar (testName ++ " input") b+  -- We need to desugar parens in the original module since we+  -- strip it away in desugaring but there isn't alawys a way to construct+  -- this paren directly from a source string+  let originalExpected = desugarPatParen . desugarExpParen $ originalExpected'+  return (originalExpected, desugaredExpected, desugared)++-- When developing:++devTest :: String -> IO ()+devTest nam = do+  let (T _ a b) = fromJust (find (\(T n _ _) -> n == nam) testDeclarations)+  (originalExpected, desugaredExpected, desugared) <- parseAndDesugarAll "" a b+  if unAnn desugared == unAnn desugaredExpected && unAnn desugared == unAnn originalExpected+    then putStrLn "OK"+    else do+      putStrLn "--- originalExpected"+      g $ unAnn originalExpected+      putStrLn "--- desugaredExpected"+      g $ unAnn desugaredExpected+      putStrLn "--- desugared"+      g $ unAnn desugared+      putStrLn "--- originalExpected"+      pretty originalExpected+      putStrLn "--- desugaredExpected"+      pretty desugaredExpected+      putStrLn "--- desugared"+      pretty desugared+  when (unAnn originalExpected  /= unAnn desugaredExpected) $ putStrLn "originalExpected /= desugaredExpected"+  when (unAnn desugared         /= unAnn desugaredExpected) $ putStrLn "desugared /= desugaredExpected"+  when (unAnn desugared         /= unAnn originalExpected ) $ putStrLn "desugared /= originalExpected"+  when (unAnn desugaredExpected /= unAnn originalExpected ) $ putStrLn "desugaredExpected /= undesugared"++g :: Show a => a -> IO ()+g = putStrLn . groom++unAnn :: Functor f => f a -> f ()+unAnn = void++pretty :: Module SrcLoc -> IO ()+pretty = putStrLn . prettyPrint++parseM :: String -> Module ()+parseM s = let ParseOk m = parseFay "module" s :: ParseResult (Module SrcSpanInfo) in unAnn m++parseE :: String -> Exp ()+parseE s = let ParseOk m = parseFay "exp" s :: ParseResult (Exp SrcSpanInfo) in unAnn m++des :: String -> IO ()+des s = do+  Right r <- desugar' "gen" () $ parseM s+  g r

@@ -1,14 +1,16 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NoImplicitPrelude #-} module Test.Util   ( fayPath   , isRight   , fromLeft+  , getRecursiveContents   ) where -import           Fay.System.Process.Extra (readAllFromProcess)+import           Fay.Compiler.Prelude -import           Control.Applicative-import           Prelude                  hiding (pred) import           System.Directory+import           System.FilePath  -- Path to the fay executable, looks in cabal-dev, dist, PATH in that order. fayPath :: IO (Maybe FilePath)@@ -20,20 +22,37 @@     usingWhich = fmap (concat . lines . snd) . hush <$> readAllFromProcess "which" ["fay"] ""  firstWhereM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)-firstWhereM pred ins = case ins of+firstWhereM p ins = case ins of   [] -> return Nothing-  a:as -> pred a >>= \b ->+  a:as -> p a >>= \b ->           if b then return (Just a)-               else firstWhereM pred as+               else firstWhereM p as  -- from the package `errors` hush :: Either a b -> Maybe b hush = either (const Nothing) Just -isRight :: Either a b -> Bool-isRight (Right _) = True-isRight (Left _) = False- fromLeft :: Either a b -> a fromLeft (Left a) = a fromLeft (Right _) = error "fromLeft got Right"++-- | Get all files in a folder and its subdirectories.+-- Taken from Real World Haskell+-- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html+getRecursiveContents :: FilePath -> IO [FilePath]+getRecursiveContents topdir = do+  names <- getDirectoryContents topdir+  let properNames = filter (`notElem` [".", ".."]) names+  paths <- forM properNames $ \name -> do+    let path = topdir </> name+    isDirectory <- doesDirectoryExist path+    if isDirectory+      then getRecursiveContents path+      else return [path]+  return (concat paths)++#if !MIN_VERSION_base(4,7,0)+isRight :: Either a b -> Bool+isRight Right{} = True+isRight Left{} = False+#endif

@@ -8,25 +8,18 @@ module Main where  import           Fay-import           Fay.Compiler.Config-import           Fay.System.Directory.Extra-import           Fay.System.Process.Extra+import           Fay.Compiler.Prelude+import qualified Test.CommandLine     as Cmd+import qualified Test.Compile         as Compile+import qualified Test.Convert         as Convert+import qualified Test.Desugar         as Desugar+import           Test.Util -import           Control.Applicative-import           Data.Char-import           Data.Default-import           Data.List-import           Data.Maybe-import           Data.Ord import           System.Directory import           System.Environment import           System.FilePath-import qualified Test.CommandLine               as Cmd-import qualified Test.Compile                   as Compile-import qualified Test.Convert                   as C-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit                     (assertEqual, assertFailure)+import           Test.Tasty+import           Test.Tasty.HUnit  -- | Main test runner. main :: IO ()@@ -35,15 +28,21 @@   (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs   let (basePath,args') = prefixed (=="-base-path") args   (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath-  defaultMainWithArgs [Compile.tests, Cmd.tests, runtime, codegen, C.tests]-                      args'+  withArgs args' $ defaultMain $ testGroup "Fay"+    [ Desugar.tests+    , Convert.tests+    , codegen+    , Cmd.tests+    , Compile.tests+    , runtime+    ]  -- | Extract the element prefixed by the given element in the list. prefixed :: (a -> Bool) -> [a] -> (Maybe a,[a]) prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y)  -- | Make the case-by-case unit tests.-makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO (Test,Test)+makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO (TestTree,TestTree) makeCompilerTests packageConf basePath = do   runtimeFiles <- runtimeTestFiles   codegenFiles <- codegenTestFiles@@ -54,7 +53,7 @@                                 testFile packageConf basePath True file)     ,makeTestGroup "Codegen tests"                    codegenFiles-                   (\file -> do testCodegen packageConf basePath file))+                   (\file -> testCodegen packageConf basePath file))   where     makeTestGroup title files inner =       testGroup title $ flip map files $ \file ->@@ -75,12 +74,13 @@       out = toJsName file       resf = root <.> "res"       config =-        addConfigDirectoryIncludePaths ["tests/"] $-          def { configOptimize = opt-              , configTypecheck = False-              , configPackageConf = packageConf-              , configBasePath = basePath-              }+        addConfigDirectoryIncludePaths ["tests/"]+          defaultConfig+            { configOptimize = opt+            , configTypecheck = False+            , configPackageConf = packageConf+            , configBasePath = basePath+            }   resExists <- doesFileExist resf   let partialName = root ++ "_partial.res"   partialExists <- doesFileExist partialName@@ -107,16 +107,17 @@       out = toJsName file       resf = root <.> "res"       config =-        addConfigDirectoryIncludePaths ["tests/codegen/"] $-          def { configOptimize      = True-              , configTypecheck     = False-              , configPackageConf   = packageConf-              , configBasePath      = basePath-              , configExportStdlib  = False-              , configPrettyPrint   = True-              , configLibrary       = True-              , configExportRuntime = False-              }+        addConfigDirectoryIncludePaths ["tests/codegen/"]+          defaultConfig+            { configOptimize      = True+            , configTypecheck     = False+            , configPackageConf   = packageConf+            , configBasePath      = basePath+            , configExportStdlib  = False+            , configPrettyPrint   = True+            , configLibrary       = True+            , configExportRuntime = False+            }   compileFromTo config file (Just out)   actual <- readStripped out   expected <- readStripped resf

@@ -0,0 +1,11 @@+{-# LANGUAGE LambdaCase #-}+module LambdaCase where++f :: Int -> Bool+f = \case+  2 -> True+  _ -> False++main :: Fay ()+main = do+  print (f 2)

@@ -0,0 +1,1 @@+true

@@ -0,0 +1,13 @@+{-# LANGUAGE MultiWayIf #-}+module MultiWayIf where++f :: Int -> Char+f x = if | x == 1    -> 'a'+         | x == 2    -> 'b'+         | otherwise -> 'c'++main :: Fay ()+main = do+  print (f 1)+  print (f 2)+  print (f 3)

@@ -0,0 +1,3 @@+a+b+c

@@ -0,0 +1,7 @@+module PrefixOpPat where++f ((:) x y) = x++main :: Fay ()+main = do+  print $ f [1,2]

@@ -0,0 +1,1 @@+1

@@ -0,0 +1,11 @@+module Case3 where++f x = case () of+  _ | x == 1 -> 1+    | x == 2 -> 2+    | True -> 3++main = do+  print (f 1)+  print (f 2)+  print (f 3)

@@ -0,0 +1,3 @@+1+2+3