fay 0.16.0.3 → 0.17.0.0

raw patch · 44 files changed

+840/−723 lines, 44 filesdep +faydep ~language-ecmascriptPVP ok

version bump matches the API change (PVP)

Dependencies added: fay

Dependency ranges changed: language-ecmascript

API changes (from Hackage documentation)

Files

• fay.cabal +24/−15
• js/runtime.js +3/−4
• src/Control/Monad/Extra.hs +0/−31
• src/Control/Monad/IO.hs +0/−9
• src/Data/List/Extra.hs +0/−14
• src/Fay/Compiler.hs +13/−3
• src/Fay/Compiler/Decl.hs +1/−1
• src/Fay/Compiler/Defaults.hs +1/−0
• src/Fay/Compiler/Exp.hs +5/−2
• src/Fay/Compiler/InitialPass.hs +3/−3
• src/Fay/Compiler/Misc.hs +1/−1
• src/Fay/Compiler/Packages.hs +13/−13
• src/Fay/Compiler/Typecheck.hs +6/−5
• src/Fay/Control/Monad/Extra.hs +31/−0
• src/Fay/Control/Monad/IO.hs +9/−0
• src/Fay/Data/List/Extra.hs +14/−0
• src/Fay/FFI.hs +3/−1
• src/Fay/System/Directory/Extra.hs +21/−0
• src/Fay/System/Process/Extra.hs +15/−0
• src/Fay/Types.hs +11/−10
• src/Main.hs +0/−173
• src/System/Directory/Extra.hs +0/−21
• src/System/Process/Extra.hs +0/−15
• src/Test/CommandLine.hs +0/−44
• src/Test/Compile.hs +0/−82
• src/Test/Convert.hs +0/−156
• src/Test/Util.hs +0/−38
• src/Tests.hs +0/−82
• src/main/Main.hs +173/−0
• src/tests/Test/CommandLine.hs +45/−0
• src/tests/Test/Compile.hs +82/−0
• src/tests/Test/Convert.hs +156/−0
• src/tests/Test/Util.hs +39/−0
• src/tests/Tests.hs +82/−0
• tests/AutomaticList.hs +3/−0
• tests/AutomaticList.res +3/−0
• tests/FromString.hs +15/−0
• tests/FromString.res +5/−0
• tests/FromString/Dep.hs +11/−0
• tests/FromString/Dep.res +0/−0
• tests/FromString/DepDep.hs +9/−0
• tests/FromString/DepDep.res +0/−0
• tests/FromString/FayText.hs +43/−0
• tests/FromString/FayText.res +0/−0

@@ -1,5 +1,5 @@ name:                fay-version:             0.16.0.3+version:             0.17.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,@@ -136,6 +136,14 @@   tests/Floating.res   tests/fromInteger.hs   tests/fromInteger.res+  tests/FromString/Dep.hs+  tests/FromString/Dep.res+  tests/FromString/DepDep.hs+  tests/FromString/DepDep.res+  tests/FromString/FayText.hs+  tests/FromString/FayText.res+  tests/FromString.hs+  tests/FromString.res   tests/GADTs_without_records.hs   tests/GADTs_without_records.res   tests/guards.hs@@ -345,13 +353,15 @@                      , Fay.Compiler                      , Fay.Compiler.Config                      , Fay.Compiler.Debug+                     , Fay.Control.Monad.Extra+                     , Fay.Control.Monad.IO                      , Fay.Convert-                     , Fay.Types+                     , Fay.Data.List.Extra                      , Fay.FFI-  other-modules:       Control.Monad.Extra-                     , Control.Monad.IO-                     , Data.List.Extra-                     , Fay.Compiler.Decl+                     , Fay.System.Directory.Extra+                     , Fay.System.Process.Extra+                     , Fay.Types+  other-modules:       Fay.Compiler.Decl                      , Fay.Compiler.Defaults                      , Fay.Compiler.Exp                      , Fay.Compiler.FFI@@ -366,8 +376,6 @@                      , Fay.Compiler.QName                      , Fay.Compiler.Typecheck                      , Paths_fay-                     , System.Directory.Extra-                     , System.Process.Extra   ghc-options:       -O2 -Wall -fno-warn-name-shadowing   build-depends:     base >= 4 && < 5                    , Cabal@@ -382,7 +390,7 @@                    , filepath                    , ghc-paths                    , haskell-src-exts >= 1.14-                   , language-ecmascript >= 0.15+                   , language-ecmascript >= 0.15 && < 1.0                    , mtl                    , optparse-applicative >= 0.5                    , pretty-show >= 1.6@@ -400,11 +408,12 @@                    , vector  executable fay-  hs-source-dirs:    src+  hs-source-dirs:    src/main   ghc-options:       -O2 -Wall   ghc-prof-options:  -fprof-auto   main-is:           Main.hs   build-depends:     base >= 4 && < 5+                   , fay                    , Cabal                    , aeson                    , containers@@ -415,7 +424,7 @@                    , ghc-paths                    , haskeline                    , haskell-src-exts >= 1.14-                   , language-ecmascript >= 0.15+                   , language-ecmascript >= 0.15 && < 1.0                    , mtl                    , optparse-applicative >= 0.5                    , process@@ -425,16 +434,16 @@                    , utf8-string  executable fay-tests-  hs-source-dirs:    src+  hs-source-dirs:    src/tests   ghc-options:       -O2 -Wall -threaded -with-rtsopts=-N   ghc-prof-options:  -fprof-auto   main-is:           Tests.hs-  other-modules:     Fay.Compiler-                     Test.CommandLine+  other-modules:     Test.CommandLine                      Test.Compile                      Test.Convert                      Test.Util   build-depends:     base >= 4 && < 5+                   , fay                    , Cabal                    , HUnit                    , aeson@@ -447,7 +456,7 @@                    , filepath                    , ghc-paths                    , haskell-src-exts >= 1.14-                   , language-ecmascript >= 0.15+                   , language-ecmascript >= 0.15 && < 1.0                    , mtl                    , pretty-show >= 1.6                    , process

