fay 0.17.0.0 → 0.18.0.0

raw patch · 78 files changed

+2422/−1888 lines, 78 filesdep +haskell-namesdep +haskell-packagesdep ~basedep ~haskell-src-extsdep ~optparse-applicativePVP ok

version bump matches the API change (PVP)

Dependencies added: haskell-names, haskell-packages

Dependency ranges changed: base, haskell-src-exts, optparse-applicative

API changes (from Hackage documentation)

Files

• fay.cabal +28/−3
• js/runtime.js +44/−17
• src/Fay.hs +65/−46
• src/Fay/Compiler.hs +116/−129
• src/Fay/Compiler/Config.hs +11/−4
• src/Fay/Compiler/Debug.hs +0/−60
• src/Fay/Compiler/Decl.hs +141/−140
• src/Fay/Compiler/Defaults.hs +24/−26
• src/Fay/Compiler/Desugar.hs +269/−0
• src/Fay/Compiler/Exp.hs +176/−236
• src/Fay/Compiler/FFI.hs +152/−145
• src/Fay/Compiler/GADT.hs +13/−12
• src/Fay/Compiler/Import.hs +119/−0
• src/Fay/Compiler/InitialPass.hs +89/−143
• src/Fay/Compiler/Misc.hs +108/−145
• src/Fay/Compiler/ModuleScope.hs +0/−149
• src/Fay/Compiler/Optimizer.hs +85/−83
• src/Fay/Compiler/Packages.hs +1/−1
• src/Fay/Compiler/Pattern.hs +105/−107
• src/Fay/Compiler/PrimOp.hs +69/−0
• src/Fay/Compiler/Print.hs +34/−31
• src/Fay/Compiler/QName.hs +21/−12
• src/Fay/Compiler/State.hs +66/−0
• src/Fay/Compiler/Typecheck.hs +10/−12
• src/Fay/Convert.hs +22/−29
• src/Fay/Data/List/Extra.hs +2/−2
• src/Fay/Exts.hs +70/−0
• src/Fay/Exts/NoAnnotation.hs +67/−0
• src/Fay/Exts/Scoped.hs +49/−0
• src/Fay/FFI.hs +1/−1
• src/Fay/System/Directory/Extra.hs +2/−2
• src/Fay/Types.hs +123/−170
• src/main/Main.hs +58/−84
• src/tests/Test/CommandLine.hs +1/−1
• src/tests/Test/Compile.hs +35/−18
• src/tests/Test/Util.hs +1/−1
• src/tests/Tests.hs +3/−3
• tests/Compile/StrictWrapper.hs +21/−0
• tests/Compile/StrictWrapper.res +3/−0
• tests/ExportQualified_Export.hs +2/−2
• tests/FromString/FayText.hs +1/−2
• tests/LazyOperators.hs +3/−1
• tests/List.hs +4/−0
• tests/List2.hs +4/−0
• tests/Monad2.hs +2/−2
• tests/Nullable.hs +1/−1
• tests/Num.hs +9/−7
• tests/Ord.hs +18/−16
• tests/QualifiedImport.hs +18/−0
• tests/QualifiedImport.res +6/−0
• tests/QualifiedImport/X.hs +8/−0
• tests/QualifiedImport/X.res +0/−0
• tests/QualifiedImport/Y.hs +6/−0
• tests/QualifiedImport/Y.res +0/−0
• tests/ReExportGlobally.hs +14/−0
• tests/ReExportGlobally.res +5/−0
• tests/ReExportGlobally/A.hs +8/−0
• tests/ReExportGlobally/A.res +0/−0
• tests/ReExportGloballyExplicit.hs +9/−0
• tests/ReExportGloballyExplicit.res +1/−0
• tests/T190_B.hs +2/−1
• tests/automatic.hs +22/−0
• tests/automatic.res +4/−0
• tests/circular.hs +4/−3
• tests/ffimunging.hs +3/−3
• tests/fromIntegral.hs +4/−0
• tests/fromIntegral.res +1/−0
• tests/guards.hs +4/−3
• tests/listComprehensions.hs +2/−2
• tests/negation.hs +7/−5
• tests/pats.hs +8/−7
• tests/pats.res +1/−0
• tests/patternGuards.hs +4/−1
• tests/recordWildCards.hs +23/−13
• tests/recordWildCards_partial.res +3/−1
• tests/sections.hs +4/−2
• tests/whereBind.hs +2/−3
• tests/whereBind2.hs +1/−1

@@ -1,5 +1,5 @@ name:                fay-version:             0.17.0.0+version:             0.18.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,@@ -44,6 +44,8 @@   -- Test cases   tests/asPatternMatch.hs   tests/asPatternMatch.res+  tests/automatic.hs+  tests/automatic.res   tests/AutomaticList.hs   tests/AutomaticList.res   tests/baseFixities.hs@@ -67,6 +69,8 @@   tests/Compile/CPPTypecheck.hs   tests/Compile/ImportRecords.hs   tests/Compile/Records.hs+  tests/Compile/StrictWrapper.hs+  tests/Compile/StrictWrapper.res   tests/CPP.hs   tests/CPP.res   tests/curry.hs@@ -136,6 +140,8 @@   tests/Floating.res   tests/fromInteger.hs   tests/fromInteger.res+  tests/fromIntegral.hs+  tests/fromIntegral.res   tests/FromString/Dep.hs   tests/FromString/Dep.res   tests/FromString/DepDep.hs@@ -253,6 +259,12 @@   tests/patternMatchFail.hs   tests/patternMatchingTuples.hs   tests/patternMatchingTuples.res+  tests/QualifiedImport/X.hs+  tests/QualifiedImport/X.res+  tests/QualifiedImport/Y.hs+  tests/QualifiedImport/Y.res+  tests/QualifiedImport.hs+  tests/QualifiedImport.res   tests/Ratio.hs   tests/Ratio.res   tests/RealFrac.hs@@ -291,6 +303,12 @@   tests/ReExport2.res   tests/ReExport3.hs   tests/ReExport3.res+  tests/ReExportGlobally/A.hs+  tests/ReExportGlobally/A.res+  tests/ReExportGlobally.hs+  tests/ReExportGlobally.res+  tests/ReExportGloballyExplicit.hs+  tests/ReExportGloballyExplicit.res   tests/reservedWords.hs   tests/reservedWords.res   tests/sections.hs@@ -352,28 +370,33 @@   exposed-modules:     Fay                      , Fay.Compiler                      , Fay.Compiler.Config-                     , Fay.Compiler.Debug                      , 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.ModuleScope                      , 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 -fno-warn-name-shadowing@@ -389,6 +412,8 @@                    , directory                    , filepath                    , ghc-paths+                   , haskell-packages+                   , haskell-names >= 0.3 && < 0.4                    , haskell-src-exts >= 1.14                    , language-ecmascript >= 0.15 && < 1.0                    , mtl

@@ -165,8 +165,17 @@         fayFunc = Fay$$_(fayFunc,true);         // TODO: Perhaps we should throw an error when JS         // passes more arguments than Haskell accepts.++        // Unserialize the JS values to Fay for the Fay callback.+        if (args == "automatic_function")+        {+          for (var i = 0; i < arguments.length; i++) {+            fayFunc = Fay$$fayToJs(["automatic"], Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true));+          }+          return fayFunc;+        }+         for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {-          // Unserialize the JS values to Fay for the Fay callback.           fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);         }         // Finally, serialize the Fay return value back to JS.@@ -240,7 +249,9 @@      fayObj = Fay$$_(fayObj); -    if(fayObj instanceof Fay$$Cons || fayObj === null){+    if(fayObj instanceof Function) {+      jsObj = Fay$$fayToJs(["function", "automatic_function"], fayObj);+    } else if(fayObj instanceof Fay$$Cons || fayObj === null){       // Serialize Fay list to JavaScript array.       var arr = [];       while(fayObj instanceof Fay$$Cons) {@@ -249,7 +260,7 @@       }       jsObj = arr;     } else {-      var fayToJsFun = Fay$$fayToJsHash[fayObj.constructor.name];+      var fayToJsFun = fayObj && fayObj.constructor && Fay$$fayToJsHash[fayObj.constructor.name];       jsObj = fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;     }   }@@ -313,21 +324,31 @@     //    }}}}};     var returnType = args[args.length-1];     var funArgs = args.slice(0,-1);-    var makePartial = function(args){-      return function(arg){-        var i = args.length;-        var fayArg = Fay$$fayToJs(funArgs[i],arg);-        var newArgs = args.concat(fayArg);-        if(newArgs.length == funArgs.length) {-          return new Fay$$$(function(){-            return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));-          });-        } else {-          return makePartial(newArgs);-        }++    if (jsObj.length > 0) {+      var makePartial = function(args){+        return function(arg){+          var i = args.length;+          var fayArg = Fay$$fayToJs(funArgs[i],arg);+          var newArgs = args.concat([fayArg]);+          if(newArgs.length == funArgs.length) {+            return new Fay$$$(function(){+              return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));+            });+          } else {+            return makePartial(newArgs);+          }+        };       };-    };-    return makePartial([]);+      fayObj = makePartial([]);+    }+    else {+      fayObj =+        function (arg)+        {+           return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg)));+        };+    }   }   else if(base == "string") {     // Unserialize a JS string into Fay list (String).@@ -396,6 +417,12 @@         list = new Fay$$Cons(Fay$$jsToFay([base], jsObj[i]), list);       }       fayObj = list;+    }+    else if (jsObj instanceof Function) {+      var type = [["automatic"]];+      for (var i = 0; i < jsObj.length; i++)+        type.push(["automatic"]);+      return Fay$$jsToFay(["function", type], jsObj);     }     else       fayObj = jsObj;

