Hs2lib-0.4.8: 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
import WinDll.Builder
import WinDll.Utils.Feedback
import WinDll.Identifier
import WinDll.Parsers
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
(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
let (imp,lets) = insertHeaders
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"]
(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 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)
,HaskellImport cc ann (Export ("dyn" ++ name) "dynamic" tyFrom otype)]
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
-- | 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 :: ([Import],[HSC_Let])
insertHeaders = (map Import (stdImports ++
["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 ntypes) = (name, length ntypes)
in HSStorable name sizes "ptr" e esc po [peeks] 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 ntypes) =
let col = case newtpe of
False -> [PokeTag dna "tag" _ptr (PokeValue enum)
,NewPtr _newptr dnamod
] ++ inner ++
[PokeTag dna "elt" _ptr (PokeValue _newptr)]
True -> concat $ zipWith (\x (c,b)->let base = PokeTag dna (antName x) _ptr (PokeVar esc b Nothing c ann)
msg = "(length " ++ b ++ ")"
size = PokeTag name (antName x++"_Size") _ptr (PokeVar 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 (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 esc b Nothing c ann)
msg = "(length " ++ b ++ ")"
size = PokeTag name (antName x++"_Size") _newptr (PokeVar 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 ntypes) =
let col = case newtpe of
True -> inner ++ [PeekReturn esc namep aName]
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 esc namep aName]]
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)]]