Hs2lib-0.5.7: WinDll/Session/Hs2lib.hs
{-# 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.
, optGHC :: String -- ^ @optGHC@ Extra options to pass along to ghc
, 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@ supplementary list of conversions of Haskell to C, user provided
, n_csize :: [(String, Int )] -- ^ @n_csize@ supplementary list of C sizes, user provided
, n_hs2cs :: Bool -> [(String, String)] -- ^ @n_hs2cs@ supplementary list of conversions of Haskell to C#, user provided
, n_hs2hs :: [(String, String)] -- ^ @n_hs2hs@ supplementary 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 = []
, optGHC = []
, 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 = []
}
}
-- | Escape paths with whitespaces
escapePath :: String -> String
escapePath path = if ' ' `elem` path
then '"' : path ++ "\""
else path
-- | 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