@@ -15,32 +15,43 @@   ,compileFromToAndGenerateHtml   ,toJsName   ,showCompileError-  ,getRuntime)-   where+  ,getConfigRuntime+  ,getRuntime+  ) where  import           Fay.Compiler-import           Fay.Compiler.Misc   (printSrcLoc)+import           Fay.Compiler.Misc                      (ioWarn,+                                                         printSrcSpanInfo) import           Fay.Compiler.Packages+import           Fay.Compiler.Typecheck+import qualified Fay.Exts                               as F import           Fay.Types  import           Control.Applicative import           Control.Monad import           Data.List-import           Language.Haskell.Exts        (prettyPrint)-import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Exts.Annotated        (prettyPrint)+import           Language.Haskell.Exts.Annotated.Syntax+import           Language.Haskell.Exts.SrcLoc import           Paths_fay import           System.FilePath  -- | 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 filein fileout = do-  result <- maybe (compileFile config filein)-                  (compileFromToAndGenerateHtml config filein)-                  fileout-  case result of-    Right out -> maybe (putStrLn out) (`writeFile` out) fileout-    Left err -> error $ showCompileError err+compileFromTo cfg filein fileout =+  if configTypecheckOnly cfg+  then do+    cfg' <- resolvePackages cfg+    res <- typecheck cfg' filein+    either (error . showCompileError) (ioWarn cfg') res+  else do+    result <- maybe (compileFile cfg filein)+                      (compileFromToAndGenerateHtml cfg filein)+                      fileout+    case result of+      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)@@ -74,16 +85,15 @@ -- | Compile a file returning the state. compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,CompileState)) compileFileWithState config filein = do-  runtime <- getRuntime+  runtime <- getConfigRuntime config   hscode <- readFile filein   raw <- readFile runtime   config' <- resolvePackages config   compileToModule filein config' raw (compileToplevelModule filein) hscode  -- | Compile the given module to a runnable module.-compileToModule :: (Show from,Show to,CompilesTo from to)-                => FilePath-                -> CompileConfig -> String -> (from -> Compile to) -> String+compileToModule :: FilePath+                -> CompileConfig -> String -> (F.Module -> Compile [JsStmt]) -> String                 -> IO (Either CompileError (String,CompileState)) compileToModule filepath config raw with hscode = do   result <- compileViaStr filepath config with hscode@@ -95,7 +105,7 @@             , state             )   where-    generateWrapped jscode (ModuleName modulename) =+    generateWrapped jscode (ModuleName _ modulename) =       unlines $ filter (not . null)       [if configExportRuntime config then raw else ""       ,jscode@@ -115,38 +125,47 @@ -- | Print a compile error for human consumption. showCompileError :: CompileError -> String showCompileError e = case e of-  ParseError pos err -> err ++ " at line: " ++ show (srcLine pos) ++ " column: " ++ show (srcColumn pos)-  UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d-  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-  UnsupportedLet -> "let not supported here"-  UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d-  UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit-  UnsupportedModuleSyntax m -> "unsupported module syntax" ++ prettyPrint m-  UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat-  UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt-  UnsupportedRecursiveDo -> "recursive `do' isn't supported"-  UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs-  UnsupportedWhereInAlt alt -> "`where' not supported here: " ++ prettyPrint alt-  UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m-  EmptyDoBlock -> "empty `do' block"-  InvalidDoBlock -> "invalid `do' block"-  FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d-  FfiFormatBadChars      srcloc cs -> printSrcLoc srcloc ++ ": invalid characters for FFI format string: " ++ show cs-  FfiFormatNoSuchArg     srcloc i  -> printSrcLoc srcloc ++ ": no such argument in FFI format string: " ++ show i-  FfiFormatIncompleteArg srcloc    -> printSrcLoc srcloc ++ ": incomplete `%' syntax in FFI format string"-  FfiFormatInvalidJavaScript srcloc code err ->-    printSrcLoc srcloc ++ ":" ++-    "\ninvalid JavaScript code in FFI format string:\n"-                                         ++ err ++ "\nin " ++ code-  Couldn'tFindImport i places ->+  Couldn'tFindImport i places      ->     "could not find an import in the path: " ++ prettyPrint i ++ ", \n" ++     "searched in these places: " ++ intercalate ", " places-  UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname-  GHCError s -> "ghc: " ++ s+  EmptyDoBlock -> "empty `do' block"+  FfiFormatBadChars srcloc cs      -> printSrcSpanInfo srcloc ++ ": invalid characters for FFI format string: " ++ show cs+  FfiFormatIncompleteArg srcloc    -> printSrcSpanInfo srcloc ++ ": incomplete `%' syntax in FFI format string"+  FfiFormatInvalidJavaScript l c m ->+    printSrcSpanInfo l ++ ":" +++    "\ninvalid JavaScript code in FFI format string:\n" ++ m ++ "\nin " ++ c+  FfiFormatNoSuchArg srcloc i      ->+    printSrcSpanInfo srcloc ++ ":" +++    "\nno such argument in FFI format string: " ++ show i+  FfiNeedsTypeSig d                -> "your FFI declaration needs a type signature: " ++ prettyPrint d+  GHCError s                       -> "ghc: " ++ s+  InvalidDoBlock                   -> "invalid `do' block"+  ParseError pos err               ->+    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+  UnsupportedDeclaration d         -> "unsupported declaration: " ++ prettyPrint d+  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+  UnsupportedLet                   -> "let not supported here"+  UnsupportedLetBinding d          -> "unsupported let binding: " ++ prettyPrint d+  UnsupportedLiteral lit           -> "unsupported literal syntax: " ++ prettyPrint lit+  UnsupportedModuleSyntax s m      -> "unsupported module syntax in " ++ s ++ ": " ++ prettyPrint m+  UnsupportedPattern pat           -> "unsupported pattern syntax: " ++ prettyPrint pat+  UnsupportedQualStmt stmt         -> "unsupported list qualifier: " ++ prettyPrint stmt+  UnsupportedRecursiveDo           -> "recursive `do' isn't supported"+  UnsupportedRhs rhs               -> "unsupported right-hand side syntax: " ++ prettyPrint rhs+  UnsupportedWhereInAlt alt        -> "`where' not supported here: " ++ prettyPrint alt+  UnsupportedWhereInMatch m        -> "unsupported `where' syntax: " ++ prettyPrint m  -- | Get the JS runtime source.+-- This will return the user supplied runtime if it exists.+getConfigRuntime :: CompileConfig -> IO String+getConfigRuntime cfg = maybe getRuntime return $ configRuntimePath cfg++-- | Get the default JS runtime source. getRuntime :: IO String getRuntime = getDataFileName "js/runtime.js"

@@ -1,23 +1,20 @@-{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE ViewPatterns          #-}  -- | The Haskell→Javascript compiler.  module Fay.Compiler-  (runCompile+  (runCompileModule   ,compileViaStr-  ,compileToAst+  ,compileWith   ,compileExp   ,compileDecl   ,compileToplevelModule-  ,compileModuleFromFile   ,compileModuleFromContents-  ,compileModuleFromName-  ,compileModule   ,compileModuleFromAST   ,parseFay)   where@@ -25,119 +22,83 @@ import           Fay.Compiler.Config import           Fay.Compiler.Decl import           Fay.Compiler.Defaults+import           Fay.Compiler.Desugar import           Fay.Compiler.Exp import           Fay.Compiler.FFI-import           Fay.Compiler.InitialPass (initialPass)+import           Fay.Compiler.Import+import           Fay.Compiler.InitialPass        (initialPass) import           Fay.Compiler.Misc-import           Fay.Compiler.ModuleScope (findPrimOp) import           Fay.Compiler.Optimizer+import           Fay.Compiler.PrimOp             (findPrimOp) import           Fay.Compiler.QName+import           Fay.Compiler.State import           Fay.Compiler.Typecheck import           Fay.Control.Monad.IO+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.State import           Control.Monad.RWS+import           Control.Monad.State import           Data.Default                    (def)-import qualified Data.Map                        as M import           Data.Maybe import qualified Data.Set                        as S-import           Language.Haskell.Exts+import           Language.Haskell.Exts.Annotated hiding (name)+import           Language.Haskell.Names+import           Prelude                         hiding (mod)  -------------------------------------------------------------------------------- -- Top level entry points  -- | Compile a Haskell source string to a JavaScript source string.-compileViaStr :: (Show from,Show to,CompilesTo from to)-              => FilePath-              -> CompileConfig-              -> (from -> Compile to)-              -> String-              -> IO (Either CompileError (PrintState,CompileState,CompileWriter))-compileViaStr filepath config with from = do-  cs <- defaultCompileState-  rs <- defaultCompileReader config-  runCompile rs-             cs+compileViaStr+  :: FilePath+  -> CompileConfig+  -> (F.Module -> Compile [JsStmt])+  -> String+  -> IO (Either CompileError (PrintState,CompileState,CompileWriter))+compileViaStr filepath cfg with from = do+  rs <- defaultCompileReader cfg+  runTopCompile rs+             defaultCompileState              (parseResult (throwError . uncurry ParseError)                           (fmap (\x -> execState (runPrinter (printJS x)) printConfig) . with)                           (parseFay filepath from)) -  where printConfig = def { psPretty = configPrettyPrint config }---- | Compile a Haskell source string to a JavaScript source string.-compileToAst :: (Show from,Show to,CompilesTo from to)-              => FilePath-              -> CompileReader-              -> CompileState-              -> (from -> Compile to)-              -> String-              -> IO (Either CompileError (to,CompileState,CompileWriter))-compileToAst filepath reader state with from =-  runCompile reader-             state-             (parseResult (throwError . uncurry ParseError)-                          with-                          (parseFay filepath from))+  where printConfig = def { psPretty = configPrettyPrint cfg }  -- | Compile the top-level Fay module.-compileToplevelModule :: FilePath -> Module -> Compile [JsStmt]-compileToplevelModule filein mod@(Module _ (ModuleName modulename) _ _ _ _ _)  = do+compileToplevelModule :: FilePath -> F.Module -> Compile [JsStmt]+compileToplevelModule filein mod@Module{}  = do   cfg <- config id-  when (configTypecheck cfg) $-    typecheck (configPackageConf cfg) (configWall cfg) $-      fromMaybe modulename $ configFilePath cfg-  initialPass mod-  cs <- io defaultCompileState-  modify $ \s -> s { stateImported = stateImported cs }-  fmap fst . listen $ compileModuleFromFile filein+  when (configTypecheck cfg) $ do+    res <- io $ typecheck cfg $+             fromMaybe (F.moduleNameString (F.moduleName mod)) $+               configFilePath cfg+    either throwError warn res+  initialPass filein+  -- Reset imports after initialPass so the modules can be imported during code generation.+  startCompile compileFileWithSource filein+compileToplevelModule _ m = throwError $ UnsupportedModuleSyntax "compileToplevelModule" m  -------------------------------------------------------------------------------- -- Compilers --- | Read a file and compile.-compileModuleFromFile :: FilePath -> Compile [JsStmt]-compileModuleFromFile fp = io (readFile fp) >>= compileModule fp- -- | Compile a source string. compileModuleFromContents :: String -> Compile [JsStmt]-compileModuleFromContents = compileModule "<interactive>"---- | Lookup a module from include directories and compile.-compileModuleFromName :: ModuleName -> Compile [JsStmt]-compileModuleFromName name =-  unlessImported name compileModule-    where-      unlessImported :: ModuleName-                     -> (FilePath -> String -> Compile [JsStmt])-                     -> Compile [JsStmt]-      unlessImported "Fay.Types" _ = return []-      unlessImported name importIt = do-        imported <- gets stateImported-        case lookup name imported of-          Just _  -> return []-          Nothing -> do-            dirs <- configDirectoryIncludePaths <$> config id-            (filepath,contents) <- findImport dirs name-            modify $ \s -> s { stateImported = (name,filepath) : imported }-            importIt filepath contents+compileModuleFromContents = compileFileWithSource "<interactive>"  -- | Compile given the location and source string.-compileModule :: FilePath -> String -> Compile [JsStmt]-compileModule filepath contents = do-  state <- get-  reader <- ask-  result <- io $ compileToAst filepath reader state compileModuleFromAST contents-  case result of-    Right (stmts,state,writer) -> do-      modify $ \s -> s { stateImported      = stateImported state-                       , stateLocalScope    = S.empty-                       , stateJsModulePaths = stateJsModulePaths state-                       }-      maybeOptimize $ stmts ++ writerCons writer ++ makeTranscoding writer-    Left err -> throwError err+compileFileWithSource :: FilePath -> String -> Compile [JsStmt]+compileFileWithSource filepath contents = do+  (stmts,st,wr) <- compileWith filepath compileModuleFromAST compileFileWithSource contents+  modify $ \s -> s { stateImported      = stateImported      st+                   , stateJsModulePaths = stateJsModulePaths st+                   }+  maybeOptimize $ stmts ++ writerCons wr ++ makeTranscoding wr   where     makeTranscoding :: CompileWriter -> [JsStmt]     makeTranscoding CompileWriter{..} =@@ -152,52 +113,62 @@         else stmts  -- | Compile a parse HSE module.-compileModuleFromAST :: Module -> Compile [JsStmt]-compileModuleFromAST (Module _ modulename pragmas Nothing _exports imports decls) =-  withModuleScope $ do-    imported <- fmap concat (mapM compileImport imports)-    modify $ \s -> s { stateModuleName = modulename-                     , stateModuleScope = fromMaybe (error $ "Could not find stateModuleScope for " ++ show modulename) $ M.lookup modulename $ stateModuleScopes s-                     , stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas-                     }-    current <- compileDecls True decls+compileModuleFromAST :: [JsStmt] -> F.Module -> Compile [JsStmt]+compileModuleFromAST imported mod''@(Module _ _ pragmas _ _) = do+  res <- io $ desugar mod''+  case res of+    Left err -> throwError err+    Right mod' -> do+      mod@(Module _ _ _ _ decls) <- annotateModule Haskell2010 [] $ mod'+      let modName = unAnn $ F.moduleName mod+      modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas+                       }+      current <- compileDecls True decls -    exportStdlib     <- config configExportStdlib-    exportStdlibOnly <- config configExportStdlibOnly-    modulePaths      <- createModulePath modulename-    extExports       <- generateExports-    let stmts = imported ++ modulePaths ++ current ++ extExports-    return $ if exportStdlibOnly-      then if anStdlibModule modulename-              then stmts-              else []-      else if not exportStdlib && anStdlibModule modulename-              then []-              else stmts-compileModuleFromAST mod = throwError (UnsupportedModuleSyntax mod)+      exportStdlib     <- config configExportStdlib+      exportStdlibOnly <- config configExportStdlibOnly+      modulePaths      <- createModulePath modName+      extExports       <- generateExports+      strictExports    <- generateStrictExports+      let stmts = imported ++ modulePaths ++ current ++ extExports ++ strictExports+      return $ if exportStdlibOnly+        then if anStdlibModule modName+                then stmts+                else []+        else if not exportStdlib && anStdlibModule modName+                then []+                else stmts+compileModuleFromAST _ mod = throwError $ UnsupportedModuleSyntax "compileModuleFromAST" mod -hasLanguagePragmas :: [String] -> [ModulePragma] -> Bool++--------------------------------------------------------------------------------+-- Misc compilation++-- | Check if the given language pragmas are all present.+hasLanguagePragmas :: [String] -> [F.ModulePragma] -> Bool hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas   where-    flattenPragmas :: [ModulePragma] -> [String]+    flattenPragmas :: [F.ModulePragma] -> [String]     flattenPragmas ps = concat $ map pragmaName ps     pragmaName (LanguagePragma _ q) = map unname q     pragmaName _ = [] --instance CompilesTo Module [JsStmt] where compileTo = compileModuleFromAST-- -- | For a module A.B, generate -- | var A = {}; -- | A.B = {};-createModulePath :: ModuleName -> Compile [JsStmt]-createModulePath =-  liftM concat . mapM modPath . mkModulePaths+createModulePath :: ModuleName a -> Compile [JsStmt]+createModulePath (unAnn -> m) = do+  cfg <- config id+  reg <- liftM concat . mapM modPath . mkModulePaths $ m+  strict <-+    if shouldExportStrictWrapper m cfg+      then liftM concat . mapM modPath . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m+       else return []+  return $ reg ++ strict   where     modPath :: ModulePath -> Compile [JsStmt]     modPath mp = whenImportNotGenerated mp $ \(unModulePath -> l) -> case l of-     [n] -> [JsVar (JsNameVar . UnQual $ Ident n) (JsObj [])]+     [n] -> [JsVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])]      _   -> [JsSetModule mp (JsObj [])]      whenImportNotGenerated :: ModulePath -> (ModulePath -> [JsStmt]) -> Compile [JsStmt]@@ -212,22 +183,38 @@ -- | Generate exports for non local names, local exports have already been added to the module. generateExports :: Compile [JsStmt] generateExports = do-  m <- gets stateModuleName-  map (exportExp m) . S.toList . getNonLocalExports <$> gets id+  modName <- gets stateModuleName+  maybe [] (map (exportExp modName) . S.toList) <$> gets (getNonLocalExportsWithoutNewtypes modName)   where-    exportExp :: ModuleName -> QName -> JsStmt+    exportExp :: N.ModuleName -> N.QName -> JsStmt     exportExp m v = JsSetQName (changeModule m v) $ case findPrimOp v of-      Just p  -> JsName $ JsNameVar p+      Just p  -> JsName $ JsNameVar p -- TODO add test case for this case, is it needed at all?       Nothing -> JsName $ JsNameVar v +-- | Generate strict wrappers for the exports of the module.+generateStrictExports :: Compile [JsStmt]+generateStrictExports = do+  cfg <- config id+  modName <- gets stateModuleName+  if shouldExportStrictWrapper modName cfg+    then do+      locals <- gets (getLocalExportsWithoutNewtypes modName)+      nonLocals <- gets (getNonLocalExportsWithoutNewtypes modName)+      let int = maybe [] (map exportExp' . S.toList) locals+      let ext = maybe [] (map (exportExp modName)  . S.toList) nonLocals+      return $ int ++ ext+    else return []+  where+    exportExp :: N.ModuleName -> N.QName -> JsStmt+    exportExp m v = JsSetQName (changeModule' ("Strict." ++) $ changeModule m v) $ JsName $ JsNameVar $ changeModule' ("Strict." ++) v++    exportExp' :: N.QName -> JsStmt+    exportExp' name = JsSetQName (changeModule' ("Strict." ++) name) $ serialize (JsName (JsNameVar name))++    serialize :: JsExp -> JsExp+    serialize n = JsApp (JsRawExp "Fay$$fayToJs") [JsRawExp "['automatic']", n]+ -- | Is the module a standard module, i.e., one that we'd rather not -- output code for if we're compiling separate files.-anStdlibModule :: ModuleName -> Bool-anStdlibModule (ModuleName name) = name `elem` ["Prelude","FFI","Fay.FFI","Data.Data"]---- | Compile the given import.-compileImport :: ImportDecl -> Compile [JsStmt]--- Package imports are ignored since they are used for some trickery in fay-base.-compileImport (ImportDecl _ _    _     _ Just{}  _       _) = return []-compileImport (ImportDecl _ name False _ Nothing Nothing _) = compileModuleFromName name-compileImport i = throwError $ UnsupportedImport i+anStdlibModule :: ModuleName a -> Bool+anStdlibModule (ModuleName _ name) = name `elem` ["Prelude","FFI","Fay.FFI","Data.Data"]

@@ -4,10 +4,12 @@  module Fay.Compiler.Config where -import Data.Default-import Data.Maybe-import Fay.Types+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@@ -36,13 +38,15 @@ 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-    , configExportBuiltins     = True     , configExportRuntime      = True     , configExportStdlib       = True     , configExportStdlibOnly   = False@@ -59,4 +63,7 @@     , configPackageConf        = Nothing     , configPackages           = []     , configBasePath           = Nothing+    , configStrict             = []+    , configTypecheckOnly      = False+    , configRuntimePath        = Nothing     }

@@ -1,60 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Some useful debug functions.--module Fay.Compiler.Debug where--import Fay.Compiler.Defaults-import Fay.Compiler-import Fay.Compiler.Misc (parseResult)-import Fay.Types--import Control.Monad.Error-import Data.Default---- | Compile a String of Fay and print it as beautified JavaScript.-printTestCompile :: String -> IO ()-printTestCompile = printCompile def { configWarn = False } compileModuleFromAST---- | Compile a Haskell source string to a JavaScript source string.-compileTestAst :: (Show from,Show to,CompilesTo from to)-             => CompileConfig-             -> (from -> Compile to)-             -> String-             -> IO ()-compileTestAst cfg with from = do-  state <- defaultCompileState-  reader <- defaultCompileReader cfg-  out <- runCompile reader-             state-             (parseResult (throwError . uncurry ParseError)-                          with-                          (parseFay "<interactive>" from))-  case out of-    Left err -> error $ show err-    Right (ok,_,_) -> print ok---- | Print a useful debug output of a compilation.-debug :: (Show from,Show to,CompilesTo from to) => (from -> Compile to) -> String -> IO ()-debug compile string = do-  putStrLn "AST:\n"-  compileTestAst c compile string-  putStrLn ""-  putStrLn "JS (unoptimized):\n"-  printCompile def { configTypecheck = False } compile string-  putStrLn "JS (optimized):\n"-  printCompile c compile string--  where c = def { configOptimize = True, configTypecheck = False }---- | Compile the given input and print the output out prettily.-printCompile :: (Show from,Show to,CompilesTo from to)-              => CompileConfig-              -> (from -> Compile to)-              -> String-              -> IO ()-printCompile config with from = do-  result <- compileViaStr "<interactive>" config { configPrettyPrint = True } with from-  case result of-    Left err -> print err-    Right (PrintState{..},_,_) -> putStrLn . concat . reverse $ psOutput

@@ -1,131 +1,129 @@-{-# OPTIONS -fno-warn-orphans -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns          #-}  -- | Compile declarations.  module Fay.Compiler.Decl where -import Fay.Compiler.Exp-import Fay.Compiler.FFI-import Fay.Compiler.GADT-import Fay.Compiler.Misc-import Fay.Compiler.Pattern-import Fay.Data.List.Extra-import Fay.Types+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+import           Control.Applicative+import           Control.Monad.Error+import           Control.Monad.RWS+import           Language.Haskell.Exts.Annotated  -- | Compile Haskell declaration.-compileDecls :: Bool -> [Decl] -> Compile [JsStmt]-compileDecls toplevel decls =-  case decls of-    [] -> return []-    (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (scoped (compilePatBind toplevel (Just sig) bind))-                                                      (compileDecls toplevel decls)-    (decl:decls) -> appendM (scoped (compileDecl toplevel decl))-                            (compileDecls toplevel decls)+compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]+compileDecls toplevel decls = case decls of+  [] -> return []+  (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind toplevel (Just sig) bind)+                                                    (compileDecls toplevel decls)+  (decl:decls) -> appendM (compileDecl toplevel decl)+                          (compileDecls toplevel decls) -  where appendM m n = do x <- m-                         xs <- n-                         return (x ++ xs)-        scoped = if toplevel then withScope else id+  where+    appendM m n = do x <- m+                     xs <- n+                     return (x ++ xs)  -- | Compile a declaration.-compileDecl :: Bool -> Decl -> Compile [JsStmt]-compileDecl toplevel decl =-  case decl of-    pat@PatBind{} -> compilePatBind toplevel Nothing pat-    FunBind matches -> compileFunCase toplevel matches-    DataDecl _ DataType _ _ tyvars constructors _ -> compileDataDecl toplevel tyvars constructors-    GDataDecl _ DataType _l _i tyvars _n decls _ -> compileDataDecl toplevel tyvars (map convertGADT decls)-    DataDecl _ NewType  _ _ _ _ _ -> return []-    -- Just ignore type aliases and signatures.-    TypeDecl {} -> return []-    TypeSig  {} -> return []-    InfixDecl{} -> return []-    ClassDecl{} -> return []-    InstDecl {} -> return [] -- FIXME: Ignore.-    DerivDecl{} -> return []-    _ -> throwError (UnsupportedDeclaration decl)+compileDecl :: Bool -> S.Decl -> Compile [JsStmt]+compileDecl toplevel decl = case decl of+  pat@PatBind{} -> compilePatBind toplevel Nothing pat+  FunBind _ matches -> compileFunCase toplevel matches+  DataDecl _ (DataType _ ) _ head' constructors _ -> compileDataDecl toplevel (mkTyVars head') constructors+  GDataDecl _ (DataType _) _l (mkTyVars -> tyvars) _n decls _ -> compileDataDecl toplevel tyvars (map convertGADT decls)+  DataDecl _ (NewType _)  _ _ _ _ -> return []+  -- Just ignore type aliases and signatures.+  TypeDecl {} -> return []+  TypeSig  {} -> return []+  InfixDecl{} -> return []+  ClassDecl{} -> return []+  InstDecl {} -> return [] -- FIXME: Ignore.+  DerivDecl{} -> return []+  _ -> throwError (UnsupportedDeclaration decl) --- | Convenient instance.-instance CompilesTo Decl [JsStmt] where compileTo = compileDecl True +mkTyVars :: S.DeclHead -> [S.TyVarBind]+mkTyVars (DHead _ _ binds) = binds+mkTyVars (DHInfix _ t1 _ t2) = [t1, t2]+mkTyVars (DHParen _ dh) = mkTyVars dh+ -- | Compile a top-level pattern bind.-compilePatBind :: Bool -> Maybe Type -> Decl -> Compile [JsStmt]-compilePatBind toplevel sig pat =-  case pat of-    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->-      case ffiExp rhs of-        Just formatstr -> case sig of-          Just sig -> compileFFI srcloc ident formatstr sig-          Nothing  -> throwError (FfiNeedsTypeSig pat)-        _ -> compileUnguardedRhs srcloc toplevel ident rhs-    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls ->-      compileUnguardedRhs srcloc toplevel ident (Let bdecls rhs)-    PatBind srcloc pat Nothing (UnGuardedRhs rhs) _bdecls -> do-      exp <- compileExp rhs-      name <- withScopedTmpJsName return-      [JsIf t b1 []] <- compilePat (JsName name) pat []-      let err = [throw (prettyPrint srcloc ++ "Irrefutable pattern failed for pattern: " ++ prettyPrint pat) (JsList [])]-      return [JsVar name exp, JsIf t b1 err]-    _ -> throwError (UnsupportedDeclaration pat)+compilePatBind :: Bool -> Maybe S.Type -> S.Decl -> Compile [JsStmt]+compilePatBind toplevel sig pat = case pat of+  PatBind _ (PVar _ ident) Nothing (UnGuardedRhs _ rhs) Nothing ->+    case ffiExp rhs of+      Just formatstr -> case sig of+        Just sig -> compileFFI ident formatstr sig+        Nothing  -> throwError (FfiNeedsTypeSig pat)+      _ -> compileUnguardedRhs toplevel ident rhs+  PatBind _ (PVar _ ident) Nothing (UnGuardedRhs _ rhs) (Just bdecls) ->+    compileUnguardedRhs toplevel ident (Let S.noI bdecls rhs)+  PatBind _ pat Nothing (UnGuardedRhs _ rhs) _bdecls -> do+    exp <- compileExp rhs+    name <- withScopedTmpJsName return+    [JsIf t b1 []] <- compilePat (JsName name) pat []+    let err = [throw ("Irrefutable pattern failed for pattern: " ++ prettyPrint pat) (JsList [])]+    return [JsVar name exp, JsIf t b1 err]+  _ -> throwError (UnsupportedDeclaration pat)  -- | Compile a normal simple pattern binding.-compileUnguardedRhs :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt]-compileUnguardedRhs _srcloc toplevel ident rhs = do-  unless toplevel $ bindVar ident-  withScope $ do-    body <- compileExp rhs-    bind <- bindToplevel toplevel ident (thunk body)-    return [bind]+compileUnguardedRhs :: Bool -> S.Name -> S.Exp -> Compile [JsStmt]+compileUnguardedRhs toplevel ident rhs = do+  body <- compileExp rhs+  bind <- bindToplevel toplevel ident (thunk body)+  return [bind]  -- | Compile a data declaration (or a GADT, latter is converted to former).-compileDataDecl :: Bool -> [TyVarBind] -> [QualConDecl] -> Compile [JsStmt]+compileDataDecl :: Bool -> [S.TyVarBind] -> [S.QualConDecl] -> Compile [JsStmt] compileDataDecl toplevel tyvars constructors =   fmap concat $-    forM constructors $ \(QualConDecl srcloc _ _ condecl) ->+    forM constructors $ \(QualConDecl _ _ _ condecl) ->       case condecl of-        ConDecl name types  -> do-          let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types-              fields' = zip (map return fields) types-          cons <- makeConstructor name fields-          func <- makeFunc name fields-          emitFayToJs name tyvars fields'-          emitJsToFay name tyvars fields'-          emitCons cons-          return [func]-        InfixConDecl t1 name t2 -> do-          let slots = ["slot1","slot2"]+        ConDecl _ name types -> do+          let slots =  map (Ident () . ("slot"++) . show . fst) $ zip [1 :: Int ..] types+              fields = zip (map return slots) types+          cons <- makeConstructor name slots+          func <- makeFunc name slots+          emitFayToJs name tyvars fields+          emitJsToFay name tyvars fields+          return [cons, func]+        InfixConDecl _ t1 name t2 -> do+          let slots = [Ident () "slot1",Ident () "slot2"]               fields = zip (map return slots) [t1, t2]           cons <- makeConstructor name slots           func <- makeFunc name slots           emitFayToJs name tyvars fields           emitJsToFay name tyvars fields-          emitCons cons-          return [func]-        RecDecl name fields' -> do-          let fields = concatMap fst fields'+          return [cons, func]+        RecDecl _ name fields' -> do+          let fields = concatMap fieldDeclNames fields'           cons <- makeConstructor name fields           func <- makeFunc name fields-          funs <- makeAccessors srcloc fields-          emitFayToJs name tyvars fields'-          emitJsToFay name tyvars fields'-          emitCons cons-          return (func : funs)+          funs <- makeAccessors fields+          emitFayToJs name tyvars (map convertFieldDecl fields')+          emitJsToFay name tyvars (map convertFieldDecl fields')+          return (cons : func : funs)    where-    emitCons cons = tell (mempty { writerCons = [cons] })-     -- Creates a constructor _RecConstr for a Record-    makeConstructor :: Name -> [Name] -> Compile JsStmt-    makeConstructor name (map (JsNameVar . UnQual) -> fields) = do+    makeConstructor :: Name a -> [Name b] -> Compile JsStmt+    makeConstructor (unAnn -> name) (map (JsNameVar . UnQual () . unAnn) -> fields) = do       qname <- qualify name       return $         JsSetConstructor qname $@@ -135,8 +133,8 @@                 Nothing      -- Creates a function to initialize the record by regular application-    makeFunc :: Name -> [Name] -> Compile JsStmt-    makeFunc name (map (JsNameVar . UnQual) -> fields) = do+    makeFunc :: Name a -> [Name b] -> Compile JsStmt+    makeFunc (unAnn -> name) (map (JsNameVar . UnQual () . unAnn) -> fields) = do       let fieldExps = map JsName fields       qname <- qualify name       let mp = mkModulePathFromQName qname@@ -152,69 +150,72 @@           return $ JsSetQName qname func      -- Creates getters for a RecDecl's values-    makeAccessors :: SrcLoc -> [Name] -> Compile [JsStmt]-    makeAccessors _srcloc fields =-      forM fields $ \name ->+    makeAccessors :: [S.Name] -> Compile [JsStmt]+    makeAccessors fields =+      forM fields $ \(unAnn -> name) ->            bindToplevel toplevel                         name                         (JsFun Nothing                                [JsNameVar "x"]                                []                                (Just (thunk (JsGetProp (force (JsName (JsNameVar "x")))-                                                       (JsNameVar (UnQual name))))))+                                                       (JsNameVar (UnQual () name))))))   -- | Compile a function which pattern matches (causing a case analysis).-compileFunCase :: Bool -> [Match] -> Compile [JsStmt]+compileFunCase :: Bool -> [S.Match] -> Compile [JsStmt] compileFunCase _toplevel [] = return []-compileFunCase toplevel matches@(Match _ name argslen _ _ _:_) = do+compileFunCase toplevel (InfixMatch l pat name pats rhs binds : rest) =+  compileFunCase toplevel (Match l name (pat:pats) rhs binds : rest)+compileFunCase toplevel matches@(Match _ name argslen _ _:_) = do   pats <- fmap optimizePatConditions (mapM compileCase matches)-  bindVar name   bind <- bindToplevel toplevel                        name                        (foldr (\arg inner -> JsFun Nothing [arg] [] (Just inner))                               (stmtsThunk (concat pats ++ basecase))                               args)   return [bind]-  where args = zipWith const uniqueNames argslen+  where+    args = zipWith const uniqueNames argslen -        isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats+    isWildCardMatch (Match _ _ pats          _ _) = all isWildCardPat pats+    isWildCardMatch (InfixMatch _ pat _ pats _ _) = all isWildCardPat (pat:pats) -        compileCase :: Match -> Compile [JsStmt]-        compileCase match@(Match _ _ pats _ rhs _) =-          withScope $ do-            whereDecls' <- whereDecls match-            generateScope $ zipWithM (\arg pat -> compilePat (JsName arg) pat []) args pats-            generateScope $ mapM compileLetDecl whereDecls'-            rhsform <- compileRhs rhs-            body <- if null whereDecls'-                      then return [either id JsEarlyReturn rhsform]-                      else do-                          binds <- mapM compileLetDecl whereDecls'-                          case rhsform of-                            Right exp ->-                              return [JsEarlyReturn $ JsApp (JsFun Nothing [] (concat binds) (Just exp)) []]-                            Left stmt ->-                              withScopedTmpJsName $ \n -> return-                                [ JsVar n (JsApp (JsFun Nothing [] (concat binds ++ [stmt]) Nothing) [])-                                , JsIf (JsNeq JsUndefined (JsName n)) [JsEarlyReturn (JsName n)] []-                                ]-            foldM (\inner (arg,pat) ->-                    compilePat (JsName arg) pat inner)-                  body-                  (zip args pats)+    compileCase :: S.Match -> Compile [JsStmt]+    compileCase (InfixMatch l pat name pats rhs binds) =+      compileCase $ Match l name (pat:pats) rhs binds+    compileCase match@(Match _ _ pats rhs _) = do+      whereDecls' <- whereDecls match+      rhsform <- compileRhs rhs+      body <- if null whereDecls'+                then return [either id JsEarlyReturn rhsform]+                else do+                    binds <- mapM compileLetDecl whereDecls'+                    case rhsform of+                      Right exp ->+                        return [JsEarlyReturn $ JsApp (JsFun Nothing [] (concat binds) (Just exp)) []]+                      Left stmt ->+                        withScopedTmpJsName $ \n -> return+                          [ JsVar n (JsApp (JsFun Nothing [] (concat binds ++ [stmt]) Nothing) [])+                          , JsIf (JsNeq JsUndefined (JsName n)) [JsEarlyReturn (JsName n)] []+                          ]+      foldM (\inner (arg,pat) ->+              compilePat (JsName arg) pat inner)+            body+            (zip args pats) -        whereDecls :: Match -> Compile [Decl]-        whereDecls (Match _ _ _ _ _ (BDecls decls)) = return decls-        whereDecls match = throwError (UnsupportedWhereInMatch match)+    whereDecls :: S.Match -> Compile [S.Decl]+    whereDecls (Match _ _ _ _ (Just (BDecls _ decls))) = return decls+    whereDecls (Match _ _ _ _ Nothing) = return []+    whereDecls match = throwError (UnsupportedWhereInMatch match) -        basecase :: [JsStmt]-        basecase = if any isWildCardMatch matches-                      then []-                      else [throw ("unhandled case in " ++ prettyPrint name)-                                  (JsList (map JsName args))]+    basecase :: [JsStmt]+    basecase = if any isWildCardMatch matches+                  then []+                  else [throw ("unhandled case in " ++ prettyPrint name)+                              (JsList (map JsName args))]  -- | Compile a right-hand-side expression.-compileRhs :: Rhs -> Compile (Either JsStmt JsExp)-compileRhs (UnGuardedRhs exp) = Right <$> compileExp exp-compileRhs (GuardedRhss rhss) = Left <$> compileGuards rhss+compileRhs :: S.Rhs -> Compile (Either JsStmt JsExp)+compileRhs (UnGuardedRhs _ exp) = Right <$> compileExp exp+compileRhs (GuardedRhss _ rhss) = Left <$> compileGuards rhss

@@ -4,17 +4,19 @@  module Fay.Compiler.Defaults where -import Fay.Compiler.Config-import Fay.Compiler.Decl (compileDecls)-import Fay.Compiler.Exp (compileLit)-import Fay.Types+import           Fay.Compiler.Config+import           Fay.Compiler.Decl   (compileDecls)+import           Fay.Compiler.Exp    (compileLit)+import           Fay.Types+import           Paths_fay -import Data.Default-import Data.Map as M-import Data.Set as S-import Language.Haskell.Exts.Syntax-import Paths_fay+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 = do@@ -26,20 +28,16 @@     }  -- | The default compiler state.-defaultCompileState :: IO CompileState-defaultCompileState = do-  types <- getDataFileName "src/Language/Fay/Types.hs"-  return CompileState-    {  _stateExports = M.empty-    , stateModuleName = ModuleName "Main"-    , stateRecordTypes = []-    , stateRecords = []-    , stateNewtypes = []-    , stateImported = [("Fay.Types",types)]-    , stateNameDepth = 1-    , stateLocalScope = S.empty-    , stateModuleScope = def-    , stateModuleScopes = M.empty-    , stateJsModulePaths = S.empty-    , stateUseFromString = False-    }+defaultCompileState :: CompileState+defaultCompileState = CompileState+  { stateInterfaces    = M.empty+  , stateModuleName    = "Main"+  , stateRecordTypes   = []+  , stateRecords       = []+  , stateNewtypes      = []+  , stateImported      = []+  , stateNameDepth     = 1+  , stateJsModulePaths = S.empty+  , stateUseFromString = False+  , stateTypeSigs      = M.empty+  }

@@ -0,0 +1,269 @@+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}++module Fay.Compiler.Desugar+  (desugar+  ) where++import           Fay.Types                       (CompileError (..))++import           Control.Applicative+import           Control.Monad.Error+import           Control.Monad.Reader+import           Data.Maybe+import           Language.Haskell.Exts.Annotated hiding (binds, loc)+import           Prelude                         hiding (exp)+++-- Types++data DesugarReader = DesugarReader { readerNameDepth :: Int }++newtype Desugar a = Desugar+  { unDesugar :: (ReaderT DesugarReader+                       (ErrorT CompileError IO))+                       a+  } deriving ( MonadReader DesugarReader+             , MonadError CompileError+             , MonadIO+             , Monad+             , Functor+             , Applicative+             )++runDesugar :: Desugar a -> IO (Either CompileError a)+runDesugar m = runErrorT (runReaderT (unDesugar m) (DesugarReader 0))++-- | Generate a temporary, SCOPED name for testing conditions and+-- such. We don't have name tracking yet, so instead we use this.+withScopedTmpName :: l -> (Name l -> Desugar a) -> Desugar a+withScopedTmpName l f = do+  n <- asks readerNameDepth+  local (\r -> DesugarReader $ readerNameDepth r + 1) $+   f $ Ident l $ "$gen" ++ show n+++-- | Top level, desugar a whole module possibly returning errors+desugar :: Module l -> IO (Either CompileError (Module l))+desugar md = runDesugar (desugarModule md)++-- | Desugaring++desugarModule :: Module l -> Desugar (Module l)+desugarModule m = case m of+  Module l h ps is decls -> Module l h ps is <$> mapM desugarDecl decls+  _ -> return $ m++desugarDecl :: Decl l -> Desugar (Decl l)+desugarDecl d = case d of+  FunBind l ms -> FunBind l <$> mapM desugarMatch ms+  PatBind l p mt rhs mbs -> PatBind l <$> desugarPat p <*> return mt <*> desugarRhs rhs <*> mmap desugarBinds mbs++  _ -> return d++mmap :: (Applicative f) => (t -> f a) -> Maybe t -> f (Maybe a)+mmap f mbs' = case mbs' of Just b -> return <$> f b; Nothing -> pure Nothing++desugarBinds :: Binds l -> Desugar (Binds l)+desugarBinds bs = case bs of+  BDecls l ds -> BDecls l <$> mapM desugarDecl ds+  _ -> return bs++desugarMatch :: Match l -> Desugar (Match l)+desugarMatch m = case m of+  Match l n ps rhs mb -> Match l (desugarName n) <$> mapM desugarPat ps <*> desugarRhs rhs <*> mmap desugarBinds mb+  InfixMatch l p n ps r mb -> InfixMatch l <$> desugarPat p <*> return (desugarName n) <*> mapM desugarPat ps <*> desugarRhs r <*> mmap desugarBinds mb++desugarRhs :: Rhs l -> Desugar (Rhs l)+desugarRhs r = case r of+  UnGuardedRhs l e -> UnGuardedRhs l <$> desugarExp e+  GuardedRhss l gs -> GuardedRhss l <$> mapM desugarGuardedRhs gs++desugarGuardedRhs :: GuardedRhs l -> Desugar (GuardedRhs l)+desugarGuardedRhs g = case g of+  GuardedRhs l stmts exp -> GuardedRhs l <$> mapM desugarStmt stmts <*> desugarExp exp++desugarExp :: Exp l -> Desugar (Exp l)+desugarExp ex = case ex of+  -- (a `f`) => (\b -> f a b)+  LeftSection l e q -> desugarExp =<<+    (withScopedTmpName l $ \v ->+      return $ Lambda l [PVar l v] (InfixApp l e q (Var l (UnQual l v))))+  -- (`f` b) => (\a -> f a b)+  RightSection l q e -> desugarExp =<<+    (withScopedTmpName l $ \tmp ->+      return (Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e)))++  -- Check for TupleCon+  Var _ q -> return $ desugarVar ex q+  Con _ q -> return $ desugarVar ex q++  IPVar{} -> return ex+  Lit{} -> return ex+  InfixApp l e1 qop e2 -> InfixApp l <$> desugarExp e1 <*> return (desugarQOp qop) <*> desugarExp e2+  App l e1 e2 -> App l <$> desugarExp e1 <*> desugarExp e2+  NegApp l e -> NegApp l <$> desugarExp e+  Lambda l ps e -> Lambda l <$> mapM desugarPat ps <*> desugarExp e+  Let l b e -> Let l <$> desugarBinds b <*> desugarExp e+  If l e1 e2 e3 -> If l <$> desugarExp e1 <*> desugarExp e2 <*> desugarExp e3+  Case l e as -> Case l <$> desugarExp e <*> mapM desugarAlt as+  Do _ stmts -> maybe (throwError EmptyDoBlock) return =<< (mmap desugarExp $ foldl desugarStmt' Nothing (reverse stmts))+  MDo l ss -> MDo l <$> mapM desugarStmt ss+  Tuple l b es -> Tuple l b <$> mapM desugarExp es+  TupleSection l b mes -> TupleSection l b <$> mapM (mmap desugarExp) mes+  List l es -> List l <$> mapM desugarExp es+  Paren l e -> Paren l <$> desugarExp e+  RecConstr l q f -> RecConstr l (desugarQName q) <$> mapM desugarFieldUpdate f+  RecUpdate l e f -> RecUpdate l <$> desugarExp e <*> mapM desugarFieldUpdate f+  EnumFrom l e -> EnumFrom l <$> desugarExp e+  EnumFromTo l e1 e2 -> EnumFromTo l <$> desugarExp e1 <*> desugarExp e2+  EnumFromThen l e1 e2 -> EnumFromThen l <$> desugarExp e1 <*> desugarExp e2+  EnumFromThenTo l e1 e2 e3 -> EnumFromThenTo l <$> desugarExp e1 <*> desugarExp e2 <*> desugarExp e3+  ListComp l e qs -> ListComp l <$> desugarExp e <*> mapM desugarQualStmt qs+  ParComp l e qqs -> ParComp l <$> desugarExp e <*> mapM (mapM desugarQualStmt) qqs+  ExpTypeSig l e t -> ExpTypeSig l <$> desugarExp e <*> return (desugarType t)+  VarQuote l q -> return $ VarQuote l (desugarQName q)+  TypQuote l q -> return $ TypQuote l (desugarQName q)+  BracketExp l b -> return $ BracketExp l (desugarBracket b)+  SpliceExp l s -> return $ SpliceExp l (desugarSplice s)+  QuasiQuote{} -> return ex+  XTag{} -> return ex+  XETag{} -> return ex+  XPcdata{} -> return ex+  XExpTag{} -> return ex+  XChildTag{} -> return ex+  GenPragma{} -> return ex+  Proc l p e -> Proc l <$> desugarPat p <*> desugarExp e+  LeftArrApp{} -> return ex+  RightArrApp{} -> return ex+  LeftArrHighApp{} -> return ex+  RightArrHighApp{} -> return ex+  CorePragma{} -> return ex+  SCCPragma{} -> return ex++-- | Convert do notation into binds and thens.+desugarStmt' :: Maybe (Exp l) -> (Stmt l) -> Maybe (Exp l)+desugarStmt' inner stmt =+  maybe initStmt subsequentStmt inner+  where+    initStmt = case stmt of+      Qualifier _ exp -> Just exp+      LetStmt{}     -> error "UnsupportedLet"+      _             -> error "InvalidDoBlock"++    subsequentStmt inner' = case stmt of+      Generator loc pat exp -> desugarGenerator loc pat inner' exp+      Qualifier s exp -> Just $ InfixApp s exp+                                         (QVarOp s $ UnQual s $ Symbol s ">>")+                                         inner'+      LetStmt _ (BDecls s binds) -> Just $ Let s (BDecls s binds) inner'+      LetStmt _ _ -> error "UnsupportedLet"+      RecStmt{} -> error "UnsupportedRecursiveDo"++    desugarGenerator :: l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)+    desugarGenerator s pat inner' exp =+      Just $ InfixApp s+                      exp+                      (QVarOp s $ UnQual s $ Symbol s ">>=")+                      (Lambda s [pat] (inner'))+++desugarPat :: Pat l -> Desugar (Pat l)+desugarPat pt = case pt of+  -- (p) => p+  PParen _ p -> desugarPat p++  PVar l n -> return $ PVar l (desugarName n)+  PLit {} -> return pt+  PNeg l p -> PNeg l <$> desugarPat p+  PNPlusK{} -> return pt+  PInfixApp l p1 q p2 -> PInfixApp l <$> desugarPat p1 <*> return (desugarQName q) <*> desugarPat p2+  PApp l q ps -> PApp l (desugarQName q) <$> mapM desugarPat ps+  PTuple l b ps -> PTuple l b <$> mapM desugarPat ps+  PList l ps -> PList l <$> mapM desugarPat ps+  PRec l q pfs -> PRec l (desugarQName q) <$> mapM desugarPatField pfs+  PAsPat l n p -> PAsPat l (desugarName n) <$> desugarPat p+  PWildCard{} -> return pt+  PIrrPat l p -> PIrrPat l <$> desugarPat p+  PatTypeSig l p t -> PatTypeSig l <$> desugarPat p <*> return (desugarType t)+  PViewPat l e p -> PViewPat l <$> desugarExp e <*> desugarPat p+  PBangPat l p -> PBangPat l <$> desugarPat p+  _ -> return pt++desugarPatField :: PatField l -> Desugar (PatField l)+desugarPatField pf = case pf of+  -- {a} => {a=a} for R{a}+  PFieldPun l n -> let dn = desugarName n in desugarPatField $ PFieldPat l (UnQual l dn) (PVar l dn)++  PFieldPat l q p -> PFieldPat l (desugarQName q) <$> desugarPat p+  PFieldWildcard l -> return $ PFieldWildcard l++desugarGuardedAlts :: GuardedAlts l -> Desugar (GuardedAlts l)+desugarGuardedAlts g = case g of+  UnGuardedAlt l e -> UnGuardedAlt l <$> desugarExp e+  GuardedAlts l gas -> GuardedAlts l <$> mapM desugarGuardedAlt gas++desugarQOp :: QOp l -> QOp l+desugarQOp = id++desugarType :: Type l -> Type l+desugarType = id++desugarQName :: QName l -> QName l+desugarQName = id++desugarQualStmt :: QualStmt l -> Desugar (QualStmt l)+desugarQualStmt q = case q of+  QualStmt l s -> QualStmt l <$> desugarStmt s+  ThenTrans l e -> ThenTrans l <$> desugarExp e+  ThenBy l e1 e2 -> ThenBy l <$> desugarExp e1 <*> desugarExp e2+  GroupBy l e -> GroupBy l <$> desugarExp e+  GroupUsing l e -> GroupUsing l <$> desugarExp e+  GroupByUsing l e1 e2 -> GroupByUsing l <$> desugarExp e1 <*> desugarExp e2++desugarAlt :: Alt l -> Desugar (Alt l)+desugarAlt (Alt l p ga mb) = Alt l <$> desugarPat p <*> desugarGuardedAlts ga <*> mmap desugarBinds mb++desugarFieldUpdate :: FieldUpdate l -> Desugar (FieldUpdate l)+desugarFieldUpdate f = case f of+  FieldUpdate l q e -> FieldUpdate l (desugarQName q) <$> desugarExp e+  FieldPun l n -> let dn = UnQual l (desugarName n)+                  in desugarFieldUpdate $ FieldUpdate l dn (Var l dn)+  FieldWildcard{} -> return f++desugarBracket :: Bracket l -> Bracket l+desugarBracket = id++desugarSplice :: Splice l -> Splice l+desugarSplice = id++desugarGuardedAlt :: GuardedAlt l -> Desugar (GuardedAlt l)+desugarGuardedAlt (GuardedAlt l ss e) = GuardedAlt l <$> mapM desugarStmt ss <*> desugarExp e++desugarStmt :: Stmt l -> Desugar (Stmt l)+desugarStmt s = case s of+  Generator l p e -> Generator l <$> desugarPat p <*> desugarExp e+  Qualifier l e -> Qualifier l <$> desugarExp e+  LetStmt l b -> LetStmt l <$> desugarBinds b+  RecStmt l ss -> RecStmt l <$> mapM desugarStmt ss++desugarName :: Name a -> Name a+desugarName = id++desugarVar :: Exp l -> QName l -> Exp l+desugarVar e q = case q of+  Special _ t@TupleCon{} -> fromMaybe e $ desugarTupleCon t+  _ -> e++-- | (,) => \x y -> (x,y)+desugarTupleCon :: SpecialCon l -> Maybe (Exp l)+desugarTupleCon s = 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)..]+      params = PVar l <$> names+      body   = Tuple l b (Var l . UnQual l <$> names)+  _ -> Nothing

