diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ See full history at: +### 0.20.2.0 (2014-09-14) + +* Config option to disable optimizations of newtypes, treating them as + normal data types. This can be triggered by setting + `configOptimizeNewtypes = False` or passing + `--no-optimized-newtypes`. + #### 0.20.1.4 (2014-09-04) * Update to `optparse-applicative == 0.10.*` diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.20.1.4 +version: 0.20.2.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, @@ -132,7 +132,7 @@ , split < 0.3 , spoon < 0.4 , syb < 0.5 - , text < 1.2 + , text < 1.3 , time >= 1 && < 1.5 , transformers >= 0.3 && < 0.4 || > 0.4.1 && < 0.5 , uniplate >= 1.6.11 && < 1.7 @@ -173,7 +173,7 @@ , filepath , groom == 0.1.* , haskell-src-exts - , tasty == 0.9.* + , tasty >= 0.9 && < 0.11 , tasty-hunit >= 0.8 && < 0.10 , tasty-th == 0.1.* , text 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 @@ -36,7 +36,9 @@ FunBind _ matches -> compileFunCase toplevel matches DataDecl _ (DataType _ ) _ (mkTyVars -> tyvars) constructors _ -> compileDataDecl toplevel tyvars constructors GDataDecl _ (DataType _) _l (mkTyVars -> tyvars) _n decls _ -> compileDataDecl toplevel tyvars (map convertGADT decls) - DataDecl _ (NewType _) _ _ _ _ -> return [] + DataDecl _ (NewType _) _ head' constructors _ -> + ifOptimizeNewtypes (return []) + (compileDataDecl toplevel (mkTyVars head') constructors) -- Just ignore type aliases and signatures. TypeDecl {} -> return [] TypeSig {} -> return [] 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 @@ -99,9 +99,13 @@ -- | Compile simple application. compileApp :: S.Exp -> S.Exp -> Compile JsExp compileApp exp1@(Con _ q) exp2 = - maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q + ifOptimizeNewtypes + (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q) + (compileApp' exp1 exp2) compileApp exp1@(Var _ q) exp2 = - maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q + ifOptimizeNewtypes + (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q) + (compileApp' exp1 exp2) compileApp exp1 exp2 = compileApp' exp1 exp2 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 @@ -56,7 +56,9 @@ modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s } forM_ decls scanTypeSigs forM_ decls scanRecordDecls - forM_ decls scanNewtypeDecls + ifOptimizeNewtypes + (forM_ decls scanNewtypeDecls) + (return ()) preprocessAST () mod = throwError $ UnsupportedModuleSyntax "preprocessAST" mod -------------------------------------------------------------------------------- @@ -93,14 +95,29 @@ scanRecordDecls :: F.Decl -> Compile () scanRecordDecls decl = do case decl of - DataDecl _loc DataType{} _ctx (F.declHeadName -> name) qualcondecls _deriv -> do - let ns = for qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) - addRecordTypeState name ns + DataDecl _loc ty _ctx (F.declHeadName -> name) qualcondecls _deriv -> do + let addIt = let ns = for qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) + in addRecordTypeState name ns + case ty of + DataType{} -> addIt + NewType{} -> ifOptimizeNewtypes + (return ()) + addIt _ -> return () case decl of - DataDecl _ DataType{} _ _ constructors _ -> dataDecl constructors - GDataDecl _ DataType{} _ _ _ decls _ -> dataDecl (map convertGADT decls) + DataDecl _ ty _ _ constructors _ -> + case ty of + DataType{} -> dataDecl constructors + NewType{} -> ifOptimizeNewtypes + (return ()) + (dataDecl constructors) + GDataDecl _ ty _ _ _ decls _ -> + case ty of + DataType{} -> dataDecl (map convertGADT decls) + NewType{} -> ifOptimizeNewtypes + (return ()) + (dataDecl (map convertGADT decls)) _ -> return () where 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 @@ -288,3 +288,11 @@ hasLanguagePragma :: String -> [ModulePragma l] -> Bool hasLanguagePragma pr = hasLanguagePragmas [pr] + +-- | if then else for when 'configOptimizeNewtypes'. +ifOptimizeNewtypes :: Compile a -> Compile a -> Compile a +ifOptimizeNewtypes then' else' = do + optimize <- config configOptimizeNewtypes + if optimize + then then' + else else' diff --git a/src/Fay/Config.hs b/src/Fay/Config.hs --- a/src/Fay/Config.hs +++ b/src/Fay/Config.hs @@ -22,6 +22,7 @@ , configStrict , configTypecheckOnly , configRuntimePath + , configOptimizeNewtypes ) , defaultConfig , defaultConfigWithSandbox @@ -70,6 +71,7 @@ -- exported functions with type signatures in the given module , configTypecheckOnly :: Bool -- ^ Only invoke GHC for typechecking, don't produce any output , configRuntimePath :: Maybe FilePath + , configOptimizeNewtypes :: Bool -- ^ Optimize away newtype constructors? } deriving (Show) @@ -98,6 +100,7 @@ , configTypecheckOnly = False , configRuntimePath = Nothing , configSourceMap = False + , configOptimizeNewtypes = True } defaultConfigWithSandbox :: IO Config diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -15,31 +15,32 @@ -- | Options and help. data FayCompilerOptions = FayCompilerOptions - { optLibrary :: Bool - , optFlattenApps :: Bool - , optHTMLWrapper :: Bool - , optHTMLJSLibs :: [String] - , optInclude :: [String] - , optPackages :: [String] - , optWall :: Bool - , optNoGHC :: Bool - , optStdout :: Bool - , optVersion :: Bool - , optOutput :: Maybe String - , optPretty :: Bool - , optOptimize :: Bool - , optGClosure :: Bool - , optPackageConf :: Maybe String - , optNoRTS :: Bool - , optNoStdlib :: Bool - , optPrintRuntime :: Bool - , optStdlibOnly :: Bool - , optBasePath :: Maybe FilePath - , optStrict :: [String] - , optTypecheckOnly :: Bool - , optRuntimePath :: Maybe FilePath - , optSourceMap :: Bool - , optFiles :: [String] + { optLibrary :: Bool + , optFlattenApps :: Bool + , optHTMLWrapper :: Bool + , optHTMLJSLibs :: [String] + , optInclude :: [String] + , optPackages :: [String] + , optWall :: Bool + , optNoGHC :: Bool + , optStdout :: Bool + , optVersion :: Bool + , optOutput :: Maybe String + , optPretty :: Bool + , optOptimize :: Bool + , optGClosure :: Bool + , optPackageConf :: Maybe String + , optNoRTS :: Bool + , optNoStdlib :: Bool + , optPrintRuntime :: Bool + , optStdlibOnly :: Bool + , optBasePath :: Maybe FilePath + , optStrict :: [String] + , optTypecheckOnly :: Bool + , optRuntimePath :: Maybe FilePath + , optSourceMap :: Bool + , optFiles :: [String] + , optNoOptimizeNewtypes :: Bool } -- | Main entry point. @@ -67,6 +68,7 @@ , configTypecheckOnly = optTypecheckOnly opts , configRuntimePath = optRuntimePath opts , configSourceMap = optSourceMap opts + , configOptimizeNewtypes = not $ optNoOptimizeNewtypes opts } if optVersion opts then runCommandVersion @@ -117,6 +119,7 @@ <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it") <*> switch (long "sourcemap" <> help "Produce a source map in .map") <*> many (argument Just (metavar "...")) + <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types") where strsOption :: Mod OptionFields [String] -> Parser [String] strsOption m = option (ReadM . Right . wordsBy (== ',')) (m <> value [])