Compiler config for disabling newtype optimizations

src/Fay/Compiler/Decl.hs

@@ -36,7 +36,9 @@ compileDecl toplevel decl = case decl of
   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 []

src/Fay/Compiler/Exp.hs

@@ -99,9 +99,13 @@ compileLit lit = case lit of
 -- | 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
 

src/Fay/Compiler/InitialPass.hs

@@ -56,7 +56,9 @@ preprocessAST () mod@(Module _ _ _ _ decls) = do
   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 @@ compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this i
 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

src/Fay/Compiler/Misc.hs

@@ -288,3 +288,11 @@ hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter
 
 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'

src/Fay/Config.hs

@@ -22,6 +22,7 @@ module Fay.Config
       , configStrict
       , configTypecheckOnly
       , configRuntimePath
+      , configOptimizeNewtypes
       )
   , defaultConfig
   , defaultConfigWithSandbox
@@ -70,6 +71,7 @@ data Config = Config
                                                             --   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 @@ defaultConfig = addConfigPackage "fay-base"
     , configTypecheckOnly      = False
     , configRuntimePath        = Nothing
     , configSourceMap          = False
+    , configOptimizeNewtypes   = True
     }
 
 defaultConfigWithSandbox :: IO Config