@@ -1,107 +1,104 @@-{-# OPTIONS -fno-warn-name-shadowing -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE ViewPatterns          #-}  -- | Compile expressions. -module Fay.Compiler.Exp where+module Fay.Compiler.Exp+  (compileExp+  ,compileGuards+  ,compileLetDecl+  ,compileLit+  ) where -import Fay.Compiler.Misc-import Fay.Compiler.Pattern-import Fay.Compiler.Print-import Fay.Compiler.FFI             (compileFFIExp)-import Fay.Types+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.Exts.NoAnnotation           (unAnn)+import           Fay.Exts.Scoped                 (noI)+import qualified Fay.Exts.Scoped                 as S+import           Fay.Types -import Control.Applicative-import Control.Monad.Error-import Control.Monad.RWS-import Data.Maybe-import Language.Haskell.Exts+import           Control.Applicative+import           Control.Monad.Error+import           Control.Monad.RWS+import           Language.Haskell.Exts.Annotated+import           Language.Haskell.Names  -- | Compile Haskell expression.-compileExp :: Exp -> Compile JsExp-compileExp exp =-  case exp of-    Paren exp                     -> compileExp exp-    Var qname                     -> compileVar qname-    Lit lit                       -> compileLit lit-    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-    Tuple _boxed xs               -> compileList xs-    If cond conseq alt            -> compileIf cond conseq alt-    Case exp alts                 -> compileCase exp alts-    Con (UnQual (Ident "True"))   -> return (JsLit (JsBool True))-    Con (UnQual (Ident "False"))  -> return (JsLit (JsBool False))-    Con qname                     -> compileVar qname-    Do stmts                      -> compileDoBlock stmts-    Lambda _ pats exp             -> compileLambda pats exp-    LeftSection e o               -> compileExp =<< desugarLeftSection e o-    RightSection o e              -> compileExp =<< desugarRightSection o e-    EnumFrom i                    -> compileEnumFrom i-    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-    ListComp exp stmts            -> compileExp =<< desugarListComp exp stmts-    ExpTypeSig srcloc exp sig     ->-      case ffiExp exp of-        Nothing -> compileExp exp-        Just formatstr -> compileFFIExp srcloc Nothing formatstr sig--    exp -> throwError (UnsupportedExpression exp)---- | Compiling instance.-instance CompilesTo Exp JsExp where compileTo = compileExp+compileExp :: S.Exp -> Compile JsExp+compileExp exp = case exp of+  Paren _ exp                        -> compileExp exp+  Var _ qname                        -> compileVar qname+  Lit _ lit                          -> compileLit lit+  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+  Tuple _ _boxed xs                  -> compileList xs+  If _ cond conseq alt               -> compileIf cond conseq alt+  Case _ exp alts                    -> compileCase exp alts+  Con _ (UnQual _ (Ident _ "True"))  -> return (JsLit (JsBool True))+  Con _ (UnQual _ (Ident _ "False")) -> return (JsLit (JsBool False))+  Con _ qname                        -> compileVar qname+  Lambda _ pats exp                  -> compileLambda pats exp+  EnumFrom _ i                       -> compileEnumFrom i+  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+  ListComp _ exp stmts               -> compileExp =<< desugarListComp exp stmts+  Do {}                              -> shouldBeDesugared exp+  LeftSection {}                     -> shouldBeDesugared exp+  RightSection {}                    -> shouldBeDesugared exp+  ExpTypeSig _ exp sig               ->+    case ffiExp exp of+      Nothing -> compileExp exp+      Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig --- | Turn a tuple constructor into a normal lambda expression.-tupleConToFunction :: Boxed -> Int -> Exp-tupleConToFunction b n = Lambda noLoc params body-  where names  = take n (Ident . pure <$> ['a'..])-        params = PVar <$> names-        body   = Tuple b (Var . UnQual <$> names)-        noLoc  = error "no source location for SpecialCon"+  exp -> throwError (UnsupportedExpression exp)  -- | Compile variable.-compileVar :: QName -> Compile JsExp-compileVar qname = do-  case qname of-    Special (TupleCon b n) -> compileExp (tupleConToFunction b n)-    _ -> do-      qname <- unsafeResolveName qname-      return (JsName (JsNameVar qname))+compileVar :: S.QName -> Compile JsExp+compileVar qname = case qname of+  Special _ t@TupleCon{} -> shouldBeDesugared t+  _ -> do+    qname <- unsafeResolveName qname+    return (JsName (JsNameVar qname))  -- | Compile Haskell literal.-compileLit :: Literal -> Compile JsExp-compileLit lit =-  case lit of-    Char ch       -> return (JsLit (JsChar ch))-    Int integer   -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME:-    Frac rational -> return (JsLit (JsFloating (fromRational rational)))-    -- TODO: Use real JS strings instead of array, probably it will-    -- lead to the same result.-    String string -> do-      fromString <- gets stateUseFromString-      if fromString-        then return (JsLit (JsStr string))-        else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)])-    lit           -> throwError (UnsupportedLiteral lit)+compileLit :: S.Literal -> Compile JsExp+compileLit lit = case lit of+  Char _ ch _      -> return (JsLit (JsChar ch))+  Int _ integer _   -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME:+  Frac _ rational _ -> return (JsLit (JsFloating (fromRational rational)))+  String _ string _ -> do+    fromString <- gets stateUseFromString+    if fromString+      then return (JsLit (JsStr string))+      else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)])+  lit           -> throwError (UnsupportedLiteral lit)  -- | Compile simple application.-compileApp :: Exp -> Exp -> Compile JsExp-compileApp exp1@(Con q) exp2 =+compileApp :: S.Exp -> S.Exp -> Compile JsExp+compileApp exp1@(Con _ q) exp2 =   maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q-compileApp exp1@(Var q) exp2 =+compileApp exp1@(Var _ q) exp2 =   maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q compileApp exp1 exp2 =   compileApp' exp1 exp2  -- | Helper for compileApp.-compileApp' :: Exp -> Exp -> Compile JsExp+compileApp' :: S.Exp -> S.Exp -> Compile JsExp compileApp' exp1 exp2 = do   flattenApps <- config configFlattenApps   jsexp1 <- compileExp exp1@@ -111,7 +108,7 @@     -- In this approach code ends up looking like this:     -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)})     -- Which might be OK for speed, but increases the JS stack a fair bit.-    method1 :: JsExp -> Exp -> Compile JsExp+    method1 :: JsExp -> S.Exp -> Compile JsExp     method1 exp1 exp2 =       JsApp <$> (forceFlatName <$> return exp1)             <*> fmap return (compileExp exp2)@@ -122,7 +119,7 @@     -- In this approach code ends up looking like this:     -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05))     -- Which should be much better for the stack and readability, but probably not great for speed.-    method2 :: JsExp -> Exp -> Compile JsExp+    method2 :: JsExp -> S.Exp -> Compile JsExp     method2 exp1 exp2 = fmap flatten $       JsApp <$> return exp1             <*> fmap return (compileExp exp2)@@ -134,28 +131,25 @@         flatten x = x  -- | Compile a negate application-compileNegApp :: Exp -> Compile JsExp+compileNegApp :: S.Exp -> Compile JsExp compileNegApp e = JsNegApp . force <$> compileExp e  -- | Compile an infix application, optimizing the JS cases.-compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp-compileInfixApp exp1 ap exp2 = compileExp (App (App (Var op) exp1) exp2)-+compileInfixApp :: S.Exp -> S.QOp -> S.Exp -> Compile JsExp+compileInfixApp exp1 ap exp2 = compileExp (App noI (App noI (Var noI op) exp1) exp2)   where op = getOp ap-        getOp (QVarOp op) = op-        getOp (QConOp op) = op+        getOp (QVarOp _ op) = op+        getOp (QConOp _ op) = op  -- | Compile a let expression.-compileLet :: [Decl] -> Exp -> Compile JsExp-compileLet decls exp =-  withScope $ do-    generateScope $ mapM compileLetDecl decls-    binds <- mapM compileLetDecl decls-    body <- compileExp exp-    return (JsApp (JsFun Nothing [] [] (Just $ stmtsThunk $ concat binds ++ [JsEarlyReturn body])) [])+compileLet :: [S.Decl] -> S.Exp -> Compile JsExp+compileLet decls exp = do+  binds <- mapM compileLetDecl decls+  body <- compileExp exp+  return (JsApp (JsFun Nothing [] [] (Just $ stmtsThunk $ concat binds ++ [JsEarlyReturn body])) [])  -- | Compile let declaration.-compileLetDecl :: Decl -> Compile [JsStmt]+compileLetDecl :: S.Decl -> Compile [JsStmt] compileLetDecl decl = do   compileDecls <- asks readerCompileDecls   case decl of@@ -165,20 +159,20 @@     _              -> throwError (UnsupportedLetBinding decl)  -- | Compile a list expression.-compileList :: [Exp] -> Compile JsExp+compileList :: [S.Exp] -> Compile JsExp compileList xs = do   exps <- mapM compileExp xs   return (makeList exps)  -- | Compile an if.-compileIf :: Exp -> Exp -> Exp -> Compile JsExp+compileIf :: S.Exp -> S.Exp -> S.Exp -> Compile JsExp compileIf cond conseq alt =   JsTernaryIf <$> fmap force (compileExp cond)               <*> compileExp conseq               <*> compileExp alt  -- | Compile case expressions.-compileCase :: Exp -> [Alt] -> Compile JsExp+compileCase :: S.Exp -> [S.Alt] -> Compile JsExp compileCase exp alts = do   exp <- compileExp exp   withScopedTmpJsName $ \tmpName -> do@@ -193,29 +187,28 @@             [exp]  -- | Compile the given pattern against the given expression.-compilePatAlt :: JsExp -> Alt -> Compile [JsStmt]+compilePatAlt :: JsExp -> S.Alt -> Compile [JsStmt] compilePatAlt exp alt@(Alt _ pat rhs wheres) = case wheres of-  BDecls (_ : _) -> throwError (UnsupportedWhereInAlt alt)-  IPBinds (_ : _) -> throwError (UnsupportedWhereInAlt alt)-  _ -> withScope $ do-    generateScope $ compilePat exp pat []+  Just (BDecls _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt)+  Just (IPBinds _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt)+  _ -> do     alt <- compileGuardedAlt rhs     compilePat exp pat [alt]  -- | Compile a guarded alt.-compileGuardedAlt :: GuardedAlts -> Compile JsStmt+compileGuardedAlt :: S.GuardedAlts -> Compile JsStmt compileGuardedAlt alt =   case alt of-    UnGuardedAlt exp -> JsEarlyReturn <$> compileExp exp-    GuardedAlts alts -> compileGuards (map altToRhs alts)+    UnGuardedAlt _ exp -> JsEarlyReturn <$> compileExp exp+    GuardedAlts _ alts -> compileGuards (map altToRhs alts)    where     altToRhs (GuardedAlt l s e) = GuardedRhs l s e  -- | Compile guards-compileGuards :: [GuardedRhs] -> Compile JsStmt-compileGuards ((GuardedRhs _ (Qualifier (Var (UnQual (Ident "otherwise"))):_) exp):_) =+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) =+compileGuards (GuardedRhs _ (Qualifier _ guard:_) exp : rest) =   makeIf <$> fmap force (compileExp guard)          <*> compileExp exp          <*> if null rest then return [] else do@@ -223,24 +216,16 @@            return [gs']     where makeIf gs e gss = JsIf gs [JsEarlyReturn e] gss -compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss $ rhss---- | Compile a do block.-compileDoBlock :: [Stmt] -> Compile JsExp-compileDoBlock stmts = do-  doblock <- foldM compileStmt Nothing (reverse stmts)-  maybe (throwError EmptyDoBlock) compileExp doblock+compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss noI $ rhss  -- | Compile a lambda.-compileLambda :: [Pat] -> Exp -> Compile JsExp-compileLambda pats exp =-  withScope $ do-    generateScope $ generateStatements JsNull-    exp   <- compileExp exp-    stmts <- generateStatements exp-    case stmts of-      [JsEarlyReturn fun@JsFun{}] -> return fun-      _ -> error "Unexpected statements in compileLambda"+compileLambda :: [S.Pat] -> S.Exp -> Compile JsExp+compileLambda pats exp = do+  exp   <- compileExp exp+  stmts <- generateStatements exp+  case stmts of+    [JsEarlyReturn fun@JsFun{}] -> return fun+    _ -> error "Unexpected statements in compileLambda"    where unhandledcase = throw "unhandled case" . JsName         allfree = all isWildCardPat pats@@ -251,151 +236,106 @@                 [JsEarlyReturn exp]                 (reverse (zip uniqueNames pats)) --- | Desugar left sections to lambdas.-desugarLeftSection :: Exp -> QOp -> Compile Exp-desugarLeftSection e o = withScopedTmpName $ \tmp ->-    return (Lambda undefined [PVar tmp] (InfixApp e o (Var (UnQual tmp))))---- | Desugar left sections to lambdas.-desugarRightSection :: QOp -> Exp -> Compile Exp-desugarRightSection o e = withScopedTmpName $ \tmp ->-    return (Lambda undefined [PVar tmp] (InfixApp (Var (UnQual tmp)) o e))- -- | Compile [e1..] arithmetic sequences.-compileEnumFrom :: Exp -> Compile JsExp+compileEnumFrom :: S.Exp -> Compile JsExp compileEnumFrom i = do   e <- compileExp i-  name <- unsafeResolveName "enumFrom"-  return (JsApp (JsName (JsNameVar name)) [e])+  return (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFrom"))) [e])  -- | Compile [e1..e3] arithmetic sequences.-compileEnumFromTo :: Exp -> Exp -> Compile JsExp+compileEnumFromTo :: S.Exp -> S.Exp -> Compile JsExp compileEnumFromTo i i' = do   f <- compileExp i   t <- compileExp i'-  name <- unsafeResolveName "enumFromTo"   cfg <- config id   return $ case optEnumFromTo cfg f t of     Just s -> s-    _ -> JsApp (JsApp (JsName (JsNameVar name)) [f]) [t]+    _ -> JsApp (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFromTo"))) [f]) [t]  -- | Compile [e1,e2..] arithmetic sequences.-compileEnumFromThen :: Exp -> Exp -> Compile JsExp+compileEnumFromThen :: S.Exp -> S.Exp -> Compile JsExp compileEnumFromThen a b = do   fr <- compileExp a   th <- compileExp b-  name <- unsafeResolveName "enumFromThen"-  return (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th])+  return (JsApp (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFromThen"))) [fr]) [th])  -- | Compile [e1,e2..e3] arithmetic sequences.-compileEnumFromThenTo :: Exp -> Exp -> Exp -> Compile JsExp+compileEnumFromThenTo :: S.Exp -> S.Exp -> S.Exp -> Compile JsExp compileEnumFromThenTo a b z = do   fr <- compileExp a   th <- compileExp b   to <- compileExp z-  name <- unsafeResolveName "enumFromThenTo"   cfg <- config id   return $ case optEnumFromThenTo cfg fr th to of     Just s -> s-    _ -> JsApp (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th]) [to]+    _ -> JsApp (JsApp (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFromThenTo"))) [fr]) [th]) [to]  -- | Compile a record construction with named fields -- | GHC will warn on uninitialized fields, they will be undefined in JS.-compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp+compileRecConstr :: S.QName -> [S.FieldUpdate] -> Compile JsExp compileRecConstr name fieldUpdates = do-    -- var obj = new $_Type()-    qname <- unsafeResolveName name-    let record = JsVar (JsNameVar name) (JsNew (JsConstructor qname) [])-    setFields <- liftM concat (forM fieldUpdates (updateStmt name))-    return $ JsApp (JsFun Nothing [] (record:setFields) (Just (JsName (JsNameVar name)))) []-  where updateStmt :: QName -> FieldUpdate -> Compile [JsStmt]-        updateStmt o (FieldUpdate field value) = do-          exp <- compileExp value-          return [JsSetProp (JsNameVar o) (JsNameVar field) exp]-        updateStmt name FieldWildcard = do-          records <- liftM stateRecords get-          let fields = fromJust (lookup name records)-          return (map (\fieldName -> JsSetProp (JsNameVar name)-                                               (JsNameVar fieldName)-                                               (JsName (JsNameVar fieldName)))-                      fields)-        -- TODO: FieldPun-        -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))-        updateStmt _ u = error ("updateStmt: " ++ show u)+  -- var obj = new $_Type()+  let unQualName = unQualify $ unAnn name+  qname <- unsafeResolveName name+  let record = JsVar (JsNameVar unQualName) (JsNew (JsConstructor qname) [])+  setFields <- liftM concat (forM fieldUpdates (updateStmt name))+  return $ JsApp (JsFun Nothing [] (record:setFields) (Just $ JsName $ JsNameVar $ unQualify $ unAnn name)) []+  where+    -- updateStmt :: QName a -> S.FieldUpdate -> Compile [JsStmt]+    updateStmt (unAnn -> o) (FieldUpdate _ (unAnn -> field) value) = do+      exp <- compileExp value+      return [JsSetProp (JsNameVar $ unQualify o) (JsNameVar $ unQualify field) exp]+    updateStmt name (FieldWildcard (wildcardFields -> fields)) = do+      return $ for fields $ \fieldName -> JsSetProp (JsNameVar $ unAnn name)+                                                    (JsNameVar fieldName)+                                                    (JsName $ JsNameVar fieldName)+    -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))+    updateStmt _ u = error ("updateStmt: " ++ show u) +    wildcardFields l = case l of+      Scoped (RecExpWildcard es) _ -> map (unQualify . gname2Qname . origGName) . map fst $ es+      _ -> []++ -- | Compile a record update.-compileRecUpdate :: Exp -> [FieldUpdate] -> Compile JsExp+compileRecUpdate :: S.Exp -> [S.FieldUpdate] -> Compile JsExp compileRecUpdate rec fieldUpdates = do-    record <- force <$> compileExp rec-    let copyName = UnQual (Ident "$_record_to_update")-        copy = JsVar (JsNameVar copyName)-                     (JsRawExp ("Object.create(" ++ printJSString record ++ ")"))-    setFields <- forM fieldUpdates (updateExp copyName)-    return $ JsApp (JsFun Nothing [] (copy:setFields) (Just (JsName (JsNameVar copyName)))) []-  where updateExp :: QName -> FieldUpdate -> Compile JsStmt-        updateExp copyName (FieldUpdate field value) =-          JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value-        updateExp copyName (FieldPun name) =-          -- let a = 1 in C {a}-          return $ JsSetProp (JsNameVar copyName)-                             (JsNameVar (UnQual name))-                             (JsName (JsNameVar (UnQual name)))-        -- TODO: FieldWildcard-        -- I also couldn't find a code that generates (FieldUpdate FieldWildCard)-        updateExp _ FieldWildcard = error "unsupported update: FieldWildcard"+  record <- force <$> compileExp rec+  let copyName = UnQual () $ Ident () "$_record_to_update"+      copy = JsVar (JsNameVar copyName)+                   (JsRawExp ("Object.create(" ++ printJSString record ++ ")"))+  setFields <- forM fieldUpdates (updateExp copyName)+  return $ JsApp (JsFun Nothing [] (copy:setFields) (Just $ JsName $ JsNameVar copyName)) []+  where+    updateExp :: QName a -> S.FieldUpdate -> Compile JsStmt+    updateExp (unAnn -> copyName) (FieldUpdate _ (unQualify . unAnn -> field) value) =+      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"  -- | Desugar list comprehensions.-desugarListComp :: Exp -> [QualStmt] -> Compile Exp-desugarListComp e [] =-    return (List [ e ])-desugarListComp e (QualStmt (Generator loc p e2) : stmts) = do-    nested <- desugarListComp e stmts-    withScopedTmpName $ \f ->-      return (Let (BDecls [ FunBind [-          Match loc f [ p         ] Nothing (UnGuardedRhs nested)    (BDecls []),-          Match loc f [ PWildCard ] Nothing (UnGuardedRhs (List [])) (BDecls [])-          ]]) (App (App (Var (UnQual (Ident "concatMap"))) (Var (UnQual f))) e2))-desugarListComp e (QualStmt (Qualifier e2)       : stmts) = do-    nested <- desugarListComp e stmts-    return (If e2 nested (List []))-desugarListComp e (QualStmt (LetStmt bs)         : stmts) = do-    nested <- desugarListComp e stmts-    return (Let bs nested)-desugarListComp _ (s                             : _    ) =-    throwError (UnsupportedQualStmt s)+desugarListComp :: S.Exp -> [S.QualStmt] -> Compile S.Exp+desugarListComp e [] = return (List noI [ e ])+desugarListComp e (QualStmt _ (Generator _ p e2) : stmts) = do+  nested <- desugarListComp e stmts+  withScopedTmpName $ \f ->+    return (Let noI (BDecls noI [ FunBind noI [+        Match noI f [ p             ] (UnGuardedRhs noI nested) Nothing+      , Match noI f [ PWildCard noI ] (UnGuardedRhs noI (List noI [])) Nothing+      ]]) (App noI (App noI (Var noI (Qual noI (ModuleName noI "$Prelude") (Ident noI "concatMap"))) (Var noI (UnQual noI f))) e2))+desugarListComp e (QualStmt _ (Qualifier _ e2) : stmts) = do+  nested <- desugarListComp e stmts+  return (If noI e2 nested (List noI []))+desugarListComp e (QualStmt _ (LetStmt _ bs) : stmts) = do+  nested <- desugarListComp e stmts+  return (Let noI bs nested)+desugarListComp _ (s : _ ) =+  throwError (UnsupportedQualStmt s)  -- | Make a Fay list. makeList :: [JsExp] -> JsExp makeList exps = JsApp (JsName $ JsBuiltIn "list") [JsList exps]---- | Compile a statement of a do block.-compileStmt :: Maybe Exp -> Stmt -> Compile (Maybe Exp)-compileStmt inner stmt =-  case inner of-    Nothing -> initStmt-    Just inner -> subsequentStmt inner--  where initStmt =-          case stmt of-            Qualifier exp -> return (Just exp)-            LetStmt{}     -> throwError UnsupportedLet-            _             -> throwError InvalidDoBlock--        subsequentStmt inner =-          case stmt of-            Generator loc pat exp -> compileGenerator loc pat inner exp-            Qualifier exp -> return (Just (InfixApp exp-                                                    (QVarOp (UnQual (Symbol ">>")))-                                                    inner))-            LetStmt (BDecls binds) -> return (Just (Let (BDecls binds) inner))-            LetStmt _ -> throwError UnsupportedLet-            RecStmt{} -> throwError UnsupportedRecursiveDo--        compileGenerator srcloc pat inner exp = do-          let body = Lambda srcloc [pat] inner-          return (Just (InfixApp exp-                                 (QVarOp (UnQual (Symbol ">>=")))-                                 body))  -- | Optimize short literal [e1..e3] arithmetic sequences. optEnumFromTo :: CompileConfig -> JsExp -> JsExp -> Maybe JsExp

@@ -12,123 +12,131 @@   ,compileFFIExp   ,jsToFayHash   ,fayToJsHash+  ,typeArity   ) where -import Fay.Compiler.Misc-import Fay.Compiler.Print           (printJSString)-import Fay.Compiler.QName-import Fay.Types+import           Fay.Compiler.Misc+import           Fay.Compiler.Print                     (printJSString)+import           Fay.Compiler.QName+import           Fay.Exts.NoAnnotation                  (unAnn)+import qualified Fay.Exts.NoAnnotation                  as N+import qualified Fay.Exts.Scoped                        as S+import           Fay.Types -import Control.Monad.Error-import Control.Monad.Writer-import Control.Applicative ((<$>), (<*>))-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        (prettyPrint)-import Language.Haskell.Exts.Syntax-import Prelude                      hiding (exp, mod)-import Safe+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 call.-compileFFI :: SrcLoc -- ^ Location of the original FFI decl.-           -> Name  -- ^ Name of the to-be binding.+compileFFI :: S.Name  -- ^ Name of the to-be binding.            -> String -- ^ The format string.-           -> Type   -- ^ Type signature.+           -> S.Type   -- ^ Type signature.            -> Compile [JsStmt]-compileFFI srcloc name formatstr sig =+compileFFI name' formatstr sig =   -- substitute newtypes with their child types before calling   -- real compileFFI   compileFFI' =<< rmNewtys sig -  where rmNewtys :: Type -> Compile Type-        rmNewtys (TyForall b c t) = TyForall b c <$> rmNewtys t-        rmNewtys (TyFun t1 t2)    = TyFun <$> rmNewtys t1 <*> rmNewtys t2-        rmNewtys (TyTuple b tl)   = TyTuple b <$> mapM rmNewtys tl-        rmNewtys (TyList t)       = TyList <$> rmNewtys t-        rmNewtys (TyApp t1 t2)    = TyApp <$> rmNewtys t1 <*> rmNewtys t2-        rmNewtys t@TyVar{}        = return t-        rmNewtys (TyCon qname)    = do-          newty <- lookupNewtypeConst qname-          return $ case newty of-                     Nothing     -> TyCon qname-                     Just (_,ty) -> ty-        rmNewtys (TyParen t)      = TyParen <$> rmNewtys t-        rmNewtys (TyInfix t1 q t2)= flip TyInfix q <$> rmNewtys t1 <*> rmNewtys t2-        rmNewtys (TyKind t k)     = flip TyKind k <$> rmNewtys t+  where+    rmNewtys :: S.Type -> Compile N.Type+    rmNewtys (TyForall _ b c t) = TyForall () (fmap (map unAnn) b) (fmap unAnn c) <$> rmNewtys t+    rmNewtys (TyFun _ t1 t2)    = TyFun () <$> rmNewtys t1 <*> rmNewtys t2+    rmNewtys (TyTuple _ b tl)   = TyTuple () b <$> mapM rmNewtys tl+    rmNewtys (TyList _ t)       = TyList () <$> rmNewtys t+    rmNewtys (TyApp _ t1 t2)    = TyApp () <$> rmNewtys t1 <*> rmNewtys t2+    rmNewtys t@TyVar{}          = return (unAnn t)+    rmNewtys (TyCon _ qname)    = do+      newty <- lookupNewtypeConst qname+      return $ case newty of+                 Nothing     -> TyCon () (unAnn qname)+                 Just (_,ty) -> ty+    rmNewtys (TyParen _ t)      = TyParen () <$> rmNewtys t+    rmNewtys (TyInfix _ t1 q t2)= flip (TyInfix ()) (unAnn q) <$> rmNewtys t1 <*> rmNewtys t2+    rmNewtys (TyKind _ t k)     = flip (TyKind ()) (unAnn k) <$> rmNewtys t -        compileFFI' :: Type -> Compile [JsStmt]-        compileFFI' sig' = do-          fun <- compileFFIExp srcloc (Just name) formatstr sig'-          stmt <- bindToplevel True name fun-          return [stmt]+    compileFFI' :: N.Type -> Compile [JsStmt]+    compileFFI' sig' = do+      fun <- compileFFIExp loc (Just name) formatstr sig'+      stmt <- bindToplevel True name fun+      return [stmt] +    name = unAnn name'+    loc = S.srcSpanInfo $ ann name'+ -- | Compile an FFI expression (also used when compiling top level definitions).-compileFFIExp :: SrcLoc -> Maybe Name -> String -> Type -> Compile JsExp-compileFFIExp srcloc nameopt formatstr sig = do+compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> (Type a) -> Compile JsExp+compileFFIExp loc (fmap unAnn -> nameopt) formatstr (unAnn -> sig) = do   let name = fromMaybe "<exp>" nameopt-  inner <- formatFFI srcloc formatstr (zip params funcFundamentalTypes)+  inner <- formatFFI loc formatstr (zip params funcFundamentalTypes)   case JS.parse JS.expression (prettyPrint name) (printJSString (wrapReturn inner)) of-    Left err -> throwError (FfiFormatInvalidJavaScript srcloc inner (show err))+    Left err -> throwError (FfiFormatInvalidJavaScript loc inner (show err))     Right exp  -> do       config' <- config id-      when (configGClosure config') $ warnDotUses srcloc inner exp+      when (configGClosure config') $ warnDotUses loc inner exp       return (body inner) -  where body inner = foldr wrapParam (wrapReturn inner) params-        wrapParam pname inner = JsFun Nothing [pname] [] (Just inner)-        params = zipWith const uniqueNames [1..typeArity sig]-        wrapReturn inner = thunk $-          case lastMay funcFundamentalTypes of-            -- Returns a “pure” value;-            Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner)-            -- Base case:-            Nothing -> JsRawExp inner-        funcFundamentalTypes = functionTypeArgs sig-        returnType = last funcFundamentalTypes+  where+    body inner = foldr wrapParam (wrapReturn inner) params+    wrapParam pname inner = JsFun Nothing [pname] [] (Just inner)+    params = zipWith const uniqueNames [1..typeArity sig]+    wrapReturn :: String -> JsExp+    wrapReturn inner = thunk $+      case lastMay funcFundamentalTypes of+        -- Returns a “pure” value;+        Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner)+        -- Base case:+        Nothing -> JsRawExp inner+    funcFundamentalTypes = functionTypeArgs sig+    returnType = last funcFundamentalTypes  -- | Warn about uses of naked x.y which will not play nicely with Google Closure.-warnDotUses :: SrcLoc -> String -> Expression SourcePos -> Compile ()-warnDotUses srcloc string expr =+warnDotUses :: SrcSpanInfo -> String -> Expression SourcePos -> Compile ()+warnDotUses srcSpanInfo string expr =   when anyrefs $-    warn $ printSrcLoc srcloc ++ ":\nDot ref syntax used in FFI JS code: " ++ string+    warn $ printSrcSpanInfo srcSpanInfo ++ ":\nDot ref syntax used in FFI JS code: " ++ string -  where anyrefs = not (null (listify dotref expr)) ||+  where+    anyrefs = not (null (listify dotref expr)) ||                   not (null (listify ldot expr)) -        dotref :: Expression SourcePos -> Bool-        dotref x = case x of-          DotRef _ (VarRef _ (Id _ name)) _-             | name `elem` globalNames -> False-          DotRef{}                     -> True-          _                            -> False+    dotref :: Expression SourcePos -> Bool+    dotref x = case x of+      DotRef _ (VarRef _ (Id _ name)) _+         | name `elem` globalNames -> False+      DotRef{}                     -> True+      _                            -> False -        ldot :: LValue SourcePos -> Bool-        ldot x =-          case x of-            LDot _ (VarRef _ (Id _ name)) _-             | name `elem` globalNames -> False-            LDot{}                     -> True-            _                          -> False+    ldot :: LValue SourcePos -> Bool+    ldot x =+      case x of+        LDot _ (VarRef _ (Id _ name)) _+         | name `elem` globalNames -> False+        LDot{}                     -> True+        _                          -> False -        globalNames = ["Math","console","JSON"]+    globalNames = ["Math","console","JSON"]  -- | Make a Fay→JS encoder.-emitFayToJs :: Name -> [TyVarBind] -> [([Name],BangType)] -> Compile ()-emitFayToJs name tyvars (explodeFields -> fieldTypes) = do+emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], BangType d)] -> Compile ()+emitFayToJs (unAnn -> name) (map unAnn -> tyvars) (explodeFields -> fieldTypes) = do   qname <- qualify name-  let ctrName = printJSString $ unqualName qname+  let ctrName = printJSString $ unQual qname   tell $ mempty { writerFayToJs = [(ctrName, translator)] }    where-    unqualName :: QName -> Name-    unqualName (UnQual n) = n-    unqualName (Qual _ n) = n-    unqualName Special{}  = error "unqualName: Special{}"     translator =       JsFun Nothing             [JsNameVar "type", argTypes, transcodingObjForced]@@ -137,9 +145,9 @@      obj :: JsStmt     obj = JsVar obj_ $-      JsObj [("instance",JsLit (JsStr (printJSString name)))]+      JsObj [("instance",JsLit (JsStr (printJSString (unAnn name))))] -    fieldStmts :: [(Int,(Name,BangType))] -> [JsStmt]+    fieldStmts :: [(Int,(N.Name,N.BangType))] -> [JsStmt]     fieldStmts [] = []     fieldStmts ((i,fieldType):fts) =       JsVar obj_v field :@@ -148,20 +156,20 @@           [] :         fieldStmts fts       where-        obj_v = JsNameVar (UnQual (Ident $ "obj_" ++ d))-        decl = JsNameVar (UnQual (Ident d))+        obj_v = JsNameVar $ UnQual () (Ident () $ "obj_" ++ d)+        decl = JsNameVar $ UnQual () (Ident () d)         (d, field) = declField i fieldType -    obj_ = JsNameVar (UnQual (Ident "obj_"))+    obj_ = JsNameVar "obj_"      -- Declare/encode Fay→JS field-    declField :: Int -> (Name,BangType) -> (String,JsExp)+    declField :: Int -> (N.Name,N.BangType) -> (String,JsExp)     declField i (fname,typ) =       (prettyPrint fname       ,fayToJs (SerializeUserArg i)                (argType (bangType typ))                (JsGetProp (JsName transcodingObjForced)-                          (JsNameVar (UnQual fname))))+                          (JsNameVar (UnQual () fname))))  -- | A name used for transcoding. transcodingObj :: JsName@@ -172,54 +180,53 @@ transcodingObjForced = JsNameVar "_obj"  -- | Get arg types of a function type.-functionTypeArgs :: Type -> [FundamentalType]-functionTypeArgs t =-  case t of-    TyForall _ _ i -> functionTypeArgs i-    TyFun a b      -> argType a : functionTypeArgs b-    TyParen st     -> functionTypeArgs st-    r              -> [argType r]+functionTypeArgs :: N.Type -> [FundamentalType]+functionTypeArgs t = case t of+  TyForall _ _ _ i -> functionTypeArgs i+  TyFun _ a b      -> argType a : functionTypeArgs b+  TyParen _ st     -> functionTypeArgs st+  r                -> [argType r]  -- | Convert a Haskell type to an internal FFI representation.-argType :: Type -> FundamentalType+argType :: N.Type -> FundamentalType argType t = case t of-  TyCon "String"              -> StringType-  TyCon "Double"              -> DoubleType-  TyCon "Int"                 -> IntType-  TyCon "Bool"                -> BoolType-  TyApp (TyCon "Ptr") _       -> PtrType-  TyApp (TyCon "Automatic") _ -> Automatic-  TyApp (TyCon "Defined") a   -> Defined (argType a)-  TyApp (TyCon "Nullable") a  -> Nullable (argType a)-  TyApp (TyCon "Fay") a       -> JsType (argType a)-  TyFun x xs                  -> FunctionType (argType x : functionTypeArgs xs)-  TyList x                    -> ListType (argType x)-  TyTuple _ xs                -> TupleType (map argType xs)-  TyParen st                  -> argType st-  TyApp op arg                -> userDefined (reverse (arg : expandApp op))+  TyCon _ (UnQual _ (Ident _ "String"))                -> StringType+  TyCon _ (UnQual _ (Ident _ "Double"))                -> DoubleType+  TyCon _ (UnQual _ (Ident _ "Int"))                   -> IntType+  TyCon _ (UnQual _ (Ident _ "Bool"))                  -> BoolType+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Ptr"))) _       -> PtrType+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Automatic"))) _ -> Automatic+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Defined"))) a   -> Defined (argType a)+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Nullable"))) a  -> Nullable (argType a)+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Fay"))) a       -> JsType (argType a)+  TyFun _ x xs                  -> FunctionType (argType x : functionTypeArgs xs)+  TyList _ x                    -> ListType (argType x)+  TyTuple _ _ xs                -> TupleType (map argType xs)+  TyParen _ st                  -> argType st+  TyApp _ op arg                -> userDefined (reverse (arg : expandApp op))   _                     ->     -- No semantic point to this, merely to avoid GHC's broken     -- warning.     case t of-      TyCon (UnQual user)   -> UserDefined user []+      TyCon _ (UnQual _ user)   -> UserDefined user []       _ -> UnknownType  -- | Extract the type.-bangType :: BangType -> Type+bangType :: N.BangType -> N.Type bangType typ = case typ of-  BangedTy ty   -> ty-  UnBangedTy ty -> ty-  UnpackedTy ty -> ty+  BangedTy _ ty   -> ty+  UnBangedTy _ ty -> ty+  UnpackedTy _ ty -> ty  -- | Expand a type application.-expandApp :: Type -> [Type]-expandApp (TyParen t) = expandApp t-expandApp (TyApp op arg) = arg : expandApp op+expandApp :: N.Type -> [N.Type]+expandApp (TyParen _ t) = expandApp t+expandApp (TyApp _ op arg) = arg : expandApp op expandApp x = [x]  -- | Generate a user-defined type.-userDefined :: [Type] -> FundamentalType-userDefined (TyCon (UnQual name):typs) = UserDefined name (map argType typs)+userDefined :: [N.Type] -> FundamentalType+userDefined (TyCon _ (UnQual _ name):typs) = UserDefined name (map argType typs) userDefined _ = UnknownType  -- | Translate: JS → Fay.@@ -245,10 +252,10 @@   _ -> recursive    where flat specialize =-          JsApp (JsName (JsBuiltIn (fromString (method ++ "_" ++ specialize))))+          JsApp (JsName (JsBuiltIn (Ident () (method ++ "_" ++ specialize))))                 [exp]         recursive =-          JsApp (JsName (JsBuiltIn (fromString method)))+          JsApp (JsName (JsBuiltIn (Ident () method)))                 [typeRep context typ                 ,exp]         js ty' =@@ -295,19 +302,19 @@                                         (ret "unknown"))  -- | Get the arity of a type.-typeArity :: Type -> Int+typeArity :: Type a -> Int typeArity t = case t of-  TyForall _ _ i -> typeArity i-  TyFun _ b      -> 1 + typeArity b-  TyParen st     -> typeArity st+  TyForall _ _ _ i -> typeArity i+  TyFun _ _ b      -> 1 + typeArity b+  TyParen _ st     -> typeArity st   _              -> 0 --- | Format the FFI format string with the given arguments.-formatFFI :: SrcLoc                     -- ^ Location of the original FFI decl.+-- | Format the FFI  format string with the given arguments.+formatFFI :: SrcSpanInfo                -- ^ Source Location.           -> String                     -- ^ The format string.           -> [(JsName,FundamentalType)] -- ^ Arguments.           -> Compile String             -- ^ The JS code.-formatFFI srcloc formatstr args = go formatstr where+formatFFI loc formatstr args = go formatstr where   go ('%':'*':xs) = do     these <- mapM inject (zipWith const [1..] args)     rest <- go xs@@ -315,10 +322,10 @@   go ('%':'%':xs) = do     rest <- go xs     return ('%' : rest)-  go ['%'] = throwError (FfiFormatIncompleteArg srcloc)+  go ['%'] = throwError (FfiFormatIncompleteArg loc)   go ('%':(span isDigit -> (op,xs))) =     case readMay op of-     Nothing -> throwError (FfiFormatBadChars srcloc op)+     Nothing -> throwError (FfiFormatBadChars loc op)      Just n -> do        this <- inject n        rest <- go xs@@ -329,7 +336,7 @@    inject n =     case listToMaybe (drop (n-1) args) of-      Nothing -> throwError (FfiFormatNoSuchArg srcloc n)+      Nothing -> throwError (FfiFormatNoSuchArg loc n)       Just (arg,typ) ->         return (printJSString (fayToJs SerializeAnywhere typ (JsName arg))) @@ -346,10 +353,10 @@ jsToFayHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "jsToFayHash", JsObj cases]]  -- | Make a JS→Fay decoder.-emitJsToFay ::  Name -> [TyVarBind] -> [([Name], BangType)] -> Compile ()-emitJsToFay name tyvars (explodeFields -> fieldTypes) = do+emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],BangType d)] -> Compile ()+emitJsToFay (unAnn -> name) (map unAnn -> tyvars) (map (unAnn *** unAnn) . explodeFields -> fieldTypes) = do   qname <- qualify name-  tell (mempty { writerJsToFay = [(printJSString name, translator qname)] })+  tell (mempty { writerJsToFay = [(printJSString (unAnn name), translator qname)] })    where     translator qname =@@ -357,7 +364,7 @@             (Just $ JsNew (JsConstructor qname)                           (map (decodeField . getIndex name tyvars) fieldTypes))     -- Decode JS→Fay field-    decodeField :: (Int,(Name,BangType)) -> JsExp+    decodeField :: (Int,(N.Name,N.BangType)) -> JsExp     decodeField (i,(fname,typ)) =       jsToFay (SerializeUserArg i)               (argType (bangType typ))@@ -369,17 +376,17 @@ argTypes = JsNameVar "argTypes"  -- | Get the index of a name from the set of type variables bindings.-getIndex :: Name -> [TyVarBind] -> (Name,BangType) -> (Int,(Name,BangType))-getIndex name tyvars (sname,ty) =+getIndex :: Name a -> [TyVarBind b] -> (Name c,BangType d) -> (Int,(N.Name,N.BangType))+getIndex (unAnn -> name) (map unAnn -> tyvars) (unAnn -> sname,unAnn -> ty) =   case bangType ty of-    TyVar tyname -> case elemIndex tyname (map tyvar tyvars) of+    TyVar _ tyname -> case elemIndex tyname (map tyvar tyvars) of       Nothing -> error $ "unknown type variable " ++ prettyPrint tyname ++                          " for " ++ prettyPrint name ++ "." ++ prettyPrint sname ++ "," ++-                         " vars were: " ++ unwords (map prettyPrint tyvars)+                         " vars were: " ++ unwords (map prettyPrint tyvars) ++ ", rest: " ++ show tyvars       Just i -> (i,(sname,ty))     _ -> (0,(sname,ty))  -- | Extract the name from a possibly-kinded tyvar.-tyvar :: TyVarBind -> Name-tyvar (UnkindedVar v) = v-tyvar (KindedVar v _) = v+tyvar :: N.TyVarBind -> N.Name+tyvar (UnkindedVar _ v) = v+tyvar (KindedVar _ v _) = v

@@ -4,17 +4,18 @@   (convertGADT   ) where -import           Language.Haskell.Exts hiding (name, binds)+import           Language.Haskell.Exts.Annotated hiding (binds, name)  -- | Convert a GADT to a normal data type.-convertGADT :: GadtDecl -> QualConDecl-convertGADT d =-  case d of-    GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context-                                            (ConDecl name (convertFunc typ))-  where tyvars = []-        context = []-        convertFunc (TyCon _) = []-        convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs-        convertFunc (TyParen x) = convertFunc x-        convertFunc _ = []+convertGADT :: GadtDecl a -> QualConDecl a+convertGADT d = case d of+  GadtDecl s name typ -> QualConDecl s tyvars context+                           (ConDecl s name (convertFunc typ))+  where+    tyvars = Nothing+    context = Nothing+    convertFunc :: Type a -> [BangType a]+    convertFunc (TyCon _ _) = []+    convertFunc (TyFun s x xs) = UnBangedTy s x : convertFunc xs+    convertFunc (TyParen _ x) = convertFunc x+    convertFunc _ = []

@@ -0,0 +1,119 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns  #-}++-- | Handles finding imports and compiling them recursively.+-- This is done for each full AST traversal the copmiler does+-- which at this point is InitialPass's preprocessing+-- and Compiler's code generation+module Fay.Compiler.Import+  (startCompile+  ,compileWith+  ) where++import           Fay.Compiler.Config+import           Fay.Compiler.Misc+import           Fay.Control.Monad.IO+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++-- | Start the compilation process using `compileModule` to compile a file.+startCompile :: (FilePath -> String -> Compile a) -> FilePath -> Compile a+startCompile compileModule filein = do+  modify $ \s -> s { stateImported = [] }+  fmap fst . listen $ compileModuleFromFile compileModule filein++-- | Compile a module+compileWith+  :: Monoid a+  => FilePath+  -> (a -> F.Module -> Compile a)+  -> (FilePath -> String -> Compile a)+  -> String+  -> Compile (a, CompileState, CompileWriter)+compileWith filepath with compileModule from = do+  rd <- ask+  st <- get+  res <- Compile . lift . lift $+    runCompileModule+      rd+      st+      (parseResult (throwError . uncurry ParseError)+                   (\mod@(Module _ _ _ imports _) -> do+                     res <- foldr (<>) mempty <$> mapM (compileImport compileModule) imports+                     modify $ \s -> s { stateModuleName = unAnn $ F.moduleName mod }+                     with res mod+                   )+                   (parseFay filepath from))+  either throwError return res++-- | Compile a module given its file path+compileModuleFromFile+  :: (FilePath -> String -> Compile a)+  -> FilePath+  -> Compile a+compileModuleFromFile compileModule fp = io (readFile fp) >>= compileModule fp++-- | Lookup a module from include directories and compile.+compileModuleFromName+  :: Monoid a+  => (FilePath -> String -> Compile a)+  -> F.ModuleName+  -> Compile a+compileModuleFromName compileModule nm =+  unlessImported nm compileModule+    where+      unlessImported+        :: Monoid a+        => ModuleName l+        -> (FilePath -> String -> Compile a)+        -> Compile a+      unlessImported (ModuleName _ "Fay.Types") _ = return mempty+      unlessImported (unAnn -> name) importIt = do+        imported <- gets stateImported+        case lookup name imported of+          Just _  -> return mempty+          Nothing -> do+            dirs <- configDirectoryIncludePaths <$> config id+            (filepath,contents) <- findImport dirs name+            modify $ \s -> s { stateImported = (name,filepath) : imported }+            importIt filepath contents++-- | Compile an import.+compileImport+  :: Monoid a+  => (FilePath -> String -> Compile a)+  -> F.ImportDecl+  -> Compile a+compileImport compileModule i = case i of+  -- Package imports are ignored since they are used for some trickery in fay-base.+  ImportDecl _ _    _ _ Just{}  _ _ -> return mempty+  ImportDecl _ name _ _ Nothing _ _ -> compileModuleFromName compileModule name++-- | Find an import's filepath and contents from its module name.+findImport :: [FilePath] -> ModuleName a -> Compile (FilePath,String)+findImport alldirs (unAnn -> mname) = go alldirs mname where+  go :: [FilePath] -> ModuleName a -> Compile (FilePath,String)+  go _ (ModuleName _ "Fay.Types") = return ("Fay/Types.hs", "newtype Fay a = Fay (Identity a)\n\nnewtype Identity a = Identity a")+  go (dir:dirs) name = do+    exists <- io (doesFileExist path)+    if exists+      then (path,) . stdlibHack <$> io (readFile path)+      else go dirs name+    where+      path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"+      replace c r = map (\x -> if x == c then r else x)+  go [] name =+    throwError $ Couldn'tFindImport (unAnn name) alldirs++  stdlibHack = case mname of+    ModuleName _ "Fay.FFI" -> const "module Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined"+    _ -> id

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Preprocessing collecting names, data types, newtypes, imports, and exports -- for all modules recursively.@@ -6,104 +7,83 @@   (initialPass   ) where -import           Fay.Compiler.Config+import           Fay.Compiler.Desugar import           Fay.Compiler.GADT+import           Fay.Compiler.Import import           Fay.Compiler.Misc-import           Fay.Compiler.ModuleScope-import           Fay.Control.Monad.Extra import           Fay.Control.Monad.IO import           Fay.Data.List.Extra+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.Set as S-import qualified Data.Map as M-import           Language.Haskell.Exts.Parser-import           Language.Haskell.Exts.Syntax-import           Prelude hiding (mod, read)+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 :: Module -> Compile ()-initialPass (Module _ mod _ Nothing exports imports decls) =-  withModuleScope $ do-    modify $ \s -> s { stateModuleName = mod-                     , stateModuleScope = findTopLevelNames mod decls-                     }-    forM_ imports compileImport-    forM_ decls scanRecordDecls-    forM_ decls scanNewtypeDecls-    case exports of-      Just exps -> mapM_ emitExport exps-      Nothing -> do-        exps <- moduleLocals mod <$> gets stateModuleScope-        modify $ flip (foldr addCurrentExport) exps-    modify $ \s -> s { stateModuleScopes = M.insert mod (stateModuleScope s) (stateModuleScopes s) }-initialPass m = throwError (UnsupportedModuleSyntax m)+initialPass :: FilePath -> Compile ()+initialPass = startCompile preprocessFileWithSource -compileImport :: ImportDecl -> Compile ()-compileImport (ImportDecl _ _ _ _ Just{} _ _) = return ()-compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) =-  compileImportWithFilter name (const $ return True)-compileImport (ImportDecl _ name False _ Nothing Nothing (Just (True, specs))) =-  compileImportWithFilter name (fmap not . imported specs)-compileImport (ImportDecl _ name False _ Nothing Nothing (Just (False, specs))) =-  compileImportWithFilter name (imported specs)-compileImport i =-  throwError $ UnsupportedImport i+-- | Preprocess a module given its filepath and content.+preprocessFileWithSource :: FilePath -> String -> Compile ()+preprocessFileWithSource filepath contents = do+  (_,st,_) <- compileWith filepath preprocessAST preprocessFileWithSource contents+  -- This is the state we want to keep+  modify $ \s -> s { stateRecords     = stateRecords     st+                   , stateRecordTypes = stateRecordTypes st+                   , stateImported    = stateImported    st+                   , stateNewtypes    = stateNewtypes    st+                   , stateInterfaces  = stateInterfaces  st+                   , stateTypeSigs    = stateTypeSigs    st+                     -- TODO This needs to be added otherwise the+                     -- "executable" generation in Fay.hs gets the+                     -- wrong name. Not sure why it works to do it+                     -- here!+                   , stateModuleName  = stateModuleName  st+                   } -compileWith :: (Show from,Parseable from)-            => FilePath-            -> CompileReader-            -> CompileState-            -> (from -> Compile ())-            -> String-            -> Compile (Either CompileError ((),CompileState,CompileWriter))-compileWith filepath r st with from =-  io $ runCompile r-                  st-                  (parseResult (throwError . uncurry ParseError)-                  with-                  (parseFay filepath from))+-- | Preprocess from an AST+preprocessAST :: () -> F.Module -> Compile ()+preprocessAST () mod'@Module{} = do+  res <- io $ desugar mod'+  case res of+    Left err -> throwError err+    Right dmod -> do+      let (Module _ _ _ _ decls) = dmod+      -- This can only return one element since we only compile one module.+      ([exports],_) <- HN.getInterfaces Haskell2010 [] [dmod]+      modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s }+      forM_ decls scanTypeSigs+      forM_ decls scanRecordDecls+      forM_ decls scanNewtypeDecls+preprocessAST () mod = throwError $ UnsupportedModuleSyntax "preprocessAST" mod --- | Don't re-import the same modules.-unlessImported :: ModuleName-               -> (QName -> Compile Bool)-               -> (FilePath -> String -> Compile ())-               -> Compile ()-unlessImported "Fay.Types" _ _ = return ()-unlessImported name importFilter importIt = do-  isImported <- lookup name <$> gets stateImported-  case isImported of-    Just _ -> return ()-    Nothing -> do-      dirs <- configDirectoryIncludePaths <$> config id-      (filepath,contents) <- findImport dirs name-      modify $ \s -> s { stateImported = (name,filepath) : stateImported s }-      importIt filepath contents-  exports <- gets $ getExportsFor name-  imports <- filterM importFilter $ S.toList exports-  modify $ \s -> s { stateModuleScope = bindAsLocals imports (stateModuleScope s) }+--------------------------------------------------------------------------------+-- | Preprocessing  -- | Find newtype declarations-scanNewtypeDecls :: Decl -> Compile ()-scanNewtypeDecls (DataDecl _ NewType _ _ _ constructors _) = compileNewtypeDecl constructors+scanNewtypeDecls :: F.Decl -> Compile ()+scanNewtypeDecls (DataDecl _ NewType{} _ _ constructors _) = compileNewtypeDecl constructors scanNewtypeDecls _ = return ()  -- | Add new types to the state-compileNewtypeDecl :: [QualConDecl] -> Compile ()-compileNewtypeDecl [QualConDecl _ _ _ condecl] =-  case condecl of-      -- newtype declaration without destructor-    ConDecl name  [ty]            -> addNewtype name Nothing ty-    RecDecl cname [([dname], ty)] -> addNewtype cname (Just dname) ty-    x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x+compileNewtypeDecl :: [F.QualConDecl] -> Compile ()+compileNewtypeDecl [QualConDecl _ _ _ condecl] = case condecl of+    -- newtype declaration without destructor+  ConDecl _ name  [ty]            -> addNewtype name Nothing ty+  RecDecl _ cname [FieldDecl _ [dname] ty] -> addNewtype cname (Just dname) ty+  x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x   where-    getBangTy :: BangType -> Type-    getBangTy (BangedTy t)   = t-    getBangTy (UnBangedTy t) = t-    getBangTy (UnpackedTy t) = t+    getBangTy :: F.BangType -> N.Type+    getBangTy (BangedTy _ t)   = unAnn t+    getBangTy (UnBangedTy _ t) = unAnn t+    getBangTy (UnpackedTy _ t) = unAnn t      addNewtype cname dname ty = do       qcname <- qualify cname@@ -115,91 +95,57 @@ compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q  -- | Add record declarations to the state-scanRecordDecls :: Decl -> Compile ()+scanRecordDecls :: F.Decl -> Compile () scanRecordDecls decl = do   case decl of-    DataDecl _loc DataType _ctx name _tyvarb qualcondecls _deriv -> do+    DataDecl _loc DataType{} _ctx (F.declHeadName -> name) qualcondecls _deriv -> do       let ns = for qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl)       addRecordTypeState name ns     _ -> return ()    case decl of-    DataDecl _ DataType _ _ _ constructors _ -> dataDecl constructors-    GDataDecl _ DataType _l _i _v _n decls _ -> dataDecl (map convertGADT decls)+    DataDecl _ DataType{} _ _ constructors _ -> dataDecl constructors+    GDataDecl _ DataType{} _ _ _ decls _ -> dataDecl (map convertGADT decls)     _ -> return ()    where-    addRecordTypeState name cons = modify $ \s -> s-      { stateRecordTypes = (UnQual name, map UnQual cons) : stateRecordTypes s }+    addRecordTypeState (unAnn -> name') (map unAnn -> cons') = do+      name <- qualify name'+      cons <- mapM qualify cons'+      modify $ \s -> s { stateRecordTypes = (name, cons) : stateRecordTypes s } -    conDeclName (ConDecl n _) = n-    conDeclName (InfixConDecl _ n _) = n-    conDeclName (RecDecl n _) = n+    conDeclName (ConDecl _ n _) = n+    conDeclName (InfixConDecl _ _ n _) = n+    conDeclName (RecDecl _ n _) = n      -- | Collect record definitions and store record name and field names.     -- A ConDecl will have fields named slot1..slotN-    dataDecl :: [QualConDecl] -> Compile ()+    dataDecl :: [F.QualConDecl] -> Compile ()     dataDecl constructors = do       forM_ constructors $ \(QualConDecl _ _ _ condecl) ->         case condecl of-          ConDecl name types -> do-            let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types+          ConDecl _ name types -> do+            let fields =  map (Ident () . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types             addRecordState name fields-          InfixConDecl _t1 name _t2 ->-            addRecordState name ["slot1", "slot2"]-          RecDecl name fields' -> do-            let fields = concatMap fst fields'+          InfixConDecl _ _t1 name _t2 ->+            addRecordState name [F.mkIdent "slot1", F.mkIdent "slot2"]+          RecDecl _ name fields' -> do+            let fields = concatMap F.fieldDeclNames fields'             addRecordState name fields        where-        addRecordState :: Name -> [Name] -> Compile ()-        addRecordState name fields = modify $ \s -> s-          { stateRecords = (UnQual name,map UnQual fields) : stateRecords s }+        addRecordState :: Name a -> [Name b] -> Compile ()+        addRecordState name' fields = do+          name <- qualify name'+          modify $ \s -> s+            { stateRecords = (name,map unAnn fields) : stateRecords s } --- | Is this name imported from anywhere?-imported :: [ImportSpec] -> QName -> Compile Bool-imported is qn = anyM (matching qn) is+scanTypeSigs :: F.Decl -> Compile ()+scanTypeSigs decl = case decl of+  TypeSig _ names typ -> mapM_ (`addTypeSig` typ) names+  _ -> return ()   where-    matching :: QName -> ImportSpec -> Compile Bool-    matching (Qual _ name) (IAbs typ) = return (name == typ)-    matching (Qual _ name) (IVar var) = return $ name == var-    matching (Qual _ name) (IThingAll typ) = do-      recs <- typeToRecs $ UnQual typ-      if UnQual name `elem` recs-        then return True-        else do-          fields <- typeToFields $ UnQual typ-          return $ UnQual name `elem` fields-    matching (Qual _ name) (IThingWith typ cns) =-      flip anyM cns $ \cn -> case cn of-        ConName _ -> do-          recs <- typeToRecs $ UnQual typ-          return $ UnQual name `elem` recs-        VarName _ -> do-          fields <- typeToFields $ UnQual typ-          return $ UnQual name `elem` fields-    matching q is' = error $ "compileImport: Unsupported QName ImportSpec combination " ++ show (q, is') ++ ", this is a bug!"---- | Compile an import filtering the exports based on the current module's imports-compileImportWithFilter :: ModuleName -> (QName -> Compile Bool) -> Compile ()-compileImportWithFilter name importFilter =-  unlessImported name importFilter $ \filepath contents -> do-    read <- ask-    stat <- get-    result <- compileWith filepath read stat initialPass contents-    case result of-      Right ((),st,_) -> do-        imports <- filterM importFilter $ S.toList $ getCurrentExports st-        -- Merges the state gotten from passing through an imported-        -- module with the current state. We can assume no duplicate-        -- records exist since GHC would pick that up.-        modify $ \s -> s { stateRecords      = stateRecords st-                         , stateLocalScope   = S.empty-                         , stateRecordTypes  = stateRecordTypes st-                         , stateImported     = stateImported st-                         , stateNewtypes     = stateNewtypes st-                         , stateModuleScope  = bindAsLocals imports (stateModuleScope s)-                         , _stateExports     = _stateExports st-                         , stateModuleScopes = stateModuleScopes st-                         }-      Left err -> throwError err+    addTypeSig :: F.Name -> F.Type -> Compile ()+    addTypeSig (unAnn -> n') (unAnn -> t) = do+      n <- qualify n'+      modify $ \s -> s { stateTypeSigs = M.insert n t (stateTypeSigs s) }

@@ -1,40 +1,36 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS -Wall -fno-warn-orphans  #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Miscellaneous functions used throughout the compiler.  module Fay.Compiler.Misc where +import           Fay.Compiler.PrimOp import           Fay.Control.Monad.IO-import qualified Fay.Compiler.ModuleScope        as ModuleScope+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           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 qualified Data.Map                        as M-import qualified Data.Set                        as S import           Data.String-import           Data.Version                    (parseVersion)-import           Language.Haskell.Exts.Extension-import           Language.Haskell.Exts.Fixity-import           Language.Haskell.Exts.Parser-import           Language.Haskell.Exts.Pretty-import           Language.Haskell.Exts.Syntax-import           Prelude                         hiding (exp, mod)-import           System.Directory-import           System.FilePath+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)---- | Make an identifier from the built-in HJ module.-fayBuiltin :: String -> QName-fayBuiltin = Qual (ModuleName "Fay$") . Ident+import           System.Process                    (readProcess)+import           Text.ParserCombinators.ReadP      (readP_to_S)  -- | Wrap an expression in a thunk. thunk :: JsExp -> JsExp@@ -59,26 +55,43 @@ uniqueNames = map JsParam [1::Integer ..]  -- | Resolve a given maybe-qualified name to a fully qualifed name.-tryResolveName :: QName -> Compile (Maybe QName)-tryResolveName special@Special{} = return (Just special)-tryResolveName q@Qual{} =-  ModuleScope.resolveName q <$> gets stateModuleScope-tryResolveName u@(UnQual name) = do-  names <- gets stateLocalScope-  env <- gets stateModuleScope-  if S.member name names-    then return $ Just (UnQual name)-    else maybe (Just <$> qualify name) (return . Just) $ ModuleScope.resolveName u env+tryResolveName :: Show l => QName (Scoped l) -> Maybe N.QName+tryResolveName s@Special{}                                      = Just $ unAnn s+tryResolveName s@(UnQual _ (Ident _ n)) | "$gen" `isPrefixOf` n = Just $ unAnn s+tryResolveName (unAnn -> Qual () (ModuleName () "$Prelude") n)  = Just $ Qual () (ModuleName () "Prelude") n+tryResolveName q@(Qual _ (ModuleName _ "Fay$") _)               = Just $ unAnn q+tryResolveName (Qual (Scoped ni _) _ _)                         = case ni of+    GlobalValue n -> replaceWithBuiltIns . gname2Qname . origGName $ origName n+    _             -> Nothing+    -- TODO should LocalValue just return the name for qualified imports?+tryResolveName q@(UnQual (Scoped ni _) (unAnn -> name))         = case ni of+    GlobalValue n -> replaceWithBuiltIns . gname2Qname . origGName $ origName n+    LocalValue _  -> Just $ UnQual () name+    ScopeError _  -> resolvePrimOp q+    _             -> Nothing +gname2Qname :: GName -> N.QName+gname2Qname g = case g of+  GName "" s -> UnQual () $ mkName s+  GName m  s -> Qual () (ModuleName () m) $ mkName s+  where+    mkName s@(x:_)+      | isAlpha x || x == '_' = Ident () s+      | otherwise = Symbol () s+    mkName "" = error "mkName \"\""++replaceWithBuiltIns :: N.QName -> Maybe N.QName+replaceWithBuiltIns n = findPrimOp n <|> return n+ -- | Resolve a given maybe-qualified name to a fully qualifed name. -- Use this when a resolution failure is a bug.-unsafeResolveName :: QName -> Compile QName-unsafeResolveName q = maybe (throwError $ UnableResolveQualified q) return =<< tryResolveName q+unsafeResolveName :: S.QName -> Compile N.QName+unsafeResolveName q = maybe (throwError $ UnableResolveQualified (unAnn q)) return $ tryResolveName q  -- | Resolve a newtype constructor.-lookupNewtypeConst :: QName -> Compile (Maybe (Maybe QName,Type))+lookupNewtypeConst :: S.QName -> Compile (Maybe (Maybe N.QName,N.Type)) lookupNewtypeConst n = do-  mName <- tryResolveName n+  let mName = tryResolveName n   case mName of     Nothing -> return Nothing     Just name -> do@@ -88,94 +101,36 @@         Just (_,dname,ty) -> return $ Just (dname,ty)  -- | Resolve a newtype destructor.-lookupNewtypeDest :: QName -> Compile (Maybe (QName,Type))+lookupNewtypeDest :: S.QName -> Compile (Maybe (N.QName,N.Type)) lookupNewtypeDest n = do-  mName <- tryResolveName n+  let mName = tryResolveName n   newtypes <- gets stateNewtypes   case find (\(_,dname,_) -> dname == mName) newtypes of     Nothing -> return Nothing     Just (cname,_,ty) -> return $ Just (cname,ty)  -- | Qualify a name for the current module.-qualify :: Name -> Compile QName-qualify name = do+qualify :: Name a -> Compile (N.QName)+qualify (Ident _ name) = do   modulename <- gets stateModuleName-  return (Qual modulename name)+  return (Qual () modulename (Ident () name))+qualify (Symbol _ name) = do+  modulename <- gets stateModuleName+  return (Qual () modulename (Symbol () name))  -- | Qualify a QName for the current module if unqualified.-qualifyQName :: QName -> Compile QName-qualifyQName (UnQual name) = qualify name-qualifyQName n             = return n+qualifyQName :: QName a -> Compile N.QName+qualifyQName (UnQual _ name) = qualify name+qualifyQName (unAnn -> n)    = return n  -- | Make a top-level binding.-bindToplevel :: Bool -> Name -> JsExp -> Compile JsStmt-bindToplevel toplevel name expr =+bindToplevel :: Bool -> Name a -> JsExp -> Compile JsStmt+bindToplevel toplevel (unAnn -> name) expr =   if toplevel     then do       mod <- gets stateModuleName-      return $ JsSetQName (Qual mod name) expr-    else return $ JsVar (JsNameVar $ UnQual name) expr----- | Create a temporary environment and discard it after the given computation.-withModuleScope :: Compile a -> Compile a-withModuleScope m = do-  scope <- gets stateModuleScope-  value <- m-  modify $ \s -> s { stateModuleScope = scope }-  return value---- | Create a temporary scope and discard it after the given computation.-withScope :: Compile a -> Compile a-withScope m = do-  scope <- gets stateLocalScope-  value <- m-  modify $ \s -> s { stateLocalScope = scope }-  return value---- | Run a compiler and just get the scope information.-generateScope :: Compile a -> Compile ()-generateScope m = do-  st <- get-  _ <- m-  scope <- gets stateLocalScope-  put st { stateLocalScope = scope }---- | Bind a variable in the current scope.-bindVar :: Name -> Compile ()-bindVar name =-  modify $ \s -> s { stateLocalScope = S.insert name (stateLocalScope s) }---- | Emit exported names.-emitExport :: ExportSpec -> Compile ()-emitExport spec = case spec of-  EVar (UnQual n) -> emitVar n-  EVar q@Qual{} -> modify $ addCurrentExport q-  EThingAll (UnQual name) -> do-    cons <- typeToRecs (UnQual name)-    fields <- typeToFields (UnQual name)-    mapM_ (emitVar . unQName) $ cons ++ fields-  EThingWith (UnQual _) ns -> mapM_ emitCName ns-  EAbs _ -> return () -- Type only, skip-  EModuleContents mod -> do-    known_exports <- gets _stateExports-    current_scope <- gets stateModuleScope-    let names = case M.lookup mod known_exports of-          Just exports -> S.toList exports                      -- in case we're exporting other module take it's export list-          Nothing -> ModuleScope.moduleLocals mod current_scope -- in case we're exporting outselves export local names-    mapM_ (emitExport . EVar) names--  -- Skip qualified exports for type exports in fay-base since-  -- qualified imports are not supported yet an error will be thrown-  -- on the import so hopefully this won't be confusing.-  EThingAll (Qual _ _) -> return ()-  e -> throwError $ UnsupportedExportSpec e- where-   emitVar = return . UnQual >=> unsafeResolveName >=> emitExport . EVar-   emitCName (VarName n) = emitVar n-   emitCName (ConName n) = emitVar n-   unQName (UnQual u) = u-   unQName _ = error "unQName Qual or Special -- should never happen"+      return $ JsSetQName (Qual () mod name) expr+    else return $ JsVar (JsNameVar $ UnQual () name) expr  -- | Force an expression in a thunk. force :: JsExp -> JsExp@@ -189,7 +144,7 @@ isConstant _       = False  -- | Deconstruct a parse result (a la maybe, foldr, either).-parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b+parseResult :: ((F.SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b parseResult die ok result = case result of   ParseOk a -> ok a   ParseFailed srcloc msg -> die (srcloc,msg)@@ -218,18 +173,18 @@ throwExp msg expr = JsThrowExp (JsList [JsLit (JsStr msg),expr])  -- | Is an alt a wildcard?-isWildCardAlt :: Alt -> Bool+isWildCardAlt :: S.Alt -> Bool isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat  -- | Is a pattern a wildcard?-isWildCardPat :: Pat -> Bool+isWildCardPat :: S.Pat -> Bool isWildCardPat PWildCard{} = True isWildCardPat PVar{}      = True isWildCardPat _           = False  -- | Return formatter string if expression is a FFI call.-ffiExp :: Exp -> Maybe String-ffiExp (App (Var (UnQual (Ident "ffi"))) (Lit (String formatstr))) = Just formatstr+ffiExp :: Exp a -> Maybe String+ffiExp (App _ (Var _ (UnQual _ (Ident _ "ffi"))) (Lit _ (String _ formatstr _))) = Just formatstr ffiExp _ = Nothing  -- | Generate a temporary, SCOPED name for testing conditions and@@ -244,32 +199,49 @@  -- | Generate a temporary, SCOPED name for testing conditions and -- such. We don't have name tracking yet, so instead we use this.-withScopedTmpName :: (Name -> Compile a) -> Compile a+withScopedTmpName :: (S.Name -> Compile a) -> Compile a withScopedTmpName withName = do   depth <- gets stateNameDepth   modify $ \s -> s { stateNameDepth = depth + 1 }-  ret <- withName $ Ident $ "$gen" ++ show depth+  ret <- withName $ Ident S.noI $ "$gen" ++ show depth   modify $ \s -> s { stateNameDepth = depth }   return ret  -- | Print out a compiler warning. warn :: String -> Compile () warn "" = return ()-warn w = do-  shouldWarn <- config configWarn-  when shouldWarn . io . hPutStrLn stderr $ "Warning: " ++ w+warn w = config id >>= io . (`ioWarn` w) +ioWarn :: CompileConfig -> String -> IO ()+ioWarn _ "" = return ()+ioWarn cfg w =+  when (configWall cfg) $+    hPutStrLn stderr $ "Warning: " ++ w+ -- | Pretty print a source location.-printSrcLoc :: SrcLoc -> String+printSrcLoc :: S.SrcLoc -> String printSrcLoc SrcLoc{..} = srcFilename ++ ":" ++ show srcLine ++ ":" ++ show srcColumn +printSrcSpanInfo :: SrcSpanInfo -> String+printSrcSpanInfo (SrcSpanInfo a b) = concat $ printSrcSpan a : map printSrcSpan b++printSrcSpan :: SrcSpan -> String+printSrcSpan SrcSpan{..} = srcSpanFilename ++ ": (" ++ show srcSpanStartLine ++ "," ++ show srcSpanStartColumn ++ ")-(" ++ show srcSpanEndLine ++ "," ++ show srcSpanEndColumn ++ ")"++ -- | Lookup the record for a given type name.-typeToRecs :: QName -> Compile [QName]-typeToRecs typ = fromMaybe [] . lookup typ <$> gets stateRecordTypes+typeToRecs :: QName a -> Compile [N.QName]+typeToRecs (unAnn -> typ) = fromMaybe [] . lookup typ <$> gets stateRecordTypes +recToFields :: S.QName -> Compile [N.Name]+recToFields con = do+  case tryResolveName con of+    Nothing -> return []+    Just c -> fromMaybe [] . lookup c <$> gets stateRecords+ -- | Get the fields for a given type.-typeToFields :: QName -> Compile [QName]-typeToFields typ = do+typeToFields :: QName a -> Compile [N.Name]+typeToFields (unAnn -> typ) = do   allrecs <- gets stateRecords   typerecs <- typeToRecs typ   return . concatMap snd . filter ((`elem` typerecs) . fst) $ allrecs@@ -287,29 +259,17 @@   where     readVersion = listToMaybe . filter (null . snd) . readP_to_S parseVersion --- | Find an import's filepath and contents from its module name.-findImport :: [FilePath] -> ModuleName -> Compile (FilePath,String)-findImport alldirs mname = go alldirs mname where-  go (dir:dirs) name = do-    exists <- io (doesFileExist path)-    if exists-      then (path,) . stdlibHack <$> io (readFile path)-      else go dirs name-    where-      path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"-      replace c r = map (\x -> if x == c then r else x)-  go [] name =-    throwError $ Couldn'tFindImport name alldirs--  stdlibHack-    | mname == ModuleName "Fay.FFI" = const "module Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined"-    | otherwise = id+-- | Run the top level compilation for all modules.+runTopCompile+  :: CompileReader+  -> CompileState+  -> Compile a+  -> IO (Either CompileError (a,CompileState,CompileWriter))+runTopCompile reader' state' m = fst <$> runModuleT (runErrorT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty --- | Run the compiler.-runCompile :: CompileReader -> CompileState-           -> Compile a-           -> IO (Either CompileError (a,CompileState,CompileWriter))-runCompile reader' state' m = runErrorT (runRWST (unCompile m) reader' state')+-- | Runs compilation for a single module.+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@@ -364,3 +324,6 @@                    ,KindSignatures]   , fixities = Just (preludeFixities ++ baseFixities)   }++shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a+shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn

@@ -1,149 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Handles variable bindings on the module level and also keeps track of--- primitive operations that we want to treat specially.--module Fay.Compiler.ModuleScope-  (ModuleScope-  ,bindAsLocals-  ,findTopLevelNames-  ,resolveName-  ,moduleLocals-  ,findPrimOp-  ) where--import           Fay.Compiler.GADT--import           Control.Arrow-import           Control.Monad.Reader-import           Control.Monad.Writer-import           Data.Default-import           Data.Map (Map)-import qualified Data.Map as M-import           Language.Haskell.Exts hiding (name, binds)-import           Prelude hiding (mod)---- | Maps names bound in the module to their real names--- The keys are unqualified for locals and imports,--- the values are always fully qualified--- Example contents:---   [ (UnQUal     "main"      , Qual "Main"     "main")---   , (UnQual     "take"      , Qual "Prelude"  "take")---   , (  Qual "M" "insertWith", Qual "Data.Map" "insertWith") ]-newtype ModuleScope = ModuleScope (Map QName QName)-  deriving Show--instance Monoid ModuleScope where-  mempty                                  = ModuleScope M.empty-  mappend (ModuleScope a) (ModuleScope b) = ModuleScope $ a `M.union` b--instance Default ModuleScope where-  def = mempty---- | Find the path of a locally bound name--- Returns special values in the "Fay$" module for primOps-resolveName :: QName -> ModuleScope -> Maybe QName-resolveName q (ModuleScope binds) = case M.lookup q binds of -- lookup in the module environment.--  -- something pointing to prelude, is it a primop?-  Just q'@(Qual (ModuleName "Prelude") n) -> case M.lookup n envPrimOpsMap of-    Just x  -> Just x  -- A primop which looks like it's imported from prelude.-    Nothing -> Just q' -- Regular prelude import, leave it as is.--  -- No matches in the current environment, so it may be a primop if it's unqualified.-  -- If Nothing is returned from either of the branches it means that there is-  -- no primop and nothing in env scope so GHC would have given an error.-  Nothing -> case q of-    UnQual n -> M.lookup n envPrimOpsMap-    _        -> Nothing-  j -> j -- Non-prelude import that was found in the env---- | Bind a list of names into the local scope--- Right now all bindings are made unqualified-bindAsLocals :: [QName] -> ModuleScope -> ModuleScope-bindAsLocals qs (ModuleScope binds) =-  -- This needs to be changed to not use unqual to support qualified imports.-  ModuleScope $ binds `M.union` M.fromList (map (unqual &&& id) qs)-    where unqual (Qual _ n) = UnQual n-          unqual u@UnQual{} = u-          unqual Special{}  = error "fay: ModuleScope.bindAsLocals: Special"---- | Find all names that are bound locally in this module, which excludes imports.-moduleLocals :: ModuleName -> ModuleScope -> [QName]-moduleLocals mod (ModuleScope binds) = filter isLocal . M.elems $ binds-  where-    isLocal (Qual m _) = mod == m-    isLocal _ = False------------------------------------------------------------------------------------- Primitive Operations---- | The built-in operations that aren't actually compiled from--- anywhere, they come from runtime.js.------ They're in the names list so that they can be overriden by the user--- in e.g. let a * b = a - b in 1 * 2.------ So we resolve them to Fay$, i.e. the prefix used for the runtime--- support. $ is not allowed in Haskell module names, so there will be--- no conflicts if a user decicdes to use a module named Fay.------ So e.g. will compile to (*) Fay$$mult, which is in runtime.js.-envPrimOpsMap :: Map Name QName-envPrimOpsMap = M.fromList-  [ (Symbol ">>",    Qual (ModuleName "Fay$") (Ident "then"))-  , (Symbol ">>=",   Qual (ModuleName "Fay$") (Ident "bind"))-  , (Ident "return", Qual (ModuleName "Fay$") (Ident "return"))-  , (Ident "force",  Qual (ModuleName "Fay$") (Ident "force"))-  , (Ident "seq",    Qual (ModuleName "Fay$") (Ident "seq"))-  , (Symbol "*",     Qual (ModuleName "Fay$") (Ident "mult"))-  , (Symbol "+",     Qual (ModuleName "Fay$") (Ident "add"))-  , (Symbol "-",     Qual (ModuleName "Fay$") (Ident "sub"))-  , (Symbol "/",     Qual (ModuleName "Fay$") (Ident "divi"))-  , (Symbol "==",    Qual (ModuleName "Fay$") (Ident "eq"))-  , (Symbol "/=",    Qual (ModuleName "Fay$") (Ident "neq"))-  , (Symbol ">",     Qual (ModuleName "Fay$") (Ident "gt"))-  , (Symbol "<",     Qual (ModuleName "Fay$") (Ident "lt"))-  , (Symbol ">=",    Qual (ModuleName "Fay$") (Ident "gte"))-  , (Symbol "<=",    Qual (ModuleName "Fay$") (Ident "lte"))-  , (Symbol "&&",    Qual (ModuleName "Fay$") (Ident "and"))-  , (Symbol "||",    Qual (ModuleName "Fay$") (Ident "or"))-  ]---- | Lookup a primop that was resolved to a Prelude definition.-findPrimOp :: QName -> Maybe QName-findPrimOp (Qual (ModuleName "Prelude") s) = M.lookup s envPrimOpsMap-findPrimOp _ = Nothing------------------------------------------------------------------------------------- AST--type ModuleScopeSt = ReaderT ModuleName (Writer ModuleScope) ()---- | Get module level names from a haskell module AST.-findTopLevelNames :: ModuleName -> [Decl] -> ModuleScope-findTopLevelNames mod decls = snd . runWriter $ runReaderT (mapM_ d_decl decls) mod--bindName :: Name -> ModuleScopeSt-bindName k = ask >>= \mod -> tell (ModuleScope $ M.singleton (UnQual k) (Qual mod k))--d_decl :: Decl -> ModuleScopeSt-d_decl d = case d of-  DataDecl _ _ _ _ _ dd _           -> mapM_ d_qualCon dd-  GDataDecl _ DataType _ _ _ _ ds _ -> mapM_ (d_qualCon . convertGADT) ds-  PatBind _ (PVar n) _ _ _          -> bindName n-  FunBind (Match _ n _ _ _ _ : _)   -> bindName n-  ClassDecl _ _ _ _ _ cds           -> mapM_ d_classDecl cds-  TypeSig _ ns _                    -> mapM_ bindName ns-  _                                 -> return ()--d_classDecl :: ClassDecl -> ModuleScopeSt-d_classDecl cd = case cd of-  ClsDecl d -> d_decl d-  _         -> return ()--d_qualCon :: QualConDecl -> ModuleScopeSt-d_qualCon (QualConDecl _ _ _ cd) = case cd of-  ConDecl n _        -> bindName n-  InfixConDecl _ n _ -> bindName n-  RecDecl n ns       -> bindName n >> mapM_ bindName (concatMap fst ns)

@@ -1,31 +1,31 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE TupleSections     #-}  -- | Optimizing the outputted JavaScript(-ish) AST.  module Fay.Compiler.Optimizer where -import Fay.Compiler.Misc+import           Fay.Compiler.Misc+import           Fay.Types -import Control.Applicative-import Control.Arrow (first)-import Control.Monad.Error-import Control.Monad.Writer-import Control.Monad.State-import Data.List-import Data.Maybe-import Fay.Types-import Language.Haskell.Exts (QName(..),ModuleName(..),Name(..))+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)+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 -- arity of 3, not 4.-type FuncArity = (QName,Int)+type FuncArity = (N.QName,Int)  -- | Optimize monad. type Optimize = State OptState@@ -33,7 +33,7 @@ -- | State. data OptState = OptState   { optStmts   :: [JsStmt]-  , optUncurry :: [QName]+  , optUncurry :: [N.QName]   }  -- | Run an optimizer, which may output additional statements.@@ -46,50 +46,48 @@ -- | Inline x >> y to x;y in the JS output. inlineMonad :: [JsStmt] -> [JsStmt] inlineMonad = map go where-  go stmt =-    case stmt of-      JsVar name exp          -> JsVar name (inline exp)-      JsMappedVar a name exp  -> JsMappedVar a name (inline exp)-      JsIf exp stmts stmts'   -> JsIf (inline exp) (map go stmts) (map go stmts')-      JsEarlyReturn exp       -> JsEarlyReturn (inline exp)-      JsThrow exp             -> JsThrow (inline exp)-      JsWhile exp stmts       -> JsWhile (inline exp) (map go stmts)-      JsUpdate name exp       -> JsUpdate name (inline exp)-      JsSetProp a b exp       -> JsSetProp a b (inline exp)-      JsSetQName a exp        -> JsSetQName a (inline exp)-      JsSetModule a exp       -> JsSetModule a (inline exp)-      JsSetConstructor a exp  -> JsSetConstructor a (inline exp)-      JsSetPropExtern a b exp -> JsSetPropExtern a b (inline exp)-      JsContinue              -> JsContinue-      JsBlock stmts           -> JsBlock (map go stmts)-      JsExpStmt exp           -> JsExpStmt (inline exp)+  go stmt = case stmt of+    JsVar name exp          -> JsVar name (inline exp)+    JsMappedVar a name exp  -> JsMappedVar a name (inline exp)+    JsIf exp stmts stmts'   -> JsIf (inline exp) (map go stmts) (map go stmts')+    JsEarlyReturn exp       -> JsEarlyReturn (inline exp)+    JsThrow exp             -> JsThrow (inline exp)+    JsWhile exp stmts       -> JsWhile (inline exp) (map go stmts)+    JsUpdate name exp       -> JsUpdate name (inline exp)+    JsSetProp a b exp       -> JsSetProp a b (inline exp)+    JsSetQName a exp        -> JsSetQName a (inline exp)+    JsSetModule a exp       -> JsSetModule a (inline exp)+    JsSetConstructor a exp  -> JsSetConstructor a (inline exp)+    JsSetPropExtern a b exp -> JsSetPropExtern a b (inline exp)+    JsContinue              -> JsContinue+    JsBlock stmts           -> JsBlock (map go stmts)+    JsExpStmt exp           -> JsExpStmt (inline exp) -  inline expr =-    case expr of-      -- Optimizations-      JsApp op args -> fromMaybe (JsApp (inline op) $ map inline args) (flatten expr)+  inline expr = case expr of+    -- Optimizations+    JsApp op args -> fromMaybe (JsApp (inline op) $ map inline args) (flatten expr) -      -- Plumbing-      JsFun nm names stmts mexp        -> JsFun nm names (map go stmts) (fmap inline mexp)+    -- Plumbing+    JsFun nm names stmts mexp        -> JsFun nm names (map go stmts) (fmap inline mexp) -      JsNegApp exp                     -> JsNegApp (inline exp)-      JsTernaryIf exp1 exp2 exp3       -> JsTernaryIf (inline exp1) (inline exp2) (inline exp3)-      JsParen exp                      -> JsParen (inline exp)-      JsGetProp exp name               -> JsGetProp (inline exp) name-      JsLookup exp exp2                -> JsLookup (inline exp) (inline exp2)-      JsUpdateProp exp name exp2       -> JsUpdateProp (inline exp) name (inline exp2)-      JsGetPropExtern exp string       -> JsGetPropExtern (inline exp) string-      JsUpdatePropExtern exp name exp2 -> JsUpdatePropExtern (inline exp) name (inline exp2)-      JsList exps                      -> JsList (map inline exps)-      JsNew name exps                  -> JsNew name (map inline exps)-      JsThrowExp exp                   -> JsThrowExp (inline exp)-      JsInstanceOf exp name            -> JsInstanceOf (inline exp) name-      JsIndex i exp                    -> JsIndex i (inline exp)-      JsEq exp exp2                    -> JsEq (inline exp) (inline exp2)-      JsNeq exp exp2                   -> JsNeq (inline exp) (inline exp2)-      JsInfix string exp exp2          -> JsInfix string (inline exp) (inline exp2)-      JsObj keyvals                    -> JsObj keyvals-      rest                             -> rest+    JsNegApp exp                     -> JsNegApp (inline exp)+    JsTernaryIf exp1 exp2 exp3       -> JsTernaryIf (inline exp1) (inline exp2) (inline exp3)+    JsParen exp                      -> JsParen (inline exp)+    JsGetProp exp name               -> JsGetProp (inline exp) name+    JsLookup exp exp2                -> JsLookup (inline exp) (inline exp2)+    JsUpdateProp exp name exp2       -> JsUpdateProp (inline exp) name (inline exp2)+    JsGetPropExtern exp string       -> JsGetPropExtern (inline exp) string+    JsUpdatePropExtern exp name exp2 -> JsUpdatePropExtern (inline exp) name (inline exp2)+    JsList exps                      -> JsList (map inline exps)+    JsNew name exps                  -> JsNew name (map inline exps)+    JsThrowExp exp                   -> JsThrowExp (inline exp)+    JsInstanceOf exp name            -> JsInstanceOf (inline exp) name+    JsIndex i exp                    -> JsIndex i (inline exp)+    JsEq exp exp2                    -> JsEq (inline exp) (inline exp2)+    JsNeq exp exp2                   -> JsNeq (inline exp) (inline exp2)+    JsInfix string exp exp2          -> JsInfix string (inline exp) (inline exp2)+    JsObj keyvals                    -> JsObj keyvals+    rest                             -> rest  -- | Flatten a a>>(b>>c) to [a,b,c]. flatten :: JsExp -> Maybe JsExp@@ -100,17 +98,19 @@  -- | Try to collect nested a>>(b>>c). collect :: JsExp -> Maybe [JsExp]-collect exp =-  case exp of-    JsApp op args | isThen op ->-      case args of-        [rest,x] -> (x :) <$> collect rest-        [x]  -> return [x]-        _ -> Nothing-    _ -> return [exp]+collect exp = case exp of+  JsApp op args | isThen op ->+    case args of+      [rest,x] -> (x :) <$> collect rest+      [x]  -> return [x]+      _ -> Nothing+  _ -> return [exp] -  where isThen = (== JsName (JsNameVar (Qual (ModuleName "Fay$") (Ident "then$uncurried"))))+  where+    isThen (JsName (JsNameVar (Qual _ (ModuleName _ m) (Ident _ n)))) = m == "Fay$" && n == "then$uncurried"+    isThen _ = False + -- | Perform any top-level cross-module optimizations and GO DEEP to -- optimize further. optimizeToplevel :: [JsStmt] -> Optimize [JsStmt]@@ -169,8 +169,8 @@     JsApp a b                      -> do       result <- walkAndStripForces arities exp       case result of-        Just strippedExp             -> go strippedExp-        Nothing                      -> JsApp <$> go a <*> mapM go b+        Just strippedExp           -> go strippedExp+        Nothing                    -> JsApp <$> go a <*> mapM go b     JsNegApp e                     -> JsNegApp <$> go e     JsTernaryIf a b c              -> JsTernaryIf <$> go a <*> go b <*> go c     JsParen e                      -> JsParen <$> go e@@ -190,12 +190,14 @@ walkAndStripForces :: [FuncArity] -> JsExp -> Optimize (Maybe JsExp) walkAndStripForces arities = go True [] where   go frst args app = case app of-    JsApp (JsName JsForce) [e] -> if frst-                                     then do result <- go False args e-                                             case result of-                                               Nothing -> return Nothing-                                               Just ex -> return (Just (JsApp (JsName JsForce) [ex]))-                                     else go False args e+    JsApp (JsName JsForce) [e] ->+      if frst+        then do+          result <- go False args e+          case result of+            Nothing -> return Nothing+            Just ex -> return (Just (JsApp (JsName JsForce) [ex]))+        else go False args e     JsApp op [arg] -> go False (arg:args) op     JsName (JsNameVar f)       | Just arity <- lookup f arities, length args == arity -> do@@ -229,9 +231,9 @@   collectFunc (JsVar (JsNameVar name) exp) | arity > 0 = [(name,arity)]     where arity = expArity exp   collectFunc _ = []-  prim = map (first (Qual (ModuleName "Fay$"))) (unary ++ binary)-  unary = map (,1) [Ident "return"]-  binary = map ((,2) . Ident)+  prim = map (first (Qual () (ModuleName () "Fay$"))) (unary ++ binary)+  unary = map (,1) [Ident () "return"]+  binary = map ((,2) . Ident ())                ["then","bind","mult","mult","add","sub","div"                ,"eq","neq","gt","lt","gte","lte","and","or"] @@ -241,7 +243,7 @@ expArity _ = 0  -- | Change foo(x)(y) to foo$uncurried(x,y).-uncurryBinding :: [JsStmt] -> QName -> Maybe JsStmt+uncurryBinding :: [JsStmt] -> N.QName -> Maybe JsStmt uncurryBinding stmts qname = listToMaybe (mapMaybe funBinding stmts)   where     funBinding stmt = case stmt of@@ -257,13 +259,13 @@         inner -> JsFun Nothing (reverse args) [] (Just inner)  -- | Rename an uncurried copy of a curried function.-renameUncurried :: QName -> QName+renameUncurried :: N.QName -> N.QName renameUncurried q = case q of-  Qual m n -> Qual m (renameUnQual n)-  UnQual n -> UnQual (renameUnQual n)+  Qual _ m n -> Qual () m (renameUnQual n)+  UnQual _ n -> UnQual () (renameUnQual n)   s -> s   where     renameUnQual n = case n of-      Ident nom -> Ident (nom ++ postfix)-      Symbol nom -> Symbol (nom ++ postfix)+      Ident _ nom -> Ident () (nom ++ postfix)+      Symbol _ nom -> Symbol () (nom ++ postfix)     postfix = "$uncurried"

@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TupleSections #-}  -- | Dealing with Cabal packages in Fay's own special way. 

@@ -1,83 +1,83 @@ {-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Compile pattern matches.  module Fay.Compiler.Pattern where -import Fay.Compiler.Misc-import Fay.Compiler.QName-import Fay.Types+import           Fay.Compiler.Misc+import           Fay.Compiler.QName+import           Fay.Exts.NoAnnotation           (unAnn)+import qualified Fay.Exts.NoAnnotation           as N+import qualified Fay.Exts.Scoped                 as S+import           Fay.Types -import Control.Monad.Error-import Control.Monad.State-import Control.Monad.Reader-import Data.List-import Data.Maybe-import Language.Haskell.Exts+import           Control.Applicative+import           Control.Monad.Error+import           Control.Monad.Reader+import           Language.Haskell.Exts.Annotated+import           Language.Haskell.Names  -- | Compile the given pattern against the given expression.-compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]-compilePat exp pat body =-  case pat of-    PVar name       -> compilePVar name exp body-    PApp cons pats  -> do-      newty <- lookupNewtypeConst cons-      case newty of-        Nothing -> compilePApp cons pats exp body-        Just _  -> compileNewtypePat pats exp body-    PLit literal    -> compilePLit exp literal body-    PParen pat      -> compilePat exp pat body-    PWildCard       -> return body-    pat@PInfixApp{} -> compileInfixPat exp pat body-    PList pats      -> compilePList pats body exp-    PTuple _bx pats -> compilePList pats body exp-    PAsPat name pat -> compilePAsPat exp name pat body-    PRec name pats  -> compilePatFields exp name pats body-    pat             -> throwError (UnsupportedPattern pat)+compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]+compilePat exp pat body = case pat of+  PVar _ name       -> compilePVar name exp body+  PApp _ cons pats  -> do+    newty <- lookupNewtypeConst cons+    case newty of+      Nothing -> compilePApp cons pats exp body+      Just _  -> compileNewtypePat pats exp body+  PLit _ literal    -> compilePLit exp literal body+  PParen{}          -> shouldBeDesugared pat+  PWildCard _       -> return body+  pat@PInfixApp{}   -> compileInfixPat exp pat body+  PList _ pats      -> compilePList pats body exp+  PTuple _ _bx pats -> compilePList pats body exp+  PAsPat _ name pat -> compilePAsPat exp name pat body+  PRec _ name pats  -> compilePatFields exp name pats body+  pat               -> throwError (UnsupportedPattern pat)  -- | Compile a pattern variable e.g. x.-compilePVar :: Name -> JsExp -> [JsStmt] -> Compile [JsStmt]-compilePVar name exp body = do-  bindVar name-  return $ JsVar (JsNameVar (UnQual name)) exp : body+compilePVar :: S.Name -> JsExp -> [JsStmt] -> Compile [JsStmt]+compilePVar (unAnn -> name) exp body =+  return $ JsVar (JsNameVar (UnQual () name)) exp : body  -- | Compile a record field pattern.-compilePatFields :: JsExp -> QName -> [PatField] -> [JsStmt] -> Compile [JsStmt]+compilePatFields :: JsExp -> S.QName -> [S.PatField] -> [JsStmt] -> Compile [JsStmt] compilePatFields exp name pats body = do-    c <- liftM (++ body) (compilePats' [] pats)-    qname <- unsafeResolveName name-    return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]-  where -- compilePats' collects field names that had already been matched so that-        -- wildcard generates code for the rest of the fields.-        compilePats' :: [QName] -> [PatField] -> Compile [JsStmt]-        compilePats' names (PFieldPun name:xs) =-          compilePats' names (PFieldPat (UnQual name) (PVar name):xs)+  c <- liftM (++ body) (compilePats' [] pats)+  qname <- unsafeResolveName name+  return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]+  where+    -- compilePats' collects field names that had already been matched so that+      -- wildcard generates code for the rest of the fields.+      compilePats' :: [S.QName] -> [S.PatField] -> Compile [JsStmt]+      compilePats' _ (p@PFieldPun{}:_) = shouldBeDesugared p+      compilePats' names (PFieldPat _ fieldname (PVar _ (unAnn -> varName)):xs) = do+        r <- compilePats' (fieldname : names) xs+        return $ JsVar (JsNameVar (UnQual () varName))+                       (JsGetProp (force exp) (JsNameVar (unQualify $ unAnn fieldname)))+                 : r -- TODO: think about this force call -        compilePats' names (PFieldPat fieldname (PVar varName):xs) = do-          r <- compilePats' (fieldname : names) xs-          bindVar varName-          return $ JsVar (JsNameVar (UnQual varName))-                         (JsGetProp (force exp) (JsNameVar fieldname))-                   : r -- TODO: think about this force call+      compilePats' names (PFieldWildcard (wildcardFields -> fields):xs) = do+        f <- forM fields $ \fieldName ->+          return $ JsVar (JsNameVar fieldName)+                         (JsGetProp (force exp) (JsNameVar fieldName))+        r <- compilePats' names xs+        return $ f ++ r -        compilePats' names (PFieldWildcard:xs) = do-          records <- liftM stateRecords get-          let fields = fromJust (lookup name records)-              fields' = fields \\ names-          f <- mapM (\fieldName -> do bindVar (unQual fieldName)-                                      return (JsVar (JsNameVar fieldName)-                                             (JsGetProp (force exp) (JsNameVar fieldName))))-                   fields'-          r <- compilePats' names xs-          return $ f ++ r+      compilePats' _ [] = return [] -        compilePats' _ [] = return []+      compilePats' _ (pat:_) = throwError (UnsupportedFieldPattern pat) -        compilePats' _ (pat:_) = throwError (UnsupportedFieldPattern pat)+      wildcardFields :: S.X -> [N.QName]+      wildcardFields l = case l of+        Scoped (RecPatWildcard es) _ -> map (unQualify . gname2Qname . origGName) es+        _ -> []  -- | Compile a literal value from a pattern match.-compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt]+compilePLit :: JsExp -> S.Literal -> [JsStmt] -> Compile [JsStmt] compilePLit exp literal body = do   c <- ask   lit <- readerCompileLit c literal@@ -85,56 +85,55 @@                body                []] -  where -- Equality test for two expressions, with some optimizations.-        equalExps :: JsExp -> JsExp -> JsExp-        equalExps a b-          | isConstant a && isConstant b = JsEq a b-          | isConstant a = JsEq a (force b)-          | isConstant b = JsEq (force a) b-          | otherwise =-             JsApp (JsName (JsBuiltIn "equal")) [a,b]+  where+    -- Equality test for two expressions, with some optimizations.+    equalExps :: JsExp -> JsExp -> JsExp+    equalExps a b+      | isConstant a && isConstant b = JsEq a b+      | isConstant a = JsEq a (force b)+      | isConstant b = JsEq (force a) b+      | otherwise =+         JsApp (JsName (JsBuiltIn "equal")) [a,b]  -- | Compile as binding in pattern match-compilePAsPat :: JsExp -> Name -> Pat -> [JsStmt] -> Compile [JsStmt]-compilePAsPat exp name pat body = do-  bindVar name+compilePAsPat :: JsExp -> S.Name -> S.Pat -> [JsStmt] -> Compile [JsStmt]+compilePAsPat exp (unAnn -> name) pat body = do   p <- compilePat exp pat body-  return $ JsVar (JsNameVar $ UnQual name) exp : p+  return $ JsVar (JsNameVar $ UnQual () name) exp : p  -- | Compile a pattern match on a newtype.-compileNewtypePat :: [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]+compileNewtypePat :: [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] compileNewtypePat [pat] exp body = compilePat exp pat body compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps  -- | Compile a pattern application.-compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]+compilePApp :: S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] compilePApp 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)-    UnQual "True"   -> boolIf True-    UnQual "False"  -> boolIf False+    Special _ (UnitCon _) -> return (JsExpStmt forcedExp : body)+    UnQual _ (Ident _ "True")   -> boolIf True+    UnQual _ (Ident _ "False")  -> boolIf False     -- Everything else, generic:-    _ -> do-      rf <- fmap (lookup cons) (gets stateRecords)-      let recordFields =-            fromMaybe-              (error $ "Constructor '" ++ prettyPrint cons ++-                       "' was not found in stateRecords, did you try running this through GHC first?")-              rf-      substmts <- foldM (\body (field,pat) ->-                             compilePat (JsGetProp forcedExp (JsNameVar field)) pat body)-                  body-                  (reverse (zip recordFields pats))-      qcons <- unsafeResolveName cons-      return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons)-                   substmts-                   []]+    n -> do+      let n' = tryResolveName n+      case n' of+        Nothing -> error $ "Constructor '" ++ prettyPrint n ++ "' could not be resolved"+        Just _ -> do+          recordFields <- map (UnQual ()) <$> recToFields n+          substmts <- foldM (\body (field,pat) ->+                                 compilePat (JsGetProp forcedExp (JsNameVar field)) pat body)+                      body+                      (reverse (zip recordFields pats))+          qcons <- unsafeResolveName cons+          return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons)+                       substmts+                       []]  -- | Compile a pattern list.-compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]+compilePList :: [S.Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt] compilePList [] body exp =   return [JsIf (JsEq (force exp) JsNull) body []] compilePList pats body exp = do@@ -151,19 +150,18 @@                []]  -- | Compile an infix pattern (e.g. cons and tuples.)-compileInfixPat :: JsExp -> 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 :: 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 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}++--------------------------------------------------------------------------------+-- | Primitive Operations+-- Built-in operations that aren't actually compiled from+-- anywhere, they come from runtime.js.+--+-- They're in the names list so that they can be overriden by the user+-- in e.g. let a * b = a - b in 1 * 2.+--+-- So we resolve them to Fay$, i.e. the prefix used for the runtime+-- support. $ is not allowed in Haskell module names, so there will be+-- no conflicts if a user decicdes to use a module named Fay.+--+-- So e.g. will compile to (*) Fay$$mult, which is in runtime.js.++module Fay.Compiler.PrimOp+  ( fayBuiltin+  , findPrimOp+  , resolvePrimOp+  ) where++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+fayBuiltin a = Qual a (ModuleName a "Fay$") . Ident a++-- | Mapping from unqualified names to qualified primitive names.+primOpsMap :: Map N.Name N.QName+primOpsMap = M.fromList+  [ (Symbol () ">>",     fayBuiltin () "then")+  , (Symbol () ">>=",    fayBuiltin () "bind")+  , (Ident  () "return", fayBuiltin () "return")+  , (Ident  () "force",  fayBuiltin () "force")+  , (Ident  () "seq",    fayBuiltin () "seq")+  , (Symbol ()  "*",     fayBuiltin () "mult")+  , (Symbol ()  "+",     fayBuiltin () "add")+  , (Symbol ()  "-",     fayBuiltin () "sub")+  , (Symbol ()  "/",     fayBuiltin () "divi")+  , (Symbol ()  "==",    fayBuiltin () "eq")+  , (Symbol ()  "/=",    fayBuiltin () "neq")+  , (Symbol ()  ">",     fayBuiltin () "gt")+  , (Symbol ()  "<",     fayBuiltin () "lt")+  , (Symbol ()  ">=",    fayBuiltin () "gte")+  , (Symbol ()  "<=",    fayBuiltin () "lte")+  , (Symbol ()  "&&",    fayBuiltin () "and")+  , (Symbol ()  "||",    fayBuiltin () "or")+  ]++-- | Lookup a primop that was resolved to a Prelude definition.+findPrimOp :: N.QName -> Maybe N.QName+findPrimOp (Qual _ (ModuleName _ "Prelude") s) = M.lookup s primOpsMap+findPrimOp _ = Nothing++-- | If this is resolved to a Prelude identifier or if it's unqualified,+-- check if it's a primop+resolvePrimOp :: QName a -> Maybe N.QName+resolvePrimOp (unAnn -> q) = case q of+  (Qual _ (ModuleName _ "Prelude") _) -> findPrimOp q+  (UnQual _ n) -> findPrimOp $ Qual () (ModuleName () "Prelude") n+  _ -> Nothing

@@ -1,9 +1,9 @@ {-# OPTIONS -fno-warn-orphans        #-} {-# OPTIONS -fno-warn-unused-do-bind #-}-{-# LANGUAGE FlexibleInstances       #-}-{-# LANGUAGE RecordWildCards         #-}-{-# LANGUAGE TypeSynonymInstances    #-}-{-# LANGUAGE ViewPatterns            #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}  -- | Simple code (non-pretty) printing. --@@ -16,17 +16,19 @@  module Fay.Compiler.Print where +import           Fay.Compiler.PrimOp+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 qualified Data.ByteString.Lazy.UTF8              as UTF8 import           Data.Default import           Data.List import           Data.String-import           Language.Haskell.Exts.Syntax-import           Prelude                      hiding (exp)+import           Language.Haskell.Exts.Annotated.Syntax+import           Prelude                                hiding (exp)  -------------------------------------------------------------------------------- -- Printing@@ -52,39 +54,39 @@       (JsBool b)       -> if b then "true" else "false"  -- | Print (and properly encode to JS) a qualified name.-instance Printable QName where+instance Printable N.QName where   printJS qname =     case qname of-      Qual (ModuleName "Fay$") name -> "Fay$$" +> name-      Qual moduleName name -> moduleName +> "." +> name-      UnQual name -> printJS name-      Special con -> printJS con+      Qual _ (ModuleName _ "Fay$") name -> "Fay$$" +> name+      Qual _ moduleName name -> moduleName +> "." +> name+      UnQual _ name -> printJS name+      Special _ con -> printJS con  -- | Print module name.-instance Printable ModuleName where-  printJS (ModuleName "Fay$") =+instance Printable N.ModuleName where+  printJS (ModuleName _ "Fay$") =     write "Fay$"-  printJS (ModuleName moduleName) = write $ go moduleName+  printJS (ModuleName _ moduleName) = write $ go moduleName      where go ('.':xs) = '.' : go xs           go (x:xs) = normalizeName [x] ++ go xs           go [] = []  -- | Print special constructors (tuples, list, etc.)-instance Printable SpecialCon where+instance Printable N.SpecialCon where   printJS specialCon =-    printJS $ (Qual (ModuleName "Fay$") . Ident) $+    printJS $ fayBuiltin () $       case specialCon of-        UnitCon -> "unit"-        Cons    -> "cons"+        UnitCon _ -> "unit"+        Cons    _ -> "cons"         _       -> error $ "Special constructor not supported: " ++ show specialCon  -- | Print (and properly encode) a name.-instance Printable Name where+instance Printable N.Name where   printJS name = write $     case name of-      Ident  idn -> encodeName idn-      Symbol sym -> encodeName sym+      Ident  _ idn -> encodeName idn+      Symbol _ sym -> encodeName sym  -- | Print a list of statements. instance Printable [JsStmt] where@@ -180,7 +182,7 @@   printJS (JsLitObj assoc) =     "{" +> (intercalateM "," (map cons assoc)) +> "}"       where-        cons :: (Name, JsExp) -> Printer ()+        cons :: (N.Name, JsExp) -> Printer ()         cons (key,value) = "\"" +> key +> "\": " +> value   printJS (JsFun nm params stmts ret) =        "function"@@ -209,8 +211,8 @@ -- | Unqualify a JsName. ident :: JsName -> JsName ident n = case n of-  JsConstructor (Qual _ s) -> JsNameVar $ UnQual s-  a -> a+  JsConstructor (Qual _ _ s) -> JsNameVar $ UnQual () s+  a                          -> a  -- | Print one of the kinds of names. instance Printable JsName where@@ -226,16 +228,16 @@       JsConstructor qname -> printCons qname       JsBuiltIn qname     -> "Fay$$" +> printJS qname       JsParametrizedType  -> write "type"-      JsModuleName (ModuleName m) -> write m+      JsModuleName (ModuleName _ m) -> write m  -- | Print a constructor name given a QName.-printCons :: QName -> Printer ()-printCons (UnQual n) = printConsName n-printCons (Qual (ModuleName m) n) = printJS m +> "." +> printConsName n-printCons (Special _) = error "qname2String Special"+printCons :: N.QName -> Printer ()+printCons (UnQual _ n) = printConsName n+printCons (Qual _ (ModuleName _ m) n) = printJS m +> "." +> printConsName n+printCons (Special {}) = error "qname2String Special"  -- | Print a constructor name given a Name. Helper for printCons.-printConsName :: Name -> Printer ()+printConsName :: N.Name -> Printer () printConsName n = write "_" >> printJS n  -- | Just write out strings.@@ -287,6 +289,7 @@     allowed = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"     escapeChar c = "$" ++ charId c ++ "$"     charId c = show (fromEnum c)+  -------------------------------------------------------------------------------- -- Printing

@@ -2,26 +2,35 @@  module Fay.Compiler.QName where -import Language.Haskell.Exts.Syntax+import           Language.Haskell.Exts.Annotated  -- | Extract the module name from a qualified name.-qModName :: QName -> Maybe ModuleName-qModName (Qual m _) = Just m+qModName :: QName a -> Maybe (ModuleName a)+qModName (Qual _ m _) = Just m qModName _          = Nothing  -- | Extract the name from a QName.-unQual :: QName -> Name-unQual (Qual _ n) = n-unQual (UnQual n) = n+unQual :: QName a -> Name a+unQual (Qual _ _ n) = n+unQual (UnQual _ n) = n unQual Special{} = error "unQual Special{}" +unQualify :: QName a -> QName a+unQualify (Qual a _ n) = UnQual a n+unQualify u@UnQual{} = u+unQualify Special{}  = error "unQualify: Special{}"+ -- | Change or add the ModuleName of a QName.-changeModule :: ModuleName -> QName -> QName-changeModule m (Qual _ n) = Qual m n-changeModule m (UnQual n) = Qual m n+changeModule :: ModuleName a -> QName a -> QName a+changeModule m (Qual a _ n) = Qual a m n+changeModule m (UnQual a n) = Qual a m n changeModule _ Special{}  = error "changeModule Special{}" +changeModule' :: (String -> String) -> QName a -> QName a+changeModule' f (Qual l (ModuleName ml mn) n) = Qual l (ModuleName ml $ f mn) n+changeModule' _ x = x+ -- | Extract the string from a Name.-unname :: Name -> String-unname (Ident s) = s-unname (Symbol s) = s+unname :: Name a -> String+unname (Ident _ s) = s+unname (Symbol _ s) = s

@@ -0,0 +1,66 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | Pure functions for working with CompileState++module Fay.Compiler.State where++import           Fay.Compiler.Misc+import           Fay.Compiler.QName+import qualified Fay.Exts.NoAnnotation  as N+import           Fay.Types++import qualified Data.Map               as M+import           Data.Set               (Set)+import qualified Data.Set               as S+import           Language.Haskell.Names++-- | Get all non local identifiers that should be exported in the JS module scope.+getNonLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)+getNonLocalExportsWithoutNewtypes modName cs =+  fmap ( S.filter (not . isLocal)+       . S.map (gname2Qname . origGName . sv_origName)+       . S.filter (not . (`isNewtype` cs))+       . (\(Symbols exports _) -> exports)+       )+       . M.lookup modName . stateInterfaces $ cs+  where+   isLocal = (Just modName ==) . qModName++getLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)+getLocalExportsWithoutNewtypes modName cs =+  fmap ( S.filter isLocal+       . S.map (gname2Qname . origGName . sv_origName)+       . S.filter (not . (`isNewtype` cs))+       . (\(Symbols exports _) -> exports)+       )+       . M.lookup modName . stateInterfaces $ cs+  where+   isLocal = (Just modName ==) . qModName++-- | 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) . gname2Qname . origGName $ sv_typeName+  SymConstructor { sv_typeName } -> not . (`isNewtypeCons` cs) . gname2Qname . origGName $ sv_typeName++-- | Is this *resolved* name a new type destructor?+isNewtypeDest :: N.QName -> CompileState -> Bool+isNewtypeDest o = any (\(_,mdest,_) -> mdest == Just o) . stateNewtypes++-- | Is this *resolved* name a new type constructor?+isNewtypeCons :: N.QName -> CompileState -> Bool+isNewtypeCons o = any (\(cons,_,_) -> cons  == o) . stateNewtypes++-- | Add a ModulePath to CompileState, meaning it has been printed.+addModulePath :: ModulePath -> CompileState -> CompileState+addModulePath mp cs = cs { stateJsModulePaths = mp `S.insert` stateJsModulePaths cs }++-- | Has this ModulePath been added/printed?+addedModulePath :: ModulePath -> CompileState -> Bool+addedModulePath mp CompileState { stateJsModulePaths } = mp `S.member` stateJsModulePaths+++findTypeSig :: N.QName -> CompileState -> Maybe N.Type+findTypeSig n  = M.lookup n . stateTypeSigs

