diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,47 @@ See full history at: +## 0.20.0.0 (2014-04-29) + +* Adds support for LambdaCase and MultiWayIf + +* Modules have moved around a lot and several modules have been un-exposed. From now on you will probably only need to deal with at most `Fay` (which re-exports a lot of things), `Fay.Config`, `Fay.Types.CompileError`, `Fay.Convert`, and `Fay.Types.CompileResult`. Please let us know if you would like us to expose more things + +* Config: + * `CompileConfig` has been renamed to `Config` and is now located in `Fay.Config`. + * `CompileConfig` has become a temporary type alias for `Config`. + * `Fay.Compiler.Config` is deprecated, import `Fay` or `Fay.Config` instead. + * The `data-default` instance for `Config` is deprecated, use `defaultConfig` instead. + +* compiling + * `compileFileWithState` is deprecated, use `compileFileWithResult` which returns a `Fay.Types.CompileResult` instead. As a consequence `CompileState` is also deprecated from public consumption. + * `compileFile`, `compileFromToAndGenerateHtml` no longer return a triple with the sourcemap, use `compileFileWithResult` if you want access to this. + +* Importing `Fay.Types` has been deprecated, import `Fay` instead. + +* `readFromFay` has been rewritten using `syb` instead of `pretty-show` (Thanks to Michael Sloan and Chris Done) + * This introduces the following breaking changes: + * `readFromFay` has a `Data` constraint instead of `Show`. + * Drops support for Rational and Integer (see below for migration steps). The reason is that neither was serialized in a way that would roundtrip for all values. Also, for similar reasons, fromRational is potentially divergent for aeson's new use of the Scientific type. + * And adds the following features: + * You can now write custom `Show` instances targeting GHC for types shared with Fay. + * Better performance. + * Allows the serialization and deserialization to be customized on a per-type basis, via encodeFay and decodeFay. + * To migrate code using Rational or Integer, use encodeFay and pass an argument e.g. `(\f x -> maybe (f x) myIntegerToValueConversion (cast x))` and likewise to decodeFay. + +Bugfixes: + +* Mltiple guards on a pattern in a case expression skipped everything but the first guard. To fix this an optimization we had on pattern conditions was disabled. + +Dependency bumps: + +* Allow Cabal 1.20 and 1.21 + +Internal: + +* Test cases are now using `tasty` instead of `test-framework`. To run cases in parallel use `fay-tests --num-threads=N` (see `fay-tests --help` for more info). +* Added a test group for desugaring. + #### 0.19.2.1 (2014-04-14) * Allow `haskell-src-exts 1.15.*` diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.19.2.1 +version: 0.20.0.0 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which is type-checked with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad, @@ -23,12 +23,13 @@ category: Development, Web, Fay build-type: Custom cabal-version: >=1.8 -data-files: js/runtime.js - src/Fay/FFI.hs +data-files: + js/runtime.js + src/Fay/FFI.hs extra-source-files: + CHANGELOG.md LICENSE README.md - CHANGELOG.md -- Examples examples/*.hs examples/*.html @@ -66,102 +67,107 @@ location: https://github.com/faylang/fay.git library - hs-source-dirs: src - exposed-modules: Fay - , Fay.Compiler - , Fay.Compiler.Config - , Fay.Control.Monad.Extra - , Fay.Control.Monad.IO - , Fay.Convert - , Fay.Data.List.Extra - , Fay.Exts - , Fay.Exts.Scoped - , Fay.Exts.NoAnnotation - , Fay.FFI - , Fay.System.Directory.Extra - , Fay.System.Process.Extra - , Fay.Types - other-modules: Fay.Compiler.Decl - , Fay.Compiler.Defaults - , Fay.Compiler.Desugar - , Fay.Compiler.Exp - , Fay.Compiler.FFI - , Fay.Compiler.GADT - , Fay.Compiler.Import - , Fay.Compiler.InitialPass - , Fay.Compiler.Misc - , Fay.Compiler.Optimizer - , Fay.Compiler.Packages - , Fay.Compiler.Pattern - , Fay.Compiler.PrimOp - , Fay.Compiler.Print - , Fay.Compiler.QName - , Fay.Compiler.State - , Fay.Compiler.Typecheck - , Paths_fay ghc-options: -O2 -Wall - build-depends: base >= 4 && < 5 - , Cabal < 1.20 - , aeson < 0.8 - , attoparsec < 0.12 - , bytestring < 0.11 - , containers < 0.6 - , cpphs < 1.19 - , data-default < 0.6 - , directory < 1.3 - , filepath < 1.4 - , ghc-paths < 0.2 - , haskell-names >= 0.3.1 && < 0.4 - , haskell-packages == 0.2.3.1 || > 0.2.3.2 && < 0.3 - , haskell-src-exts >= 1.14 && < 1.16 - , language-ecmascript >= 0.15 && < 1.0 - , mtl < 2.2 - , pretty-show >= 1.6 && < 1.7 - , process < 1.3 - , safe < 0.4 - , split < 0.3 - , syb < 0.5 - , text < 1.2 - , time < 1.5 - , uniplate >= 1.6.11 && < 1.7 - , unordered-containers < 0.3 - , utf8-string < 0.4 - , vector < 0.11 - , sourcemap < 0.2 - , scientific < 0.3 + hs-source-dirs: src + exposed-modules: + Fay + Fay.Compiler + Fay.Compiler.Desugar + Fay.Compiler.Parse + Fay.Compiler.Prelude + Fay.Config + Fay.Convert + Fay.FFI + Fay.Types + Fay.Types.CompileError + Fay.Types.CompileResult + other-modules: + Fay.Compiler.Decl + Fay.Compiler.Defaults + Fay.Compiler.Desugar.Name + Fay.Compiler.Desugar.Types + Fay.Compiler.Exp + Fay.Compiler.FFI + Fay.Compiler.GADT + Fay.Compiler.Import + Fay.Compiler.InitialPass + Fay.Compiler.Misc + Fay.Compiler.Optimizer + Fay.Compiler.Packages + Fay.Compiler.Pattern + Fay.Compiler.PrimOp + Fay.Compiler.Print + Fay.Compiler.QName + Fay.Compiler.State + Fay.Compiler.Typecheck + Fay.Exts + Fay.Exts.NoAnnotation + Fay.Exts.Scoped + Fay.Types.FFI + Fay.Types.Js + Fay.Types.ModulePath + Paths_fay + build-depends: + base >= 4 && < 4.8 + , aeson < 0.8 + , bytestring < 0.11 + , containers < 0.6 + , data-default < 0.6 + , directory < 1.3 + , filepath < 1.4 + , ghc-paths < 0.2 + , haskell-names >= 0.3.1 && < 0.4 + , haskell-packages == 0.2.3.1 || > 0.2.3.2 && < 0.3 + , haskell-src-exts >= 1.15.0.1 && < 1.16 + , language-ecmascript >= 0.15 && < 0.17 + , mtl < 2.2 + , process < 1.3 + , safe < 0.4 + , sourcemap < 0.2 + , split < 0.3 + , spoon < 0.4 + , syb < 0.5 + , text < 1.2 + , transformers == 0.3.* + , uniplate >= 1.6.11 && < 1.7 + , unordered-containers < 0.3 + , utf8-string < 0.4 + , vector < 0.11 executable fay hs-source-dirs: src/main ghc-options: -O2 -Wall ghc-prof-options: -fprof-auto main-is: Main.hs - build-depends: base - , fay - , data-default - , optparse-applicative >= 0.6 && < 0.9 - , split + build-depends: + base + , fay + , optparse-applicative >= 0.6 && < 0.9 + , split executable fay-tests - hs-source-dirs: src/tests ghc-options: -O2 -Wall -threaded -with-rtsopts=-N ghc-prof-options: -fprof-auto + hs-source-dirs: src/tests main-is: Tests.hs - other-modules: Test.CommandLine - Test.Compile - Test.Convert - Test.Util - build-depends: base - , fay - , HUnit < 1.3 - , aeson - , attoparsec - , bytestring - , data-default - , directory - , filepath - , haskell-src-exts - , test-framework < 0.9 - , test-framework-hunit < 0.4 - , test-framework-th < 0.3 - , text - , utf8-string + other-modules: + Test.CommandLine + Test.Compile + Test.Convert + Test.Desugar + Test.Util + build-depends: + base + , aeson + , attoparsec + , bytestring + , directory + , fay + , filepath + , groom == 0.1.* + , haskell-src-exts + , tasty == 0.8.* + , tasty-hunit == 0.8.* + , tasty-th == 0.1.* + , text + , utf8-string diff --git a/src/Fay.hs b/src/Fay.hs --- a/src/Fay.hs +++ b/src/Fay.hs @@ -8,9 +8,13 @@ -- | Main library entry point. module Fay - (module Fay.Types + (module Fay.Config + ,CompileError (..) + ,CompileState (..) + ,CompileResult (..) ,compileFile ,compileFileWithState + ,compileFileWithResult ,compileFromTo ,compileFromToAndGenerateHtml ,toJsName @@ -22,16 +26,15 @@ import Fay.Compiler import Fay.Compiler.Misc (ioWarn, printSrcSpanInfo) import Fay.Compiler.Packages +import Fay.Compiler.Prelude import Fay.Compiler.Typecheck +import Fay.Config import qualified Fay.Exts as F import Fay.Types +import Fay.Types.CompileResult -import Control.Applicative -import Control.Monad import Data.Aeson (encode) import qualified Data.ByteString.Lazy as L -import Data.Default -import Data.List import Language.Haskell.Exts.Annotated (prettyPrint) import Language.Haskell.Exts.Annotated.Syntax import Language.Haskell.Exts.SrcLoc @@ -42,7 +45,7 @@ -- | Compile the given file and write the output to the given path, or -- if nothing given, stdout. -compileFromTo :: CompileConfig -> FilePath -> Maybe FilePath -> IO () +compileFromTo :: Config -> FilePath -> Maybe FilePath -> IO () compileFromTo cfg filein fileout = if configTypecheckOnly cfg then do @@ -54,15 +57,15 @@ (compileFromToAndGenerateHtml cfg filein) fileout case result of - Right (out,_) -> maybe (putStrLn out) (`writeFile` out) fileout + Right out -> maybe (putStrLn out) (`writeFile` out) fileout Left err -> error $ showCompileError err --- | Compile the given file and write to the output, also generate any HTML. -compileFromToAndGenerateHtml :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError (String,[Mapping])) +-- | Compile the given file and write to the output, also generates HTML and sourcemap files if configured. +compileFromToAndGenerateHtml :: Config -> FilePath -> FilePath -> IO (Either CompileError String) compileFromToAndGenerateHtml config filein fileout = do - result <- compileFile config { configFilePath = Just filein } filein - case result of - Right (out,mappings) -> do + mres <- compileFileWithResult config { configFilePath = Just filein } filein + case mres of + Right res -> do when (configHtmlWrapper config) $ writeFile (replaceExtension fileout "html") $ unlines [ "" @@ -76,16 +79,18 @@ , " " , ""] - when (configSourceMap config) $ do - L.writeFile (replaceExtension fileout "map") $ - encode $ - generate SourceMapping - { smFile = fileout - , smSourceRoot = Nothing - , smMappings = mappings - } + case (configSourceMap config, resSourceMappings res) of + (True, Just mappings) -> + L.writeFile (replaceExtension fileout "map") $ + encode $ + generate SourceMapping + { smFile = fileout + , smSourceRoot = Nothing + , smMappings = mappings + } + _ -> return () - return (Right (if configSourceMap config then sourceMapHeader ++ out else out,mappings)) + return $ Right (if configSourceMap config then sourceMapHeader ++ resOutput res else resOutput res) where relativeJsPath = makeRelative (dropFileName fileout) fileout makeScriptTagSrc :: FilePath -> String makeScriptTagSrc s = "" @@ -93,11 +98,24 @@ Left err -> return (Left err) -- | Compile the given file. -compileFile :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping])) -compileFile config filein = fmap (\(src,maps,_) -> (src,maps)) <$> compileFileWithState config filein +compileFile :: Config -> FilePath -> IO (Either CompileError String) +compileFile config filein = fmap (\(src,_,_) -> src) <$> compileFileWithState config filein --- | Compile a file returning the state. -compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping],CompileState)) +-- | Compile a file returning additional generated metadata. +compileFileWithResult :: Config -> FilePath -> IO (Either CompileError CompileResult) +compileFileWithResult config filein = do + res <- compileFileWithState config filein + return $ do + (s,m,st) <- res + return CompileResult + { resOutput = s + , resImported = map (first F.moduleNameString) $ stateImported st + , resSourceMappings = m + } + +-- | Compile a file returning the resulting internal state of the compiler. +-- Don't use this directly, it's only exposed for the test suite. +compileFileWithState :: Config -> FilePath -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileFileWithState config filein = do runtime <- getConfigRuntime config hscode <- readFile filein @@ -107,16 +125,16 @@ -- | Compile the given module to a runnable module. compileToModule :: FilePath - -> CompileConfig -> String -> (F.Module -> Compile [JsStmt]) -> String - -> IO (Either CompileError (String,[Mapping],CompileState)) + -> Config -> String -> (F.Module -> Compile [JsStmt]) -> String + -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileToModule filepath config raw with hscode = do result <- compileViaStr filepath config printState with hscode return $ case result of Left err -> Left err - Right (PrintState{..},state,_) -> - Right ( generateWrapped (concat $ reverse psOutput) + Right (ps,state,_) -> + Right ( generateWrapped (concat . reverse $ psOutput ps) (stateModuleName state) - , psMappings + , if null (psMappings ps) then Nothing else Just (psMappings ps) , state ) where @@ -130,9 +148,10 @@ ] else "" ] - printState = def { psPretty = configPrettyPrint config - , psLine = length (lines raw) + 3 - } + printState = defaultPrintState + { psPretty = configPrettyPrint config + , psLine = length (lines raw) + 3 + } -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String @@ -162,13 +181,13 @@ err ++ " at line: " ++ show (srcLine pos) ++ " column:" ++ "\n" ++ show (srcColumn pos) ShouldBeDesugared s -> "Expected this to be desugared (this is a bug): " ++ s - UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname + UnableResolveQualified qname -> "unable to resolve qualified names (this might be a bug):" ++ prettyPrint qname UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d UnsupportedEnum{} -> "only Int is allowed in enum expressions" UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p - UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i + UnsupportedImport i -> "unsupported import syntax: " ++ prettyPrint i UnsupportedLet -> "let not supported here" UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit @@ -182,7 +201,7 @@ -- | Get the JS runtime source. -- This will return the user supplied runtime if it exists. -getConfigRuntime :: CompileConfig -> IO String +getConfigRuntime :: Config -> IO String getConfigRuntime cfg = maybe getRuntime return $ configRuntimePath cfg -- | Get the default JS runtime source. diff --git a/src/Fay/Compiler.hs b/src/Fay/Compiler.hs --- a/src/Fay/Compiler.hs +++ b/src/Fay/Compiler.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,7 +20,8 @@ ,parseFay) where -import Fay.Compiler.Config +import Fay.Compiler.Prelude + import Fay.Compiler.Decl import Fay.Compiler.Defaults import Fay.Compiler.Desugar @@ -29,26 +31,23 @@ import Fay.Compiler.InitialPass (initialPass) import Fay.Compiler.Misc import Fay.Compiler.Optimizer +import Fay.Compiler.Parse import Fay.Compiler.PrimOp (findPrimOp) import Fay.Compiler.QName import Fay.Compiler.State import Fay.Compiler.Typecheck -import Fay.Control.Monad.IO +import Fay.Config import qualified Fay.Exts as F import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Applicative import Control.Monad.Error import Control.Monad.RWS import Control.Monad.State - -import Data.Maybe import qualified Data.Set as S import Language.Haskell.Exts.Annotated hiding (name) import Language.Haskell.Names -import Prelude hiding (mod) -------------------------------------------------------------------------------- -- Top level entry points @@ -57,7 +56,7 @@ compileViaStr :: FilePath - -> CompileConfig + -> Config -> PrintState -> (F.Module -> Compile [JsStmt]) -> String @@ -123,7 +122,7 @@ -- | Compile a parse HSE module. compileModuleFromAST :: ([JsStmt], [JsStmt]) -> F.Module -> Compile ([JsStmt], [JsStmt]) compileModuleFromAST (hstmts0, fstmts0) mod'@Module{} = do - mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions $ mod' + mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod' let modName = unAnn $ F.moduleName mod modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas } diff --git a/src/Fay/Compiler/Config.hs b/src/Fay/Compiler/Config.hs deleted file mode 100644 --- a/src/Fay/Compiler/Config.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} - --- | Configuration functions. - -module Fay.Compiler.Config where - -import Fay.Types - -import Data.Default -import Data.Maybe -import Language.Haskell.Exts.Annotated (ModuleName (..)) - --- | Get all include directories without the package mapping. -configDirectoryIncludePaths :: CompileConfig -> [FilePath] -configDirectoryIncludePaths = map snd . configDirectoryIncludes - --- | Get all include directories not included through packages. -nonPackageConfigDirectoryIncludePaths :: CompileConfig -> [FilePath] -nonPackageConfigDirectoryIncludePaths = map snd . filter (isJust . fst) . configDirectoryIncludes - --- | Add a mapping from (maybe) a package to a source directory -addConfigDirectoryInclude :: Maybe String -> FilePath -> CompileConfig -> CompileConfig -addConfigDirectoryInclude pkg fp cfg = cfg { configDirectoryIncludes = (pkg, fp) : configDirectoryIncludes cfg } - --- | Add several include directories. -addConfigDirectoryIncludes :: [(Maybe String,FilePath)] -> CompileConfig -> CompileConfig -addConfigDirectoryIncludes pkgFps cfg = foldl (\c (pkg,fp) -> addConfigDirectoryInclude pkg fp c) cfg pkgFps - --- | Add several include directories without package references. -addConfigDirectoryIncludePaths :: [FilePath] -> CompileConfig -> CompileConfig -addConfigDirectoryIncludePaths fps cfg = foldl (flip (addConfigDirectoryInclude Nothing)) cfg fps - --- | Add a package to compilation -addConfigPackage :: String -> CompileConfig -> CompileConfig -addConfigPackage pkg cfg = cfg { configPackages = pkg : configPackages cfg } - --- | Add several packages to compilation -addConfigPackages :: [String] -> CompileConfig -> CompileConfig -addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps - -shouldExportStrictWrapper :: ModuleName a -> CompileConfig -> Bool -shouldExportStrictWrapper (ModuleName _ m) cs = m `elem` configStrict cs - --- | Default configuration. -instance Default CompileConfig where - def = addConfigPackage "fay-base" - CompileConfig - { configOptimize = False - , configFlattenApps = False - , configExportRuntime = True - , configExportStdlib = True - , configExportStdlibOnly = False - , configDirectoryIncludes = [] - , configPrettyPrint = False - , configHtmlWrapper = False - , configHtmlJSLibs = [] - , configLibrary = False - , configWarn = True - , configFilePath = Nothing - , configTypecheck = True - , configWall = False - , configGClosure = False - , configPackageConf = Nothing - , configPackages = [] - , configBasePath = Nothing - , configStrict = [] - , configTypecheckOnly = False - , configRuntimePath = Nothing - , configSourceMap = False - } 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -7,27 +8,26 @@ module Fay.Compiler.Decl where +import Fay.Compiler.Prelude + import Fay.Compiler.Exp import Fay.Compiler.FFI import Fay.Compiler.GADT import Fay.Compiler.Misc import Fay.Compiler.Pattern import Fay.Compiler.State -import Fay.Data.List.Extra import Fay.Exts (convertFieldDecl, fieldDeclNames) import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative import Control.Monad.Error import Control.Monad.RWS import Language.Haskell.Exts.Annotated hiding (binds, loc, name) -import Prelude hiding (exp) -- | Compile Haskell declaration. compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt] -compileDecls toplevel = fmap concat . sequence . map (compileDecl toplevel) +compileDecls toplevel = fmap concat . mapM (compileDecl toplevel) -- | Compile a declaration. compileDecl :: Bool -> S.Decl -> Compile [JsStmt] 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 @@ -4,21 +4,21 @@ module Fay.Compiler.Defaults where -import Fay.Compiler.Config -import Fay.Compiler.Decl (compileDecls) -import Fay.Compiler.Exp (compileLit) +import Fay.Compiler.Decl (compileDecls) +import Fay.Compiler.Exp (compileLit) +import Fay.Config import Fay.Types import Paths_fay -import Data.Map as M -import Data.Set as S +import Data.Map as M +import Data.Set as S -- | The data-files source directory. faySourceDir :: IO FilePath faySourceDir = getDataFileName "src/" -- | The default compiler reader value. -defaultCompileReader :: CompileConfig -> IO CompileReader +defaultCompileReader :: Config -> IO CompileReader defaultCompileReader config = do srcdir <- faySourceDir return CompileReader diff --git a/src/Fay/Compiler/Desugar.hs b/src/Fay/Compiler/Desugar.hs --- a/src/Fay/Compiler/Desugar.hs +++ b/src/Fay/Compiler/Desugar.hs @@ -1,65 +1,40 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} - +-- | Desugars a reasonable amount of syntax to reduce duplication in code generation. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} module Fay.Compiler.Desugar - (desugar + ( desugar + , desugar' + , desugarExpParen + , desugarPatParen ) where +import Fay.Compiler.Prelude + +import Fay.Compiler.Desugar.Name +import Fay.Compiler.Desugar.Types +import Fay.Compiler.Misc (ffiExp, hasLanguagePragma) import Fay.Compiler.QName (unname) -import Fay.Compiler.Misc (hasLanguagePragma, ffiExp) import Fay.Exts.NoAnnotation (unAnn) import Fay.Types (CompileError (..)) -import Control.Applicative import Control.Monad.Error -import Control.Monad.Reader -import Data.Data (Data) -import Data.Maybe -import Data.Typeable (Typeable) -import Language.Haskell.Exts.Annotated hiding (binds, loc, name) -import Prelude hiding (exp, mod) +import Control.Monad.Reader (asks) import qualified Data.Generics.Uniplate.Data as U - --- Types - -data DesugarReader l = DesugarReader - { readerNameDepth :: Int - , readerNoInfo :: l - } - -newtype Desugar l a = Desugar - { unDesugar :: (ReaderT (DesugarReader l) - (ErrorT CompileError IO)) - a - } deriving ( MonadReader (DesugarReader l) - , MonadError CompileError - , MonadIO - , Monad - , Functor - , Applicative - ) - -runDesugar :: l -> Desugar l a -> IO (Either CompileError a) -runDesugar emptyAnnotation m = - runErrorT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation)) - --- | Generate a temporary, SCOPED name for testing conditions and --- such. We don't have name tracking yet, so instead we use this. -withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar l a) -> Desugar l a -withScopedTmpName l f = do - n <- asks readerNameDepth - local (\r -> r { readerNameDepth = n + 1 }) $ - f $ Ident l $ "$gen" ++ show n +import Language.Haskell.Exts.Annotated hiding (binds, loc, name) -- | Top level, desugar a whole module possibly returning errors desugar :: (Data l, Typeable l) => l -> Module l -> IO (Either CompileError (Module l)) -desugar emptyAnnotation md = runDesugar emptyAnnotation $ +desugar = desugar' "$gen" + +-- | Desugar with the option to specify a prefix for generated names. +-- Useful if you want to provide valid haskell name that HSE can print. +desugar' :: (Data l, Typeable l) => String -> l -> Module l -> IO (Either CompileError (Module l)) +desugar' prefix emptyAnnotation md = runDesugar prefix emptyAnnotation $ checkEnum md >> desugarSection md >>= desugarListComp - >>= return . desugarTupleCon + >>= desugarTupleCon >>= return . desugarPatParen >>= return . desugarFieldPun >>= return . desugarPatFieldPun @@ -67,9 +42,14 @@ >>= desugarTupleSection >>= desugarImplicitPrelude >>= desugarFFITypeSigs - --- | Desugaring + >>= desugarLCase + >>= return . desugarMultiIf + >>= return . desugarInfixOp + >>= return . desugarInfixPat + >>= return . desugarExpParen +-- | (a `f`) => \b -> a `f` b +-- (`f` b) => \a -> a `f` b desugarSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarSection = transformBiM $ \ex -> case ex of LeftSection l e q -> withScopedTmpName l $ \tmp -> @@ -78,13 +58,13 @@ return $ Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e) _ -> return ex +-- | Convert do notation into binds and thens. desugarDo :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarDo = transformBiM $ \ex -> case ex of Do _ stmts -> maybe (throwError EmptyDoBlock) return $ foldl desugarStmt' Nothing (reverse stmts) _ -> return ex --- | Convert do notation into binds and thens. -desugarStmt' :: Maybe (Exp l) -> (Stmt l) -> Maybe (Exp l) +desugarStmt' :: Maybe (Exp l) -> Stmt l -> Maybe (Exp l) desugarStmt' inner stmt = maybe initStmt subsequentStmt inner where @@ -107,37 +87,54 @@ Just $ InfixApp s exp (QVarOp s $ UnQual s $ Symbol s ">>=") - (Lambda s [pat] (inner')) + (Lambda s [pat] inner') -- | (,) => \x y -> (x,y) -- (,,) => \x y z -> (x,y,z) -- etc -desugarTupleCon :: (Data l, Typeable l) => Module l -> Module l -desugarTupleCon = transformBi $ \ex -> case ex of - Var _ (Special _ t@TupleCon{}) -> fromTupleCon ex t - Con _ (Special _ t@TupleCon{}) -> fromTupleCon ex t - _ -> ex +desugarTupleCon :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarTupleCon md = do + prefix <- asks readerTmpNamePrefix + return $ flip transformBi md $ \ex -> case ex of + Var _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t + Con _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t + _ -> ex where - fromTupleCon :: Exp l -> SpecialCon l -> Exp l - fromTupleCon e s = fromMaybe e $ case s of + fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l + fromTupleCon prefix e s = fromMaybe e $ case s of TupleCon l b n -> Just $ Lambda l params body where -- It doesn't matter if these variable names shadow anything since -- this lambda won't have inner scopes. - names = take n $ map (Ident l . ("$gen" ++) . show) [(1::Int)..] + names = take n $ unscopedTmpNames l prefix params = PVar l <$> names body = Tuple l b (Var l . UnQual l <$> names) _ -> Nothing -desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l) -desugarTupleSection = transformBiM $ \ex -> case ex of - TupleSection l _ mes -> do - (names, lst) <- genSlotNames l mes (varNames l) - return $ Lambda l (map (PVar l) names) (Tuple l Unboxed lst) +-- | \case { ... } => \foo -> case foo of { ... } +desugarLCase :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarLCase = transformBiM $ \ex -> case ex of + LCase l alts -> withScopedTmpName l $ \n -> return $ Lambda l [PVar l n] (Case l (Var l (UnQual l n)) alts) _ -> return ex + +-- | if | p -> x | q -> y => case () of _ | p -> x | q -> y +desugarMultiIf :: (Data l, Typeable l) => Module l -> Module l +desugarMultiIf = transformBi $ \ex -> case ex of + MultiIf l alts -> Case l (Con l (Special l (UnitCon l))) + [Alt l (PWildCard l) (GuardedAlts l gas) Nothing] + where gas = map (\(IfAlt l' p a) -> GuardedAlt l' [Qualifier l' p] a) alts + _ -> ex + +-- | (a,) => \b -> (a,b) +desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarTupleSection md = do + prefix <- asks readerTmpNamePrefix + flip transformBiM md $ \ex -> case ex of + TupleSection l _ mes -> do + (names, lst) <- genSlotNames l mes (unscopedTmpNames l prefix) + return $ Lambda l (map (PVar l) names) (Tuple l Boxed lst) + _ -> return ex where - varNames :: l -> [Name l] - varNames l = map (\i -> Ident l ("$gen_" ++ show i)) [0::Int ..] genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l]) genSlotNames _ [] _ = return ([], []) @@ -155,14 +152,15 @@ PParen _ p -> p _ -> pt +-- | {a} => {a=a} for R{a} expressions desugarFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarFieldPun = transformBi $ \f -> case f of FieldPun l n -> let dn = UnQual l n in FieldUpdate l dn (Var l dn) _ -> f +-- | {a} => {a=a} for R{a} patterns desugarPatFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarPatFieldPun = transformBi $ \pf -> case pf of - -- {a} => {a=a} for R{a} PFieldPun l n -> PFieldPat l (UnQual l n) (PVar l n) _ -> pf @@ -204,7 +202,7 @@ _ -> return () checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar l () - checkIntOrUnknown exp es = when (not $ any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp) + checkIntOrUnknown exp es = unless (any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp) isIntOrUnknown :: Exp l -> Bool isIntOrUnknown e = case e of Con {} -> False @@ -218,6 +216,7 @@ EnumFromThenTo {} -> False _ -> True +-- | Adds an explicit import Prelude statement when appropriate. desugarImplicitPrelude :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarImplicitPrelude m = if preludeNotNeeded @@ -266,7 +265,7 @@ -- foo = ffi "3" -- becomes -- foo :: Int --- foo = (ffi "3" :: Int) +-- foo = ffi "3" :: Int desugarToplevelFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarToplevelFFITypeSigs m = case m of Module a b c d decls -> do @@ -289,7 +288,7 @@ -- scope level. getTypeSigs ds = [ (unname n, typ) | TypeSig _ names typ <- ds, n <- names ] - go typeSigs ds = map (addTypeSig typeSigs) ds + go typeSigs = map (addTypeSig typeSigs) addTypeSig typeSigs decl = case decl of (PatBind loc pat typ rhs binds) -> @@ -325,6 +324,29 @@ getTypeFor typeSigs decl = case decl of (PatBind _ (PVar _ name) _ _ _) -> lookup (unname name) typeSigs _ -> Nothing + +-- | a `op` b => op a b +-- a + b => (+) a b +-- for expressions +desugarInfixOp :: (Data l, Typeable l) => Module l -> Module l +desugarInfixOp = transformBi $ \ex -> case ex of + InfixApp l e1 oper e2 -> App l (App l (getOp oper) e1) e2 + where + getOp (QVarOp l' o) = Var l' o + getOp (QConOp l' o) = Con l' o + _ -> ex + +-- | a : b => (:) a b for patterns +desugarInfixPat :: (Data l, Typeable l) => Module l -> Module l +desugarInfixPat = transformBi $ \pt -> case pt of + PInfixApp l p1 iop p2 -> PApp l iop [p1, p2] + _ -> pt + +-- | (a) => a for patterns +desugarExpParen :: (Data l, Typeable l) => Module l -> Module l +desugarExpParen = transformBi $ \ex -> case ex of + Paren _ e -> e + _ -> ex transformBi :: U.Biplate (from a) (to a) => (to a -> to a) -> from a -> from a transformBi = U.transformBi diff --git a/src/Fay/Compiler/Desugar/Name.hs b/src/Fay/Compiler/Desugar/Name.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Desugar/Name.hs @@ -0,0 +1,29 @@ +-- | Generate names while desugaring. +module Fay.Compiler.Desugar.Name + ( withScopedTmpName + , unscopedTmpNames + ) where + +import Fay.Compiler.Prelude + +import Fay.Compiler.Desugar.Types + +import Control.Monad.Reader (asks, local) +import Language.Haskell.Exts.Annotated (Name (..)) + +-- | Generate a temporary, SCOPED name for testing conditions and +-- such. We don't have name tracking yet, so instead we use this. +withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar l a) -> Desugar l a +withScopedTmpName l f = do + prefix <- asks readerTmpNamePrefix + n <- asks readerNameDepth + local (\r -> r { readerNameDepth = n + 1 }) $ + f $ tmpName l prefix n + +-- | Generates temporary names where the scope doesn't matter. +unscopedTmpNames :: l -> String -> [Name l] +unscopedTmpNames l prefix = map (tmpName l prefix) [0..] + +-- | Don't call this directly, use withScopedTmpName or unscopedTmpNames instead. +tmpName :: l -> String -> Int -> Name l +tmpName l prefix n = Ident l $ prefix ++ show n diff --git a/src/Fay/Compiler/Desugar/Types.hs b/src/Fay/Compiler/Desugar/Types.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Desugar/Types.hs @@ -0,0 +1,39 @@ +-- | The transformer stack used during desugaring. +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Fay.Compiler.Desugar.Types + ( DesugarReader (..) + , Desugar + , runDesugar + ) where + +import Fay.Compiler.Prelude + +import Fay.Types (CompileError (..)) + +import Control.Monad.Error +import Control.Monad.Reader + +data DesugarReader l = DesugarReader + { readerNameDepth :: Int + , readerNoInfo :: l + , readerTmpNamePrefix :: String + } + +newtype Desugar l a = Desugar + { unDesugar :: (ReaderT (DesugarReader l) + (ErrorT CompileError IO)) + a + } deriving ( MonadReader (DesugarReader l) + , MonadError CompileError + , MonadIO + , Monad + , Functor + , Applicative + ) + +runDesugar :: String -> l -> Desugar l a -> IO (Either CompileError a) +runDesugar tmpNamePrefix emptyAnnotation m = + runErrorT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation tmpNamePrefix)) 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -13,36 +14,33 @@ ,compileLit ) where +import Fay.Compiler.Prelude + import Fay.Compiler.FFI (compileFFIExp) import Fay.Compiler.Misc import Fay.Compiler.Pattern import Fay.Compiler.Print import Fay.Compiler.QName -import Fay.Data.List.Extra +import Fay.Config import Fay.Exts.NoAnnotation (unAnn) import Fay.Exts.Scoped (noI) import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative -import Control.Monad ((>=>), foldM, liftM, forM) import Control.Monad.Error (throwError) -import Control.Monad.RWS (gets, asks) +import Control.Monad.RWS (asks, gets) import qualified Data.Char as Char import Language.Haskell.Exts.Annotated hiding (alt, binds, name, op) import Language.Haskell.Names -import Prelude hiding (exp) -- | Compile Haskell expression. compileExp :: S.Exp -> Compile JsExp compileExp e = case e of - Paren _ exp -> compileExp exp Var _ qname -> compileVar qname Lit _ lit -> compileLit lit App _ (Var _ (UnQual _ (Ident _ "ffi"))) _ -> throwError $ FfiNeedsTypeSig e App _ exp1 exp2 -> compileApp exp1 exp2 NegApp _ exp -> compileNegApp exp - InfixApp _ exp1 op exp2 -> compileInfixApp exp1 op exp2 Let _ (BDecls _ decls) exp -> compileLet decls exp List _ [] -> return JsNull List _ xs -> compileList xs @@ -57,8 +55,8 @@ EnumFromTo _ i i' -> compileEnumFromTo i i' EnumFromThen _ a b -> compileEnumFromThen a b EnumFromThenTo _ a b z -> compileEnumFromThenTo a b z - RecConstr _ name fieldUpdates -> compileRecConstr name fieldUpdates - RecUpdate _ rec fieldUpdates -> compileRecUpdate rec fieldUpdates + RecConstr _ name fieldUpdates -> compileRecConstr e name fieldUpdates + RecUpdate _ rec fieldUpdates -> compileRecUpdate e rec fieldUpdates ExpTypeSig _ exp sig -> case ffiExp exp of Nothing -> compileExp exp Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig @@ -67,6 +65,8 @@ LeftSection {} -> shouldBeDesugared e RightSection {} -> shouldBeDesugared e TupleSection {} -> shouldBeDesugared e + Paren {} -> shouldBeDesugared e + InfixApp {} -> shouldBeDesugared e exp -> throwError $ UnsupportedExpression exp -- | Compile variable. @@ -75,7 +75,7 @@ compileVar qname = do nc <- lookupNewtypeConst qname nd <- lookupNewtypeDest qname - if (nc /= Nothing || nd /= Nothing) + if isJust nc || isJust nd then -- variable is either a newtype constructor or newtype destructor, -- replace it with identity function return idFun @@ -91,9 +91,9 @@ Frac _ rational _ -> return (JsLit (JsFloating (fromRational rational))) String _ string _ -> do fromString <- gets stateUseFromString - if fromString - then return (JsLit (JsStr string)) - else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)]) + return $ if fromString + then JsLit (JsStr string) + else JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)] _ -> throwError $ UnsupportedLiteral lit -- | Compile simple application. @@ -142,21 +142,6 @@ compileNegApp :: S.Exp -> Compile JsExp compileNegApp e = JsNegApp . force <$> compileExp e --- | Compile an infix application, optimizing the JS cases. -compileInfixApp :: S.Exp -> S.QOp -> S.Exp -> Compile JsExp -compileInfixApp exp1 ap exp2 = case exp1 of - Con _ q -> do - newtypeConst <- lookupNewtypeConst q - case newtypeConst of - Just _ -> compileExp exp2 - Nothing -> normalApp - _ -> normalApp - where - normalApp = compileExp (App noI (App noI (Var noI op) exp1) exp2) - op = getOp ap - getOp (QVarOp _ o) = o - getOp (QConOp _ o) = o - -- | Compile a let expression. compileLet :: [S.Decl] -> S.Exp -> Compile JsExp compileLet decls exp = do @@ -192,7 +177,7 @@ compileCase e alts = do exp <- compileExp e withScopedTmpJsName $ \tmpName -> do - pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts + pats <- optimizePatConditions <$> mapM (compilePatAlt (JsName tmpName)) alts return $ JsApp (JsFun Nothing [tmpName] @@ -222,8 +207,6 @@ -- | Compile guards compileGuards :: [S.GuardedRhs] -> Compile JsStmt -compileGuards ((GuardedRhs _ (Qualifier _ (Var _ (UnQual _ (Ident _ "otherwise"))):_) exp):_) = - (\e -> JsIf (JsLit $ JsBool True) [JsEarlyReturn e] []) <$> compileExp exp compileGuards (GuardedRhs _ (Qualifier _ guard:_) exp : rest) = makeIf <$> fmap force (compileExp guard) <*> compileExp exp @@ -287,8 +270,8 @@ -- | Compile a record construction with named fields -- | GHC will warn on uninitialized fields, they will be undefined in JS. -compileRecConstr :: S.QName -> [S.FieldUpdate] -> Compile JsExp -compileRecConstr name fieldUpdates = do +compileRecConstr :: S.Exp -> S.QName -> [S.FieldUpdate] -> Compile JsExp +compileRecConstr origExp name fieldUpdates = do -- var obj = new $_Type() let unQualName = withIdent lowerFirst . unQualify $ unAnn name qname <- unsafeResolveName name @@ -300,23 +283,23 @@ updateStmt (unAnn -> o) (FieldUpdate _ (unAnn -> field) value) = do exp <- compileExp value return [JsSetProp (JsNameVar $ withIdent lowerFirst $ unQualify o) (JsNameVar $ unQualify field) exp] - updateStmt o (FieldWildcard (wildcardFields -> fields)) = do + updateStmt o (FieldWildcard (wildcardFields -> fields)) = return $ for fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o) (JsNameVar fieldName) (JsName $ JsNameVar fieldName) -- I couldn't find a code that generates (FieldUpdate (FieldPun ..)) - updateStmt _ u = error ("updateStmt: " ++ show u) + updateStmt _ _ = throwError $ UnsupportedExpression origExp wildcardFields l = case l of - Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName) . map fst $ es + Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName . fst) es _ -> [] lowerFirst :: String -> String lowerFirst "" = "" lowerFirst (x:xs) = '_' : Char.toLower x : xs -- | Compile a record update. -compileRecUpdate :: S.Exp -> [S.FieldUpdate] -> Compile JsExp -compileRecUpdate rec fieldUpdates = do +compileRecUpdate :: S.Exp -> S.Exp -> [S.FieldUpdate] -> Compile JsExp +compileRecUpdate origExp rec fieldUpdates = do record <- force <$> compileExp rec let copyName = UnQual () $ Ident () "$_record_to_update" copy = JsVar (JsNameVar copyName) @@ -329,14 +312,14 @@ JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value updateExp _ f@FieldPun{} = shouldBeDesugared f -- I also couldn't find a code that generates (FieldUpdate FieldWildCard) - updateExp _ FieldWildcard{} = error "unsupported update: FieldWildcard" + updateExp _ FieldWildcard{} = throwError $ UnsupportedExpression origExp -- | Make a Fay list. makeList :: [JsExp] -> JsExp makeList exps = JsApp (JsName $ JsBuiltIn "list") [JsList exps] -- | Optimize short literal [e1..e3] arithmetic sequences. -optEnumFromTo :: CompileConfig -> JsExp -> JsExp -> Maybe JsExp +optEnumFromTo :: Config -> JsExp -> JsExp -> Maybe JsExp optEnumFromTo cfg (JsLit f) (JsLit t) = if configOptimize cfg then case (f,t) of @@ -352,7 +335,7 @@ optEnumFromTo _ _ _ = Nothing -- | Optimize short literal [e1,e2..e3] arithmetic sequences. -optEnumFromThenTo :: CompileConfig -> JsExp -> JsExp -> JsExp -> Maybe JsExp +optEnumFromThenTo :: Config -> JsExp -> JsExp -> JsExp -> Maybe JsExp optEnumFromThenTo cfg (JsLit fr) (JsLit th) (JsLit to) = if configOptimize cfg then case (fr,th,to) of diff --git a/src/Fay/Compiler/FFI.hs b/src/Fay/Compiler/FFI.hs --- a/src/Fay/Compiler/FFI.hs +++ b/src/Fay/Compiler/FFI.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS -Wall #-} -- | Compile FFI definitions. @@ -15,6 +15,8 @@ ,typeArity ) where +import Fay.Compiler.Prelude + import Fay.Compiler.Misc import Fay.Compiler.Print (printJSString) import Fay.Compiler.QName @@ -23,21 +25,13 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow ((***)) import Control.Monad.Error import Control.Monad.Writer -import Data.Char import Data.Generics.Schemes -import Data.List -import Data.Maybe -import Data.String import Language.ECMAScript3.Parser as JS import Language.ECMAScript3.Syntax import Language.Haskell.Exts.Annotated (SrcSpanInfo, prettyPrint) import Language.Haskell.Exts.Annotated.Syntax -import Prelude hiding (exp, mod) -import Safe -- | Compile an FFI expression (also used when compiling top level definitions). compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> S.Type -> Compile JsExp diff --git a/src/Fay/Compiler/GADT.hs b/src/Fay/Compiler/GADT.hs --- a/src/Fay/Compiler/GADT.hs +++ b/src/Fay/Compiler/GADT.hs @@ -4,7 +4,7 @@ (convertGADT ) where -import Language.Haskell.Exts.Annotated hiding (binds, name) +import Language.Haskell.Exts.Annotated hiding (name) -- | Convert a GADT to a normal data type. convertGADT :: GadtDecl a -> QualConDecl a diff --git a/src/Fay/Compiler/Import.hs b/src/Fay/Compiler/Import.hs --- a/src/Fay/Compiler/Import.hs +++ b/src/Fay/Compiler/Import.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | Handles finding imports and compiling them recursively. -- This is done for each full AST traversal the copmiler does @@ -10,18 +11,18 @@ ,compileWith ) where -import Fay.Compiler.Config +import Fay.Compiler.Prelude + import Fay.Compiler.Misc -import Fay.Control.Monad.IO +import Fay.Compiler.Parse +import Fay.Config import qualified Fay.Exts as F import Fay.Exts.NoAnnotation (unAnn) import Fay.Types -import Control.Applicative import Control.Monad.Error import Control.Monad.RWS import Language.Haskell.Exts.Annotated hiding (name, var) -import Prelude hiding (mod, read) import System.Directory import System.FilePath 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -7,23 +8,23 @@ (initialPass ) where +import Fay.Compiler.Prelude + import Fay.Compiler.Desugar import Fay.Compiler.GADT import Fay.Compiler.Import import Fay.Compiler.Misc -import Fay.Data.List.Extra +import Fay.Compiler.Parse import qualified Fay.Exts as F import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Applicative import Control.Monad.Error import Control.Monad.RWS import qualified Data.Map as M import Language.Haskell.Exts.Annotated hiding (name, var) import qualified Language.Haskell.Names as HN -import Prelude hiding (mod, read) -- | Preprocess and collect all information needed during code generation. initialPass :: FilePath -> Compile () @@ -115,7 +116,7 @@ -- | Collect record definitions and store record name and field names. -- A ConDecl will have fields named slot1..slotN dataDecl :: [F.QualConDecl] -> Compile () - dataDecl constructors = do + dataDecl constructors = forM_ constructors $ \(QualConDecl _ _ _ condecl) -> case condecl of ConDecl _ name types -> do 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -7,28 +8,24 @@ module Fay.Compiler.Misc where +import Fay.Compiler.Prelude + import Fay.Compiler.PrimOp -import Fay.Control.Monad.IO +import Fay.Compiler.QName (unname) +import Fay.Config import qualified Fay.Exts as F import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.NoAnnotation as N import qualified Fay.Exts.Scoped as S import Fay.Types -import Fay.Compiler.QName (unname) -import Control.Applicative import Control.Monad.Error import Control.Monad.RWS -import Data.Char (isAlpha) -import Data.List import qualified Data.Map as M -import Data.Maybe -import Data.String import Data.Version (parseVersion) import Distribution.HaskellSuite.Modules import Language.Haskell.Exts.Annotated hiding (name) import Language.Haskell.Names -import Prelude hiding (exp, mod) import System.IO import System.Process (readProcess) import Text.ParserCombinators.ReadP (readP_to_S) @@ -114,7 +111,7 @@ Just (cname,_,ty) -> return $ Just (cname,ty) -- | Qualify a name for the current module. -qualify :: Name a -> Compile (N.QName) +qualify :: Name a -> Compile N.QName qualify (Ident _ name) = do modulename <- gets stateModuleName return (Qual () modulename (Ident () name)) @@ -154,19 +151,21 @@ ParseFailed srcloc msg -> die (srcloc,msg) -- | Get a config option. -config :: (CompileConfig -> a) -> Compile a +config :: (Config -> a) -> Compile a config f = asks (f . readerConfig) -- | Optimize pattern matching conditions by merging conditions in common. +-- TODO This is buggy and no longer used. Fails on tests/case3 optimizePatConditions :: [[JsStmt]] -> [[JsStmt]] -optimizePatConditions = concatMap merge . groupBy sameIf where +optimizePatConditions = id + {- concatMap merge . groupBy sameIf where sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2 sameIf _ _ = False merge xs@([JsIf cond _ _]:_) = [[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]] merge noifs = noifs getIfConsequent [JsIf _ cons _] = cons - getIfConsequent other = other + getIfConsequent other = other -} -- | Throw a JS exception. throw :: String -> JsExp -> JsStmt @@ -216,7 +215,7 @@ warn "" = return () warn w = config id >>= io . (`ioWarn` w) -ioWarn :: CompileConfig -> String -> IO () +ioWarn :: Config -> String -> IO () ioWarn _ "" = return () ioWarn cfg w = when (configWall cfg) $ @@ -238,7 +237,7 @@ typeToRecs (unAnn -> typ) = fromMaybe [] . lookup typ <$> gets stateRecordTypes recToFields :: S.QName -> Compile [N.Name] -recToFields con = do +recToFields con = case tryResolveName con of Nothing -> return [] Just c -> fromMaybe [] . lookup c <$> gets stateRecords @@ -275,76 +274,15 @@ runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a runCompileModule reader' state' m = runErrorT (runRWST (unCompile m) reader' state') --- | Parse some Fay code. -parseFay :: Parseable ast => FilePath -> String -> ParseResult ast -parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP - --- | Apply incredibly simplistic CPP handling. It only recognizes the following: --- --- > #if FAY --- > #ifdef FAY --- > #ifndef FAY --- > #else --- > #endif --- --- Note that this implementation replaces all removed lines with blanks, so --- that line numbers remain accurate. -applyCPP :: String -> String -applyCPP = - unlines . loop NoCPP . lines - where - loop _ [] = [] - loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest - loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest - loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest - loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest - loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest - loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest - loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest - - toInclude NoCPP = True - toInclude (CPPIf x state') = x && toInclude state' - toInclude (CPPElse x state') = x && toInclude state' - --- | The CPP's parsing state. -data CPPState = NoCPP - | CPPIf Bool CPPState - | CPPElse Bool CPPState - --- | The parse mode for Fay. -parseMode :: ParseMode -parseMode = defaultParseMode - { extensions = defaultExtensions - , fixities = Just (preludeFixities ++ baseFixities) - } - shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn -defaultExtensions :: [Extension] -defaultExtensions = map EnableExtension - [EmptyDataDecls - ,ExistentialQuantification - ,FlexibleContexts - ,FlexibleInstances - ,GADTs - ,ImplicitPrelude - ,KindSignatures - ,NamedFieldPuns - ,PackageImports - ,RecordWildCards - ,StandaloneDeriving - ,TupleSections - ,TypeFamilies - ,TypeOperators - ] - -- | Check if the given language pragmas are all present. hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas where flattenPragmas :: [ModulePragma l] -> [String] - flattenPragmas ps = concat $ map pragmaName ps + flattenPragmas ps = concatMap pragmaName ps pragmaName (LanguagePragma _ q) = map unname q pragmaName _ = [] diff --git a/src/Fay/Compiler/Optimizer.hs b/src/Fay/Compiler/Optimizer.hs --- a/src/Fay/Compiler/Optimizer.hs +++ b/src/Fay/Compiler/Optimizer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} @@ -6,21 +7,16 @@ module Fay.Compiler.Optimizer where +import Fay.Compiler.Prelude + import Fay.Compiler.Misc import Fay.Types -import Control.Applicative -import Control.Arrow (first) -import Control.Monad.Error import Control.Monad.State import Control.Monad.Writer -import Data.List -import Data.Maybe import qualified Fay.Exts.NoAnnotation as N import Language.Haskell.Exts.Annotated hiding (app, name, op) -import Prelude hiding (exp) - -- | The arity of a function. Arity here is defined to be the number -- of arguments that can be directly uncurried from a curried lambda -- abstraction. So \x y z -> if x then (\a -> a) else (\a -> a) has an @@ -212,7 +208,7 @@ -- | Apply the given function to the top-level expressions in the -- given statement. applyToExpsInStmt :: [FuncArity] -> ([FuncArity] -> JsExp -> Optimize JsExp) -> JsStmt -> Optimize JsStmt -applyToExpsInStmt funcs f stmts = uncurryInStmt stmts where +applyToExpsInStmt funcs f = uncurryInStmt where transform = f funcs uncurryInStmt stmt = case stmt of JsVar name exp -> JsVar name <$> transform exp 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,16 +4,11 @@ module Fay.Compiler.Packages where -import Fay.Compiler.Config -import Fay.Control.Monad.Extra -import Fay.System.Process.Extra -import Fay.Types +import Fay.Compiler.Prelude + +import Fay.Config import Paths_fay -import Control.Applicative -import Control.Monad -import Data.List -import Data.Maybe import Data.Version import GHC.Paths import System.Directory @@ -21,12 +16,12 @@ -- | Given a configuration, resolve any packages specified to their -- data file directories for importing the *.hs sources. -resolvePackages :: CompileConfig -> IO CompileConfig +resolvePackages :: Config -> IO Config resolvePackages config = foldM resolvePackage config (configPackages config) -- | Resolve package. -resolvePackage :: CompileConfig -> String -> IO CompileConfig +resolvePackage :: Config -> String -> IO Config resolvePackage config name = do desc <- describePackage (configPackageConf config) name case packageVersion desc of diff --git a/src/Fay/Compiler/Parse.hs b/src/Fay/Compiler/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Parse.hs @@ -0,0 +1,69 @@ +module Fay.Compiler.Parse + ( parseFay + , defaultExtensions + ) where + +import Language.Haskell.Exts.Annotated hiding (name) + +-- | Parse some Fay code. +parseFay :: Parseable ast => FilePath -> String -> ParseResult ast +parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP + +-- | Apply incredibly simplistic CPP handling. It only recognizes the following: +-- +-- > #if FAY +-- > #ifdef FAY +-- > #ifndef FAY +-- > #else +-- > #endif +-- +-- Note that this implementation replaces all removed lines with blanks, so +-- that line numbers remain accurate. +applyCPP :: String -> String +applyCPP = + unlines . loop NoCPP . lines + where + loop _ [] = [] + loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest + loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest + loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest + loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest + loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest + loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest + loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest + + toInclude NoCPP = True + toInclude (CPPIf x state') = x && toInclude state' + toInclude (CPPElse x state') = x && toInclude state' + +-- | The CPP's parsing state. +data CPPState = NoCPP + | CPPIf Bool CPPState + | CPPElse Bool CPPState + +-- | The parse mode for Fay. +parseMode :: ParseMode +parseMode = defaultParseMode + { extensions = defaultExtensions + , fixities = Just (preludeFixities ++ baseFixities) + } + +defaultExtensions :: [Extension] +defaultExtensions = map EnableExtension + [EmptyDataDecls + ,ExistentialQuantification + ,FlexibleContexts + ,FlexibleInstances + ,GADTs + ,ImplicitPrelude + ,KindSignatures + ,LambdaCase + ,MultiWayIf + ,NamedFieldPuns + ,PackageImports + ,RecordWildCards + ,StandaloneDeriving + ,TupleSections + ,TypeFamilies + ,TypeOperators + ] diff --git a/src/Fay/Compiler/Pattern.hs b/src/Fay/Compiler/Pattern.hs --- a/src/Fay/Compiler/Pattern.hs +++ b/src/Fay/Compiler/Pattern.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -5,6 +6,8 @@ module Fay.Compiler.Pattern where +import Fay.Compiler.Prelude + import Fay.Compiler.Misc import Fay.Compiler.QName import Fay.Exts.NoAnnotation (unAnn) @@ -12,12 +15,10 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative import Control.Monad.Error import Control.Monad.Reader import Language.Haskell.Exts.Annotated hiding (name) import Language.Haskell.Names -import Prelude hiding (exp) -- | Compile the given pattern against the given expression. compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt] @@ -26,16 +27,16 @@ PApp _ cons pats -> do newty <- lookupNewtypeConst cons case newty of - Nothing -> compilePApp cons pats exp body + Nothing -> compilePApp pat cons pats exp body Just _ -> compileNewtypePat pats exp body PLit _ literal -> compilePLit exp literal body - PParen{} -> shouldBeDesugared pat PWildCard _ -> return body - PInfixApp{} -> compileInfixPat exp pat body PList _ pats -> compilePList pats body exp PTuple _ _bx pats -> compilePList pats body exp PAsPat _ name pt -> compilePAsPat exp name pt body PRec _ name pats -> compilePatFields exp name pats body + PParen{} -> shouldBeDesugared pat + PInfixApp{} -> shouldBeDesugared pat _ -> throwError (UnsupportedPattern pat) -- | Compile a pattern variable e.g. x. @@ -107,13 +108,26 @@ compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps -- | Compile a pattern application. -compilePApp :: S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] -compilePApp cons pats exp body = do +compilePApp :: S.Pat -> S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] +compilePApp origPat cons pats exp body = do let forcedExp = force exp let boolIf b = return [JsIf (JsEq forcedExp (JsLit (JsBool b))) body []] case cons of -- Special-casing on the booleans. Special _ (UnitCon _) -> return (JsExpStmt forcedExp : body) + Special _ Cons{} -> case pats of + [left, right] -> + withScopedTmpJsName $ \tmpName -> do + let forcedList = JsName tmpName + x = JsGetProp forcedList (JsNameVar "car") + xs = JsGetProp forcedList (JsNameVar "cdr") + rightMatch <- compilePat xs right body + leftMatch <- compilePat x left rightMatch + return [JsVar tmpName (force exp) + ,JsIf (JsInstanceOf forcedList (JsBuiltIn "Cons")) + leftMatch + []] + _ -> throwError $ UnsupportedPattern origPat UnQual _ (Ident _ "True") -> boolIf True UnQual _ (Ident _ "False") -> boolIf False -- Everything else, generic: @@ -148,20 +162,3 @@ return [JsIf (JsApp (JsName (JsBuiltIn "listLen")) [forcedExp,patsLen]) stmts []] - --- | Compile an infix pattern (e.g. cons and tuples.) -compileInfixPat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt] -compileInfixPat exp pat@(PInfixApp _ left (Special _ cons) right) body = case cons of - Cons _ -> - withScopedTmpJsName $ \tmpName -> do - let forcedExp = JsName tmpName - x = JsGetProp forcedExp (JsNameVar "car") - xs = JsGetProp forcedExp (JsNameVar "cdr") - rightMatch <- compilePat xs right body - leftMatch <- compilePat x left rightMatch - return [JsVar tmpName (force exp) - ,JsIf (JsInstanceOf forcedExp (JsBuiltIn "Cons")) - leftMatch - []] - _ -> throwError (UnsupportedPattern pat) -compileInfixPat _ pat _ = throwError (UnsupportedPattern pat) diff --git a/src/Fay/Compiler/Prelude.hs b/src/Fay/Compiler/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Prelude.hs @@ -0,0 +1,69 @@ +-- | Re-exports of base functionality. Note that this module is just +-- used inside the compiler. It's not compiled to JavaScript. +-- Based on the base-extended package (c) 2013 Simon Meier, licensed as BSD3. +module Fay.Compiler.Prelude + ( module Prelude -- Partial + + -- * Control modules + , module Control.Applicative + , module Control.Arrow -- Partial + , module Control.Monad + + -- * Data modules + , module Data.Char -- Partial + , module Data.Data -- Partial + , module Data.Either + , module Data.Function + , module Data.List -- Partial + , module Data.Maybe + , module Data.Monoid -- Partial + , module Data.Ord + + -- * Safe + , module Safe + + -- * Additions + , anyM + , for + , io + , readAllFromProcess + ) where + +import Control.Applicative +import Control.Arrow (first, second, (&&&), (***), (+++), (|||)) +import Control.Monad hiding (guard) +import Data.Char hiding (GeneralCategory (..)) +import Data.Data (Data (..), Typeable) +import Data.Either +import Data.Function (on) +import Data.List hiding (delete) +import Data.Maybe +import Data.Monoid (Monoid (..), (<>)) +import Data.Ord +import Prelude hiding (exp, mod) +import Safe + +import Control.Monad.Error +import System.Exit +import System.Process + +-- | Alias of liftIO, I hate typing it. Hate reading it. +io :: MonadIO m => IO a -> m a +io = liftIO + +-- | Do any of the (monadic) predicates match? +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM p l = return . not . null =<< filterM p l + +-- | Flip of map. +for :: (Functor f) => f a -> (a -> b) -> f b +for = flip fmap + +-- | Read from a process returning both std err and out. +readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String)) +readAllFromProcess program flags input = do + (code,out,err) <- readProcessWithExitCode program flags input + return $ case code of + ExitFailure 127 -> Left ("cannot find executable " ++ program, "") + ExitFailure _ -> Left (err, out) + ExitSuccess -> Right (err, out) diff --git a/src/Fay/Compiler/PrimOp.hs b/src/Fay/Compiler/PrimOp.hs --- a/src/Fay/Compiler/PrimOp.hs +++ b/src/Fay/Compiler/PrimOp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -21,13 +22,14 @@ , resolvePrimOp ) where +import Fay.Compiler.Prelude + import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.NoAnnotation as N import Data.Map (Map) import qualified Data.Map as M import Language.Haskell.Exts.Annotated hiding (binds, name) -import Prelude hiding (mod) -- | Make an identifier from the built-in HJ module. fayBuiltin :: a -> String -> QName a diff --git a/src/Fay/Compiler/Print.hs b/src/Fay/Compiler/Print.hs --- a/src/Fay/Compiler/Print.hs +++ b/src/Fay/Compiler/Print.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fno-warn-orphans #-} -{-# OPTIONS -fno-warn-unused-do-bind #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -16,19 +16,16 @@ module Fay.Compiler.Print where +import Fay.Compiler.Prelude + import Fay.Compiler.PrimOp -import qualified Fay.Exts.NoAnnotation as N +import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Monad import Control.Monad.State import Data.Aeson.Encode -import qualified Data.ByteString.Lazy.UTF8 as UTF8 -import Data.Default -import Data.List -import Data.String -import Language.Haskell.Exts.Annotated hiding (alt, name, op, sym) -import Prelude hiding (exp) +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import Language.Haskell.Exts.Annotated hiding (alt, name, op, sym) import SourceMap.Types -------------------------------------------------------------------------------- @@ -36,11 +33,11 @@ -- | Print the JS to a flat string. printJSString :: Printable a => a -> String -printJSString x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def +printJSString x = concat . reverse . psOutput $ execState (runPrinter (printJS x)) defaultPrintState -- | Print the JS to a pretty string. printJSPretty :: Printable a => a -> String -printJSPretty x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def { psPretty = True } +printJSPretty x = concat . reverse . psOutput $ execState (runPrinter (printJS x)) defaultPrintState { psPretty = True } -- | Print literals. These need some special encoding for -- JS-format literals. Could use the Text.JSON library. @@ -120,12 +117,12 @@ "if (" +> exp +> ") {" +> newline +> indented (printJS thens) +> "}" +> - (when (length elses > 0) $ " else {" +> + (unless (null elses) $ " else {" +> indented (printJS elses) +> "}") +> newline printJS (JsEarlyReturn exp) = "return " +> exp +> ";" +> newline - printJS (JsThrow exp) = do + printJS (JsThrow exp) = "throw " +> exp +> ";" +> newline printJS (JsWhile cond stmts) = "while (" +> cond +> ") {" +> newline +> @@ -156,7 +153,7 @@ printJS (JsList exps) = "[" +> intercalateM "," (map printJS exps) +> printJS "]" printJS (JsNew name args) = - "new " +> (JsApp (JsName name) args) + "new " +> JsApp (JsName name) args printJS (JsIndex i exp) = "(" +> exp +> ")[" +> show i +> "]" printJS (JsEq exp1 exp2) = @@ -179,10 +176,10 @@ printJS (JsInstanceOf exp classname) = exp +> " instanceof " +> classname printJS (JsObj assoc) = - "{" +> (intercalateM "," (map cons assoc)) +> "}" + "{" +> intercalateM "," (map cons assoc) +> "}" where cons (key,value) = "\"" +> key +> "\": " +> value printJS (JsLitObj assoc) = - "{" +> (intercalateM "," (map cons assoc)) +> "}" + "{" +> intercalateM "," (map cons assoc) +> "}" where cons :: (N.Name, JsExp) -> Printer () cons (key,value) = "\"" +> key +> "\": " +> value @@ -190,7 +187,7 @@ "function" +> maybe (return ()) ((" " +>) . printJS . ident) nm +> "(" - +> (intercalateM "," (map printJS params)) + +> intercalateM "," (map printJS params) +> "){" +> newline +> indented (stmts +> case ret of @@ -288,9 +285,7 @@ -- | Normalize the given name to JavaScript-valid names. normalizeName :: String -> String -normalizeName name = - concatMap encodeChar name - +normalizeName = concatMap encodeChar where encodeChar c | c `elem` allowed = [c] | otherwise = escapeChar c @@ -309,9 +304,9 @@ PrintState{..} <- get if psPretty then do modify $ \s -> s { psIndentLevel = psIndentLevel + 1 } - p + void p modify $ \s -> s { psIndentLevel = psIndentLevel } - else p >> return () + else void p -- | Output a newline. newline :: Printer () @@ -355,9 +350,9 @@ -- | Intercalate monadic action. intercalateM :: String -> [Printer a] -> Printer () intercalateM _ [] = return () -intercalateM _ [x] = x >> return () +intercalateM _ [x] = void x intercalateM str (x:xs) = do - x + void x write str intercalateM str xs diff --git a/src/Fay/Compiler/State.hs b/src/Fay/Compiler/State.hs --- a/src/Fay/Compiler/State.hs +++ b/src/Fay/Compiler/State.hs @@ -40,10 +40,10 @@ -- | Is this *resolved* name a new type constructor or destructor? isNewtype :: SymValueInfo OrigName -> CompileState -> Bool isNewtype s cs = case s of - SymValue{} -> False - SymMethod{} -> False - SymSelector { sv_typeName } -> not . (`isNewtypeDest` cs) . origName2QName $ sv_typeName - SymConstructor { sv_typeName } -> not . (`isNewtypeCons` cs) . origName2QName $ sv_typeName + SymValue{} -> False + SymMethod{} -> False + SymSelector { sv_typeName = tn } -> not . (`isNewtypeDest` cs) . origName2QName $ tn + SymConstructor { sv_typeName = tn } -> not . (`isNewtypeCons` cs) . origName2QName $ tn -- | Is this *resolved* name a new type destructor? isNewtypeDest :: N.QName -> CompileState -> Bool @@ -61,6 +61,6 @@ addedModulePath :: ModulePath -> CompileState -> Bool addedModulePath mp CompileState { stateJsModulePaths } = mp `S.member` stateJsModulePaths - +-- | Find the type signature of a top level name findTypeSig :: N.QName -> CompileState -> Maybe N.Type findTypeSig n = M.lookup n . stateTypeSigs 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,17 +2,17 @@ module Fay.Compiler.Typecheck where +import Fay.Compiler.Prelude + import Fay.Compiler.Defaults import Fay.Compiler.Misc -import Fay.System.Process.Extra +import Fay.Config import Fay.Types -import Data.List -import Data.Maybe -import qualified GHC.Paths as GHCPaths +import qualified GHC.Paths as GHCPaths -- | Call out to GHC to type-check the file. -typecheck :: CompileConfig -> FilePath -> IO (Either CompileError String) +typecheck :: Config -> FilePath -> IO (Either CompileError String) typecheck cfg fp = do faydir <- faySourceDir let includes = configDirectoryIncludes cfg diff --git a/src/Fay/Config.hs b/src/Fay/Config.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Config.hs @@ -0,0 +1,146 @@ +-- | Configuring the compiler + +module Fay.Config + ( Config + ( configOptimize + , configFlattenApps + , configExportRuntime + , configExportStdlib + , configExportStdlibOnly + , configPrettyPrint + , configHtmlWrapper + , configSourceMap + , configHtmlJSLibs + , configLibrary + , configWarn + , configFilePath + , configTypecheck + , configWall + , configGClosure + , configPackageConf + , configBasePath + , configStrict + , configTypecheckOnly + , configRuntimePath + ) + , defaultConfig + , configDirectoryIncludes + , configDirectoryIncludePaths + , nonPackageConfigDirectoryIncludePaths + , addConfigDirectoryInclude + , addConfigDirectoryIncludes + , addConfigDirectoryIncludePaths + , configPackages + , addConfigPackage + , addConfigPackages + , shouldExportStrictWrapper + ) where + +import Fay.Compiler.Prelude + +import Data.Default +import Data.Maybe () +import Language.Haskell.Exts.Annotated (ModuleName (..)) + +-- | Configuration of the compiler. +-- The fields with a leading underscore +data Config = Config + { configOptimize :: Bool -- ^ Run optimizations + , configFlattenApps :: Bool -- ^ Flatten function application? + , configExportRuntime :: Bool -- ^ Export the runtime? + , configExportStdlib :: Bool -- ^ Export the stdlib? + , configExportStdlibOnly :: Bool -- ^ Export /only/ the stdlib? + , _configDirectoryIncludes :: [(Maybe String, FilePath)] -- ^ Possibly a fay package name, and a include directory. + , configPrettyPrint :: Bool -- ^ Pretty print the JS output? + , configHtmlWrapper :: Bool -- ^ Output a HTML file including the produced JS. + , configSourceMap :: Bool -- ^ Output a source map file as outfile.map. + , configHtmlJSLibs :: [FilePath] -- ^ Any JS files to link to in the HTML. + , configLibrary :: Bool -- ^ Don't invoke main in the produced JS. + , configWarn :: Bool -- ^ Warn on dubious stuff, not related to typechecking. + , configFilePath :: Maybe FilePath -- ^ File path to output to. + , configTypecheck :: Bool -- ^ Typecheck with GHC. + , configWall :: Bool -- ^ Typecheck with -Wall. + , configGClosure :: Bool -- ^ Run Google Closure on the produced JS. + , configPackageConf :: Maybe FilePath -- ^ The package config e.g. packages-6.12.3. + , _configPackages :: [String] -- ^ Included Fay packages. + , configBasePath :: Maybe FilePath -- ^ Custom source location for fay-base + , configStrict :: [String] -- ^ Produce strict and uncurried JavaScript callable wrappers for all + -- exported functions with type signatures in the given module + , configTypecheckOnly :: Bool -- ^ Only invoke GHC for typechecking, don't produce any output + , configRuntimePath :: Maybe FilePath + } deriving (Show) + + +defaultConfig :: Config +defaultConfig = addConfigPackage "fay-base" + Config + { configOptimize = False + , configFlattenApps = False + , configExportRuntime = True + , configExportStdlib = True + , configExportStdlibOnly = False + , _configDirectoryIncludes = [] + , configPrettyPrint = False + , configHtmlWrapper = False + , configHtmlJSLibs = [] + , configLibrary = False + , configWarn = True + , configFilePath = Nothing + , configTypecheck = True + , configWall = False + , configGClosure = False + , configPackageConf = Nothing + , _configPackages = [] + , configBasePath = Nothing + , configStrict = [] + , configTypecheckOnly = False + , configRuntimePath = Nothing + , configSourceMap = False + } + +-- | Default configuration. +instance Default Config where + def = defaultConfig + +-- | Reading _configDirectoryIncludes is safe to do. +configDirectoryIncludes :: Config -> [(Maybe String, FilePath)] +configDirectoryIncludes = _configDirectoryIncludes + +-- | Get all include directories without the package mapping. +configDirectoryIncludePaths :: Config -> [FilePath] +configDirectoryIncludePaths = map snd . _configDirectoryIncludes + +-- | Get all include directories not included through packages. +nonPackageConfigDirectoryIncludePaths :: Config -> [FilePath] +nonPackageConfigDirectoryIncludePaths = map snd . filter (isJust . fst) . _configDirectoryIncludes + +-- | Add a mapping from (maybe) a package to a source directory +addConfigDirectoryInclude :: Maybe String -> FilePath -> Config -> Config +addConfigDirectoryInclude pkg fp cfg = cfg { _configDirectoryIncludes = (pkg, fp) : _configDirectoryIncludes cfg } + +-- | Add several include directories. +addConfigDirectoryIncludes :: [(Maybe String,FilePath)] -> Config -> Config +addConfigDirectoryIncludes pkgFps cfg = foldl (\c (pkg,fp) -> addConfigDirectoryInclude pkg fp c) cfg pkgFps + +-- | Add several include directories without package references. +addConfigDirectoryIncludePaths :: [FilePath] -> Config -> Config +addConfigDirectoryIncludePaths fps cfg = foldl (flip (addConfigDirectoryInclude Nothing)) cfg fps + + + +-- | Reading _configPackages is safe to do. +configPackages :: Config -> [String] +configPackages = _configPackages + +-- | Add a package to compilation +addConfigPackage :: String -> Config -> Config +addConfigPackage pkg cfg = cfg { _configPackages = pkg : _configPackages cfg } + +-- | Add several packages to compilation +addConfigPackages :: [String] -> Config -> Config +addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps + + +-- | Should a strict wrapper be generated for this module? +shouldExportStrictWrapper :: ModuleName a -> Config -> Bool +shouldExportStrictWrapper (ModuleName _ m) cs = m `elem` configStrict cs diff --git a/src/Fay/Control/Monad/Extra.hs b/src/Fay/Control/Monad/Extra.hs deleted file mode 100644 --- a/src/Fay/Control/Monad/Extra.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | Extra monadic functions. - -module Fay.Control.Monad.Extra where - -import Control.Monad -import Data.Maybe - --- | Word version of flip (>>=). -bind :: (Monad m) => (a -> m b) -> m a -> m b -bind = flip (>>=) - --- | When the value is Just. -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenJust (Just a) m = m a -whenJust Nothing _ = return () - --- | Wrap up a form in a Maybe. -just :: Functor m => m a -> m (Maybe a) -just = fmap Just - --- | Flip of mapMaybe. -forMaybe :: [a] -> (a -> Maybe b) -> [b] -forMaybe = flip mapMaybe - --- | Monadic version of maybe. -maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a -maybeM nil cons a = maybe (return nil) cons a - --- | Do any of the (monadic) predicates match? -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM p l = return . not . null =<< filterM p l diff --git a/src/Fay/Control/Monad/IO.hs b/src/Fay/Control/Monad/IO.hs deleted file mode 100644 --- a/src/Fay/Control/Monad/IO.hs +++ /dev/null @@ -1,9 +0,0 @@ --- | Alias of MonadIO. - -module Fay.Control.Monad.IO where - -import Control.Monad.Trans - --- | Alias of liftIO, I hate typing it. Hate reading it. -io :: MonadIO m => IO a -> m a -io = liftIO diff --git a/src/Fay/Convert.hs b/src/Fay/Convert.hs --- a/src/Fay/Convert.hs +++ b/src/Fay/Convert.hs @@ -1,252 +1,247 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS -fno-warn-type-defaults #-} -- | Convert a Haskell value to a (JSON representation of a) Fay value. module Fay.Convert (showToFay - ,readFromFay) + ,readFromFay + ,readFromFay' + ,encodeFay + ,decodeFay) where -import Control.Applicative -import Control.Monad +import Fay.Compiler.Prelude + import Control.Monad.State +import Control.Spoon import Data.Aeson -import Data.Attoparsec.Number -import Data.Char +import Data.Aeson.Types (parseEither) import Data.Data -import Data.Function import Data.Generics.Aliases -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Numeric -import Safe -import qualified Text.Show.Pretty as Show -#if MIN_VERSION_aeson(0,7,0) -import Data.Scientific -#endif +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as Vector -------------------------------------------------------------------------------- -- The conversion functions. --- | Convert a Haskell value to a value representing a Fay value. -showToFay :: Show a => a -> Maybe Value -showToFay = Show.reify >=> convert where - convert value = case value of - -- Special cases - Show.Con "True" _ -> return (Bool True) - Show.Con "False" _ -> return (Bool False) - - -- Objects/records - Show.Con name values -> fmap (Object . Map.fromList . (("instance",string name) :)) - (slots values) - Show.Rec name fields -> fmap (Object . Map.fromList . (("instance",string name) :)) - (mapM (uncurry keyval) fields) - Show.InfixCons _ _ -> Nothing -- TODO https://github.com/faylang/fay/issues/316 - - -- () - Show.Tuple [] -> return Null - - -- List types - Show.Tuple values -> fmap (Array . Vector.fromList) (mapM convert values) - Show.List values -> fmap (Array . Vector.fromList) (mapM convert values) - - -- Text types - Show.String chars -> fmap string (readMay chars) - Show.Char char -> fmap (string.return) (readMay char) +-- | Convert a Haskell value to a Fay json value. This can fail when primitive +-- values aren't handled by explicit cases. 'encodeFay' can be used to +-- resolve this issue. +showToFay :: Data a => a -> Maybe Value +showToFay = encodeFay (\x -> x) - -- Numeric types (everything treated as a double) - Show.Neg{} -> double <|> int - Show.Integer{} -> int - Show.Float{} -> double - Show.Ratio{} -> double - where double = convertDouble value - int = convertInt value +-- | Convert a Haskell value to a Fay json value. This can fail when primitive +-- values aren't handled by explicit cases. When this happens, you can add +-- additional cases via the first parameter. +-- +-- The first parameter is a function that can be used to override the +-- conversion. This usually looks like using 'extQ' to additional type- +-- specific cases. +encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ (Maybe Value) +encodeFay specialCases = spoon . encodeFayInternal specialCases - -- Number converters +encodeFayInternal :: (GenericQ Value -> GenericQ Value) -> GenericQ Value +encodeFayInternal specialCases = specialCases $ + encodeGeneric rec + `extQ` unit + `extQ` Bool + `extQ` (toJSON :: Int -> Value) + `extQ` (toJSON :: Float -> Value) + `extQ` (toJSON :: Double -> Value) + `ext1Q` list + `extQ` string + `extQ` char + `extQ` text + where + rec :: GenericQ Value + rec = encodeFayInternal specialCases + unit () = Null + list :: Data a => [a] -> Value + list = Array . Vector.fromList . map rec + string = String . Text.pack + char = String . Text.pack . (:[]) + text = String -#if MIN_VERSION_aeson(0,7,0) - convertDouble = fmap (Number . fromFloatDigits) . pDouble - convertInt = fmap (Number . fromInteger) . pInt -#else - convertDouble = fmap (Number . D) . pDouble - convertInt = fmap (Number . I) . pInt -#endif +encodeGeneric :: GenericQ Value -> GenericQ Value +encodeGeneric rec x = + case constrName of + '(':(dropWhile (==',') -> ")") -> + Array $ Vector.fromList $ gmapQ rec x + _ -> Object $ Map.fromList $ map (first Text.pack) fields + where + fields = + ("instance", String $ Text.pack constrName) : + zip labels (gmapQ rec x) + constrName = showConstr constr + constr = toConstr x + -- Note: constrFields can throw errors for non-algebraic datatypes. These + -- ought to be taken care of in the other cases of encodeFay. + labels = case constrFields constr of + [] -> map (("slot"++).show) [1::Int ..] + ls -> ls - -- Number parsers - pDouble :: Show.Value -> Maybe Double - pDouble value = case value of - Show.Float str -> getDouble str - Show.Ratio x y -> liftM2 (on (/) fromIntegral) (pInt x) (pInt y) - Show.Neg str -> fmap (* (-1)) (pDouble str) - _ -> Nothing - pInt value = case value of - Show.Integer str -> getInt str - Show.Neg str -> fmap (* (-1)) (pInt str) - _ -> Nothing +-- | Convert a Fay json value to a Haskell value. +readFromFay :: Data a => Value -> Maybe a +readFromFay = either (\_ -> Nothing) Just . decodeFay (\_ -> id) - -- Number readers - getDouble :: String -> Maybe Double - getDouble = fmap fst . listToMaybe . readFloat - getInt :: String -> Maybe Integer - getInt = fmap fst . listToMaybe . readInt 10 isDigit charToInt - where charToInt c = fromEnum c - fromEnum '0' +-- | Convert a Fay json value to a Haskell value. This is like readFromFay, +-- except it yields helpful error messages on failure. +readFromFay' :: Data a => Value -> Either String a +readFromFay' = decodeFay (\_ -> id) - -- Utilities - string = String . Text.pack - slots = zipWithM keyval (map (("slot"++).show) [1::Int ..]) - keyval key val = fmap (Text.pack key,) (convert val) +-- | Convert a Fay json value to a Haskell value. +-- +-- The first parameter is a function that can be used to override the +-- conversion. This usually looks like using 'extR' to additional type- +-- specific cases. +decodeFay :: Data b + => (forall a. Data a => Value -> Either String a -> Either String a) + -> Value + -> Either String b +decodeFay specialCases value = specialCases value $ + parseDataOrTuple rec value + `extR` parseUnit value + `extR` parseBool value + `extR` parseInt value + `extR` parseFloat value + `extR` parseDouble value + `ext1R` parseArray rec value + `extR` parseString value + `extR` parseChar value + `extR` parseText value + where + rec :: GenericParser + rec = decodeFay specialCases --- | Convert a value representing a Fay value to a Haskell value. -readFromFay :: Data a => Value -> Maybe a -readFromFay value = - parseDataOrTuple value - `ext1R` parseArray value - `extR` parseDouble value - `extR` parseInt value - `extR` parseInteger value - `extR` parseBool value - `extR` parseString value - `extR` parseChar value - `extR` parseText value - `extR` parseUnit value +type GenericParser = Data a => Value -> Either String a -- | Parse a data type or record or tuple. -parseDataOrTuple :: Data a => Value -> Maybe a -parseDataOrTuple value = result where +parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a +parseDataOrTuple rec value = result where result = getAndParse value - typ = dataTypeOf (fromJust result) + typ = dataTypeOf (undefined :: a) getAndParse x = case x of - Object obj -> parseObject typ obj - Array tuple -> parseTuple typ tuple - _ -> mzero + Object obj -> parseObject rec typ obj + Array tuple -> parseTuple rec typ tuple + _ -> badData value -- | Parse a tuple. -parseTuple :: Data a => DataType -> Vector Value -> Maybe a -parseTuple typ arr = +parseTuple :: Data a => GenericParser -> DataType -> Vector Value -> Either String a +parseTuple rec typ arr = case dataTypeConstrs typ of [cons] -> evalStateT (fromConstrM (do i:next <- get put next value <- lift (Vector.indexM arr i) - lift (readFromFay value)) + lift (rec value)) cons) [0..] - _ -> Nothing + _ -> badData (Array arr) -- | Parse a data constructor from an object. -parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a -parseObject typ obj = listToMaybe (catMaybes choices) where - choices = map makeConstructor constructors - constructors = dataTypeConstrs typ - makeConstructor cons = do - name <- Map.lookup (Text.pack "instance") obj >>= parseString - guard (showConstr cons == name) - if null fields - then makeSimple obj cons - else makeRecord obj cons fields - - where fields = constrFields cons +parseObject :: Data a => GenericParser -> DataType -> HashMap Text Value -> Either String a +parseObject rec typ obj = + case Map.lookup (Text.pack "instance") obj of + Just (parseString -> Right name) -> + case filter (\con -> showConstr con == name) (dataTypeConstrs typ) of + [con] -> + let fields = constrFields con + in if null fields + then makeSimple rec obj con + else makeRecord rec obj con fields + _ -> badData (Object obj) + _ -> badData (Object obj) -- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2 -makeSimple :: Data a => HashMap Text Value -> Constr -> Maybe a -makeSimple obj cons = +makeSimple :: Data a => GenericParser -> HashMap Text Value -> Constr -> Either String a +makeSimple rec obj cons = evalStateT (fromConstrM (do i:next <- get put next - value <- lift (Map.lookup (Text.pack ("slot" ++ show i)) obj) - lift (readFromFay value)) + value <- lift (lookupField obj (Text.pack ("slot" ++ show i))) + lift (rec value)) cons) [1..] -- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 } -makeRecord :: Data a => HashMap Text Value -> Constr -> [String] -> Maybe a -makeRecord obj cons fields = +makeRecord :: Data a => GenericParser -> HashMap Text Value -> Constr -> [String] -> Either String a +makeRecord rec obj cons fields = evalStateT (fromConstrM (do key:next <- get put next - value <- lift (Map.lookup (Text.pack key) obj) - lift (readFromFay value)) + value <- lift (lookupField obj (Text.pack key)) + lift (rec value)) cons) fields --- | Parse a double. -parseDouble :: Value -> Maybe Double -parseDouble value = do - number <- parseNumber value - case number of - I n -> return (fromIntegral n) - D n -> return n +lookupField :: HashMap Text Value -> Text -> Either String Value +lookupField obj key = + justRight ("Missing field " ++ Text.unpack key ++ " in " ++ show (Object obj)) $ + Map.lookup key obj --- | Parse an int. -parseInt :: Value -> Maybe Int -parseInt value = do - number <- parseNumber value - case number of - I n -> return (fromIntegral n) - _ -> mzero +-- | Parse a float. +parseFloat :: Value -> Either String Float +parseFloat = parseEither parseJSON --- | Parse an integer. -parseInteger :: Value -> Maybe Integer -parseInteger value = do - number <- parseNumber value - case number of - I n -> return n - _ -> mzero +-- | Parse a double. +parseDouble :: Value -> Either String Double +parseDouble = parseEither parseJSON --- | Parse a number. -parseNumber :: Value -> Maybe Number -#if MIN_VERSION_aeson(0,7,0) -parseNumber value = case value of - Number n - | base10Exponent n >= 0 -> return . I . round $ n - | otherwise -> return . D . fromRational . toRational $ n - _ -> mzero -#else -parseNumber value = case value of - Number n -> return n - _ -> mzero -#endif +-- | Parse an int. +parseInt :: Value -> Either String Int +parseInt = parseEither parseJSON -- | Parse a bool. -parseBool :: Value -> Maybe Bool +parseBool :: Value -> Either String Bool parseBool value = case value of Bool n -> return n - _ -> mzero + _ -> badData value -- | Parse a string. -parseString :: Value -> Maybe String +parseString :: Value -> Either String String parseString value = case value of String s -> return (Text.unpack s) - _ -> mzero + _ -> badData value -- | Parse a char. -parseChar :: Value -> Maybe Char +parseChar :: Value -> Either String Char parseChar value = case value of String s | Just (c,_) <- Text.uncons s -> return c - _ -> mzero + _ -> badData value -- | Parse a Text. -parseText :: Value -> Maybe Text +parseText :: Value -> Either String Text parseText value = case value of String s -> return s - _ -> mzero + _ -> badData value -- | Parse an array. -parseArray :: Data a => Value -> Maybe [a] -parseArray value = case value of - Array xs -> mapM readFromFay (Vector.toList xs) - _ -> mzero +parseArray :: Data a => GenericParser -> Value -> Either String [a] +parseArray rec value = case value of + Array xs -> mapM rec (Vector.toList xs) + _ -> badData value -- | Parse unit. -parseUnit :: Value -> Maybe () +parseUnit :: Value -> Either String () parseUnit value = case value of Null -> return () - _ -> mzero + _ -> badData value + +badData :: forall a. Data a => Value -> Either String a +badData value = Left $ + "Bad data in decodeFay - expected valid " ++ + show (typeOf (undefined :: a)) ++ + ", but got:\n" ++ + show value + +justRight :: b -> Maybe a -> Either b a +justRight x Nothing = Left x +justRight _ (Just y) = Right y diff --git a/src/Fay/Data/List/Extra.hs b/src/Fay/Data/List/Extra.hs deleted file mode 100644 --- a/src/Fay/Data/List/Extra.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | Extra list functions. - -module Fay.Data.List.Extra where - -import Data.List hiding (map) -import Prelude hiding (map) - --- | Get the union of a list of lists. -unionOf :: (Eq a) => [[a]] -> [a] -unionOf = foldr union [] - --- | Flip of map. -for :: (Functor f) => f a -> (a -> b) -> f b -for = flip fmap diff --git a/src/Fay/Exts.hs b/src/Fay/Exts.hs --- a/src/Fay/Exts.hs +++ b/src/Fay/Exts.hs @@ -46,7 +46,7 @@ moduleExports :: A.Module X -> Maybe (A.ExportSpecList X) moduleExports (A.Module _ (Just (A.ModuleHead _ _ _ e)) _ _ _) = e moduleExports (A.Module _ Nothing _ _ _) = Nothing -moduleExports m = error $ ("moduleExports: " ++ A.prettyPrint m) +moduleExports m = error $ "moduleExports: " ++ A.prettyPrint m moduleNameString :: A.ModuleName t -> String moduleNameString (A.ModuleName _ n) = n diff --git a/src/Fay/Exts/NoAnnotation.hs b/src/Fay/Exts/NoAnnotation.hs --- a/src/Fay/Exts/NoAnnotation.hs +++ b/src/Fay/Exts/NoAnnotation.hs @@ -2,9 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} module Fay.Exts.NoAnnotation where +import Fay.Compiler.Prelude -import Data.Char (isAlpha) -import Data.List (intercalate) import Data.List.Split (splitOn) import Data.String import qualified Language.Haskell.Exts.Annotated as A @@ -46,7 +45,7 @@ type Type = A.Type () unAnn :: Functor f => f a -> f () -unAnn = fmap (const ()) +unAnn = void -- | Helpful for some things. instance IsString (A.Name ()) where diff --git a/src/Fay/System/Directory/Extra.hs b/src/Fay/System/Directory/Extra.hs deleted file mode 100644 --- a/src/Fay/System/Directory/Extra.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Extra directory functions. -module Fay.System.Directory.Extra where - -import Control.Monad (forM) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath (()) - --- | Get all files in a folder and its subdirectories. --- Taken from Real World Haskell --- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html -getRecursiveContents :: FilePath -> IO [FilePath] -getRecursiveContents topdir = do - names <- getDirectoryContents topdir - let properNames = filter (`notElem` [".", ".."]) names - paths <- forM properNames $ \name -> do - let path = topdir name - isDirectory <- doesDirectoryExist path - if isDirectory - then getRecursiveContents path - else return [path] - return (concat paths) diff --git a/src/Fay/System/Process/Extra.hs b/src/Fay/System/Process/Extra.hs deleted file mode 100644 --- a/src/Fay/System/Process/Extra.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | Extra process functions. - -module Fay.System.Process.Extra where - -import System.Exit -import System.Process - --- | Read from a process returning both std err and out. -readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String)) -readAllFromProcess program flags input = do - (code,out,err) <- readProcessWithExitCode program flags input - return $ case code of - ExitFailure 127 -> Left ("cannot find executable " ++ program, "") - ExitFailure _ -> Left (err, out) - ExitSuccess -> Right (err, out) diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -10,16 +10,16 @@ ,JsName(..) ,CompileError(..) ,Compile(..) - ,CompileResult ,CompileModule ,Printable(..) ,Fay ,CompileReader(..) ,CompileWriter(..) - ,CompileConfig(..) + ,Config(..) ,CompileState(..) ,FundamentalType(..) ,PrintState(..) + ,defaultPrintState ,Printer(..) ,SerializeContext(..) ,ModulePath (unModulePath) @@ -28,75 +28,29 @@ ,mkModulePathFromQName ) where -import Fay.Compiler.QName -import qualified Fay.Exts as F +import Fay.Compiler.Prelude + +import Fay.Config import qualified Fay.Exts.NoAnnotation as N import qualified Fay.Exts.Scoped as S +import Fay.Types.CompileError +import Fay.Types.FFI +import Fay.Types.Js +import Fay.Types.ModulePath -import Control.Applicative -import Control.Monad.Error (Error, ErrorT, MonadError) +import Control.Monad.Error (ErrorT, MonadError) import Control.Monad.Identity (Identity) import Control.Monad.RWS import Control.Monad.State -import Data.Default -import Data.List -import Data.List.Split import Data.Map (Map) import Data.Set (Set) -import Data.String import Distribution.HaskellSuite.Modules -import Language.Haskell.Exts.Annotated import Language.Haskell.Names (Symbols) import SourceMap.Types -------------------------------------------------------------------------------- -- Compiler types --- | Configuration of the compiler. -data CompileConfig = CompileConfig - { configOptimize :: Bool -- ^ Run optimizations - , configFlattenApps :: Bool -- ^ Flatten function application? - , configExportRuntime :: Bool -- ^ Export the runtime? - , configExportStdlib :: Bool -- ^ Export the stdlib? - , configExportStdlibOnly :: Bool -- ^ Export /only/ the stdlib? - , configDirectoryIncludes :: [(Maybe String, FilePath)] -- ^ Possibly a fay package name, and a include directory. - , configPrettyPrint :: Bool -- ^ Pretty print the JS output? - , configHtmlWrapper :: Bool -- ^ Output a HTML file including the produced JS. - , configSourceMap :: Bool -- ^ Output a source map file as outfile.map. - , configHtmlJSLibs :: [FilePath] -- ^ Any JS files to link to in the HTML. - , configLibrary :: Bool -- ^ Don't invoke main in the produced JS. - , configWarn :: Bool -- ^ Warn on dubious stuff, not related to typechecking. - , configFilePath :: Maybe FilePath -- ^ File path to output to. - , configTypecheck :: Bool -- ^ Typecheck with GHC. - , configWall :: Bool -- ^ Typecheck with -Wall. - , configGClosure :: Bool -- ^ Run Google Closure on the produced JS. - , configPackageConf :: Maybe FilePath -- ^ The package config e.g. packages-6.12.3. - , configPackages :: [String] -- ^ Included Fay packages. - , configBasePath :: Maybe FilePath -- ^ Custom source location for fay-base - , configStrict :: [String] -- ^ Produce strict and uncurried wrappers for all functions with type signatures in the given module - , configTypecheckOnly :: Bool -- ^ Only invoke GHC for typechecking, don't produce any output - , configRuntimePath :: Maybe FilePath - } deriving (Show) - --- | The name of a module split into a list for code generation. -newtype ModulePath = ModulePath { unModulePath :: [String] } - deriving (Eq, Ord, Show) - --- | Construct the complete ModulePath from a ModuleName. -mkModulePath :: ModuleName a -> ModulePath -mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m - --- | Construct intermediate module paths from a ModuleName. --- mkModulePaths "A.B" => [["A"], ["A","B"]] -mkModulePaths :: ModuleName a -> [ModulePath] -mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m - --- | Converting a QName to a ModulePath is only relevant for constructors since --- they can conflict with module names. -mkModulePathFromQName :: QName a -> ModulePath -mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n -mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name" - -- | State of the compiler. data CompileState = CompileState -- TODO Change N.QName to GName? They can never be special so it would simplify. @@ -117,8 +71,7 @@ { writerCons :: [JsStmt] -- ^ Constructors. , writerFayToJs :: [(String,JsExp)] -- ^ Fay to JS dispatchers. , writerJsToFay :: [(String,JsExp)] -- ^ JS to Fay dispatchers. - } - deriving (Show) + } deriving (Show) -- | Simple concatenating instance. instance Monoid CompileWriter where @@ -128,43 +81,34 @@ -- | Configuration and globals for the compiler. data CompileReader = CompileReader - { readerConfig :: CompileConfig -- ^ The compilation configuration. + { readerConfig :: Config -- ^ The compilation configuration. , readerCompileLit :: S.Literal -> Compile JsExp , readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt] } -- | Compile monad. newtype Compile a = Compile - { unCompile :: (RWST CompileReader - CompileWriter - CompileState - (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO))) - a -- ^ Uns the compiler - } - deriving (MonadState CompileState - ,MonadError CompileError - ,MonadReader CompileReader - ,MonadWriter CompileWriter - ,MonadIO - ,Monad - ,Functor - ,Applicative - ) - -type CompileResult a - = Either CompileError - (a, CompileState, CompileWriter) + { unCompile :: RWST CompileReader CompileWriter CompileState + (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO)) + a -- ^ Uns the compiler + } deriving + ( Applicative + , Functor + , Monad + , MonadError CompileError + , MonadIO + , MonadReader CompileReader + , MonadState CompileState + , MonadWriter CompileWriter + ) -type CompileModule a - = ModuleT Symbols - IO - (CompileResult a) +type CompileModule a = ModuleT Symbols IO (Either CompileError (a, CompileState, CompileWriter)) instance MonadModule Compile where type ModuleInfo Compile = Symbols lookupInCache = liftModuleT . lookupInCache insertInCache n m = liftModuleT $ insertInCache n m - getPackages = liftModuleT $ getPackages + getPackages = liftModuleT getPackages readModuleInfo fps n = liftModuleT $ readModuleInfo fps n liftModuleT :: ModuleT Symbols IO a -> Compile a @@ -182,163 +126,26 @@ } -- | Default state. -instance Default PrintState where - def = PrintState False 0 0 [] 0 [] False +defaultPrintState :: PrintState +defaultPrintState = PrintState False 0 0 [] 0 [] False -- | The printer monad. newtype Printer a = Printer { runPrinter :: State PrintState a } - deriving (Applicative,Monad,Functor,MonadState PrintState) + deriving + ( Applicative + , Functor + , Monad + , MonadState PrintState + ) -- | Print some value. class Printable a where printJS :: a -> Printer () --- | Error type. -data CompileError - = Couldn'tFindImport N.ModuleName [FilePath] - | EmptyDoBlock - | FfiFormatBadChars SrcSpanInfo String - | FfiFormatIncompleteArg SrcSpanInfo - | FfiFormatInvalidJavaScript SrcSpanInfo String String - | FfiFormatNoSuchArg SrcSpanInfo Int - | FfiNeedsTypeSig S.Exp - | GHCError String - | InvalidDoBlock - | ParseError S.SrcLoc String - | ShouldBeDesugared String - | UnableResolveQualified N.QName - | UnsupportedDeclaration S.Decl - | UnsupportedEnum N.Exp - | UnsupportedExportSpec N.ExportSpec - | UnsupportedExpression S.Exp - | UnsupportedFieldPattern S.PatField - | UnsupportedImport F.ImportDecl - | UnsupportedLet - | UnsupportedLetBinding S.Decl - | UnsupportedLiteral S.Literal - | UnsupportedModuleSyntax String F.Module - | UnsupportedPattern S.Pat - | UnsupportedQualStmt S.QualStmt - | UnsupportedRecursiveDo - | UnsupportedRhs S.Rhs - | UnsupportedWhereInAlt S.Alt - | UnsupportedWhereInMatch S.Match - deriving (Show) -instance Error CompileError - -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a) - deriving (Applicative,Functor,Monad) - --------------------------------------------------------------------------------- --- JS AST types - --- | Statement type. -data JsStmt - = JsVar JsName JsExp - | JsIf JsExp [JsStmt] [JsStmt] - | JsEarlyReturn JsExp - | JsThrow JsExp - | JsWhile JsExp [JsStmt] - | JsUpdate JsName JsExp - | JsSetProp JsName JsName JsExp - | JsSetQName (Maybe SrcSpan) N.QName JsExp - | JsSetModule ModulePath JsExp - | JsSetConstructor N.QName JsExp - | JsSetPropExtern JsName JsName JsExp - | JsContinue - | JsBlock [JsStmt] - | JsExpStmt JsExp - deriving (Show,Eq) - --- | Expression type. -data JsExp - = JsName JsName - | JsRawExp String - | JsSeq [JsExp] - | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp) - | JsLit JsLit - | JsApp JsExp [JsExp] - | JsNegApp JsExp - | JsTernaryIf JsExp JsExp JsExp - | JsNull - | JsParen JsExp - | JsGetProp JsExp JsName - | JsLookup JsExp JsExp - | JsUpdateProp JsExp JsName JsExp - | JsGetPropExtern JsExp String - | JsUpdatePropExtern JsExp JsName JsExp - | JsList [JsExp] - | JsNew JsName [JsExp] - | JsThrowExp JsExp - | JsInstanceOf JsExp JsName - | JsIndex Int JsExp - | JsEq JsExp JsExp - | JsNeq JsExp JsExp - | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc - | JsObj [(String,JsExp)] - | JsLitObj [(N.Name,JsExp)] - | JsUndefined - | JsAnd JsExp JsExp - | JsOr JsExp JsExp - deriving (Show,Eq) - --- | A name of some kind. -data JsName - = JsNameVar N.QName - | JsThis - | JsParametrizedType - | JsThunk - | JsForce - | JsApply - | JsParam Integer - | JsTmp Integer - | JsConstructor N.QName - | JsBuiltIn N.Name - | JsModuleName N.ModuleName - deriving (Eq,Show) - --- | Literal value type. -data JsLit - = JsChar Char - | JsStr String - | JsInt Int - | JsFloating Double - | JsBool Bool - deriving (Show,Eq) - --- | Just handy to have. -instance IsString JsLit where fromString = JsStr - --- | These are the data types that are serializable directly to native --- JS data types. Strings, floating points and arrays. The others are: --- actions in the JS monad, which are thunks that shouldn't be forced --- when serialized but wrapped up as JS zero-arg functions, and --- unknown types can't be converted but should at least be forced. -data FundamentalType - -- Recursive types. - = FunctionType [FundamentalType] - | JsType FundamentalType - | ListType FundamentalType - | TupleType [FundamentalType] - | UserDefined N.Name [FundamentalType] - | Defined FundamentalType - | Nullable FundamentalType - -- Simple types. - | DateType - | StringType - | DoubleType - | IntType - | BoolType - | PtrType - -- Automatically serialize this type. - | Automatic - -- Unknown. - | UnknownType - deriving (Show) - --- | The serialization context indicates whether we're currently --- serializing some value or a particular field in a user-defined data --- type. -data SerializeContext = SerializeAnywhere | SerializeUserArg Int - deriving (Read,Show,Eq) + deriving + ( Applicative + , Functor + , Monad + ) diff --git a/src/Fay/Types/CompileError.hs b/src/Fay/Types/CompileError.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/CompileError.hs @@ -0,0 +1,41 @@ +module Fay.Types.CompileError (CompileError (..)) where + +import qualified Fay.Exts as F +import qualified Fay.Exts.NoAnnotation as N +import qualified Fay.Exts.Scoped as S + +import Control.Monad.Error (Error) +import Language.Haskell.Exts.Annotated + +-- | Error type. +data CompileError + = Couldn'tFindImport N.ModuleName [FilePath] + | EmptyDoBlock + | FfiFormatBadChars SrcSpanInfo String + | FfiFormatIncompleteArg SrcSpanInfo + | FfiFormatInvalidJavaScript SrcSpanInfo String String + | FfiFormatNoSuchArg SrcSpanInfo Int + | FfiNeedsTypeSig S.Exp + | GHCError String + | InvalidDoBlock + | ParseError S.SrcLoc String + | ShouldBeDesugared String + | UnableResolveQualified N.QName + | UnsupportedDeclaration S.Decl + | UnsupportedEnum N.Exp + | UnsupportedExportSpec N.ExportSpec + | UnsupportedExpression S.Exp + | UnsupportedFieldPattern S.PatField + | UnsupportedImport F.ImportDecl + | UnsupportedLet + | UnsupportedLetBinding S.Decl + | UnsupportedLiteral S.Literal + | UnsupportedModuleSyntax String F.Module + | UnsupportedPattern S.Pat + | UnsupportedQualStmt S.QualStmt + | UnsupportedRecursiveDo + | UnsupportedRhs S.Rhs + | UnsupportedWhereInAlt S.Alt + | UnsupportedWhereInMatch S.Match + deriving (Show) +instance Error CompileError diff --git a/src/Fay/Types/CompileResult.hs b/src/Fay/Types/CompileResult.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/CompileResult.hs @@ -0,0 +1,9 @@ +module Fay.Types.CompileResult (CompileResult (..)) where + +import SourceMap.Types + +data CompileResult = CompileResult + { resOutput :: String + , resImported :: [(String, FilePath)] + , resSourceMappings :: Maybe [Mapping] + } deriving Show diff --git a/src/Fay/Types/FFI.hs b/src/Fay/Types/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/FFI.hs @@ -0,0 +1,40 @@ + +module Fay.Types.FFI + ( FundamentalType (..) + , SerializeContext (..) + ) where + +import qualified Fay.Exts.NoAnnotation as N + +-- | These are the data types that are serializable directly to native +-- JS data types. Strings, floating points and arrays. The others are: +-- actions in the JS monad, which are thunks that shouldn't be forced +-- when serialized but wrapped up as JS zero-arg functions, and +-- unknown types can't be converted but should at least be forced. +data FundamentalType + -- Recursive types. + = FunctionType [FundamentalType] + | JsType FundamentalType + | ListType FundamentalType + | TupleType [FundamentalType] + | UserDefined N.Name [FundamentalType] + | Defined FundamentalType + | Nullable FundamentalType + -- Simple types. + | DateType + | StringType + | DoubleType + | IntType + | BoolType + | PtrType + -- Automatically serialize this type. + | Automatic + -- Unknown. + | UnknownType + deriving (Show) + +-- | The serialization context indicates whether we're currently +-- serializing some value or a particular field in a user-defined data +-- type. +data SerializeContext = SerializeAnywhere | SerializeUserArg Int + deriving (Eq, Read, Show) diff --git a/src/Fay/Types/Js.hs b/src/Fay/Types/Js.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/Js.hs @@ -0,0 +1,91 @@ +-- | JS AST types + +module Fay.Types.Js + ( JsStmt (..) + , JsExp (..) + , JsLit (..) + , JsName (..) + ) where + +import qualified Fay.Exts.NoAnnotation as N +import Fay.Types.ModulePath + +import Data.String +import Language.Haskell.Exts.Annotated + +-- | Statement type. +data JsStmt + = JsVar JsName JsExp + | JsIf JsExp [JsStmt] [JsStmt] + | JsEarlyReturn JsExp + | JsThrow JsExp + | JsWhile JsExp [JsStmt] + | JsUpdate JsName JsExp + | JsSetProp JsName JsName JsExp + | JsSetQName (Maybe SrcSpan) N.QName JsExp + | JsSetModule ModulePath JsExp + | JsSetConstructor N.QName JsExp + | JsSetPropExtern JsName JsName JsExp + | JsContinue + | JsBlock [JsStmt] + | JsExpStmt JsExp + deriving (Show,Eq) + +-- | Expression type. +data JsExp + = JsName JsName + | JsRawExp String + | JsSeq [JsExp] + | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp) + | JsLit JsLit + | JsApp JsExp [JsExp] + | JsNegApp JsExp + | JsTernaryIf JsExp JsExp JsExp + | JsNull + | JsParen JsExp + | JsGetProp JsExp JsName + | JsLookup JsExp JsExp + | JsUpdateProp JsExp JsName JsExp + | JsGetPropExtern JsExp String + | JsUpdatePropExtern JsExp JsName JsExp + | JsList [JsExp] + | JsNew JsName [JsExp] + | JsThrowExp JsExp + | JsInstanceOf JsExp JsName + | JsIndex Int JsExp + | JsEq JsExp JsExp + | JsNeq JsExp JsExp + | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc + | JsObj [(String,JsExp)] + | JsLitObj [(N.Name,JsExp)] + | JsUndefined + | JsAnd JsExp JsExp + | JsOr JsExp JsExp + deriving (Eq, Show) + +-- | A name of some kind. +data JsName + = JsNameVar N.QName + | JsThis + | JsParametrizedType + | JsThunk + | JsForce + | JsApply + | JsParam Integer + | JsTmp Integer + | JsConstructor N.QName + | JsBuiltIn N.Name + | JsModuleName N.ModuleName + deriving (Eq, Show) + +-- | Literal value type. +data JsLit + = JsChar Char + | JsStr String + | JsInt Int + | JsFloating Double + | JsBool Bool + deriving (Eq, Show) + +-- | Just handy to have. +instance IsString JsLit where fromString = JsStr diff --git a/src/Fay/Types/ModulePath.hs b/src/Fay/Types/ModulePath.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/ModulePath.hs @@ -0,0 +1,32 @@ +module Fay.Types.ModulePath + ( ModulePath (..) + , mkModulePath + , mkModulePaths + , mkModulePathFromQName + ) where + +import Fay.Compiler.QName +import qualified Fay.Exts as F + +import Data.List +import Data.List.Split +import Language.Haskell.Exts.Annotated + +-- | The name of a module split into a list for code generation. +newtype ModulePath = ModulePath { unModulePath :: [String] } + deriving (Eq, Ord, Show) + +-- | Construct the complete ModulePath from a ModuleName. +mkModulePath :: ModuleName a -> ModulePath +mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m + +-- | Construct intermediate module paths from a ModuleName. +-- mkModulePaths "A.B" => [["A"], ["A","B"]] +mkModulePaths :: ModuleName a -> [ModulePath] +mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m + +-- | Converting a QName to a ModulePath is only relevant for constructors since +-- they can conflict with module names. +mkModulePathFromQName :: QName a -> ModulePath +mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n +mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name" diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1,19 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -- | Main compiler executable. module Main where import Fay -import Fay.Compiler.Config -import Paths_fay (version) +import Paths_fay (version) -import qualified Control.Exception as E +import qualified Control.Exception as E import Control.Monad -import Data.Default -import Data.List.Split (wordsBy) +import Data.List.Split (wordsBy) import Data.Maybe -import Data.Version (showVersion) +import Data.Version (showVersion) import Options.Applicative import Options.Applicative.Types import System.Environment @@ -53,7 +49,7 @@ packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment opts <- execParser parser let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $ - addConfigPackages (optPackages opts) $ def + addConfigPackages (optPackages opts) $ defaultConfig { configOptimize = optOptimize opts , configFlattenApps = optFlattenApps opts , configPrettyPrint = optPretty opts diff --git a/src/tests/Test/CommandLine.hs b/src/tests/Test/CommandLine.hs --- a/src/tests/Test/CommandLine.hs +++ b/src/tests/Test/CommandLine.hs @@ -2,20 +2,17 @@ module Test.CommandLine (tests) where -import Fay.System.Process.Extra +import Fay.Compiler.Prelude +import Test.Util -import Control.Applicative -import Data.Maybe import System.Directory import System.Environment import System.FilePath -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.TH -import Test.HUnit (Assertion, assertBool) -import Test.Util +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH -tests :: Test +tests :: TestTree tests = $testGroupGenerator compileFile :: [String] -> IO (Either String String) diff --git a/src/tests/Test/Compile.hs b/src/tests/Test/Compile.hs --- a/src/tests/Test/Compile.hs +++ b/src/tests/Test/Compile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -5,23 +6,18 @@ module Test.Compile (tests) where import Fay -import Fay.Compiler.Config -import Fay.System.Process.Extra -import Fay.Types () +import Fay.Compiler.Prelude +#if !MIN_VERSION_base(4,7,0) +import Test.Util (isRight) +#endif -import Control.Applicative -import Control.Monad -import Data.Default -import Data.Maybe import Language.Haskell.Exts.Annotated import System.Environment -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.TH -import Test.HUnit (Assertion, assertBool, assertEqual, assertFailure) -import Test.Util +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH -tests :: Test +tests :: TestTree tests = $testGroupGenerator case_imports :: Assertion @@ -92,16 +88,16 @@ case_strictWrapper = do whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs" - (\a b -> either a b res) (assertFailure . show) $ \(js,_) -> do + (\a b -> either a b res) (assertFailure . show) $ \js -> do writeFile "tests/Compile/StrictWrapper.js" js (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/StrictWrapper.js"] "" when (err /= "") $ assertFailure err expected <- readFile "tests/Compile/StrictWrapper.res" assertEqual "strictWrapper node stdout" expected out -defConf :: CompileConfig +defConf :: Config defConf = addConfigDirectoryIncludePaths ["tests/"] - $ def { configTypecheck = False } + $ defaultConfig { configTypecheck = False } case_charEnum :: Assertion case_charEnum = do @@ -110,4 +106,4 @@ case res of Left UnsupportedEnum{} -> return () Left l -> assertFailure $ "Should have failed with UnsupportedEnum, but failed with: " ++ show l - Right _ -> assertFailure $ "Should have failed with UnsupportedEnum, but compiled" + Right _ -> assertFailure "Should have failed with UnsupportedEnum, but compiled" diff --git a/src/tests/Test/Convert.hs b/src/tests/Test/Convert.hs --- a/src/tests/Test/Convert.hs +++ b/src/tests/Test/Convert.hs @@ -3,19 +3,18 @@ module Test.Convert (tests) where +import Fay.Convert + import qualified Data.Aeson.Parser as Aeson import Data.Attoparsec.ByteString import qualified Data.ByteString as Bytes import qualified Data.ByteString.UTF8 as UTF8 import Data.Data -import Data.Ratio import Data.Text (Text, pack) -import Fay.Convert -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit (assertEqual) +import Test.Tasty +import Test.Tasty.HUnit -tests :: Test +tests :: TestTree tests = testGroup "Test.Convert" [reading, showing] where reading = testGroup "reading" $ flip map readTests $ \(ReadTest value) -> @@ -35,7 +34,7 @@ -- Test cases -- | A test. -data Testcase = forall x. Show x => Testcase x Bytes.ByteString +data Testcase = forall x. (Show x,Data x) => Testcase x Bytes.ByteString -- | A read test. data ReadTest = forall x. (Data x,Show x,Eq x,Read x) => ReadTest x @@ -69,9 +68,10 @@ showTests = -- Fundamental data types [(1 :: Int) → "1" + ,(1 :: Float) → "1.0" + ,(1/2 :: Float) → "0.5" ,(1 :: Double) → "1.0" ,(1/2 :: Double) → "0.5" - ,(1%2 :: Rational) → "0.5" ,([1,2] :: [Int]) → "[1,2]" ,((1,2) :: (Int,Int)) → "[1,2]" ,"abc" → "\"abc\"" @@ -122,7 +122,7 @@ -- | Labelled record. data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double } - | LabelledRecord2 { bar :: Int, bob :: Double } + | LabelledRecord2 { bar :: Int, bob :: Float } deriving (Show,Data,Typeable,Read,Eq) -- | Order matters in unlabelled constructors. diff --git a/src/tests/Test/Desugar.hs b/src/tests/Test/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test/Desugar.hs @@ -0,0 +1,161 @@ +module Test.Desugar + ( tests + , devTest + , parseE + , parseM + , des + ) where + +import Fay.Compiler.Prelude + +import Fay.Compiler.Desugar +import Fay.Compiler.Parse (parseFay) +import Fay.Types.CompileError (CompileError (..)) + +import Language.Haskell.Exts.Annotated hiding (alt, binds, loc, name) +import Test.Tasty +import Test.Tasty.HUnit +import Text.Groom + +tests :: TestTree +tests = testGroup "desugar" $ map (\(T k a b) -> testCase k $ doDesugar k a b) testDeclarations + +data DesugarTest = T String String String + +testDeclarations :: [DesugarTest] +testDeclarations = + [T "LambdaCase" + "import Prelude; f = \\gen0 -> case gen0 of { _ -> 2 }" + "import Prelude; f = \\case { _ -> 2 }" + ,T "MultiWayIf" + "import Prelude; f = case () of { _ | True -> 1 | False -> 2 }" + "import Prelude; f = if | True -> 1 | False -> 2" + ,T "TupleCon" + "import Prelude; f = \\gen0 gen1 gen2 -> (gen0, gen1, gen2)" + "import Prelude; f = (,,)" + ,T "Do" + "import Prelude; f = (>>=) x (\\gen0 -> (>>) y z)" + "import Prelude; f = do { gen0 <- x; y; z }" + ,T "TupleSection" + "import Prelude; f = \\gen0 gen1 -> (gen0,2,gen1)" + "import Prelude; f = (,2,)" + ,T "ImplicitPrelude1" -- Add missing Prelude import + "import Prelude" + "" + ,T "ImplicitPrelude2" -- Keep existing Prelude import + "import Prelude ()" + "import Prelude ()" + ,T "ImplicitPrelude3" -- Keep existing qualified import + "import qualified Prelude" + "import qualified Prelude" + ,T "NoImplicitPrelude" + "{-# LANGUAGE NoImplicitPrelude #-}" + "{-# LANGUAGE NoImplicitPrelude #-}" + ,T "OperatorSectionRight" + "import Prelude; f = \\gen0 -> g gen0 x" + "import Prelude; f = (`g` x)" + ,T "OperatorSectionLeft" + "import Prelude; f = \\gen0 -> g x gen0" + "import Prelude; f = (x `g`)" + ,T "InfixOpOp" + "import Prelude; f = (+) x y" + "import Prelude; f = x + y" + ,T "InfixOpFun" + "import Prelude; f = g x y" + "import Prelude; f = x `g` y" + ,T "InfixOpCons" + "import Prelude; f = (:) x y" + "import Prelude; f = x : y" + ,T "ExpParen" + "import Prelude; f = x y" + "import Prelude; f = (x (y))" + ,T "PatParen" + "import Prelude; f x = y" + "import Prelude; f (x) = y" + ,T "PatInfixOp" + "import Prelude; f ((:) x y) = z" + "import Prelude; f (x : y) = z" + ,T "PatFieldPun" + "import Prelude; f R { x = x } = y" + "import Prelude; f R { x } = y" + ,T "PatField" + "import Prelude; f = R { x = x }" + "import Prelude; f = R { x }" + ,T "FFITopLevel" + "import Prelude; f :: Int; f = ffi \"1\" :: Int" + "import Prelude; f :: Int; f = ffi \"1\"" + ,T "FFIWhere" + "import Prelude; f = () where x :: Int; x = ffi \"1\" :: Int" + "import Prelude; f = () where x :: Int; x = ffi \"1\"" + ] + +parseAndDesugar :: String -> String -> IO (Module SrcLoc, Either CompileError (Module SrcLoc)) +parseAndDesugar name s = + case parseFay "test" s :: ParseResult (Module SrcLoc) of + ParseFailed a b -> error $ show (name, a, b) + ParseOk m -> do + d <- desugar' "gen" noLoc m + return (m,d) + +doDesugar :: String -> String -> String -> Assertion +doDesugar testName a b = do + (originalExpected, desugaredExpected, desugared) <- parseAndDesugarAll testName a b + assertEqual "identity" (unAnn originalExpected) (unAnn desugaredExpected) + assertEqual "desugared" (unAnn originalExpected) (unAnn desugared ) + assertEqual "both" (unAnn desugared ) (unAnn desugaredExpected) + +parseAndDesugarAll :: String -> String -> String -> IO (Module SrcLoc, Module SrcLoc, Module SrcLoc) +parseAndDesugarAll testName a b = do + (originalExpected',Right desugaredExpected) <- parseAndDesugar (testName ++ " expected") a + (_ ,Right desugared ) <- parseAndDesugar (testName ++ " input") b + -- We need to desugar parens in the original module since we + -- strip it away in desugaring but there isn't alawys a way to construct + -- this paren directly from a source string + let originalExpected = desugarPatParen . desugarExpParen $ originalExpected' + return (originalExpected, desugaredExpected, desugared) + +-- When developing: + +devTest :: String -> IO () +devTest nam = do + let (T _ a b) = fromJust (find (\(T n _ _) -> n == nam) testDeclarations) + (originalExpected, desugaredExpected, desugared) <- parseAndDesugarAll "" a b + if unAnn desugared == unAnn desugaredExpected && unAnn desugared == unAnn originalExpected + then putStrLn "OK" + else do + putStrLn "--- originalExpected" + g $ unAnn originalExpected + putStrLn "--- desugaredExpected" + g $ unAnn desugaredExpected + putStrLn "--- desugared" + g $ unAnn desugared + putStrLn "--- originalExpected" + pretty originalExpected + putStrLn "--- desugaredExpected" + pretty desugaredExpected + putStrLn "--- desugared" + pretty desugared + when (unAnn originalExpected /= unAnn desugaredExpected) $ putStrLn "originalExpected /= desugaredExpected" + when (unAnn desugared /= unAnn desugaredExpected) $ putStrLn "desugared /= desugaredExpected" + when (unAnn desugared /= unAnn originalExpected ) $ putStrLn "desugared /= originalExpected" + when (unAnn desugaredExpected /= unAnn originalExpected ) $ putStrLn "desugaredExpected /= undesugared" + +g :: Show a => a -> IO () +g = putStrLn . groom + +unAnn :: Functor f => f a -> f () +unAnn = void + +pretty :: Module SrcLoc -> IO () +pretty = putStrLn . prettyPrint + +parseM :: String -> Module () +parseM s = let ParseOk m = parseFay "module" s :: ParseResult (Module SrcSpanInfo) in unAnn m + +parseE :: String -> Exp () +parseE s = let ParseOk m = parseFay "exp" s :: ParseResult (Exp SrcSpanInfo) in unAnn m + +des :: String -> IO () +des s = do + Right r <- desugar' "gen" () $ parseM s + g r diff --git a/src/tests/Test/Util.hs b/src/tests/Test/Util.hs --- a/src/tests/Test/Util.hs +++ b/src/tests/Test/Util.hs @@ -1,14 +1,16 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} module Test.Util ( fayPath , isRight , fromLeft + , getRecursiveContents ) where -import Fay.System.Process.Extra (readAllFromProcess) +import Fay.Compiler.Prelude -import Control.Applicative -import Prelude hiding (pred) import System.Directory +import System.FilePath -- Path to the fay executable, looks in cabal-dev, dist, PATH in that order. fayPath :: IO (Maybe FilePath) @@ -20,20 +22,37 @@ usingWhich = fmap (concat . lines . snd) . hush <$> readAllFromProcess "which" ["fay"] "" firstWhereM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a) -firstWhereM pred ins = case ins of +firstWhereM p ins = case ins of [] -> return Nothing - a:as -> pred a >>= \b -> + a:as -> p a >>= \b -> if b then return (Just a) - else firstWhereM pred as + else firstWhereM p as -- from the package `errors` hush :: Either a b -> Maybe b hush = either (const Nothing) Just -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight (Left _) = False - fromLeft :: Either a b -> a fromLeft (Left a) = a fromLeft (Right _) = error "fromLeft got Right" + +-- | Get all files in a folder and its subdirectories. +-- Taken from Real World Haskell +-- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html +getRecursiveContents :: FilePath -> IO [FilePath] +getRecursiveContents topdir = do + names <- getDirectoryContents topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents path + else return [path] + return (concat paths) + +#if !MIN_VERSION_base(4,7,0) +isRight :: Either a b -> Bool +isRight Right{} = True +isRight Left{} = False +#endif diff --git a/src/tests/Tests.hs b/src/tests/Tests.hs --- a/src/tests/Tests.hs +++ b/src/tests/Tests.hs @@ -8,25 +8,18 @@ module Main where import Fay -import Fay.Compiler.Config -import Fay.System.Directory.Extra -import Fay.System.Process.Extra +import Fay.Compiler.Prelude +import qualified Test.CommandLine as Cmd +import qualified Test.Compile as Compile +import qualified Test.Convert as Convert +import qualified Test.Desugar as Desugar +import Test.Util -import Control.Applicative -import Data.Char -import Data.Default -import Data.List -import Data.Maybe -import Data.Ord import System.Directory import System.Environment import System.FilePath -import qualified Test.CommandLine as Cmd -import qualified Test.Compile as Compile -import qualified Test.Convert as C -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit (assertEqual, assertFailure) +import Test.Tasty +import Test.Tasty.HUnit -- | Main test runner. main :: IO () @@ -35,15 +28,21 @@ (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs let (basePath,args') = prefixed (=="-base-path") args (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath - defaultMainWithArgs [Compile.tests, Cmd.tests, runtime, codegen, C.tests] - args' + withArgs args' $ defaultMain $ testGroup "Fay" + [ Desugar.tests + , Convert.tests + , codegen + , Cmd.tests + , Compile.tests + , runtime + ] -- | Extract the element prefixed by the given element in the list. prefixed :: (a -> Bool) -> [a] -> (Maybe a,[a]) prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y) -- | Make the case-by-case unit tests. -makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO (Test,Test) +makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO (TestTree,TestTree) makeCompilerTests packageConf basePath = do runtimeFiles <- runtimeTestFiles codegenFiles <- codegenTestFiles @@ -54,7 +53,7 @@ testFile packageConf basePath True file) ,makeTestGroup "Codegen tests" codegenFiles - (\file -> do testCodegen packageConf basePath file)) + (\file -> testCodegen packageConf basePath file)) where makeTestGroup title files inner = testGroup title $ flip map files $ \file -> @@ -75,12 +74,13 @@ out = toJsName file resf = root <.> "res" config = - addConfigDirectoryIncludePaths ["tests/"] $ - def { configOptimize = opt - , configTypecheck = False - , configPackageConf = packageConf - , configBasePath = basePath - } + addConfigDirectoryIncludePaths ["tests/"] + defaultConfig + { configOptimize = opt + , configTypecheck = False + , configPackageConf = packageConf + , configBasePath = basePath + } resExists <- doesFileExist resf let partialName = root ++ "_partial.res" partialExists <- doesFileExist partialName @@ -107,16 +107,17 @@ out = toJsName file resf = root <.> "res" config = - addConfigDirectoryIncludePaths ["tests/codegen/"] $ - def { configOptimize = True - , configTypecheck = False - , configPackageConf = packageConf - , configBasePath = basePath - , configExportStdlib = False - , configPrettyPrint = True - , configLibrary = True - , configExportRuntime = False - } + addConfigDirectoryIncludePaths ["tests/codegen/"] + defaultConfig + { configOptimize = True + , configTypecheck = False + , configPackageConf = packageConf + , configBasePath = basePath + , configExportStdlib = False + , configPrettyPrint = True + , configLibrary = True + , configExportRuntime = False + } compileFromTo config file (Just out) actual <- readStripped out expected <- readStripped resf diff --git a/tests/LambdaCase.hs b/tests/LambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/LambdaCase.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LambdaCase #-} +module LambdaCase where + +f :: Int -> Bool +f = \case + 2 -> True + _ -> False + +main :: Fay () +main = do + print (f 2) diff --git a/tests/LambdaCase.res b/tests/LambdaCase.res new file mode 100644 --- /dev/null +++ b/tests/LambdaCase.res @@ -0,0 +1,1 @@ +true diff --git a/tests/MultiWayIf.hs b/tests/MultiWayIf.hs new file mode 100644 --- /dev/null +++ b/tests/MultiWayIf.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiWayIf where + +f :: Int -> Char +f x = if | x == 1 -> 'a' + | x == 2 -> 'b' + | otherwise -> 'c' + +main :: Fay () +main = do + print (f 1) + print (f 2) + print (f 3) diff --git a/tests/MultiWayIf.res b/tests/MultiWayIf.res new file mode 100644 --- /dev/null +++ b/tests/MultiWayIf.res @@ -0,0 +1,3 @@ +a +b +c diff --git a/tests/PrefixOpPat.hs b/tests/PrefixOpPat.hs new file mode 100644 --- /dev/null +++ b/tests/PrefixOpPat.hs @@ -0,0 +1,7 @@ +module PrefixOpPat where + +f ((:) x y) = x + +main :: Fay () +main = do + print $ f [1,2] diff --git a/tests/PrefixOpPat.res b/tests/PrefixOpPat.res new file mode 100644 --- /dev/null +++ b/tests/PrefixOpPat.res @@ -0,0 +1,1 @@ +1 diff --git a/tests/case3.hs b/tests/case3.hs new file mode 100644 --- /dev/null +++ b/tests/case3.hs @@ -0,0 +1,11 @@ +module Case3 where + +f x = case () of + _ | x == 1 -> 1 + | x == 2 -> 2 + | True -> 3 + +main = do + print (f 1) + print (f 2) + print (f 3) diff --git a/tests/case3.res b/tests/case3.res new file mode 100644 --- /dev/null +++ b/tests/case3.res @@ -0,0 +1,3 @@ +1 +2 +3