diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.14.4.0 +version: 0.14.5.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, @@ -20,21 +20,19 @@ See . . /Release Notes/ - 0.14.4.0: - . - * Fix record updates on IE <= 8. + * Support for newtypes (with no runtime cost!) . - * Import tweaks, will make compilation a lot faster (4x reported) when there are a lot of imports. + * --base-path flag to specify custom location for fay-base . - * Parse hs sources with base fixities. + * Fix a bug where imports shadowing local bindings would prevent the local binding from being exported . - See full history at: + See full history at: homepage: http://fay-lang.org/ bug-reports: https://github.com/faylang/fay/issues license: BSD3 license-file: LICENSE author: Chris Done, Adam Bergmark -maintainer: chrisdone@gmail.com, adam@edea.se +maintainer: adam@edea.se copyright: 2012 Chris Done, Adam Bergmark category: Development build-type: Custom @@ -99,7 +97,7 @@ library hs-source-dirs: src exposed-modules: Fay, Fay.Types, Language.Fay.FFI, Fay.Convert, Fay.Compiler, Fay.Compiler.Debug, Fay.Compiler.Config - other-modules: Fay.Compiler.Print, Control.Monad.IO, System.Process.Extra, Data.List.Extra, Paths_fay, Fay.Compiler.Misc, Fay.Compiler.FFI, Fay.Compiler.Optimizer, Fay.Compiler.Packages, Fay.Compiler.ModuleScope, Control.Monad.Extra, Fay.Compiler.CollectRecords, Fay.Compiler.Decl, Fay.Compiler.Defaults, Fay.Compiler.Exp, Fay.Compiler.Pattern, Fay.Compiler.Typecheck + other-modules: Fay.Compiler.Print, Control.Monad.IO, System.Process.Extra, Data.List.Extra, Paths_fay, Fay.Compiler.Misc, Fay.Compiler.FFI, Fay.Compiler.Optimizer, Fay.Compiler.Packages, Fay.Compiler.ModuleScope, Control.Monad.Extra, Fay.Compiler.InitialPass, Fay.Compiler.Decl, Fay.Compiler.Defaults, Fay.Compiler.Exp, Fay.Compiler.Pattern, Fay.Compiler.Typecheck ghc-options: -O2 -Wall -fno-warn-name-shadowing build-depends: base >= 4 && < 5, aeson, diff --git a/src/Fay/Compiler.hs b/src/Fay/Compiler.hs --- a/src/Fay/Compiler.hs +++ b/src/Fay/Compiler.hs @@ -18,7 +18,7 @@ ,parseFay) where -import Fay.Compiler.CollectRecords (collectRecords) +import Fay.Compiler.InitialPass (initialPass) import Fay.Compiler.Config import Fay.Compiler.Defaults import Fay.Compiler.Exp @@ -82,7 +82,8 @@ -- compilation. compileForDocs :: Module -> Compile [JsStmt] compileForDocs mod = do - collectRecords mod + initialPass mod + -- collectRecords mod compileModule False mod -- | Compile the top-level Fay module. @@ -93,7 +94,8 @@ when (configTypecheck cfg) $ typecheck (configPackageConf cfg) (configWall cfg) $ fromMaybe modulename $ configFilePath cfg - collectRecords mod + initialPass mod + -- collectRecords mod cs <- io defaultCompileState modify $ \s -> s { stateImported = stateImported cs } (stmts,CompileWriter{..}) <- listen $ compileModule True mod diff --git a/src/Fay/Compiler/CollectRecords.hs b/src/Fay/Compiler/CollectRecords.hs deleted file mode 100644 --- a/src/Fay/Compiler/CollectRecords.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Initial pass-through collecting record definitions - -module Fay.Compiler.CollectRecords where - -import Fay.Compiler.Misc -import Fay.Types -import Fay.Compiler.Config - -import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS -import Language.Haskell.Exts.Syntax -import Language.Haskell.Exts.Parser - --- | Collect all the records and their fields before compiling. -collectRecords :: Module -> Compile () -collectRecords (Module _ _ _ Nothing _ imports decls) = do - mapM_ passImport imports - mapM_ scanDecl decls -collectRecords m = throwError (UnsupportedModuleSyntax m) - --- | Handle an import. -passImport :: ImportDecl -> Compile () -passImport (ImportDecl _ _ _ _ Just{} _ _) = do - return () --- warn $ "import with package syntax ignored: " ++ prettyPrint i -passImport (ImportDecl _ name False _ Nothing Nothing _) = do - void $ unlessImported name $ \filepath contents -> do - state' <- get - reader' <- ask - result <- liftIO $ records filepath reader' state' collectRecords contents - case result of - Right ((),st,_) -> do - -- Merges the state gotten from passing through an imported - -- module with the current state. We can assume no duplicate - -- records exist since GHC would pick that up. - modify $ \s -> s { stateRecords = stateRecords st - , stateRecordTypes = stateRecordTypes st - , stateImported = stateImported st - } - Left err -> throwError err - return () -passImport i = throwError $ UnsupportedImport i - --- | Don't re-import the same modules. -unlessImported :: ModuleName - -> (FilePath -> String -> Compile ()) - -> Compile () -unlessImported name importIt = do - imported <- gets stateImported - case lookup name imported of - Just _ -> return () - Nothing -> do - dirs <- configDirectoryIncludePaths <$> config id - (filepath,contents) <- findImport dirs name - modify $ \s -> s { stateImported = (name,filepath) : imported } - importIt filepath contents - --- | Compile only for record generation. -records :: (Show from,Parseable from) - => FilePath - -> CompileReader - -> CompileState - -> (from -> Compile ()) - -> String - -> IO (Either CompileError ((),CompileState,CompileWriter)) -records filepath compileReader compileState with from = - runCompile compileReader - compileState - (parseResult (throwError . uncurry ParseError) - with - (parseFay filepath from)) - --- | Handle a declaration. -scanDecl :: Decl -> Compile () -scanDecl decl = do - case decl of - DataDecl _loc DataType _ctx name _tyvarb qualcondecls _deriv -> do - let ns = flip map qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) - addRecordTypeState name ns - _ -> return () - - - case decl of - DataDecl _ DataType _ _ _ constructors _ -> dataDecl constructors - GDataDecl _ DataType _l _i _v _n decls _ -> dataDecl (map convertGADT decls) - _ -> return () - - where - addRecordTypeState name cons = modify $ \s -> s - { stateRecordTypes = (UnQual name, map UnQual cons) : stateRecordTypes s } - - conDeclName (ConDecl n _) = n - conDeclName (InfixConDecl _ n _) = n - conDeclName (RecDecl n _) = n - - --- | Collect record definitions and store record name and field names. --- A ConDecl will have fields named slot1..slotN -dataDecl :: [QualConDecl] -> Compile () -dataDecl constructors = do - forM_ constructors $ \(QualConDecl _ _ _ condecl) -> - case condecl of - ConDecl name types -> do - let fields = map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types - addRecordState name fields - InfixConDecl _t1 name _t2 -> - addRecordState name ["slot1", "slot2"] - RecDecl name fields' -> do - let fields = concatMap fst fields' - addRecordState name fields - - where - addRecordState :: Name -> [Name] -> Compile () - addRecordState name fields = modify $ \s -> s - { stateRecords = (UnQual name,map UnQual fields) : stateRecords s } diff --git a/src/Fay/Compiler/Config.hs b/src/Fay/Compiler/Config.hs --- a/src/Fay/Compiler/Config.hs +++ b/src/Fay/Compiler/Config.hs @@ -62,4 +62,5 @@ , configGClosure = False , configPackageConf = Nothing , configPackages = [] + , configBasePath = Nothing } 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 @@ -43,6 +43,7 @@ FunBind matches -> compileFunCase toplevel matches DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl toplevel decl constructors GDataDecl _ DataType _l _i _v _n decls _ -> compileDataDecl toplevel decl (map convertGADT decls) + DataDecl _ NewType _ _ _ constructors _ -> compileNewtypeDecl constructors -- Just ignore type aliases and signatures. TypeDecl{} -> return [] TypeSig{} -> return [] @@ -149,6 +150,30 @@ [] (Just (thunk (JsGetProp (force (JsName (JsNameVar "x"))) (JsNameVar (UnQual name)))))) + +-- | Compile a newtype declaration. +compileNewtypeDecl :: [QualConDecl] -> Compile [JsStmt] +compileNewtypeDecl [QualConDecl _ _ _ condecl] = do + case condecl of + -- newtype declaration without destructor + ConDecl name [ty] -> addNewtype name Nothing ty + RecDecl cname [([dname], ty)] -> addNewtype cname (Just dname) ty + x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x + return [] + where + getBangTy :: BangType -> Type + getBangTy (BangedTy t) = t + getBangTy (UnBangedTy t) = t + getBangTy (UnpackedTy t) = t + + addNewtype cname dname ty = do + qcname <- qualify cname + qdname <- case dname of + Nothing -> return Nothing + Just n -> qualify n >>= return . Just + modify (\cs@CompileState{stateNewtypes=nts} -> + cs{stateNewtypes=(qcname,qdname,getBangTy ty):nts}) +compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q -- | Compile a function which pattern matches (causing a case analysis). compileFunCase :: Bool -> [Match] -> 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 @@ -34,6 +34,7 @@ , stateModuleName = ModuleName "Main" , stateRecordTypes = [] , stateRecords = [] + , stateNewtypes = [] , stateImported = [("Fay.Types",types)] , stateNameDepth = 1 , stateLocalScope = S.empty 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 @@ -77,14 +77,22 @@ compileApp :: Exp -> Exp -> Compile JsExp compileApp exp1 exp2 = do flattenApps <- config configFlattenApps - if flattenApps then method2 else method1 + jsexp1 <- compileExp exp1 + case jsexp1 of + JsName (JsNameVar qname) -> do + ntc <- lookupNewtypeConst qname + ntd <- lookupNewtypeDest qname + if isJust ntc || isJust ntd + then compileExp exp2 + else (if flattenApps then method2 else method1) jsexp1 + _ -> (if flattenApps then method2 else method1) jsexp1 where -- Method 1: -- In this approach code ends up looking like this: -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)}) -- Which might be OK for speed, but increases the JS stack a fair bit. - method1 = - JsApp <$> (forceFlatName <$> compileExp exp1) + method1 exp1 = + JsApp <$> (forceFlatName <$> return exp1) <*> fmap return (compileExp exp2) forceFlatName name = JsApp (JsName JsForce) [name] @@ -92,8 +100,8 @@ -- In this approach code ends up looking like this: -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05)) -- Which should be much better for the stack and readability, but probably not great for speed. - method2 = fmap flatten $ - JsApp <$> compileExp exp1 + method2 exp1 = fmap flatten $ + JsApp <$> return exp1 <*> fmap return (compileExp exp2) flatten (JsApp op args) = case op 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 @@ -20,6 +20,7 @@ import Control.Monad.Error import Control.Monad.Writer +import Control.Applicative ((<$>), (<*>)) import Data.Char import Data.Generics.Schemes import Data.List @@ -38,7 +39,29 @@ -> String -- ^ The format string. -> Type -- ^ Type signature. -> Compile [JsStmt] -compileFFI srcloc name formatstr sig = do +compileFFI srcloc name formatstr sig = + -- substitute newtypes with their child types before calling + -- real compileFFI + compileFFI' srcloc name formatstr =<< rmNewtys sig + + where rmNewtys :: Type -> Compile Type + rmNewtys (TyForall b c t) = TyForall b c <$> rmNewtys t + rmNewtys (TyFun t1 t2) = TyFun <$> rmNewtys t1 <*> rmNewtys t2 + rmNewtys (TyTuple b tl) = TyTuple b <$> mapM rmNewtys tl + rmNewtys (TyList t) = TyList <$> rmNewtys t + rmNewtys (TyApp t1 t2) = TyApp <$> rmNewtys t1 <*> rmNewtys t2 + rmNewtys t@TyVar{} = return t + rmNewtys (TyCon qname) = do + newty <- lookupNewtypeConst =<< qualifyQName qname + return $ case newty of + Nothing -> TyCon qname + Just (_,ty) -> ty + rmNewtys (TyParen t) = TyParen <$> rmNewtys t + rmNewtys (TyInfix t1 q t2)= flip TyInfix q <$> rmNewtys t1 <*> rmNewtys t2 + rmNewtys (TyKind t k) = flip TyKind k <$> rmNewtys t + +compileFFI' :: SrcLoc -> Name -> String -> Type -> Compile [JsStmt] +compileFFI' srcloc name formatstr sig = do inner <- formatFFI srcloc formatstr (zip params funcFundamentalTypes) case JS.parse JS.parseExpression (prettyPrint name) (printJSString (wrapReturn inner)) of Left err -> throwError (FfiFormatInvalidJavaScript srcloc inner (show err)) diff --git a/src/Fay/Compiler/InitialPass.hs b/src/Fay/Compiler/InitialPass.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/InitialPass.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Fay.Compiler.InitialPass where + +import Fay.Compiler.Misc +import Fay.Types +import Fay.Compiler.Config +import Fay.Compiler.Decl (compileNewtypeDecl) + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.RWS +import Language.Haskell.Exts.Syntax +import Language.Haskell.Exts.Parser + +initialPass :: Module -> Compile () +initialPass (Module _ _ _ Nothing _ imports decls) = do + forM_ imports $ \imp -> + case imp of + ImportDecl _ _ _ _ Just{} _ _ -> return () + + ImportDecl _ name False _ Nothing Nothing _ -> + void $ unlessImported name $ \filepath contents -> do + result <- compileWith filepath initialPass contents + case result of + Right ((),st,_) -> + -- Merges the state gotten from passing through an imported + -- module with the current state. We can assume no duplicate + -- records exist since GHC would pick that up. + modify $ \s -> s { stateRecords = stateRecords st + , stateRecordTypes = stateRecordTypes st + , stateImported = stateImported st + , stateNewtypes = stateNewtypes st + } + Left err -> throwError err + + i -> throwError $ UnsupportedImport i + + forM_ decls scanRecordDecls + forM_ decls scanNewtypeDecls + +initialPass m = throwError (UnsupportedModuleSyntax m) + +compileWith :: (Show from,Parseable from) + => FilePath + -> (from -> Compile ()) + -> String + -> Compile (Either CompileError ((),CompileState,CompileWriter)) +compileWith filepath with from = do + compileReader <- ask + compileState <- get + liftIO $ runCompile compileReader + compileState + (parseResult (throwError . uncurry ParseError) + with + (parseFay filepath from)) + +-- | Don't re-import the same modules. +unlessImported :: ModuleName + -> (FilePath -> String -> Compile ()) + -> Compile () +unlessImported name importIt = do + imported <- gets stateImported + case lookup name imported of + Just _ -> return () + Nothing -> do + dirs <- configDirectoryIncludePaths <$> config id + (filepath,contents) <- findImport dirs name + modify $ \s -> s { stateImported = (name,filepath) : imported } + importIt filepath contents + +scanNewtypeDecls :: Decl -> Compile () +scanNewtypeDecls (DataDecl _ NewType _ _ _ constructors _) = + void $ compileNewtypeDecl constructors +scanNewtypeDecls _ = return () + +scanRecordDecls :: Decl -> Compile () +scanRecordDecls decl = do + case decl of + DataDecl _loc DataType _ctx name _tyvarb qualcondecls _deriv -> do + let ns = flip map qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) + addRecordTypeState name ns + _ -> return () + + + case decl of + DataDecl _ DataType _ _ _ constructors _ -> dataDecl constructors + GDataDecl _ DataType _l _i _v _n decls _ -> dataDecl (map convertGADT decls) + _ -> return () + + where + addRecordTypeState name cons = modify $ \s -> s + { stateRecordTypes = (UnQual name, map UnQual cons) : stateRecordTypes s } + + conDeclName (ConDecl n _) = n + conDeclName (InfixConDecl _ n _) = n + conDeclName (RecDecl n _) = n + + -- | Collect record definitions and store record name and field names. + -- A ConDecl will have fields named slot1..slotN + dataDecl :: [QualConDecl] -> Compile () + dataDecl constructors = do + forM_ constructors $ \(QualConDecl _ _ _ condecl) -> + case condecl of + ConDecl name types -> do + let fields = map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types + addRecordState name fields + InfixConDecl _t1 name _t2 -> + addRecordState name ["slot1", "slot2"] + RecDecl name fields' -> do + let fields = concatMap fst fields' + addRecordState name fields + + where + addRecordState :: Name -> [Name] -> Compile () + addRecordState name fields = modify $ \s -> s + { stateRecords = (UnQual name,map UnQual fields) : stateRecords s } 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 @@ -75,11 +75,30 @@ then return (UnQual name) else maybe (qualify name) return (ModuleScope.resolveName u env) +lookupNewtypeConst :: QName -> Compile (Maybe (Maybe QName,Type)) +lookupNewtypeConst name = do + newtypes <- gets stateNewtypes + case find (\(cname,_,_) -> cname == name) newtypes of + Nothing -> return Nothing + Just (_,dname,ty) -> return $ Just (dname,ty) + +lookupNewtypeDest :: QName -> Compile (Maybe (QName,Type)) +lookupNewtypeDest name = do + newtypes <- gets stateNewtypes + case find (\(_,dname,_) -> dname == Just name) newtypes of + Nothing -> return Nothing + Just (cname,_,ty) -> return $ Just (cname,ty) + -- | Qualify a name for the current module. qualify :: Name -> Compile QName qualify name = do modulename <- gets stateModuleName return (Qual modulename name) + +-- | Qualify a QName for the current module if unqualified. +qualifyQName :: QName -> Compile QName +qualifyQName (UnQual name) = qualify name +qualifyQName n = return n -- | Make a top-level binding. bindToplevel :: SrcLoc -> Bool -> Name -> JsExp -> Compile JsStmt diff --git a/src/Fay/Compiler/ModuleScope.hs b/src/Fay/Compiler/ModuleScope.hs --- a/src/Fay/Compiler/ModuleScope.hs +++ b/src/Fay/Compiler/ModuleScope.hs @@ -60,7 +60,7 @@ bindAsLocals :: [QName] -> ModuleScope -> ModuleScope bindAsLocals qs (ModuleScope binds) = -- This needs to be changed to not use unqual to support qualified imports. - ModuleScope $ M.fromList (map (unqual &&& id) qs) `M.union` binds + ModuleScope $ binds `M.union` M.fromList (map (unqual &&& id) qs) where unqual (Qual _ n) = (UnQual n) unqual u@UnQual{} = u unqual Special{} = error "fay: ModuleScope.bindAsLocals: Special" 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 @@ -10,6 +10,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Extra +import Data.Maybe import Data.List import Data.Version import GHC.Paths @@ -32,7 +33,9 @@ Nothing -> error $ "unable to find package version: " ++ name Just ver -> do let nameVer = name ++ "-" ++ ver - shareDir <- fmap ($ nameVer) getShareGen + shareDir <- if isJust (configBasePath config) && name == "fay-base" + then return . fromJust $ configBasePath config + else fmap ($ nameVer) getShareGen let includes = [shareDir,shareDir "src"] exists <- mapM doesSourceDirExist includes if any id exists 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 @@ -20,7 +20,12 @@ compilePat exp pat body = case pat of PVar name -> compilePVar name exp body - PApp cons pats -> compilePApp cons pats exp body + PApp cons pats -> do + qcons <- qualifyQName cons + newty <- lookupNewtypeConst qcons + case newty of + Nothing -> compilePApp cons pats exp body + Just _ -> compileNewtypePat pats exp body PLit literal -> compilePLit exp literal body PParen pat -> compilePat exp pat body PWildCard -> return body @@ -99,6 +104,10 @@ bindVar name x <- compilePat exp pat body return ([JsVar (JsNameVar (UnQual name)) exp] ++ x) + +compileNewtypePat :: [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] +compileNewtypePat [pat] exp body = compilePat exp pat body +compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps -- | Compile a pattern application. compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -76,7 +76,8 @@ , 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. + , configPackages :: [String] -- ^ Included Fay packages. + , configBasePath :: Maybe FilePath -- ^ Custom source location for fay-base } deriving (Show) -- | State of the compiler. @@ -84,6 +85,7 @@ { _stateExports :: Map ModuleName (Set QName) -- ^ Collects exports from modules , stateRecordTypes :: [(QName,[QName])] -- ^ Map types to constructors , stateRecords :: [(QName,[QName])] -- ^ Map constructors to fields + , stateNewtypes :: [(QName, Maybe QName, Type)] -- ^ Newtype constructor, destructor, wrapped type tuple , stateImported :: [(ModuleName,FilePath)] -- ^ Map of all imported modules and their source locations. , stateNameDepth :: Integer -- ^ Depth of the current lexical scope. , stateLocalScope :: Set Name -- ^ Names in the current lexical scope. @@ -131,7 +133,14 @@ -- | Get all of the exported identifiers for the given module. getExportsFor :: ModuleName -> CompileState -> Set QName -getExportsFor mn cs = fromMaybe S.empty $ M.lookup mn (_stateExports cs) +getExportsFor mn cs = excludeNewtypes cs $ fromMaybe S.empty $ M.lookup mn (_stateExports cs) + where + excludeNewtypes :: CompileState -> Set QName -> Set QName + excludeNewtypes cs' names = + let newtypes = stateNewtypes cs' + constrs = map (\(c, _, _) -> c) newtypes + destrs = map (\(_, d, _) -> fromJust d) . filter (\(_, d, _) -> isJust d) $ newtypes + in names `S.difference` (S.fromList constrs `S.union` S.fromList destrs) -- | Compile monad. newtype Compile a = Compile diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -49,6 +49,7 @@ , optDispatcher :: Bool , optStdlibOnly :: Bool , optNoBuiltins :: Bool + , optBasePath :: Maybe FilePath } -- | Main entry point. @@ -81,6 +82,7 @@ , configDispatchers = not (optNoDispatcher opts) , configDispatcherOnly = optDispatcher opts , configExportStdlibOnly = optStdlibOnly opts + , configBasePath = optBasePath opts } void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible" case optFiles opts of @@ -127,6 +129,7 @@ <*> switch (long "dispatcher" <> help "Only output the type serialization dispatchers") <*> switch (long "stdlib" <> help "Only output the stdlib") <*> switch (long "no-builtins" <> help "Don't export no-builtins") + <*> optional (strOption (long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")) where strsOption m = nullOption (m <> reader (Right . wordsBy (== ',')) <> value [])