@@ -2,21 +2,19 @@  module Fay.Compiler.Typecheck where +import           Fay.Compiler.Defaults import           Fay.Compiler.Misc-import           Fay.Control.Monad.IO import           Fay.System.Process.Extra import           Fay.Types -import           Control.Monad.Error 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 :: Maybe FilePath -> Bool -> String -> Compile ()-typecheck packageConf wall fp = do-  cfg <- config id-  faydir <- io faySourceDir+typecheck :: CompileConfig -> FilePath -> IO (Either CompileError String)+typecheck cfg fp = do+  faydir <- faySourceDir   let includes = configDirectoryIncludes cfg    -- Remove the fay source dir from includeDirs to prevent errors on FFI instance declarations.@@ -24,10 +22,10 @@   let packages = nub . map (fromJust . fst) . filter (isJust . fst) $ includes    ghcPackageDbArgs <--    case packageConf of+    case configPackageConf cfg of       Nothing -> return []       Just pk -> do-        flag <- io getGhcPackageDbFlag+        flag <- getGhcPackageDbFlag         return [flag ++ '=' : pk]   let flags =           [ "-fno-code"@@ -38,8 +36,8 @@           , "Language.Fay.DummyMain"           , "-i" ++ intercalate ":" includeDirs           , fp ] ++ ghcPackageDbArgs ++ wallF ++ map ("-package " ++) packages-  res <- io $ readAllFromProcess GHCPaths.ghc flags ""-  either (throwError . GHCError . fst) (warn . fst) res+  res <- readAllFromProcess GHCPaths.ghc flags ""+  either (return . Left . GHCError . fst) (return . Right . fst) res    where-    wallF | wall = ["-Wall"]+    wallF | configWall cfg = ["-Wall"]           | otherwise = []

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE TupleSections      #-} {-# LANGUAGE PatternGuards      #-}+{-# LANGUAGE TupleSections      #-} {-# OPTIONS -fno-warn-type-defaults #-}  -- | Convert a Haskell value to a (JSON representation of a) Fay value.@@ -184,49 +184,42 @@  -- | Parse a number. parseNumber :: Value -> Maybe Number-parseNumber value =-  case value of-    Number n -> return n-    _ -> mzero+parseNumber value = case value of+  Number n -> return n+  _ -> mzero  -- | Parse a bool. parseBool :: Value -> Maybe Bool-parseBool value =-  case value of-    Bool n -> return n-    _ -> mzero+parseBool value = case value of+  Bool n -> return n+  _ -> mzero  -- | Parse a string. parseString :: Value -> Maybe String-parseString value =-  case value of-    String s -> return (Text.unpack s)-    _ -> mzero+parseString value = case value of+  String s -> return (Text.unpack s)+  _ -> mzero  -- | Parse a char. parseChar :: Value -> Maybe Char-parseChar value =-  case value of-    String s | Just (c,_) <- Text.uncons s -> return c-    _ -> mzero+parseChar value = case value of+  String s | Just (c,_) <- Text.uncons s -> return c+  _ -> mzero  -- | Parse a Text. parseText :: Value -> Maybe Text-parseText value =-  case value of-    String s -> return s-    _ -> mzero+parseText value = case value of+  String s -> return s+  _ -> mzero  -- | Parse an array. parseArray :: Data a => Value -> Maybe [a]-parseArray value =-  case value of-    Array xs -> mapM readFromFay (Vector.toList xs)-    _ -> mzero+parseArray value = case value of+  Array xs -> mapM readFromFay (Vector.toList xs)+  _ -> mzero  -- | Parse unit. parseUnit :: Value -> Maybe ()-parseUnit value =-  case value of-    Null -> return ()-    _ -> mzero+parseUnit value = case value of+  Null -> return ()+  _ -> mzero

