{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 -- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental -- Portability : portable -- -- Session management information and global state modifiers for -- the main program -- ----------------------------------------------------------------------------- module WinDll.Session.Hs2lib (module WinDll.Session.Hs2lib ,module Control.Monad.State) where import Control.Monad.State import Control.Monad.Trans import Control.Monad.Error import Control.Monad import System.Directory import System.IO.Unsafe import WinDll.Structs.Structures import WinDll.Structs.Types import WinDll.Structs.PrettyPrinting import WinDll.Version.Hs2lib import qualified Language.Haskell.Exts.Syntax as Exts import Data.Either import Data.Data import Data.Char import Data.Generics import Data.Monoid import GHC.Paths ( libdir ) import GHC (guessTarget, targetId, TargetId(..), runGhc) import Module(moduleNameSlashes) import System.IO.Unsafe (unsafePerformIO) import Debug.Trace(trace) -- | Calling Convention for the exported module data CallConvention = StdCall -- ^ Windows StdCall | CCall -- ^ Standard C call deriving (Show,Eq,Read,Data,Typeable) -- | Export statements fully qualified data HaskellExport = HaskellExport CallConvention Ann Export deriving(Eq,Show,Data,Typeable) -- | Import statements fully qualified data HaskellImport = HaskellImport CallConvention Ann Export deriving(Eq,Show,Data,Typeable) -- | Create an empty Ann with the list in workingset filled in makeSessionAnn :: Exec Ann makeSessionAnn = do session <- fmap workingset get debug <- fmap debugging get return $ mempty { annWorkingSet = n_hs2hs session , annWorkingSetC = n_hs2c session , annWorkingSetCSize = n_csize session , annWorkingSetCs = n_hs2cs session , annDebug = debug } -- | Convert the Internal type to c types in the windef.h in mingw genCcall :: CallConvention -> String genCcall StdCall = "StdCall" genCcall CCall = "CDECL" -- | Check is whatever it is was passed as an argument contains a TyFun (->) gIsFun :: GenericQ Bool gIsFun = or . gmapQ (False `mkQ` isFun) where isFun (Exts.TyFun{}) = True isFun _ = False -- | Conditionally add parenthesis to the type, if it doesn't have any to begin with addParen :: Type -> Type addParen x@(Exts.TyParen _) = x addParen x | gIsFun x = Exts.TyParen x addParen x@(Exts.TyFun{}) = Exts.TyParen x addParen x = x -- | The platform your compiling for, This determines the type of library that is created. data Platform = Windows -- ^ Windows DLL | Unix -- ^ Lib files deriving (Show,Eq,Read) -- | Contains the enviroment settings, e.g. path to ghc,hsc2hs etc data EnvPaths = EnvPaths -- | Simple flags, used with GetOpt data Options = Version | Help deriving (Show,Eq) -- | Global session management information passed through each function data Session = Session { mainFile :: String -- ^ @mainFile @ Main filename , absPath :: String -- ^ @absPath@ The absolute path to the main file , verbosity :: Int -- ^ @verbosity@ debugging verbosity level , call :: CallConvention -- ^ @call@ The calling convention to use when exporting functions , namespace :: String -- ^ @namespace@ default namespace for c# codegen , csharp :: Bool -- ^ @csharp@ generate c# code , cpp :: Bool -- ^ @cpp@ generate c/c++ code , mvcpp :: Bool -- ^ @mvcpp@ Generate the .LIB file for when linking with the microsoft vc++ compiler. , incDef :: Bool -- ^ @incDef@ Copy the generated .DEF file also to the specified output folder , link_dynamic :: Bool -- ^ @link_dynamic@ Link the files using dynamic linking if possible. , pres_comment :: Bool -- ^ @pres_comment@ Enables Haddock comment preservation in the generated _FFI.c file , hackage_list :: String -- ^ @hackage_list@ Hackage packages url , hackage_base_url :: String -- ^ @hackage_base_url@ The base url of hackage , hackage_src_url :: String -- ^ @hackage_src_url@ What to append to the hackage url to get source , debugging :: Bool -- ^ @debugging@ Controls wether debugging is enabled. Which enables memory tracking , warnings :: Bool -- ^ @warnings@ Check if warnings should be printed , warnings_as_errors :: Bool -- ^ @warnings_as_errors@ Treat warnings as errors , outputDIR :: String -- ^ @outputDir@ Redirect output to a folder , baseDir :: String -- ^ @baseDir@ Path to the base folder which contains the WinDll includes folder and template folder , tempDIR :: String -- ^ @tempDir@ Set the temporary folder to use , keep_temps :: Bool -- ^ @keep_temps@ Keep temporary files , outputFile :: String -- ^ @outputFile@ The output file name , platform :: Platform -- ^ @platform@ The platform to compile for , dllmain :: FilePath -- ^ @dllmain@ The path to the lib main file to use , dllmanual :: Bool -- ^ @dllmanual@ Indicates that you want to manually initialize the RTS. @dllmain@ will be ignored. , threaded :: Bool -- ^ @threaded@ Compile the lib using the threaded RTS. this implies dllmanual , options :: [Options] -- ^ @options@ The none executable flags , includes :: [FilePath] -- ^ @includes@ The list of extra source files to include with data definitions , workingset :: WorkingSet -- ^ @workingset@ The current working set for the project , pipeline :: Builder -- ^ @pipeline@ Contains cleanup information needed when program is exiting , include_foreigns :: Bool -- ^ @include_foreigns@ re-expose foreign declarations found when analyzing modules. , native_symbols :: [FilePath] -- ^ @native_symbols@ The list of Native Symbols to include in the generated .DEF files. } deriving Show -- | Datatype that hold the information needed by the different components of the preprocessor data WorkingSet = WorkingSet { dependencies :: [String] -- ^ @dependencies@ Module dependencies, Othe source files to traverse , modules :: [(Module, [CommentDecl])] -- ^ @modules@ A list of modules matched with their function comments, this is done before hand to save some time. , entrypoint :: String -- ^ @entrypoint@ The main entry point for the dll, will be generated based on the top dll given. , pragmas :: [Pragma] -- ^ @pramas@ Program wide control pragmas , n_exports :: [HaskellExport] -- ^ @n_exports@ the list of haskell exports found inside parsed modules. This gets populated when \include_foreigns\ is true. , n_hs2c :: [(String, String)] -- ^ @n_hs2c@ supplimentary list of conversions of Haskell to C, user provided , n_csize :: [(String, Int )] -- ^ @n_csize@ supplimentary list of C sizes, user provided , n_hs2cs :: Bool -> [(String, String)] -- ^ @n_hs2cs@ supplimentary list of conversions of Haskell to C#, user provided , n_hs2hs :: [(String, String)] -- ^ @n_hs2hs@ supplimentary list of conversions of Haskell to HSC, user provided } deriving Show -- | DataType to hold all the filed we've build during the compilation phase in order to clean them up at the end data Builder = Builder { files :: [FilePath] -- ^ @files@ The list of files compiled during the build phase. , dirPath :: FilePath -- ^ @dirPath@ The real directory to write in. , mergeDep :: Maybe ModInfo -- ^ @mergeDep@ Cached merged dependency tree. to prevent repeated recalculations , specs :: [(Name,Types)] -- ^ @specs@ Datatypes that need to be specialized. } deriving Show -- | Contains the desugared processed module information data ModInfo = ModInfo { modFunctions :: [Function] -- ^ @modFunctions@ Functions which are to be exported by FFI , modDatatypes :: (DataTypes, DataTypes) -- ^ @modDatatypes@ A tuple of (simple datatypes, dataypes to be specialized) , modExports :: [Export] -- ^ @modExports@ A list of exports generated from the functions , modCallbacks :: [Callback] -- ^ @modCallbacks@ The Haskell Callbacks generated from the exports and datatypes , modStablePtrs :: [Stable] -- ^ @modCallbacks@ The Haskell Callbacks generated from the exports and datatypes } deriving Show -- | Monad transformer used to do all computations in type Exec a = StateT Session (ErrorT String IO) a -- | Make the Either a Monad instance -- instance Monad (Either String) where -- fail str = Left str -- return a = Right a -- (Left str ) >>= _ = Left str -- (Right a) >>= f = f a -- | And also make the Either a Functor instance Functor (Either String) where fmap f (Left str) = Left str fmap f (Right a) = Right (f a) -- | And a MonadPlus instance instance MonadPlus (Either String) where mzero = Left "" (Left _) `mplus` xs = xs xs `mplus` ys = xs -- | MonadIO instance so that liftIO can be used inside the StateT -- instance MonadIO (Either String) where -- liftIO = (($!) return) . unsafePerformIO -- | The default session initialized to the values specific for windows newSession = Session { mainFile = "" , absPath = "" , verbosity = 0 , call = StdCall , namespace = exename , csharp = False , cpp = True , mvcpp = False , incDef = False , link_dynamic = False , pres_comment = True , include_foreigns = True , hackage_base_url = "http://hackage.haskell.org/packages/archive/" , hackage_list = "00-index.tar.gz" , hackage_src_url = "/latest/doc/html/src" , debugging = False , warnings = True , warnings_as_errors = False , outputDIR = "." , baseDir = [] , tempDIR = unsafePerformIO getTemporaryDirectory , keep_temps = False , outputFile = [] , platform = Windows , dllmain = [] , dllmanual = True , threaded = False , options = [] , includes = [] , native_symbols = [] , workingset = WorkingSet { dependencies = [] , modules = [] , entrypoint = [] , pragmas = [] , n_exports = [] , n_hs2c = [] , n_csize = [] , n_hs2cs = const [] , n_hs2hs = [] } , pipeline = Builder { files = [] , dirPath = [] , mergeDep = Nothing , specs = [] } } -- | Guess the fullname of a target file guessPath :: FilePath -> IO FilePath guessPath mangled = runGhc (Just libdir) $ do target <- guessTarget mangled Nothing case targetId target of (TargetModule m) -> do let name = moduleNameSlashes m -- unsafePerformIO shouldn't be needed. There is an instance of MonadIO for GHC in -- HscTypes, however, ghc for some reason can't find it. And it's bitching too much. exist = unsafePerformIO $ doesFileExist (name ++ ".hs") case exist of True -> return $ name ++ ".hs" False -> return $ name ++ ".lhs" (TargetFile path _) -> return path