diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -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 diff --git a/js/runtime.js b/js/runtime.js --- a/js/runtime.js +++ b/js/runtime.js @@ -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); diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs deleted file mode 100644 --- a/src/Control/Monad/Extra.hs +++ /dev/null @@ -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 diff --git a/src/Control/Monad/IO.hs b/src/Control/Monad/IO.hs deleted file mode 100644 --- a/src/Control/Monad/IO.hs +++ /dev/null @@ -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 diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs deleted file mode 100644 --- a/src/Data/List/Extra.hs +++ /dev/null @@ -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 diff --git a/src/Fay/Compiler.hs b/src/Fay/Compiler.hs --- a/src/Fay/Compiler.hs +++ b/src/Fay/Compiler.hs @@ -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 diff --git a/src/Fay/Compiler/Decl.hs b/src/Fay/Compiler/Decl.hs --- a/src/Fay/Compiler/Decl.hs +++ b/src/Fay/Compiler/Decl.hs @@ -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 diff --git a/src/Fay/Compiler/Defaults.hs b/src/Fay/Compiler/Defaults.hs --- a/src/Fay/Compiler/Defaults.hs +++ b/src/Fay/Compiler/Defaults.hs @@ -41,4 +41,5 @@ , stateModuleScope = def , stateModuleScopes = M.empty , stateJsModulePaths = S.empty + , stateUseFromString = False } diff --git a/src/Fay/Compiler/Exp.hs b/src/Fay/Compiler/Exp.hs --- a/src/Fay/Compiler/Exp.hs +++ b/src/Fay/Compiler/Exp.hs @@ -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. diff --git a/src/Fay/Compiler/InitialPass.hs b/src/Fay/Compiler/InitialPass.hs --- a/src/Fay/Compiler/InitialPass.hs +++ b/src/Fay/Compiler/InitialPass.hs @@ -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 diff --git a/src/Fay/Compiler/Misc.hs b/src/Fay/Compiler/Misc.hs --- a/src/Fay/Compiler/Misc.hs +++ b/src/Fay/Compiler/Misc.hs @@ -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 diff --git a/src/Fay/Compiler/Packages.hs b/src/Fay/Compiler/Packages.hs --- a/src/Fay/Compiler/Packages.hs +++ b/src/Fay/Compiler/Packages.hs @@ -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. diff --git a/src/Fay/Compiler/Typecheck.hs b/src/Fay/Compiler/Typecheck.hs --- a/src/Fay/Compiler/Typecheck.hs +++ b/src/Fay/Compiler/Typecheck.hs @@ -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 () diff --git a/src/Fay/Control/Monad/Extra.hs b/src/Fay/Control/Monad/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Control/Monad/Extra.hs @@ -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 diff --git a/src/Fay/Control/Monad/IO.hs b/src/Fay/Control/Monad/IO.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Control/Monad/IO.hs @@ -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 diff --git a/src/Fay/Data/List/Extra.hs b/src/Fay/Data/List/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Data/List/Extra.hs @@ -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 diff --git a/src/Fay/FFI.hs b/src/Fay/FFI.hs --- a/src/Fay/FFI.hs +++ b/src/Fay/FFI.hs @@ -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." diff --git a/src/Fay/System/Directory/Extra.hs b/src/Fay/System/Directory/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Fay/System/Directory/Extra.hs @@ -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) diff --git a/src/Fay/System/Process/Extra.hs b/src/Fay/System/Process/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Fay/System/Process/Extra.hs @@ -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) diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -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. diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 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 "- | ...") - <*> 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] [- | ...]\n" - ," fay - takes input on stdin and prints to stdout. Pretty prints\n" - ," fay ... 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 "" 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 "" 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 } diff --git a/src/System/Directory/Extra.hs b/src/System/Directory/Extra.hs deleted file mode 100644 --- a/src/System/Directory/Extra.hs +++ /dev/null @@ -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) diff --git a/src/System/Process/Extra.hs b/src/System/Process/Extra.hs deleted file mode 100644 --- a/src/System/Process/Extra.hs +++ /dev/null @@ -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) diff --git a/src/Test/CommandLine.hs b/src/Test/CommandLine.hs deleted file mode 100644 --- a/src/Test/CommandLine.hs +++ /dev/null @@ -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) diff --git a/src/Test/Compile.hs b/src/Test/Compile.hs deleted file mode 100644 --- a/src/Test/Compile.hs +++ /dev/null @@ -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 } diff --git a/src/Test/Convert.hs b/src/Test/Convert.hs deleted file mode 100644 --- a/src/Test/Convert.hs +++ /dev/null @@ -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) diff --git a/src/Test/Util.hs b/src/Test/Util.hs deleted file mode 100644 --- a/src/Test/Util.hs +++ /dev/null @@ -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" diff --git a/src/Tests.hs b/src/Tests.hs deleted file mode 100644 --- a/src/Tests.hs +++ /dev/null @@ -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] "" diff --git a/src/main/Main.hs b/src/main/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/Main.hs @@ -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 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 "- | ...") + <*> 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] [- | ...]\n" + ," fay - takes input on stdin and prints to stdout. Pretty prints\n" + ," fay ... 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 "" 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 "" 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 } diff --git a/src/tests/Test/CommandLine.hs b/src/tests/Test/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test/CommandLine.hs @@ -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) diff --git a/src/tests/Test/Compile.hs b/src/tests/Test/Compile.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test/Compile.hs @@ -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 } diff --git a/src/tests/Test/Convert.hs b/src/tests/Test/Convert.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test/Convert.hs @@ -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) diff --git a/src/tests/Test/Util.hs b/src/tests/Test/Util.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test/Util.hs @@ -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" diff --git a/src/tests/Tests.hs b/src/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/src/tests/Tests.hs @@ -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] "" diff --git a/tests/AutomaticList.hs b/tests/AutomaticList.hs --- a/tests/AutomaticList.hs +++ b/tests/AutomaticList.hs @@ -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]" diff --git a/tests/AutomaticList.res b/tests/AutomaticList.res --- a/tests/AutomaticList.res +++ b/tests/AutomaticList.res @@ -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 diff --git a/tests/FromString.hs b/tests/FromString.hs new file mode 100644 --- /dev/null +++ b/tests/FromString.hs @@ -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 + diff --git a/tests/FromString.res b/tests/FromString.res new file mode 100644 --- /dev/null +++ b/tests/FromString.res @@ -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 diff --git a/tests/FromString/Dep.hs b/tests/FromString/Dep.hs new file mode 100644 --- /dev/null +++ b/tests/FromString/Dep.hs @@ -0,0 +1,11 @@ +module FromString.Dep where + +import Prelude +import FromString.DepDep (myText) + +myString :: String +myString = "test" + +depTest :: Fay () +depTest = print myText + diff --git a/tests/FromString/Dep.res b/tests/FromString/Dep.res new file mode 100644 --- /dev/null +++ b/tests/FromString/Dep.res diff --git a/tests/FromString/DepDep.hs b/tests/FromString/DepDep.hs new file mode 100644 --- /dev/null +++ b/tests/FromString/DepDep.hs @@ -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" + diff --git a/tests/FromString/DepDep.res b/tests/FromString/DepDep.res new file mode 100644 --- /dev/null +++ b/tests/FromString/DepDep.res diff --git a/tests/FromString/FayText.hs b/tests/FromString/FayText.hs new file mode 100644 --- /dev/null +++ b/tests/FromString/FayText.hs @@ -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 + diff --git a/tests/FromString/FayText.res b/tests/FromString/FayText.res new file mode 100644 --- /dev/null +++ b/tests/FromString/FayText.res