@@ -2,8 +2,8 @@  module Fay.Data.List.Extra where -import Data.List hiding (map)-import Prelude hiding (map)+import           Data.List hiding (map)+import           Prelude   hiding (map)  -- | Get the union of a list of lists. unionOf :: (Eq a) => [[a]] -> [a]

@@ -0,0 +1,70 @@+module Fay.Exts where++import qualified Language.Haskell.Exts.Annotated as A++type X = A.SrcSpanInfo++type Alt = A.Alt X+type BangType = A.BangType X+type ClassDecl = A.ClassDecl X+type Decl = A.Decl X+type DeclHead = A.DeclHead X+type Ex = A.Exp X+type Exp = A.Exp X+type ExportSpec = A.ExportSpec X+type FieldDecl = A.FieldDecl X+type FieldUpdate = A.FieldUpdate X+type GadtDecl = A.GadtDecl X+type GuardedAlts = A.GuardedAlts X+type GuardedRhs = A.GuardedRhs X+type ImportDecl = A.ImportDecl X+type ImportSpec = A.ImportSpec X+type Literal = A.Literal X+type Match = A.Match X+type Module = A.Module X+type ModuleName = A.ModuleName X+type ModulePragma = A.ModulePragma X+type Name = A.Name X+type Pat = A.Pat X+type PatField = A.PatField X+type QName = A.QName X+type QOp = A.QOp X+type QualConDecl = A.QualConDecl X+type QualStmt = A.QualStmt X+type Rhs = A.Rhs X+type SpecialCon = A.SpecialCon X+type SrcLoc = A.SrcLoc+type Stmt = A.Stmt X+type TyVarBind = A.TyVarBind X+type Type = A.Type X++moduleName :: A.SrcInfo a => A.Module a -> A.ModuleName a+moduleName (A.Module _ (Just (A.ModuleHead _ n _ _)) _ _ _) = n+moduleName (A.Module a Nothing                     _ _ _) = A.ModuleName a "Main"+moduleName m = error $ "moduleName: " ++ A.prettyPrint m++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)++moduleNameString :: A.ModuleName t -> String+moduleNameString (A.ModuleName _ n) = n++mkIdent :: String -> A.Name A.SrcSpanInfo+mkIdent = A.Ident noI++noI :: A.SrcSpanInfo+noI = A.noInfoSpan (A.mkSrcSpan A.noLoc A.noLoc)++convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.BangType a)+convertFieldDecl (A.FieldDecl _ ns b) = (ns, b)++fieldDeclNames :: A.FieldDecl a -> [A.Name a]+fieldDeclNames (A.FieldDecl _ ns _) = ns++declHeadName :: A.DeclHead a -> A.Name a+declHeadName d = case d of+  A.DHead _ n _ -> n+  A.DHInfix _ _ n _ -> n+  A.DHParen _ h -> declHeadName h