@@ -237,13 +237,12 @@   else if(base == "ptr" || base == "unknown")     return fayObj;   else if(base == "automatic" || base == "user") {-    if(fayObj instanceof Fay$$$)-      fayObj = Fay$$_(fayObj); -    if(fayObj instanceof Fay$$Cons){+    fayObj = Fay$$_(fayObj);++    if(fayObj instanceof Fay$$Cons || fayObj === null){       // Serialize Fay list to JavaScript array.       var arr = [];-      fayObj = Fay$$_(fayObj);       while(fayObj instanceof Fay$$Cons) {         arr.push(Fay$$fayToJs(["automatic"],fayObj.car));         fayObj = Fay$$_(fayObj.cdr);

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

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

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

@@ -31,13 +31,13 @@ import           Fay.Compiler.Misc import           Fay.Compiler.ModuleScope (findPrimOp) import           Fay.Compiler.Optimizer-import           Fay.Compiler.Typecheck import           Fay.Compiler.QName+import           Fay.Compiler.Typecheck+import           Fay.Control.Monad.IO import           Fay.Types  import           Control.Applicative import           Control.Monad.Error-import           Control.Monad.IO import           Control.Monad.State import           Control.Monad.RWS import           Data.Default                    (def)@@ -153,11 +153,12 @@  -- | Compile a parse HSE module. compileModuleFromAST :: Module -> Compile [JsStmt]-compileModuleFromAST (Module _ modulename _pragmas Nothing _exports imports decls) =+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 @@ -174,6 +175,15 @@               then []               else stmts compileModuleFromAST mod = throwError (UnsupportedModuleSyntax mod)++hasLanguagePragmas :: [String] -> [ModulePragma] -> Bool+hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas+  where+    flattenPragmas :: [ModulePragma] -> [String]+    flattenPragmas ps = concat $ map pragmaName ps+    pragmaName (LanguagePragma _ q) = map unname q+    pragmaName _ = []+  instance CompilesTo Module [JsStmt] where compileTo = compileModuleFromAST 

@@ -13,11 +13,11 @@ import Fay.Compiler.GADT import Fay.Compiler.Misc import Fay.Compiler.Pattern+import Fay.Data.List.Extra import Fay.Types  import Control.Applicative import Control.Monad.Error-import Data.List.Extra import Control.Monad.RWS import Language.Haskell.Exts 

@@ -41,4 +41,5 @@     , stateModuleScope = def     , stateModuleScopes = M.empty     , stateJsModulePaths = S.empty+    , stateUseFromString = False     }

@@ -84,8 +84,11 @@     Frac rational -> return (JsLit (JsFloating (fromRational rational)))     -- TODO: Use real JS strings instead of array, probably it will     -- lead to the same result.-    String string -> return (JsApp (JsName (JsBuiltIn "list"))-                                   [JsLit (JsStr string)])+    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.

@@ -10,14 +10,14 @@ import           Fay.Compiler.GADT import           Fay.Compiler.Misc import           Fay.Compiler.ModuleScope+import           Fay.Control.Monad.Extra+import           Fay.Control.Monad.IO+import           Fay.Data.List.Extra import           Fay.Types  import           Control.Applicative import           Control.Monad.Error-import           Control.Monad.Extra import           Control.Monad.RWS-import           Control.Monad.IO-import           Data.List.Extra import qualified Data.Set as S import qualified Data.Map as M import           Language.Haskell.Exts.Parser

@@ -7,12 +7,12 @@  module Fay.Compiler.Misc where +import           Fay.Control.Monad.IO import qualified Fay.Compiler.ModuleScope        as ModuleScope import           Fay.Types  import           Control.Applicative import           Control.Monad.Error-import           Control.Monad.IO import           Control.Monad.RWS import           Data.List import           Data.Maybe

@@ -4,20 +4,20 @@  module Fay.Compiler.Packages where -import Fay.Types-import Fay.Compiler.Config+import           Fay.Compiler.Config+import           Fay.Control.Monad.Extra+import           Fay.System.Process.Extra+import           Fay.Types+import           Paths_fay -import Control.Applicative-import Control.Monad-import Control.Monad.Extra-import Data.Maybe-import Data.List-import Data.Version-import GHC.Paths-import Paths_fay-import System.Directory-import System.FilePath-import System.Process.Extra+import           Control.Applicative+import           Control.Monad+import           Data.List+import           Data.Maybe+import           Data.Version+import           GHC.Paths+import           System.Directory+import           System.FilePath  -- | Given a configuration, resolve any packages specified to their -- data file directories for importing the *.hs sources.

@@ -2,14 +2,15 @@  module Fay.Compiler.Typecheck where -import           Control.Monad.IO+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           Fay.Compiler.Misc-import           Fay.Types-import qualified GHC.Paths                       as GHCPaths-import           System.Process.Extra+import qualified GHC.Paths                  as GHCPaths  -- | Call out to GHC to type-check the file. typecheck :: Maybe FilePath -> Bool -> String -> Compile ()

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

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

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

@@ -12,6 +12,7 @@   ,ffi)   where +import           Data.String (IsString) import           Fay.Types import           Prelude      (Bool, Char, Double, Int, Maybe, String, error) @@ -44,6 +45,7 @@ type Automatic a = a  -- | Declare a foreign action.-ffi :: String        -- ^ The foreign value.+ffi :: IsString s+    => s             -- ^ The foreign value.     -> a             -- ^ Bottom. ffi = error "Fay.FFI.ffi: Used foreign function outside a JS engine context."

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

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

@@ -108,17 +108,18 @@  -- | 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.+  { _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   } deriving (Show)  -- | Things written out by the compiler.

@@ -1,173 +0,0 @@-{-# 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 qualified Control.Exception        as E-import           Control.Monad-import           Control.Monad.IO-import           Data.Default-import           Data.List.Split          (wordsBy)-import           Data.Maybe-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-  }---- | Main entry point.-main :: IO ()-main = do-  packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  opts <- execParser parser-  if optVersion opts-    then runCommandVersion-    else if optPrintRuntime opts-      then getRuntime >>= 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))--  where-    parser = info (helper <*> options) (fullDesc <> header helpTxt)--    outPutFile :: FayCompilerOptions -> String -> FilePath-    outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts---- | All Fay's command-line options.-options :: Parser FayCompilerOptions-options = FayCompilerOptions-  <$> switch (long "library" <> help "Don't automatically call main in generated JavaScript")-  <*> switch (long "flatten-apps" <> help "flatten function applicaton")-  <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript")-  <*> strsOption (long "html-js-lib" <> metavar "file1[, ..]"-      <> help "javascript files to add to <head> if using option html-wrapper")-  <*> strsOption (long "include" <> metavar "dir1[, ..]"-      <> help "additional directories for include")-  <*> strsOption (long "package" <> metavar "package[, ..]"-      <> help "packages to use for compilation")-  <*> switch (long "Wall" <> help "Typecheck with -Wall")-  <*> switch (long "no-ghc" <> help "Don't typecheck, specify when not working with files")-  <*> switch (long "stdout" <> short 's' <> help "Output to stdout")-  <*> switch (long "version" <> help "Output version number")-  <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))-  <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")-  <*> arguments Just (metavar "- | <hs-file>...")-  <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")-  <*> switch (long "closure" <> help "Provide help with Google Closure")-  <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))-  <*> switch (long "no-rts" <> short 'r' <> help "Don't export the RTS")-  <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI")-  <*> switch (long "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"))--  where strsOption m =-          nullOption (m <> reader (Right . wordsBy (== ',')) <> value [])----- | Make incompatible options.-incompatible :: Monad m-  => (FayCompilerOptions -> Bool)-  -> FayCompilerOptions -> String -> m Bool-incompatible test opts message = if test opts-  then E.throw $ userError message-  else return True---- | The basic help text.-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"-  ]---- | Print the command version.-runCommandVersion :: IO ()-runCommandVersion = putStrLn $ "fay " ++ showVersion version---- | 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 }

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

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

@@ -1,44 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Test.CommandLine (tests) where--import Control.Applicative-import Data.Maybe-import System.Directory-import System.Environment-import System.FilePath-import System.Process.Extra-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.TH-import Test.HUnit                     (Assertion, assertBool)-import Test.Util--tests :: Test-tests = $testGroupGenerator--compileFile :: [String] -> IO (Either String String)-compileFile flags = do-  whatAGreatFramework <- fmap (fmap (\x -> x</>"bin"</>"fay") . lookup "HASKELL_SANDBOX")-                              getEnvironment-  fay <- fayPath-  let path = fromMaybe "couldn't find fay" (whatAGreatFramework <|> fay)-  exists <- doesFileExist path-  if exists-     then do r <- readAllFromProcess path flags ""-             return $ case r of-               Left  (l,_) -> Left ("Reason: " ++ l)-               Right (_,t) -> Right t-     else error $ "fay path not are existing: " ++ path--case_executable :: Assertion-case_executable = do-  fay <- fayPath-  assertBool "Could not find fay executable" (isJust fay)--case_compile :: Assertion-case_compile = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile (["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"] ++-                      ["--package-conf=" ++ packageConf | Just packageConf <- [whatAGreatFramework] ])-  assertBool (fromLeft res) (isRight res)

@@ -1,82 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--module Test.Compile (tests) where--import Fay-import Fay.Compiler.Config--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--tests :: Test-tests = $testGroupGenerator--case_imports :: Assertion-case_imports = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework } fp-  assertBool "Could not compile file with imports" (isRight res)--case_importedList :: Assertion-case_importedList = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } fp-  case res of-    Left err -> error (show err)-    Right (_,r) -> assertBool "RecordImport_Export was not added to stateImported" .-                     isJust . lookup (ModuleName "RecordImport_Export") $ stateImported r--fp :: FilePath-fp = "tests/RecordImport_Import.hs"--case_stateRecordTypes :: Assertion-case_stateRecordTypes = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/Records.hs"-  case res of-    Left err -> error (show err)-    Right (_,r) ->-      -- TODO order should not matter-      assertEqual "stateRecordTypes mismatch"-        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])-        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])-        ]-        (stateRecordTypes r)--case_importStateRecordTypes :: Assertion-case_importStateRecordTypes = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/ImportRecords.hs"-  case res of-    Left err -> error (show err)-    Right (_,r) ->-      -- TODO order should not matter-      assertEqual "stateRecordTypes mismatch"-        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])-        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])-        ]-        (stateRecordTypes r)--case_typecheckCPP :: Assertion-case_typecheckCPP = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/CPPTypecheck.hs" } "tests/Compile/CPPTypecheck.hs"-  either (assertFailure . show) (const $ return ()) res--case_cppMultiLineStrings :: Assertion-case_cppMultiLineStrings = do-  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--defConf :: CompileConfig-defConf = addConfigDirectoryIncludePaths ["tests/"]-        $ def { configTypecheck = False }

