----------------------------------------------------------------------------- -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 -- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental -- Portability : portable -- -- Generates the needed Haskell code needed Storage instances by the FFI Calls. -- ----------------------------------------------------------------------------- module WinDll.CodeGen.Haskell where import WinDll.Structs.Structures hiding (Import,Pragma) import qualified WinDll.Structs.Structures as ST import WinDll.Structs.C import WinDll.Structs.Haskell hiding (pragmas) import WinDll.Structs.MShow.MShow import WinDll.Structs.MShow.Haskell import WinDll.Structs.Folds.Haskell import WinDll.Utils.Pragma import WinDll.Session.Hs2lib import WinDll.Builder import WinDll.Utils.Feedback import WinDll.Identifier import WinDll.Parsers.Hs2lib import WinDll.Lib.NativeMapping import WinDll.Lib.Instances import System.Random import System.FilePath import System.IO.Unsafe import qualified Language.Haskell.Exts as Exts import Data.List import Data.Char import Data.Maybe import Data.Generics (listify, mkT, everywhere) import Data.Monoid import Control.Monad import Debug.Trace -- | Internal function type type Func = Name -> Bool -> DataType -> HaskellStorable type FuncP = Name -> Bool -> DataType -> [StorablePeek] -- | Write the main haskell file out to disc writeHaskellFiles :: Component writeHaskellFiles = do session <- get let name = namespace session createComponent (name++".hsc") mkHaskell -- | create module name and top level declarations mkHaskell :: Exec String mkHaskell = do modInfo <- generateMain session <- get let name = namespace session deps = (dependencies.workingset) session natives = (n_exports.workingset) session spco = (specs.pipeline) session build = pipeline session fullfile = dirPath build odir = outputDIR session bdir = baseDir session ldir = odir ++ [pathSeparator] ++ "Includes" datatypes = simple_datatypes ++ spec_datatypes _exports = modExports modInfo callbacks = modCallbacks modInfo stables = modStablePtrs modInfo debug = debugging session (simple_datatypes, spec_datatypes) = modDatatypes modInfo -- Code from pragmas cmds = getPragmas "IMPORT" ((pragmas.workingset) session) prag_imps = map Import $ concatMap (\(ST.Pragma _ x)->x) cmds cmds' = getPragmas "INSTANCE" $ (pragmas.workingset) session args = map (\(ST.Pragma _ x)->unwords x) cmds' mkType' x = let (y:n:_) = words x -- TODO: this is unsafe, fix it ns = read n typenames = zipWith (flip (++).show) [1..ns] (repeat "a") typevars = map (\x->Exts.TyVar (Exts.Ident x)) (y:typenames) mkPtr x = Exts.TyApp (Exts.TyCon (Exts.UnQual $ Exts.Ident "Ptr")) (Exts.TyParen x) in TypeDecL (y++"Ptr") typenames $ mkPtr (foldr1 Exts.TyApp typevars) -- end pragma code ann <- makeSessionAnn (imp,lets) <- insertHeaders let specials = getSpecializations spec_datatypes spco result = HaskellFile name [HaskellComment "Autogenerated from WinDll. Do NOT modify unless you know what you're doing."] ([Pragma LANGUAGE "ForeignFunctionInterface" -- ,Pragma LANGUAGE "UndecidableInstances" -- is this one really needed? ,Pragma LANGUAGE "TypeSynonymInstances" ,Pragma LANGUAGE "FlexibleInstances" ,Pragma LANGUAGE "MultiParamTypeClasses" ] ++ if debug then [Pragma LANGUAGE "CPP"] else []) (imp ++ map Import deps ++ prag_imps) lets [LocalInclude (name++".h") -- ,LocalInclude "Instances.h" -- already included in the generated H file ] (concatMap generateEnum $ unique $ simple_datatypes ++ specials) ( map mkType datatypes ++ map mkType' args ++ concatMap mkCallbackTypes callbacks) (map (mkExport ann (call session)) _exports ++ natives) (concatMap (mkImport ann (call session)) callbacks) (map (mkFunction ann) (modFunctions modInfo)) ( map (generateStorageCode ann True) simple_datatypes ++ map (generateStorageCode ann True) specials) callbacks stables return (mshowWithPath debug fullfile name bdir result) -- | Create a simple identiy class from the given type generateInstanceCode :: Type -> [String] generateInstanceCode t = ["instance FFIType " ++ mshow t ++ " " ++ mshow t ++ " where" ," toFFI = id" ," fromFFI = id" ] -- | Make a unique list of datatypes, kinda like nub except just checks the heads of the types. -- To be used when creating the general enum for these types, which is why only the heads need to be checked, -- since e.g. Maybe Int and Maybe String both just need the Maybe enum. unique :: DataTypes -> DataTypes unique = mkUnique [] where mkUnique :: [String] -> DataTypes -> DataTypes mkUnique _ [] = [] mkUnique lst (x:xs) = case getName x `elem` lst of True -> mkUnique lst xs False -> x : mkUnique (getName x : lst) xs -- | Generate type pointer declarations from datatypes mkType :: DataType -> Ptr_Type mkType (NewType name e t tag ) = mkType (DataType name e [t] tag) mkType (DataType name e t tag) = TypeDecL (name ++ "Ptr") e (case null e of True -> Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr"))) (Exts.TyCon (Exts.UnQual (Exts.Ident name))) False -> Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr"))) (Exts.TyParen rest) ) where rest = foldl1 Exts.TyApp $ Exts.TyCon (Exts.UnQual (Exts.Ident name)) : map (\a->Exts.TyVar (Exts.Ident a)) e mkType _ = error "Unsupported call. Please call mkType only with NewType or DataType." -- | Generate the export definitions mkExport :: Ann -> CallConvention -> Export -> HaskellExport mkExport ann cc ex = HaskellExport cc ann (ex{exName = exName ex ++"A"}) -- | Generate the import definitions mkImport :: Ann -> CallConvention -> HaskellCallback -> [HaskellImport] mkImport ann cc cb = [HaskellImport cc ann (Export ("mk" ++ name) "wrapper" tyTo otype modnm) ,HaskellImport cc ann (Export ("dyn" ++ name) "dynamic" tyFrom otype modnm)] where tyTo = Exts.TyFun newty (Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.UnQual (Exts.Ident $ name ++ "Ptr"))) ) tyFrom = Exts.TyFun (Exts.TyCon (Exts.UnQual (Exts.Ident $ name ++ "Ptr"))) newty name = cbName cb newty = cbNewType cb otype = cbInputType cb modnm = annModule ann -- | Generates the type definitions for the callback functions. mkCallbackTypes :: HaskellCallback -> [TypeDecL] mkCallbackTypes cb = [TypeDecL ((cbName cb) ++ "Ptr") [] ty' ,TypeDecN (cbName cb) [] (cbInputType cb)] where ty' = (Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "FunPtr"))) (cbNewType cb) ) -- | Generate a function definition mkFunction :: Ann -> Function -> HaskellFunction mkFunction ann' (Function name arr t ann orig) = HaskellFunction (name++"A") name t (ann `mappend` ann') orig -- | Does semantically the same as map, only it's restricted in the sense that it'll -- only return a list of lists as return type and have an empty element in between mappings spaceMap :: (a -> [b]) -> [a] -> [[b]] spaceMap _ [] = [[]] spaceMap f (x:xs) = f x : [] : spaceMap f xs -- | Insert standard headings needed for Haskell's HSC PreProcessor insertHeaders :: Exec ([Import],[HSC_Let]) insertHeaders = do stdi <- stdImports return (map Import (stdi ++ ["Control.Monad" ,"Control.Monad.Instances"]) ,[HSC_Let "alignment t = \"%lu\", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)"]) -- | Create the enum list from the Datatype if required. -- No enum is needed for newtypes or when only 1 constructor is available for the Data instance generateEnum :: DataType -> [DataEnum] generateEnum (DataType name _ t tag) = guard (length t > 1) >> return (mkEnum name t) generateEnum (NewType name _ t tag) = [] -- mkEnum name [t] -- | Create an enum list from a list of Constructors mkEnum name t = DataEnum name (map enum t) where enum (Constr name _ _) = filter isAlphaNum name -- filter isAlpha (map toLower name) -- | Create the Storage instances needed by Haskell's HSC PreProcessor generateStorageCode :: Ann -> Bool -> DataType -> HaskellStorable generateStorageCode ann esc d = generateTopLevelStruct d where generateTopLevelStruct :: DataType -> HaskellStorable generateTopLevelStruct (NewType name e t tag) = generateTopLevelStruct (DataType name e [t] tag) generateTopLevelStruct (DataType name e t tag) = let peeks = HSPeek (mkPeekHead name (isNewType d) e ++ rollFn mkPeek name (isNewType d) t) po = mkFn (mkPoke e) name (isNewType d) t sizes :: [(Name,Int)] sizes = map getSize t where getSize :: DataType -> (Name,Int) getSize (Constr name ft ntypes) = (name, length ntypes) in HSStorable name sizes "ptr" e esc po [peeks] ann dbg = annDebug ann modnm = annModule ann isNewType (NewType _ _ _ _) = True isNewType (DataType _ _ [x] _) = True -- also inline datatypes with just 1 constructor isNewType _ = False mkFn :: Func -> Name -> Bool -> [DataType] -> [HaskellStorable] mkFn fn name newtpe constrs = map (fn name newtpe) constrs rollFn :: (Int -> FuncP) -> Name -> Bool -> [DataType] -> [StorablePeek] rollFn fn name newtpe constrs =join $ zipWith ($) (map (\c a -> fn a name newtpe c) constrs) [0..(length constrs - 1)] mkPoke :: [String] -> Func mkPoke e dna newtpe (Constr name ft ntypes) = let col = case newtpe of False -> [PokeTag dna "tag" _ptr (PokeValue enum) ,NewPtr dbg _newptr dnamod ] ++ inner ++ [PokeTag dna "elt" _ptr (PokeValue _newptr)] True -> concat $ zipWith (\x (c,b)->let base = PokeTag dna (antName x) _ptr (PokeVar dbg esc b Nothing c ann) msg = "(length " ++ b ++ ")" size = PokeTag name (antName x++"_Size") _ptr (PokeVar dbg esc (b++"s") (Just msg) (Exts.TyCon (Exts.UnQual (Exts.Ident "CInt"))) ann) in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes aName in HSPoke name modnm (length ntypes) col where _ptr = "ptr" _newptr = "newptr" ++ show (unsafePerformIO $ getStdRandom (randomR (0::Int,1000000))) inner = guard (not $ null ntypes) >> concat (zipWith (\x (c,b)->let base = PokeTag name (antName x) _newptr (PokeVar dbg esc b Nothing c ann) msg = "(length " ++ b ++ ")" size = PokeTag name (antName x++"_Size") _newptr (PokeVar dbg esc (b++"s") (Just msg) (Exts.TyCon (Exts.UnQual (Exts.Ident "CInt"))) ann) in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes aName) aName = [(antType (ntypes!!(x-1)),"a"++show x) | x <- [1..(length ntypes)]] enum = pp $ filter isAlphaNum name --(map toLower name) n1 = map toLower dna pp = (("c"++dna)++) -- (n1 ++) dnamod = case null e of True -> dna False -> "(" ++ dna ++ " " ++ unwords e ++ ")" mkPeekHead :: String -> Bool -> TypeNames -> [StorablePeek] mkPeekHead dna newtpe e = if newtpe then [] else [PeekTag dna "ptr" _fulltype] where _fulltype = case (length e) > 0 of False -> dna True -> "(" ++ dna ++ " " ++ unwords e ++")" mkPeek :: Int -> FuncP mkPeek c dna newtpe (Constr namep ft ntypes) = let col = case newtpe of True -> inner ++ [PeekReturn dbg esc namep aName modnm] False -> [PeekEntry c $ concat (zipWith (\x (c,b)->let base = PeekValue (b++"'") namep (antName x) _newptr c size = PeekValue (b++"s") namep (antName x++"_Size") _newptr "CInt" in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes bName) ++ [PeekReturn dbg esc namep aName modnm]] in col where _ptr = "ptr" _newptr = "newptr" inner = guard (not $ null ntypes) >> --(PeekValue "value'" dna "elt" _ptr []): namep ==> dna (concat (zipWith (\x (c,b)->let base = PeekValue (b ++ "'") dna (antName x) _ptr c size = PeekValue (b++"s") namep (antName x++"_Size") _ptr "CInt" in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes bName)) translate2 = if esc then translatePartial (annWorkingSet ann) else id bName = [(mshowM 4 $ translate2 (antType (ntypes!!(x-1))), "a"++show x) | x <- [1..(length ntypes)]] aName = [(mshowM 2 $ (antType (ntypes!!(x-1))), "a"++show x, antAnn (ntypes!!(x-1))) | x <- [1..(length ntypes)]]