@@ -0,0 +1,67 @@+{-# OPTIONS -fno-warn-orphans  #-}+{-# LANGUAGE FlexibleInstances #-}+module Fay.Exts.NoAnnotation where+++import           Data.Char                       (isAlpha)+import           Data.List                       (intercalate)+import           Data.List.Split                 (splitOn)+import           Data.String+import qualified Language.Haskell.Exts.Annotated as A++type Alt = A.Alt ()+type BangType = A.BangType ()+type ClassDecl = A.ClassDecl ()+type Decl = A.Decl ()+type DeclHead = A.DeclHead ()+type Ex = A.Exp ()+type Exp = A.Exp ()+type ExportSpec = A.ExportSpec ()+type FieldDecl = A.FieldDecl ()+type FieldUpdate = A.FieldUpdate ()+type GadtDecl = A.GadtDecl ()+type GuardedAlts = A.GuardedAlts ()+type GuardedRhs = A.GuardedRhs ()+type ImportDecl = A.ImportDecl ()+type ImportSpec = A.ImportSpec ()+type Literal = A.Literal ()+type Match = A.Match ()+type Module = A.Module ()+type ModuleName = A.ModuleName ()+type ModulePragma = A.ModulePragma ()+type Name = A.Name ()+type Pat = A.Pat ()+type PatField = A.PatField ()+type QName = A.QName ()+type QOp = A.QOp ()+type QualConDecl = A.QualConDecl ()+type QualStmt = A.QualStmt ()+type Rhs = A.Rhs ()+type SpecialCon = A.SpecialCon ()+type SrcLoc = A.SrcLoc+type SrcSpan = A.SrcSpan+type SrcSpanInfo = A.SrcSpanInfo+type Stmt = A.Stmt ()+type TyVarBind = A.TyVarBind ()+type Type = A.Type ()++unAnn :: Functor f => f a -> f ()+unAnn = fmap (const ())++-- | Helpful for some things.+instance IsString (A.Name ()) where+  fromString n@(c:_)+    | isAlpha c || c == '_' = A.Ident () n+    | otherwise             = A.Symbol () n+  fromString [] = error "Name fromString: empty string"++-- | Helpful for some things.+instance IsString (A.QName ()) where+  fromString s = case splitOn "." s of+    []  -> error "QName fromString: empty string"+    [x] -> A.UnQual () $ fromString x+    xs  -> A.Qual () (fromString $ intercalate "." $ init xs) $ fromString (last xs)++-- | Helpful for writing qualified symbols (Fay.*).+instance IsString (A.ModuleName ()) where+   fromString = A.ModuleName ()

@@ -0,0 +1,49 @@+module Fay.Exts.Scoped where++import qualified Fay.Exts                        as F++import qualified Language.Haskell.Exts.Annotated as A+import qualified Language.Haskell.Names          as HN+++type X = HN.Scoped A.SrcSpanInfo++type Alt = A.Alt X+type BangType = A.BangType X+type ClassDecl = A.ClassDecl X+type Decl = A.Decl X+type DeclHead = A.DeclHead X+type Ex = A.Exp X+type Exp = A.Exp X+type ExportSpec = A.ExportSpec X+type FieldDecl = A.FieldDecl X+type FieldUpdate = A.FieldUpdate X+type GadtDecl = A.GadtDecl X+type GuardedAlts = A.GuardedAlts X+type GuardedRhs = A.GuardedRhs X+type ImportDecl = A.ImportDecl X+type ImportSpec = A.ImportSpec X+type Literal = A.Literal X+type Match = A.Match X+type Module = A.Module X+type ModuleName = A.ModuleName X+type ModulePragma = A.ModulePragma X+type Name = A.Name X+type Pat = A.Pat X+type PatField = A.PatField X+type QName = A.QName X+type QOp = A.QOp X+type QualConDecl = A.QualConDecl X+type QualStmt = A.QualStmt X+type Rhs = A.Rhs X+type SpecialCon = A.SpecialCon X+type SrcLoc = A.SrcLoc+type Stmt = A.Stmt X+type TyVarBind = A.TyVarBind X+type Type = A.Type X++noI :: HN.Scoped A.SrcSpanInfo+noI = HN.Scoped HN.None F.noI++srcSpanInfo :: HN.Scoped A.SrcSpanInfo -> A.SrcSpanInfo+srcSpanInfo (HN.Scoped _ l) = l

@@ -14,7 +14,7 @@  import           Data.String (IsString) import           Fay.Types-import           Prelude      (Bool, Char, Double, Int, Maybe, String, error)+import           Prelude     (Bool, Char, Double, Int, Maybe, String, error)  -- | Values that may be null --  Nullable x decodes to x, Null decodes to null.

@@ -1,9 +1,9 @@ -- | Extra directory functions. module Fay.System.Directory.Extra where -import           Control.Monad (forM)+import           Control.Monad    (forM) import           System.Directory (doesDirectoryExist, getDirectoryContents)-import           System.FilePath ((</>))+import           System.FilePath  ((</>))  -- | Get all files in a folder and its subdirectories. -- Taken from Real World Haskell

@@ -1,10 +1,5 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE FunctionalDependencies     #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeFamilies               #-}  -- | All Fay types and instances. @@ -15,19 +10,14 @@   ,JsName(..)   ,CompileError(..)   ,Compile(..)-  ,CompilesTo(..)+  ,CompileResult+  ,CompileModule   ,Printable(..)   ,Fay   ,CompileReader(..)   ,CompileWriter(..)   ,CompileConfig(..)   ,CompileState(..)-  ,addCurrentExport-  ,getCurrentExports-  ,getNonLocalExports-  ,getCurrentExportsWithoutNewtypes-  ,getExportsFor-  ,faySourceDir   ,FundamentalType(..)   ,PrintState(..)   ,Printer(..)@@ -37,54 +27,54 @@   ,mkModulePath   ,mkModulePaths   ,mkModulePathFromQName-  ,addModulePath-  ,addedModulePath   ) where +import           Fay.Compiler.QName+import qualified Fay.Exts                          as F+import qualified Fay.Exts.NoAnnotation             as N+import qualified Fay.Exts.Scoped                   as S+ import           Control.Applicative-import           Control.Monad.Error    (Error, ErrorT, MonadError)-import           Control.Monad.Identity (Identity)-import           Control.Monad.State+import           Control.Monad.Error               (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.Maybe-import           Data.Map              (Map)-import qualified Data.Map              as M-import           Data.Set              (Set)-import qualified Data.Set              as S+import           Data.Map                          (Map)+import           Data.Set                          (Set) import           Data.String-import           Language.Haskell.Exts--import           Fay.Compiler.ModuleScope (ModuleScope)-import           Fay.Compiler.QName-import           Paths_fay+import           Distribution.HaskellSuite.Modules+import           Language.Haskell.Exts.Annotated+import           Language.Haskell.Names            (Symbols)  -------------------------------------------------------------------------------- -- Compiler types  -- | Configuration of the compiler. data CompileConfig = CompileConfig-  { configOptimize           :: Bool                       -- ^ Run optimizations-  , configFlattenApps        :: Bool                       -- ^ Flatten function application?-  , configExportBuiltins     :: Bool                       -- ^ Export built-in functions?-  , configExportRuntime      :: Bool                       -- ^ Export the runtime?-  , configExportStdlib       :: Bool                       -- ^ Export the stdlib?-  , configExportStdlibOnly   :: Bool                       -- ^ Export /only/ the stdlib?+  { 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.-  , 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+  , configPrettyPrint       :: Bool                        -- ^ Pretty print the JS output?+  , configHtmlWrapper       :: Bool                        -- ^ Output a HTML file including the produced JS.+  , 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.@@ -92,41 +82,40 @@   deriving (Eq, Ord, Show)  -- | Construct the complete ModulePath from a ModuleName.-mkModulePath :: ModuleName -> ModulePath-mkModulePath (ModuleName m) = ModulePath . splitOn "." $ m+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 -> [ModulePath]-mkModulePaths (ModuleName m) = map ModulePath . tail . inits . splitOn "." $ m+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 -> ModulePath-mkModulePathFromQName (Qual (ModuleName m) n) = mkModulePath $ ModuleName $ m ++ "." ++ unname n+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-  { _stateExports      :: Map ModuleName (Set QName) -- ^ Collects exports from modules-  , stateRecordTypes   :: [(QName,[QName])]          -- ^ Map types to constructors-  , stateRecords       :: [(QName,[QName])]          -- ^ Map constructors to fields-  , stateNewtypes      :: [(QName, Maybe QName, Type)] -- ^ Newtype constructor, destructor, wrapped type tuple-  , stateImported      :: [(ModuleName,FilePath)]    -- ^ Map of all imported modules and their source locations.-  , stateNameDepth     :: Integer                    -- ^ Depth of the current lexical scope.-  , stateLocalScope    :: Set Name                   -- ^ Names in the current lexical scope.-  , stateModuleScope   :: ModuleScope                -- ^ Names in the module scope.-  , stateModuleScopes  :: Map ModuleName ModuleScope-  , stateModuleName    :: ModuleName                 -- ^ Name of the module currently being compiled.-  , stateJsModulePaths :: Set ModulePath-  , stateUseFromString :: Bool+  -- TODO Change N.QName to GName? They can never be special so it would simplify.+  { stateInterfaces    :: Map N.ModuleName Symbols           -- ^ Exported identifiers for all modules+  , stateRecordTypes   :: [(N.QName,[N.QName])]              -- ^ Map types to constructors+  , stateRecords       :: [(N.QName,[N.Name])]               -- ^ Map constructors to fields+  , stateNewtypes      :: [(N.QName, Maybe N.QName, N.Type)] -- ^ Newtype constructor, destructor, wrapped type tuple+  , stateImported      :: [(N.ModuleName,FilePath)]          -- ^ Map of all imported modules and their source locations.+  , stateNameDepth     :: Integer                            -- ^ Depth of the current lexical scope, used for creating unshadowing variables.+  , stateModuleName    :: N.ModuleName                       -- ^ Name of the module currently being compiled.+  , stateJsModulePaths :: Set ModulePath                     -- ^ Module paths that have code generated for them.+  , stateUseFromString :: Bool                               -- ^ Use JS Strings instead of [Char] for string literals?+  , stateTypeSigs      :: Map N.QName N.Type                 -- ^ Module level declarations having explicit type signatures   } deriving (Show)  -- | Things written out by the compiler. data CompileWriter = CompileWriter-  { writerCons     :: [JsStmt] -- ^ Constructors.-  , writerFayToJs  :: [(String,JsExp)] -- ^ Fay to JS dispatchers.-  , writerJsToFay  :: [(String,JsExp)] -- ^ JS to Fay dispatchers.+  { writerCons    :: [JsStmt]         -- ^ Constructors.+  , writerFayToJs :: [(String,JsExp)] -- ^ Fay to JS dispatchers.+  , writerJsToFay :: [(String,JsExp)] -- ^ JS to Fay dispatchers.   }   deriving (Show) @@ -139,57 +128,17 @@ -- | Configuration and globals for the compiler. data CompileReader = CompileReader   { readerConfig       :: CompileConfig -- ^ The compilation configuration.-  , readerCompileLit   :: Literal -> Compile JsExp-  , readerCompileDecls :: Bool -> [Decl] -> Compile [JsStmt]+  , readerCompileLit   :: S.Literal -> Compile JsExp+  , readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]   } --- | The data-files source directory.-faySourceDir :: IO FilePath-faySourceDir = getDataFileName "src/"---- | Add a ModulePath to CompileState, meaning it has been printed.-addModulePath :: ModulePath -> CompileState -> CompileState-addModulePath mp cs = cs { stateJsModulePaths = mp `S.insert` stateJsModulePaths cs }---- | Has this ModulePath been added/printed?-addedModulePath :: ModulePath -> CompileState -> Bool-addedModulePath mp CompileState{..} = mp `S.member` stateJsModulePaths---- | Adds a new export to '_stateExports' for the module specified by--- 'stateModuleName'.-addCurrentExport :: QName -> CompileState -> CompileState-addCurrentExport q cs =-    cs { _stateExports = M.insert (stateModuleName cs) qnames $ _stateExports cs}-  where-    qnames = maybe (S.singleton q) (S.insert q)-           $ M.lookup (stateModuleName cs) (_stateExports cs)---- | Get all exports for the current module.-getCurrentExports :: CompileState -> Set QName-getCurrentExports cs = getExportsFor (stateModuleName cs) cs---- | Get exports from the current module originating from other modules.-getNonLocalExports :: CompileState -> Set QName-getNonLocalExports st = S.filter ((/= Just (stateModuleName st)) . qModName) . getCurrentExportsWithoutNewtypes $ st---- | Get all exports from the current module except newtypes.-getCurrentExportsWithoutNewtypes :: CompileState -> Set QName-getCurrentExportsWithoutNewtypes cs = excludeNewtypes cs $ getCurrentExports cs-  where-    excludeNewtypes :: CompileState -> Set QName -> Set QName-    excludeNewtypes cs' names =-      let newtypes = stateNewtypes cs'-          constrs = map (\(c, _, _) -> c) newtypes-          destrs  = map (\(_, d, _) -> fromJust d) . filter (\(_, d, _) -> isJust d) $ newtypes-       in names `S.difference` (S.fromList constrs `S.union` S.fromList destrs)---- | Get all of the exported identifiers for the given module.-getExportsFor :: ModuleName -> CompileState -> Set QName-getExportsFor mn cs = fromMaybe S.empty $ M.lookup mn (_stateExports cs)- -- | Compile monad. newtype Compile a = Compile-  { unCompile :: RWST CompileReader CompileWriter CompileState (ErrorT CompileError IO) a -- ^ Run the compiler.+  { unCompile :: (RWST CompileReader+                      CompileWriter+                      CompileState+                      (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO)))+                   a -- ^ Uns the compiler   }   deriving (MonadState CompileState            ,MonadError CompileError@@ -198,13 +147,28 @@            ,MonadIO            ,Monad            ,Functor-           ,Applicative)+           ,Applicative+           ) --- | Just a convenience class to generalize the parsing/printing of--- various types of syntax.-class (Parseable from,Printable to) => CompilesTo from to | from -> to where-  compileTo :: from -> Compile to+type CompileResult a+  = Either CompileError+           (a, CompileState, CompileWriter) +type CompileModule a+  = ModuleT Symbols+            IO+            (CompileResult a)++instance MonadModule Compile where+  type ModuleInfo Compile = Symbols+  lookupInCache        = liftModuleT . lookupInCache+  insertInCache n m    = liftModuleT $ insertInCache n m+  getPackages          = liftModuleT $ getPackages+  readModuleInfo fps n = liftModuleT $ readModuleInfo fps n++liftModuleT :: ModuleT Symbols IO a -> Compile a+liftModuleT = Compile . lift . lift+ -- | A source mapping. data Mapping = Mapping   { mappingName :: String -- ^ The name of the mapping.@@ -214,13 +178,13 @@  -- | The state of the pretty printer. data PrintState = PrintState-  { psPretty       :: Bool      -- ^ Are we to pretty print?-  , psLine         :: Int       -- ^ The current line.-  , psColumn       :: Int       -- ^ Current column.-  , psMapping      :: [Mapping] -- ^ Source mappings.-  , psIndentLevel  :: Int       -- ^ Current indentation level.-  , psOutput       :: [String]  -- ^ The current output. TODO: Make more efficient.-  , psNewline      :: Bool      -- ^ Just outputted a newline?+  { psPretty      :: Bool      -- ^ Are we to pretty print?+  , psLine        :: Int       -- ^ The current line.+  , psColumn      :: Int       -- ^ Current column.+  , psMapping     :: [Mapping] -- ^ Source mappings.+  , psIndentLevel :: Int       -- ^ Current indentation level.+  , psOutput      :: [String]  -- ^ The current output. TODO: Make more efficient.+  , psNewline     :: Bool      -- ^ Just outputted a newline?   }  -- | Default state.@@ -237,32 +201,33 @@  -- | Error type. data CompileError-  = ParseError SrcLoc String-  | UnsupportedDeclaration Decl-  | UnsupportedExportSpec ExportSpec-  | UnsupportedExpression Exp-  | UnsupportedFieldPattern PatField-  | UnsupportedImport ImportDecl-  | UnsupportedLet-  | UnsupportedLetBinding Decl-  | UnsupportedLiteral Literal-  | UnsupportedModuleSyntax Module-  | UnsupportedPattern Pat-  | UnsupportedQualStmt QualStmt-  | UnsupportedRecursiveDo-  | UnsupportedRhs Rhs-  | UnsupportedWhereInAlt Alt-  | UnsupportedWhereInMatch Match+  = Couldn'tFindImport N.ModuleName [FilePath]   | EmptyDoBlock-  | InvalidDoBlock-  | Couldn'tFindImport ModuleName [FilePath]-  | FfiNeedsTypeSig Decl-  | FfiFormatBadChars SrcLoc String-  | FfiFormatNoSuchArg SrcLoc Int-  | FfiFormatIncompleteArg SrcLoc-  | FfiFormatInvalidJavaScript SrcLoc String String-  | UnableResolveQualified QName+  | FfiFormatBadChars SrcSpanInfo String+  | FfiFormatIncompleteArg SrcSpanInfo+  | FfiFormatInvalidJavaScript SrcSpanInfo String String+  | FfiFormatNoSuchArg SrcSpanInfo Int+  | FfiNeedsTypeSig S.Decl   | GHCError String+  | InvalidDoBlock+  | ParseError S.SrcLoc String+  | ShouldBeDesugared String+  | UnableResolveQualified N.QName+  | UnsupportedDeclaration S.Decl+  | 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 @@ -283,9 +248,9 @@   | JsWhile JsExp [JsStmt]   | JsUpdate JsName JsExp   | JsSetProp JsName JsName JsExp-  | JsSetQName QName JsExp+  | JsSetQName N.QName JsExp   | JsSetModule ModulePath JsExp-  | JsSetConstructor QName JsExp+  | JsSetConstructor N.QName JsExp   | JsSetPropExtern JsName JsName JsExp   | JsContinue   | JsBlock [JsStmt]@@ -318,7 +283,7 @@   | JsNeq JsExp JsExp   | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc   | JsObj [(String,JsExp)]-  | JsLitObj [(Name,JsExp)]+  | JsLitObj [(N.Name,JsExp)]   | JsUndefined   | JsAnd JsExp JsExp   | JsOr  JsExp JsExp@@ -326,7 +291,7 @@  -- | A name of some kind. data JsName-  = JsNameVar QName+  = JsNameVar N.QName   | JsThis   | JsParametrizedType   | JsThunk@@ -334,9 +299,9 @@   | JsApply   | JsParam Integer   | JsTmp Integer-  | JsConstructor QName-  | JsBuiltIn Name-  | JsModuleName ModuleName+  | JsConstructor N.QName+  | JsBuiltIn N.Name+  | JsModuleName N.ModuleName   deriving (Eq,Show)  -- | Literal value type.@@ -362,7 +327,7 @@  | JsType FundamentalType  | ListType FundamentalType  | TupleType [FundamentalType]- | UserDefined Name [FundamentalType]+ | UserDefined N.Name [FundamentalType]  | Defined FundamentalType  | Nullable FundamentalType  -- Simple types.@@ -377,18 +342,6 @@  -- Unknown.  | UnknownType    deriving (Show)---- | Helpful for some things.-instance IsString Name where-  fromString = Ident---- | Helpful for some things.-instance IsString QName where-  fromString = UnQual . Ident---- | Helpful for writing qualified symbols (Fay.*).-instance IsString ModuleName where-  fromString = ModuleName  -- | The serialization context indicates whether we're currently -- serializing some value or a particular field in a user-defined data

@@ -1,51 +1,48 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards  #-}-{-# OPTIONS -fno-warn-orphans #-} -- | Main compiler executable.  module Main where  import           Fay-import           Fay.Compiler import           Fay.Compiler.Config-import           Fay.Compiler.Debug-import           Fay.Control.Monad.IO+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           Paths_fay                (version)-import           System.Console.Haskeline import           System.Environment  -- | Options and help. data FayCompilerOptions = FayCompilerOptions-  { optLibrary      :: Bool-  , optFlattenApps  :: Bool-  , optHTMLWrapper  :: Bool-  , optHTMLJSLibs   :: [String]-  , optInclude      :: [String]-  , optPackages     :: [String]-  , optWall         :: Bool-  , optNoGHC        :: Bool-  , optStdout       :: Bool-  , optVersion      :: Bool-  , optOutput       :: Maybe String-  , optPretty       :: Bool-  , optFiles        :: [String]-  , optOptimize     :: Bool-  , optGClosure     :: Bool-  , optPackageConf  :: Maybe String-  , optNoRTS        :: Bool-  , optNoStdlib     :: Bool-  , optPrintRuntime :: Bool-  , optStdlibOnly   :: Bool-  , optNoBuiltins   :: Bool-  , optBasePath     :: Maybe FilePath+  { optLibrary       :: Bool+  , optFlattenApps   :: Bool+  , optHTMLWrapper   :: Bool+  , optHTMLJSLibs    :: [String]+  , optInclude       :: [String]+  , optPackages      :: [String]+  , optWall          :: Bool+  , optNoGHC         :: Bool+  , optStdout        :: Bool+  , optVersion       :: Bool+  , optOutput        :: Maybe String+  , optPretty        :: Bool+  , optFiles         :: [String]+  , optOptimize      :: Bool+  , optGClosure      :: Bool+  , optPackageConf   :: Maybe String+  , optNoRTS         :: Bool+  , optNoStdlib      :: Bool+  , optPrintRuntime  :: Bool+  , optStdlibOnly    :: Bool+  , optBasePath      :: Maybe FilePath+  , optStrict        :: [String]+  , optTypecheckOnly :: Bool+  , optRuntimePath   :: Maybe FilePath   }  -- | Main entry point.@@ -53,35 +50,36 @@ main = do   packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment   opts <- execParser parser+  let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $+        addConfigPackages (optPackages opts) $ def+          { configOptimize         = optOptimize opts+          , configFlattenApps      = optFlattenApps opts+          , configPrettyPrint      = optPretty opts+          , configLibrary          = optLibrary opts+          , configHtmlWrapper      = optHTMLWrapper opts+          , configHtmlJSLibs       = optHTMLJSLibs opts+          , configTypecheck        = not $ optNoGHC opts+          , configWall             = optWall opts+          , configGClosure         = optGClosure opts+          , configPackageConf      = optPackageConf opts <|> packageConf+          , configExportRuntime    = not (optNoRTS opts)+          , configExportStdlib     = not (optNoStdlib opts)+          , configExportStdlibOnly = optStdlibOnly opts+          , configBasePath         = optBasePath opts+          , configStrict           = optStrict opts+          , configTypecheckOnly    = optTypecheckOnly opts+          , configRuntimePath      = optRuntimePath opts+          }   if optVersion opts     then runCommandVersion     else if optPrintRuntime opts-      then getRuntime >>= readFile >>= putStr+      then getConfigRuntime config >>= readFile >>= putStr       else do-        let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $-              addConfigPackages (optPackages opts) $ def-                { configOptimize         = optOptimize opts-                , configFlattenApps      = optFlattenApps opts-                , configExportBuiltins   = not (optNoBuiltins opts)-                , configPrettyPrint      = optPretty opts-                , configLibrary          = optLibrary opts-                , configHtmlWrapper      = optHTMLWrapper opts-                , configHtmlJSLibs       = optHTMLJSLibs opts-                , configTypecheck        = not $ optNoGHC opts-                , configWall             = optWall opts-                , configGClosure         = optGClosure opts-                , configPackageConf      = optPackageConf opts <|> packageConf-                , configExportRuntime    = not (optNoRTS opts)-                , configExportStdlib     = not (optNoStdlib opts)-                , configExportStdlibOnly = optStdlibOnly opts-                , configBasePath         = optBasePath opts-                }         void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"         case optFiles opts of-             ["-"] -> getContents >>= printCompile config compileModuleFromAST-             []    -> runInteractive-             files -> forM_ files $ \file ->-               compileFromTo config file (if optStdout opts then Nothing else Just (outPutFile opts file))+          []    -> putStrLn $ helpTxt ++ "\n  More information: fay --help"+          files -> forM_ files $ \file ->+            compileFromTo config file (if optStdout opts then Nothing else Just (outPutFile opts file))    where     parser = info (helper <*> options) (fullDesc <> header helpTxt)@@ -107,7 +105,7 @@   <*> switch (long "version" <> help "Output version number")   <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))   <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")-  <*> arguments Just (metavar "- | <hs-file>...")+  <*> arguments Just (metavar "<hs-file>...")   <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")   <*> switch (long "closure" <> help "Provide help with Google Closure")   <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))@@ -115,8 +113,11 @@   <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI")   <*> switch (long "print-runtime" <> help "Print the runtime JS source to stdout")   <*> switch (long "stdlib" <> help "Only output the stdlib")-  <*> switch (long "no-builtins" <> help "Don't export no-builtins")-  <*> optional (strOption (long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly"))+  <*> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")+  <*> strsOption (long "strict" <> metavar "modulename[, ..]"+      <> help "Generate strict and uncurried exports for the supplied modules. Simplifies calling Fay from JS")+  <*> switch (long "typecheck-only" <> help "Only invoke GHC for typechecking, don't produce any output")+  <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it")    where strsOption m =           nullOption (m <> reader (Right . wordsBy (== ',')) <> value [])@@ -134,9 +135,6 @@ helpTxt :: String helpTxt = concat   ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"-  ,"SYNOPSIS\n"-  ,"  fay [OPTIONS] [- | <hs-file>...]\n"-  ,"  fay - takes input on stdin and prints to stdout. Pretty prints\n"   ,"  fay <hs-file>... processes each .hs file"   ] @@ -147,27 +145,3 @@ -- | Incompatible options. htmlAndStdout :: FayCompilerOptions -> Bool htmlAndStdout opts = optHTMLWrapper opts && optStdout opts---- | Run interactively.-runInteractive :: IO ()-runInteractive = runInputT defaultSettings loop where-  loop = do-    minput <- getInputLine "> "-    case minput of-      Nothing -> return ()-      Just "" -> loop-      Just input -> do-        result <- io $ compileViaStr "<interactive>" config compileExp input-        case result of-          Left err -> do-            -- an error occured, maybe input was not an expression,-            -- but a declaration, try compiling the input as a declaration-            outputStrLn $ "can't parse input as expression: " ++ show err-            result' <- io $ compileViaStr "<interactive>" config (compileDecl True) input-            case result' of-              Right (PrintState{..},_,_) -> outputStr (concat (reverse psOutput))-              Left err' ->-                outputStrLn $ "can't parse input as declaration: " ++ show err'-          Right (PrintState{..},_,_) -> outputStr (concat (reverse psOutput))-        loop-  config = def { configPrettyPrint = True }

@@ -2,7 +2,7 @@  module Test.CommandLine (tests) where -import Fay.System.Process.Extra+import           Fay.System.Process.Extra  import           Control.Applicative import           Data.Maybe

@@ -1,20 +1,26 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}  module Test.Compile (tests) where -import Fay-import Fay.Compiler.Config+import           Fay+import           Fay.Compiler.Config+import           Fay.System.Process.Extra+import           Fay.Types                       () -import Data.Default-import Data.Maybe-import Language.Haskell.Exts.Syntax-import System.Environment-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.TH-import Test.HUnit                     (Assertion, assertBool, assertEqual, assertFailure)-import Test.Util+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  tests :: Test tests = $testGroupGenerator@@ -32,7 +38,7 @@   case res of     Left err -> error (show err)     Right (_,r) -> assertBool "RecordImport_Export was not added to stateImported" .-                     isJust . lookup (ModuleName "RecordImport_Export") $ stateImported r+                     isJust . lookup (ModuleName () "RecordImport_Export") $ stateImported r  fp :: FilePath fp = "tests/RecordImport_Import.hs"@@ -46,8 +52,8 @@     Right (_,r) ->       -- TODO order should not matter       assertEqual "stateRecordTypes mismatch"-        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])-        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])+        [ ("Compile.Records.T", ["Compile.Records.:+"])+        , ("Compile.Records.R", ["Compile.Records.R","Compile.Records.S"])         ]         (stateRecordTypes r) @@ -60,8 +66,8 @@     Right (_,r) ->       -- TODO order should not matter       assertEqual "stateRecordTypes mismatch"-        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])-        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])+        [ ("Compile.Records.T",["Compile.Records.:+"])+        , ("Compile.Records.R",["Compile.Records.R", "Compile.Records.S"])         ]         (stateRecordTypes r) @@ -76,6 +82,17 @@   whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment   res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/CPPMultiLineStrings.hs" } "tests/Compile/CPPMultiLineStrings.hs"   either (assertFailure . show) (const $ return ()) res++case_strictWrapper :: Assertion+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+    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 = addConfigDirectoryIncludePaths ["tests/"]