@@ -1,156 +0,0 @@-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE ExistentialQuantification #-}--module Test.Convert (tests) where--import qualified Data.Aeson.Parser              as Aeson-import           Data.Attoparsec.ByteString-import qualified Data.ByteString                as Bytes-import qualified Data.ByteString.UTF8           as UTF8-import           Data.Data-import           Data.Ratio-import           Data.Text                      (Text, pack)-import           Fay.Convert-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit                     (assertEqual)--tests :: Test-tests = testGroup "Test.Convert" [reading, showing]-  where reading = testGroup "reading" $-          flip map readTests $ \(ReadTest value) ->-            let label = show value-            in testCase label $-                 assertEqual label (Just value) (showToFay value >>= readFromFay)-        showing = testGroup "showing" $-          flip map showTests $ \(Testcase value output) ->-            let label = show value-            in testCase label $-                 assertEqual label-                   (either error Just $ parseOnly Aeson.value output)-                   (showToFay value)-------------------------------------------------------------------------------------- Test cases---- | A test.-data Testcase = forall x. Show x => Testcase x Bytes.ByteString---- | A read test.-data ReadTest = forall x. (Data x,Show x,Eq x,Read x) => ReadTest x----- | Tests---- | Read tests.-readTests :: [ReadTest]-readTests =-  [ReadTest $ NullaryConstructor-  ,ReadTest $ NAryConstructor 123 66.6-  ,ReadTest $ LabelledRecord { barInt = 123, barDouble = 66.6 }-  ,ReadTest $ LabelledRecord2 { bar = 123, bob = 66.6 }-  ,ReadTest $ FooBar "Tinkie Winkie" "Humanzee" Zot-  ,ReadTest $ Bar $ Foo "one" "two"-  ,ReadTest $ StepcutFoo 123-  ,ReadTest $ StepcutBar (StepcutFoo 456)-  ,ReadTest $ StepcutFoo' 789-  ,ReadTest $ Baz (StepcutFoo' 10112)-  ,ReadTest $ TextConstructor $ pack "This is \"some text\n\n\""-  ,ReadTest $ (("foo",'a') :: (String,Char))-  ,ReadTest $ ((pack "foo",'a',23) :: (Text,Char,Int))-  ,ReadTest $ TupleList [(pack "foo",pack "bar")]-  ,ReadTest $ TupleList' [((pack "foo",23) :: (Text,Int))]-  ,ReadTest $ ()-  ]---- | Test cases.-showTests :: [Testcase]-showTests =-   -- Fundamental data types-  [(1 :: Int) → "1"-  ,(1 :: Double) → "1.0"-  ,(1/2 :: Double) → "0.5"-  ,(1%2 :: Rational) → "0.5"-  ,([1,2] :: [Int]) → "[1,2]"-  ,((1,2) :: (Int,Int)) → "[1,2]"-  ,"abc" → "\"abc\""-  ,'a' → "\"a\""-  , () → "null"-  -- Data records-  ,NullaryConstructor → "{\"instance\":\"NullaryConstructor\"}"-  ,NAryConstructor 123 4.5 → "{\"slot1\":123,\"slot2\":4.5,\"instance\":\"NAryConstructor\"}"-  ,LabelledRecord { barInt = 123, barDouble = 4.5 }-     → "{\"barDouble\":4.5,\"barInt\":123,\"instance\":\"LabelledRecord\"}"-  ,Bar (Foo "one" "two") → "{\"slot1\":{\"slot1\":\"one\",\"slot2\":\"two\",\"instance\":\"Foo\"},\"instance\":\"Bar\"}"-  ,TextConstructor (pack "foo bar baz") → "{\"slot1\":\"foo bar baz\",\"instance\":\"TextConstructor\"}"-  -- Unicode-  ,"¡ ¢ £ ¤ ¥ " → "\"¡ ¢ £ ¤ ¥ \""-  ,"Ā ā Ă ă Ą " → "\"Ā ā Ă ă Ą \""-  ,"ƀ Ɓ Ƃ ƃ Ƅ " → "\"ƀ Ɓ Ƃ ƃ Ƅ \""-  ,"ɐ ɑ ɒ ɓ ɔ " → "\"ɐ ɑ ɒ ɓ ɔ \""-  ,"Ё Ђ Ѓ Є Ѕ " → "\"Ё Ђ Ѓ Є Ѕ \""-  ,"Ա Բ Գ Դ Ե " → "\"Ա Բ Գ Դ Ե \""-  ,"، ؛ ؟ ء آ " → "\"، ؛ ؟ ء آ \""-  ,"ँ ं ः अ आ " → "\"ँ ं ः अ आ \""-  ,"ఁ ం ః అ ఆ " → "\"ఁ ం ః అ ఆ \""-  ,"ก ข ฃ ค ฅ " → "\"ก ข ฃ ค ฅ \""-  ,"ກ ຂ ຄ ງ ຈ " → "\"ກ ຂ ຄ ງ ຈ \""-  ,"ༀ ༁ ༂ ༃ ༄ " → "\"ༀ ༁ ༂ ༃ ༄ \""-  ,"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ " → "\"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ \""-  ,"Ḁ ḁ Ḃ ḃ Ḅ " → "\"Ḁ ḁ Ḃ ḃ Ḅ \""-  ,"ぁ あ ぃ い ぅ " → "\"ぁ あ ぃ い ぅ \""-  ,"ァ ア ィ イ ゥ " → "\"ァ ア ィ イ ゥ \""-  ,"ㄅ ㄆ ㄇ ㄈ ㄉ " → "\"ㄅ ㄆ ㄇ ㄈ ㄉ \""-  ,"ㄱ ㄲ ㄳ ㄴ ㄵ " → "\"ㄱ ㄲ ㄳ ㄴ ㄵ \""-  ]--  where x → y = Testcase x (UTF8.fromString y)--data Foo = Foo String String-  deriving (Show,Data,Typeable,Read,Eq)-data Bar = Bar Foo-  deriving (Show,Data,Typeable,Read,Eq)---- | Nullary constructor.-data NullaryConstructor = NullaryConstructor-  deriving (Show,Data,Typeable,Read,Eq)---- | n-ary labelless constructor.-data NAryConstructor = NAryConstructor Int Double-  deriving (Show,Data,Typeable,Read,Eq)---- | Labelled record.-data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double }-                    | LabelledRecord2 { bar :: Int, bob :: Double }-  deriving (Show,Data,Typeable,Read,Eq)---- | Order matters in unlabelled constructors.-data SomeThing =-  FooBar String String Zot-  deriving (Read,Data,Typeable,Show,Eq)---- | This triggers order difference. Go figure.-data Zot = Zot-  deriving (Read,Data,Typeable,Show,Eq)--data StepcutFoo = StepcutFoo { _unStepcutFoo :: Int }-    deriving (Eq, Show, Read, Typeable, Data)--data StepcutBar = StepcutBar StepcutFoo-    deriving (Eq, Show, Read, Typeable, Data)--data StepcutFoo' = StepcutFoo' Int-    deriving (Eq, Show, Read, Typeable, Data)--data Baz = Baz StepcutFoo'-    deriving (Eq, Show, Read, Typeable, Data)--data TextConstructor = TextConstructor Text-    deriving (Eq, Show, Read, Typeable, Data)--data TupleList = TupleList [(Text,Text)]-  deriving (Read, Typeable, Data, Show, Eq)--data TupleList' a = TupleList' [(Text,a)]-  deriving (Read, Typeable, Data, Show, Eq)

