Hs2lib-0.5.0: WinDll/CodeGen/Haskell.hs
-----------------------------------------------------------------------------
-- |
-- 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)]]