@@ -7,8 +7,8 @@ import           Fay.System.Process.Extra (readAllFromProcess)  import           Control.Applicative-import           System.Directory import           Prelude                  hiding (pred)+import           System.Directory  -- Path to the fay executable, looks in cabal-dev, dist, PATH in that order. fayPath :: IO (Maybe FilePath)

@@ -19,8 +19,8 @@ import           System.Directory import           System.Environment import           System.FilePath-import qualified Test.Compile                   as Compile 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@@ -43,7 +43,7 @@ -- | Make the case-by-case unit tests. makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test makeCompilerTests packageConf basePath = do-  files <- sort . filter (not . isInfixOf "/Compile/") . filter (isSuffixOf ".hs") <$> getRecursiveContents "tests"+  files <- sort . filter (\v -> not (isInfixOf "/Compile/" v) && not (isInfixOf "/regressions/" v)) . filter (isSuffixOf ".hs") <$> getRecursiveContents "tests"   return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do     testFile packageConf basePath False file     testFile packageConf basePath True file@@ -61,7 +61,7 @@               , configBasePath = basePath               }   resExists <- doesFileExist resf-  let partialName = root ++ "_partial"+  let partialName = root ++ "_partial.res"   partialExists <- doesFileExist partialName   compileFromTo config file (Just out)   result <- runJavaScriptFile out