@@ -1,38 +0,0 @@-module Test.Util-  ( fayPath-  , isRight-  , fromLeft-  ) where--import           Control.Applicative-import           System.Directory-import           System.Process.Extra        (readAllFromProcess)-import           Prelude              hiding (pred)---- Path to the fay executable, looks in cabal-dev, dist, PATH in that order.-fayPath :: IO (Maybe FilePath)-fayPath =-  (<|>) <$> firstWhereM doesFileExist [cabalDevPath, distPath] <*> usingWhich-  where-    cabalDevPath = "./cabal-dev/bin/fay"-    distPath = "./dist/build/fay/fay"-    usingWhich = fmap (concat . lines . snd) . hush <$> readAllFromProcess "which" ["fay"] ""--firstWhereM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)-firstWhereM pred ins = case ins of-  [] -> return Nothing-  a:as -> pred a >>= \b ->-          if b then return (Just a)-               else firstWhereM pred as---- from the package `errors`-hush :: Either a b -> Maybe b-hush = either (const Nothing) Just--isRight :: Either a b -> Bool-isRight (Right _) = True-isRight (Left _) = False--fromLeft :: Either a b -> a-fromLeft (Left a) = a-fromLeft (Right _) = error "fromLeft got Right"

@@ -1,82 +0,0 @@-{-# LANGUAGE ViewPatterns #-}---- | Generate the web site/documentation for the Fay project.------ This depends on the Fay compiler to generate examples and the--- javascript of the page is also built with Fay.--module Main where--import           Fay-import           Fay.Compiler.Config--import           Control.Applicative-import           Data.Default-import           Data.List-import           Data.Maybe-import           System.Directory-import           System.Directory.Extra-import           System.Environment-import           System.FilePath-import           System.Process.Extra-import qualified Test.Compile                   as Compile-import qualified Test.CommandLine               as Cmd-import qualified Test.Convert                   as C-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit                     (assertEqual, assertFailure)---- | Main test runner.-main :: IO ()-main = do-  sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs-  let (basePath,args') = prefixed (=="-base-path") args-  compiler <- makeCompilerTests (packageConf <|> sandbox) basePath-  defaultMainWithArgs [Compile.tests, Cmd.tests, compiler, C.tests]-                      args'---- | Extract the element prefixed by the given element in the list.-prefixed :: (a -> Bool) -> [a] -> (Maybe a,[a])-prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y)---- | Make the case-by-case unit tests.-makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test-makeCompilerTests packageConf basePath = do-  files <- sort . filter (not . isInfixOf "/Compile/") . 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--testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO ()-testFile packageConf basePath opt file = do-  let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file-      out = toJsName file-      resf = root <.> "res"-      config =-        addConfigDirectoryIncludePaths ["tests/"] $-          def { configOptimize = opt-              , configTypecheck = False-              , configPackageConf = packageConf-              , configBasePath = basePath-              }-  resExists <- doesFileExist resf-  let partialName = root ++ "_partial"-  partialExists <- doesFileExist partialName-  compileFromTo config file (Just out)-  result <- runJavaScriptFile out-  if resExists-     then do output <- readFile resf-             assertEqual file output (either show snd result)-     else-       if partialExists-         then case result of-           Left (_,res) -> do-             output <- readFile partialName-             assertEqual file output res-           Right (err,res) -> assertFailure $ "Did not fail:\n stdout: " ++ res ++ "\n\nstderr: " ++ err-         else assertEqual (file ++ ": Expected program to fail") True (either (const True) (const False) result)---- | Run a JS file.-runJavaScriptFile :: String -> IO (Either (String,String) (String,String))-runJavaScriptFile file = readAllFromProcess "node" [file] ""

@@ -0,0 +1,173 @@+{-# 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 qualified Control.Exception        as E+import           Control.Monad+import           Data.Default+import           Data.List.Split          (wordsBy)+import           Data.Maybe+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+  }++-- | Main entry point.+main :: IO ()+main = do+  packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  opts <- execParser parser+  if optVersion opts+    then runCommandVersion+    else if optPrintRuntime opts+      then getRuntime >>= 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))++  where+    parser = info (helper <*> options) (fullDesc <> header helpTxt)++    outPutFile :: FayCompilerOptions -> String -> FilePath+    outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts++-- | All Fay's command-line options.+options :: Parser FayCompilerOptions+options = FayCompilerOptions+  <$> switch (long "library" <> help "Don't automatically call main in generated JavaScript")+  <*> switch (long "flatten-apps" <> help "flatten function applicaton")+  <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript")+  <*> strsOption (long "html-js-lib" <> metavar "file1[, ..]"+      <> help "javascript files to add to <head> if using option html-wrapper")+  <*> strsOption (long "include" <> metavar "dir1[, ..]"+      <> help "additional directories for include")+  <*> strsOption (long "package" <> metavar "package[, ..]"+      <> help "packages to use for compilation")+  <*> switch (long "Wall" <> help "Typecheck with -Wall")+  <*> switch (long "no-ghc" <> help "Don't typecheck, specify when not working with files")+  <*> switch (long "stdout" <> short 's' <> help "Output to stdout")+  <*> switch (long "version" <> help "Output version number")+  <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))+  <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")+  <*> arguments Just (metavar "- | <hs-file>...")+  <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")+  <*> switch (long "closure" <> help "Provide help with Google Closure")+  <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))+  <*> switch (long "no-rts" <> short 'r' <> help "Don't export the RTS")+  <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI")+  <*> switch (long "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"))++  where strsOption m =+          nullOption (m <> reader (Right . wordsBy (== ',')) <> value [])+++-- | Make incompatible options.+incompatible :: Monad m+  => (FayCompilerOptions -> Bool)+  -> FayCompilerOptions -> String -> m Bool+incompatible test opts message = if test opts+  then E.throw $ userError message+  else return True++-- | The basic help text.+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"+  ]++-- | Print the command version.+runCommandVersion :: IO ()+runCommandVersion = putStrLn $ "fay " ++ showVersion version++-- | 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 }

@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.CommandLine (tests) where++import Fay.System.Process.Extra++import           Control.Applicative+import           Data.Maybe+import           System.Directory+import           System.Environment+import           System.FilePath+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.Framework.TH+import           Test.HUnit                     (Assertion, assertBool)+import           Test.Util++tests :: Test+tests = $testGroupGenerator++compileFile :: [String] -> IO (Either String String)+compileFile flags = do+  whatAGreatFramework <- fmap (fmap (\x -> x</>"bin"</>"fay") . lookup "HASKELL_SANDBOX")+                              getEnvironment+  fay <- fayPath+  let path = fromMaybe "couldn't find fay" (whatAGreatFramework <|> fay)+  exists <- doesFileExist path+  if exists+     then do r <- readAllFromProcess path flags ""+             return $ case r of+               Left  (l,_) -> Left ("Reason: " ++ l)+               Right (_,t) -> Right t+     else error $ "fay path not are existing: " ++ path++case_executable :: Assertion+case_executable = do+  fay <- fayPath+  assertBool "Could not find fay executable" (isJust fay)++case_compile :: Assertion+case_compile = do+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  res <- compileFile (["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"] +++                      ["--package-conf=" ++ packageConf | Just packageConf <- [whatAGreatFramework] ])+  assertBool (fromLeft res) (isRight res)

@@ -0,0 +1,82 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Compile (tests) where++import Fay+import Fay.Compiler.Config++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++tests :: Test+tests = $testGroupGenerator++case_imports :: Assertion+case_imports = do+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  res <- compileFile defConf { configPackageConf = whatAGreatFramework } fp+  assertBool "Could not compile file with imports" (isRight res)++case_importedList :: Assertion+case_importedList = do+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } fp+  case res of+    Left err -> error (show err)+    Right (_,r) -> assertBool "RecordImport_Export was not added to stateImported" .+                     isJust . lookup (ModuleName "RecordImport_Export") $ stateImported r++fp :: FilePath+fp = "tests/RecordImport_Import.hs"++case_stateRecordTypes :: Assertion+case_stateRecordTypes = do+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/Records.hs"+  case res of+    Left err -> error (show err)+    Right (_,r) ->+      -- TODO order should not matter+      assertEqual "stateRecordTypes mismatch"+        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])+        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])+        ]+        (stateRecordTypes r)++case_importStateRecordTypes :: Assertion+case_importStateRecordTypes = do+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/ImportRecords.hs"+  case res of+    Left err -> error (show err)+    Right (_,r) ->+      -- TODO order should not matter+      assertEqual "stateRecordTypes mismatch"+        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])+        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])+        ]+        (stateRecordTypes r)++case_typecheckCPP :: Assertion+case_typecheckCPP = do+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/CPPTypecheck.hs" } "tests/Compile/CPPTypecheck.hs"+  either (assertFailure . show) (const $ return ()) res++case_cppMultiLineStrings :: Assertion+case_cppMultiLineStrings = do+  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++defConf :: CompileConfig+defConf = addConfigDirectoryIncludePaths ["tests/"]+        $ def { configTypecheck = False }