@@ -0,0 +1,21 @@+module StrictWrapper (f,g,h) where++import           FFI+import           Prelude++f :: Int -> Int -> Int+f x y = x + y++data R = R { i :: Int }++g :: R -> Int+g R{i=i} = i++h :: R -> R+h (R i) = R (i + 1)++main :: Fay ()+main = do+  ffi "console.log(Strict.StrictWrapper.f(1,2))" :: Fay ()+  ffi "console.log(Strict.StrictWrapper.g({instance:'R',i:1}))" :: Fay ()+  ffi "console.log(Strict.StrictWrapper.h({instance:'R',i:1}))" :: Fay ()

@@ -0,0 +1,3 @@+3+1+{ instance: 'R', i: 2 }

@@ -1,9 +1,9 @@ {-# LANGUAGE PackageImports #-} module ExportQualified_Export (main, X.X) where -import Prelude+import           Prelude -import "foo" X+import           "foo" X  main :: Fay () main = return ()

@@ -3,7 +3,7 @@ -- | Module to be shared between server and client. -- -- This module must be valid for both GHC and Fay.-module FayText where+module FromString.FayText where  import           Prelude #ifdef FAY@@ -40,4 +40,3 @@  fromString :: String -> Text fromString = pack-

@@ -1,6 +1,8 @@+module LazyOperators where+ import           Prelude  main :: Fay () main = print testFn -testFn = let f a b = snd (a/b,10::Double) in f 1 0 -- undefined undefined+testFn = let f a b = snd (a/b,10::Double) in f (1::Double) (0::Double)

@@ -1,11 +1,15 @@ import           FFI import           Prelude hiding (take) +main :: Fay () main = putStrLn (showList (take 5 (let ns = 1 : map' (\x -> x + 1) ns in ns))) +take :: Int -> [a] -> [a] take 0 _      = [] take n (x:xs) = x : take (n - 1) xs ++map' :: (a -> b) -> [a] -> [b] map' f []     = [] map' f (x:xs) = f x : map' f xs 

@@ -3,11 +3,15 @@  main = putStrLn (showList (take 5 (let ns = 1 : map' (foo 123) ns in ns))) +foo :: Double -> Double -> Double foo x y = x * y / 2 +take :: Int -> [a] -> [a] take 0 _      = [] take n (x:xs) = x : take (n - 1) xs ++map' :: (a -> b) -> [a] -> [b] map' f []     = [] map' f (x:xs) = f x : map' f xs 

@@ -1,6 +1,6 @@-{-# LANGUAGE EmptyDataDecls    #-}+{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE RankNTypes     #-}  -- | Monads test. 

@@ -7,7 +7,7 @@ main = do   printD $ Nullable (1 :: Double)   printNS $ Nullable "Hello, World!"-  printSS $ Nullable ["Hello,","World!"]+  printSS $ Defined ["Hello,","World!"]   printD $ (Null :: Nullable Double)   print' $ R (Nullable 1)   print' $ R Null

@@ -1,9 +1,11 @@-import Prelude+module Num where +import           Prelude+ main = do-  print (1 + 2)-  print (4 - 1)-  print (3 * 1)-  print (negate (1 - 4))-  print (abs (1 - 4))-  print ((-3) * signum (-10))+  print (1 + 2::Int)+  print (4 - 1::Int)+  print (3 * 1::Int)+  print (negate (1 - 4::Int))+  print (abs (1 - 4::Int))+  print ((-3) * signum (-10::Int))

@@ -1,21 +1,23 @@-import Prelude+module Ord where +import           Prelude+ main = do-  when (1 < 2) $ putStrLn "Expected <"-  when (1 < 1) $ putStrLn "Unexpected < (1)"-  when (2 < 1) $ putStrLn "Unexpected < (2)"-  when (1 >= 2) $ putStrLn "Unexpected >="-  when (1 >= 1) $ putStrLn "Expected >= (1)"-  when (2 >= 1) $ putStrLn "Expected >= (2)"-  when (1 > 2) $ putStrLn "Unexpected > (1)"-  when (1 > 1) $ putStrLn "Unexpected > (2)"-  when (2 > 1) $ putStrLn "Expected >"-  when (1 <= 2) $ putStrLn "Expected <= (1)"-  when (1 <= 1) $ putStrLn "Expected <= (2)"-  when (2 <= 1) $ putStrLn "Unexpected <="-  print $ max 1 2-  print $ min 1 2-  case compare 1 2 of+  when ((1::Int) < 2) $ putStrLn "Expected <"+  when ((1::Int) < 1) $ putStrLn "Unexpected < (1)"+  when ((2::Int) < 1) $ putStrLn "Unexpected < (2)"+  when ((1::Int) >= 2) $ putStrLn "Unexpected >="+  when ((1::Int) >= 1) $ putStrLn "Expected >= (1)"+  when ((2::Int) >= 1) $ putStrLn "Expected >= (2)"+  when ((1::Int) > 2) $ putStrLn "Unexpected > (1)"+  when ((1::Int) > 1) $ putStrLn "Unexpected > (2)"+  when ((2::Int) > 1) $ putStrLn "Expected >"+  when ((1::Int) <= 2) $ putStrLn "Expected <= (1)"+  when ((1::Int) <= 1) $ putStrLn "Expected <= (2)"+  when ((2::Int) <= 1) $ putStrLn "Unexpected <="+  print $ max 1 (2::Int)+  print $ min 1 (2::Int)+  case compare 1 (2::Int) of     EQ -> putStrLn "FAIL (EQ)"     LT -> putStrLn "WIN (LT)"     GT -> putStrLn "FAIL (GT)"

@@ -0,0 +1,18 @@+module QualifiedImport where++import           FFI+import           Prelude++import qualified QualifiedImport.X+import qualified QualifiedImport.X as X+import qualified QualifiedImport.Y as Y++main :: Fay ()+main = do+  print QualifiedImport.X.x+  print Y.y+  print X.X3 { X.x4 = 1 }+  print $ X.X3 2+  print (X.X3 3) { X.x4 = 4 }+  case X.X3 4 of+    X.X3 { X.x4 = n } -> print n

@@ -0,0 +1,6 @@+1+2+{ instance: 'X3', x4: 1 }+{ instance: 'X3', x4: 2 }+{ instance: 'X3', x4: 4 }+4

@@ -0,0 +1,8 @@+module QualifiedImport.X where++import           Prelude++x :: Double+x = 1++data X2 = X3 { x4 :: Double }

@@ -0,0 +1,6 @@+module QualifiedImport.Y where++import           Prelude++y :: Double+y = 2

@@ -0,0 +1,14 @@+module ReExportGlobally (main, x) where++import           FFI+import           Prelude++import           ReExportGlobally.A (x)++main :: Fay ()+main = do+  ffi "console.log(ReExportGlobally.x)" :: Fay () -- Re-export to JS+  ffi "console.log('NewTy' in ReExportGlobally.A)" :: Fay () -- Don't add exports for new types+  ffi "console.log('NewTy' in ReExportGlobally)" :: Fay () -- Don't add exports for new types+  ffi "console.log('unNewTy' in ReExportGlobally.A)" :: Fay () -- Don't add exports for new types+  ffi "console.log('unNewTy' in ReExportGlobally)" :: Fay () -- Don't add exports for new types

@@ -0,0 +1,5 @@+1+false+false+false+false

@@ -0,0 +1,8 @@+module ReExportGlobally.A (x, NewTy(..)) where++import           Prelude++x :: Double+x = 1++newtype NewTy = NewTy { unNewTy :: Double }

@@ -0,0 +1,9 @@+module Foo (main, x) where++import           FFI+import           Prelude++import           ReExportGlobally.A (x)++main :: Fay ()+main = ffi "console.log(Foo.x)"

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

@@ -1,6 +1,7 @@ module T190_B where -import T190_A+import           Prelude+import           T190_A  main :: Fay () main = return ()

@@ -0,0 +1,22 @@+import Prelude+import FFI++func :: Bool -> Int -> Int -> Int+func a b c = if a then b else c++semiAutomatic :: Ptr (Bool -> Int -> Int -> Int) -> Bool -> Int+semiAutomatic = ffi "(function () { return Fay$$fayToJs(['function', 'automatic_function'], %1)(%2, 1, 2); })()"++automatic :: Ptr (Bool -> Int -> Int -> Int) -> Bool -> Int+automatic = ffi "(function () { return Fay$$fayToJs(['automatic'], %1)(%2, 1, 2); })()"++print' :: Ptr a -> Fay ()+print' = ffi "console.log(Fay$$_(%1))"++main :: Fay ()+main = do+  print' (semiAutomatic func True)+  print' (semiAutomatic func False)+  print' (automatic func True)+  print' (automatic func False)+

@@ -0,0 +1,4 @@+1+2+1+2

@@ -1,7 +1,8 @@-import Prelude+module Circular where +import           Prelude+ main :: Fay ()-main = let y = x + 1+main = let y = x + 1::Double            x = y + 1        in print y-

@@ -2,8 +2,8 @@  module Maybe where -import FFI-import Prelude+import           FFI+import           Prelude  data Munge a b = Fudge a b @@ -19,7 +19,7 @@   case munge (Foo (Fudge ["a","b"] [1,2])) of     Foo (Fudge xs is) -> do printS xs                             printI is-  case sponge Fudge ["a","b"] [1,2] of+  case sponge (Fudge ["a","b"] [1,2]) of     Fudge xs is -> do printS xs                       printI is 

@@ -0,0 +1,4 @@+import           Prelude++main :: Fay ()+main = putStrLn $ show $ fromIntegral 5

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

@@ -1,9 +1,11 @@-import Prelude+import           Prelude -f n | n <= 0 = 0+f :: Int -> Int+f n | n <=  0 = 0     | n >= 10 = 11 f n          = n + 1 +g :: Int -> Int g n = case n of   n | n <= 0 -> 0     | n >= 10 -> 11@@ -17,4 +19,3 @@   print $ g (-1)   print $ g 12   print $ g 1-

@@ -1,4 +1,4 @@-import Prelude+import           Prelude  main :: Fay ()-main = putStrLn $ show $ sum [ x*x | x <- [1, 2, 3, 4, 5], let y = x + 4, y < 8]+main = putStrLn $ show $ sum [ x*x | x <- [1::Int, 2, 3, 4, 5], let y = x + 4, y < 8]

@@ -1,9 +1,11 @@-import Prelude+import           Prelude -main = do print $ (-7/2)-          print $ (-7)/2-          print $ -f x/y+print' :: Double -> Fay ()+print' = print++main = do print' $ (-7/2)+          print' $ (-7)/2+          print' $ -f x/y      where f n = n * n            x = 5            y = 2-

@@ -1,9 +1,10 @@-import Prelude+import           Prelude  main :: Fay ()-main =-      case [1,2] of-        []    -> putStrLn "got []"-        [a]   -> putStrLn "got one value."-        [a,b] -> putStrLn "got two values."-+main = do+  case [1,2] of+    []    -> putStrLn "got []"+    [a]   -> putStrLn "got one value."+    [a,b] -> putStrLn "got two values."+  case [1,2] of+    (([1,2])) -> putStrLn "parens"

@@ -1,1 +1,2 @@ got two values.+parens

@@ -2,21 +2,24 @@  -- | As pattern matches -import           Prelude import           FFI+import           Prelude  isPositive :: Double -> Bool isPositive x | x > 0 = True              | x <= 0 = False +threeConds :: Double -> Double threeConds x | x > 1 = 2              | x == 1 = 1              | x < 1 = 0 +withOtherwise :: Double -> Bool withOtherwise x | x > 1 = True                 | otherwise = False  -- Not called, throws "non-exhaustive guard"+nonExhaustive :: Double -> Bool nonExhaustive x | x > 1 = True  main :: Fay ()

@@ -8,22 +8,32 @@  data X = X { foo :: Int } | Y { foo :: Int } -f :: C -> Int-f (C {a, ..}) = a + d+partialMatch :: C -> Int+partialMatch C{a=x, ..} = x + d -test_fun :: C-test_fun = let {a=10; b=20; c=30; d=40} in C{..}+con :: C+con = let {a=10; b=20; c=30; d=40} in C{..} -test2 :: X -> Int-test2 X{..} = foo+match :: X -> Int+match X{..} = foo +partialCon :: C+partialCon = let a = 11; b = 2; c = 3; d = 4 in C { a = 1, ..}++partialMatch2 c =+  let a = 100+  in case c of+       C{a=x,..} -> a+ main = do-    let r = C{a=1, b=2, c=3, d=4}-    print (f r)-    print test_fun+  print con+  print partialCon -    let x = X{foo=9}-    print (test2 x)+  print $ match X{foo=9}+  print $ partialMatch C{a=1, b=2, c=3, d=4}+  print $ partialMatch2 $ C 1 2 3 4 -    let y = Y{foo=6}-    print (test2 y)++  -- non exhaustive pattern match in `match`+  let y = Y{foo=6}+  print (match y)

@@ -1,3 +1,5 @@-5 { instance: 'C', a: 10, b: 20, c: 30, d: 40 }+{ instance: 'C', a: 1, b: 2, c: 3, d: 4 } 9+5+100

@@ -1,10 +1,12 @@-import Prelude+module Sections where +import           Prelude+ withTwo :: (Int -> Int) -> Int withTwo f = f 2  main :: Fay () main = do-  print $ (* 3) 2+  print $ (* 3) (2::Int)   print $ (7 `div`) 2   print $ withTwo (4*)

@@ -2,7 +2,6 @@  main :: Fay () main =-    let x = 10-    in putStrLn $ show (x + y)+    let x = 10 :: Int+    in print $ x + y   where y = 20-

@@ -1,5 +1,6 @@ import           Prelude +someFun :: Int -> String someFun x = fun x   where fun x | x < 50 = "ok"               | otherwise = "nop"@@ -8,4 +9,3 @@ main = do     putStrLn (someFun 30)     putStrLn (someFun 100)-