@@ -0,0 +1,156 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}++module Test.Convert (tests) where++import qualified Data.Aeson.Parser              as Aeson+import           Data.Attoparsec.ByteString+import qualified Data.ByteString                as Bytes+import qualified Data.ByteString.UTF8           as UTF8+import           Data.Data+import           Data.Ratio+import           Data.Text                      (Text, pack)+import           Fay.Convert+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.HUnit                     (assertEqual)++tests :: Test+tests = testGroup "Test.Convert" [reading, showing]+  where reading = testGroup "reading" $+          flip map readTests $ \(ReadTest value) ->+            let label = show value+            in testCase label $+                 assertEqual label (Just value) (showToFay value >>= readFromFay)+        showing = testGroup "showing" $+          flip map showTests $ \(Testcase value output) ->+            let label = show value+            in testCase label $+                 assertEqual label+                   (either error Just $ parseOnly Aeson.value output)+                   (showToFay value)+++--------------------------------------------------------------------------------+-- Test cases++-- | A test.+data Testcase = forall x. Show x => Testcase x Bytes.ByteString++-- | A read test.+data ReadTest = forall x. (Data x,Show x,Eq x,Read x) => ReadTest x+++-- | Tests++-- | Read tests.+readTests :: [ReadTest]+readTests =+  [ReadTest $ NullaryConstructor+  ,ReadTest $ NAryConstructor 123 66.6+  ,ReadTest $ LabelledRecord { barInt = 123, barDouble = 66.6 }+  ,ReadTest $ LabelledRecord2 { bar = 123, bob = 66.6 }+  ,ReadTest $ FooBar "Tinkie Winkie" "Humanzee" Zot+  ,ReadTest $ Bar $ Foo "one" "two"+  ,ReadTest $ StepcutFoo 123+  ,ReadTest $ StepcutBar (StepcutFoo 456)+  ,ReadTest $ StepcutFoo' 789+  ,ReadTest $ Baz (StepcutFoo' 10112)+  ,ReadTest $ TextConstructor $ pack "This is \"some text\n\n\""+  ,ReadTest $ (("foo",'a') :: (String,Char))+  ,ReadTest $ ((pack "foo",'a',23) :: (Text,Char,Int))+  ,ReadTest $ TupleList [(pack "foo",pack "bar")]+  ,ReadTest $ TupleList' [((pack "foo",23) :: (Text,Int))]+  ,ReadTest $ ()+  ]++-- | Test cases.+showTests :: [Testcase]+showTests =+   -- Fundamental data types+  [(1 :: Int) → "1"+  ,(1 :: Double) → "1.0"+  ,(1/2 :: Double) → "0.5"+  ,(1%2 :: Rational) → "0.5"+  ,([1,2] :: [Int]) → "[1,2]"+  ,((1,2) :: (Int,Int)) → "[1,2]"+  ,"abc" → "\"abc\""+  ,'a' → "\"a\""+  , () → "null"+  -- Data records+  ,NullaryConstructor → "{\"instance\":\"NullaryConstructor\"}"+  ,NAryConstructor 123 4.5 → "{\"slot1\":123,\"slot2\":4.5,\"instance\":\"NAryConstructor\"}"+  ,LabelledRecord { barInt = 123, barDouble = 4.5 }+     → "{\"barDouble\":4.5,\"barInt\":123,\"instance\":\"LabelledRecord\"}"+  ,Bar (Foo "one" "two") → "{\"slot1\":{\"slot1\":\"one\",\"slot2\":\"two\",\"instance\":\"Foo\"},\"instance\":\"Bar\"}"+  ,TextConstructor (pack "foo bar baz") → "{\"slot1\":\"foo bar baz\",\"instance\":\"TextConstructor\"}"+  -- Unicode+  ,"¡ ¢ £ ¤ ¥ " → "\"¡ ¢ £ ¤ ¥ \""+  ,"Ā ā Ă ă Ą " → "\"Ā ā Ă ă Ą \""+  ,"ƀ Ɓ Ƃ ƃ Ƅ " → "\"ƀ Ɓ Ƃ ƃ Ƅ \""+  ,"ɐ ɑ ɒ ɓ ɔ " → "\"ɐ ɑ ɒ ɓ ɔ \""+  ,"Ё Ђ Ѓ Є Ѕ " → "\"Ё Ђ Ѓ Є Ѕ \""+  ,"Ա Բ Գ Դ Ե " → "\"Ա Բ Գ Դ Ե \""+  ,"، ؛ ؟ ء آ " → "\"، ؛ ؟ ء آ \""+  ,"ँ ं ः अ आ " → "\"ँ ं ः अ आ \""+  ,"ఁ ం ః అ ఆ " → "\"ఁ ం ః అ ఆ \""+  ,"ก ข ฃ ค ฅ " → "\"ก ข ฃ ค ฅ \""+  ,"ກ ຂ ຄ ງ ຈ " → "\"ກ ຂ ຄ ງ ຈ \""+  ,"ༀ ༁ ༂ ༃ ༄ " → "\"ༀ ༁ ༂ ༃ ༄ \""+  ,"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ " → "\"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ \""+  ,"Ḁ ḁ Ḃ ḃ Ḅ " → "\"Ḁ ḁ Ḃ ḃ Ḅ \""+  ,"ぁ あ ぃ い ぅ " → "\"ぁ あ ぃ い ぅ \""+  ,"ァ ア ィ イ ゥ " → "\"ァ ア ィ イ ゥ \""+  ,"ㄅ ㄆ ㄇ ㄈ ㄉ " → "\"ㄅ ㄆ ㄇ ㄈ ㄉ \""+  ,"ㄱ ㄲ ㄳ ㄴ ㄵ " → "\"ㄱ ㄲ ㄳ ㄴ ㄵ \""+  ]++  where x → y = Testcase x (UTF8.fromString y)++data Foo = Foo String String+  deriving (Show,Data,Typeable,Read,Eq)+data Bar = Bar Foo+  deriving (Show,Data,Typeable,Read,Eq)++-- | Nullary constructor.+data NullaryConstructor = NullaryConstructor+  deriving (Show,Data,Typeable,Read,Eq)++-- | n-ary labelless constructor.+data NAryConstructor = NAryConstructor Int Double+  deriving (Show,Data,Typeable,Read,Eq)++-- | Labelled record.+data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double }+                    | LabelledRecord2 { bar :: Int, bob :: Double }+  deriving (Show,Data,Typeable,Read,Eq)++-- | Order matters in unlabelled constructors.+data SomeThing =+  FooBar String String Zot+  deriving (Read,Data,Typeable,Show,Eq)++-- | This triggers order difference. Go figure.+data Zot = Zot+  deriving (Read,Data,Typeable,Show,Eq)++data StepcutFoo = StepcutFoo { _unStepcutFoo :: Int }+    deriving (Eq, Show, Read, Typeable, Data)++data StepcutBar = StepcutBar StepcutFoo+    deriving (Eq, Show, Read, Typeable, Data)++data StepcutFoo' = StepcutFoo' Int+    deriving (Eq, Show, Read, Typeable, Data)++data Baz = Baz StepcutFoo'+    deriving (Eq, Show, Read, Typeable, Data)++data TextConstructor = TextConstructor Text+    deriving (Eq, Show, Read, Typeable, Data)++data TupleList = TupleList [(Text,Text)]+  deriving (Read, Typeable, Data, Show, Eq)++data TupleList' a = TupleList' [(Text,a)]+  deriving (Read, Typeable, Data, Show, Eq)

@@ -0,0 +1,39 @@+module Test.Util+  ( fayPath+  , isRight+  , fromLeft+  ) where++import           Fay.System.Process.Extra (readAllFromProcess)++import           Control.Applicative+import           System.Directory+import           Prelude                  hiding (pred)++-- Path to the fay executable, looks in cabal-dev, dist, PATH in that order.+fayPath :: IO (Maybe FilePath)+fayPath =+  (<|>) <$> firstWhereM doesFileExist [cabalDevPath, distPath] <*> usingWhich+  where+    cabalDevPath = "./cabal-dev/bin/fay"+    distPath = "./dist/build/fay/fay"+    usingWhich = fmap (concat . lines . snd) . hush <$> readAllFromProcess "which" ["fay"] ""++firstWhereM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)+firstWhereM pred ins = case ins of+  [] -> return Nothing+  a:as -> pred a >>= \b ->+          if b then return (Just a)+               else firstWhereM pred as++-- from the package `errors`+hush :: Either a b -> Maybe b+hush = either (const Nothing) Just++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight (Left _) = False++fromLeft :: Either a b -> a+fromLeft (Left a) = a+fromLeft (Right _) = error "fromLeft got Right"

@@ -0,0 +1,82 @@+{-# LANGUAGE ViewPatterns #-}++-- | Generate the web site/documentation for the Fay project.+--+-- This depends on the Fay compiler to generate examples and the+-- javascript of the page is also built with Fay.++module Main where++import           Fay+import           Fay.Compiler.Config+import           Fay.System.Directory.Extra+import           Fay.System.Process.Extra++import           Control.Applicative+import           Data.Default+import           Data.List+import           Data.Maybe+import           System.Directory+import           System.Environment+import           System.FilePath+import qualified Test.Compile                   as Compile+import qualified Test.CommandLine               as Cmd+import qualified Test.Convert                   as C+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.HUnit                     (assertEqual, assertFailure)++-- | Main test runner.+main :: IO ()+main = do+  sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs+  let (basePath,args') = prefixed (=="-base-path") args+  compiler <- makeCompilerTests (packageConf <|> sandbox) basePath+  defaultMainWithArgs [Compile.tests, Cmd.tests, compiler, C.tests]+                      args'++-- | Extract the element prefixed by the given element in the list.+prefixed :: (a -> Bool) -> [a] -> (Maybe a,[a])+prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y)++-- | Make the case-by-case unit tests.+makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test+makeCompilerTests packageConf basePath = do+  files <- sort . filter (not . isInfixOf "/Compile/") . 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++testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO ()+testFile packageConf basePath opt file = do+  let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file+      out = toJsName file+      resf = root <.> "res"+      config =+        addConfigDirectoryIncludePaths ["tests/"] $+          def { configOptimize = opt+              , configTypecheck = False+              , configPackageConf = packageConf+              , configBasePath = basePath+              }+  resExists <- doesFileExist resf+  let partialName = root ++ "_partial"+  partialExists <- doesFileExist partialName+  compileFromTo config file (Just out)+  result <- runJavaScriptFile out+  if resExists+     then do output <- readFile resf+             assertEqual file output (either show snd result)+     else+       if partialExists+         then case result of+           Left (_,res) -> do+             output <- readFile partialName+             assertEqual file output res+           Right (err,res) -> assertFailure $ "Did not fail:\n stdout: " ++ res ++ "\n\nstderr: " ++ err+         else assertEqual (file ++ ": Expected program to fail") True (either (const True) (const False) result)++-- | Run a JS file.+runJavaScriptFile :: String -> IO (Either (String,String) (String,String))+runJavaScriptFile file = readAllFromProcess "node" [file] ""

@@ -5,6 +5,8 @@  main :: Fay () main = do+  printA ()+  printA ([] :: [Int])   printA [1,2,3]   printA [[1],[2],[3]]   printA (1,2)@@ -13,6 +15,7 @@   printArr [[1],[2],[3]]   printT (1,2)   printT ([1],[2])+  printA $ readA "[]"   printA . tail $ readA "[1,2,3]"   printA . tail $ readArr "[1,2,3]"   printA . snd $ readT "[1,2]"

@@ -1,3 +1,5 @@+[]+[] [ 1, 2, 3 ] [ [ 1 ], [ 2 ], [ 3 ] ] [ 1, 2 ]@@ -6,6 +8,7 @@ [ [ 1 ], [ 2 ], [ 3 ] ] [ 1, 2 ] [ [ 1 ], [ 2 ] ]+[] [ 2, 3 ] [ 2, 3 ] 2

@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}+module FromString where++import Prelude+import FromString.FayText+import FromString.Dep (myString, depTest)++main :: Fay ()+main = do+  print ("This is not a String" :: Text)+  print "This is not a String"+  putStrLn myString+  print myString+  depTest+

@@ -0,0 +1,5 @@+This is not a String+This is not a String+test+[ 't', 'e', 's', 't' ]+This is also not a String

@@ -0,0 +1,11 @@+module FromString.Dep where++import Prelude+import FromString.DepDep (myText)++myString :: String+myString = "test"++depTest :: Fay ()+depTest = print myText+

@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}+module FromString.DepDep where++import Prelude+import FromString.FayText++myText :: Text+myText = "This is also not a String"+

@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP                #-}+-- | Module to be shared between server and client.+--+-- This module must be valid for both GHC and Fay.+module FayText where++import           Prelude+#ifdef FAY+import           FFI+#else+import           Fay.FFI+#endif+import           Data.Data++#ifdef FAY++data Text = Text+    deriving (Show, Read, Eq, Typeable, Data)++pack :: String -> Text+pack = ffi "%1"++unpack :: Text -> String+unpack = ffi "%1"++#else++import qualified Data.Text as T++type Text = T.Text++pack :: String -> Text+pack = T.pack++unpack :: Text -> String+unpack = T.unpack++#endif++fromString :: String -> Text+fromString = pack+