Hs2lib-0.6.3: WinDll/Structs/MShow/Haskell.hs
{-# LANGUAGE TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- MShow instances for the Haskell datatypes
--
-----------------------------------------------------------------------------
module WinDll.Structs.MShow.Haskell() where
import WinDll.Structs.MShow.MShow
import WinDll.Structs.Folds.Haskell
import WinDll.Structs.Haskell
import WinDll.Structs.Structures hiding (Import,imports,Pragma)
import WinDll.Structs.Folds.C
import WinDll.Structs.C
import WinDll.Parsers.Hs2lib
import WinDll.Utils.ListTypes
import WinDll.Session.Hs2lib(addParen)
import WinDll.Lib.NativeMapping
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Syntax
import qualified Language.Haskell.Exts.Syntax as Exts
import Data.Char
import Data.List hiding(maximum)
import Prelude hiding(maximum)
import Debug.Trace
instance MShow HaskellComment where
mshow (HaskellComment s) = "-- @@ " ++ s
instance MShow PragmaType where
mshow = show
instance MShow GHCPragma where
mshow (Pragma t o) = "{-# " ++ mshow t ++ " " ++ o ++ " #-}"
instance MShow Import where
mshow (Import s) = "import " ++ s
instance MShow HSC_Let where
mshow (HSC_Let s) = "#let " ++ s
instance MShow Ptr_Type where
mshow (TypeDecL name vars typ) = "type " ++ name ++ " " ++ unwords vars ++ "= " ++ mshow typ
mshow (TypeDecN name vars typ) = "type " ++ name ++ " " ++ unwords vars ++ "= " ++ mshowM 2 typ
instance MShow HaskellExport where
mshow (HaskellExport cc ann (Export name ename typ _orig modnm)) =
let call = map toLower . show
in "foreign export " ++ call cc ++ " \"" ++ ename ++ "\" " ++ name ++ " :: " ++ mshowM 3 (mkIO $ translatePartial (annWorkingSet ann) typ)
instance MShow HaskellImport where
mshow (HaskellImport cc ann (Export name ename typ _orig modnm)) =
let call = map toLower . show
in "foreign import " ++ call cc ++ " \"" ++ ename ++ "\" " ++ name ++ " :: " ++ mshowM 3 typ -- (translatePartial (annWorkingSet ann) typ)
instance MShow HaskellFunction where
mshow (HaskellFunction name orign typ ann _orig) =
let line1 = name ++ " :: " ++ mshowM 3 resTy -- (translatePartial typ)
resTy = (mkIO $ translatePartial (annWorkingSet ann) typ)
arity = tlength typ - 1 -- last argument is result type not an actual argument
vars' = ["a"++show x|x<- [1..arity]]
isList = (arity - 1) `elem` idx
vars = if isList
then init vars'
else vars'
size = last vars'
debug = annDebug ann
pokesz = [(st `add` "s") ++ " <- toNative " ++ st ++ "$! length res"
,"poke " ++ size ++ " " ++ (st `add` "s")
]
trim x = filter (/=' ') x
add x y = trim x ++ trim y
idx = annArrayIndices ann
front = unwords [name, unwords vars',"="]
indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++)
lines = munch mkFFI debug ((arity - 1) `delete` idx) vars
inner = ((maximum $ map (length.fst) lines)) `max` 3
binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines
names = map fst lines
res = if isIO typ
then ["res" ++ replicate (inner - 3) ' ', "<-", orign] ++ names
else ["let res =", orign] ++ names
ret = "toNative " ++ st ++ "res"
st = if debug then "st " else ""
defs = map indent $ [unwords res] ++ if isList then pokesz ++ [ret] else [ret]
dbgDef = if debug
then [indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\")"]
else []
in unlines $ [line1,front] ++ addDo (dbgDef ++ binds ++ defs)
where addDo :: [String] -> [String]
addDo [] = [" do "]
addDo (x:xs) = (" do " ++drop 5 x):xs
type Key = String
type Munch = Bool -> [Int] -> [String] -> Int -> ([(Key, String)], [String], Int -> Int)
mkFFI :: Munch
mkFFI _ _ [] _ = ([], [], id)
mkFFI dbg idx l i = if i `elem` idx
then let (a:b:xs) = l
st = mkBinds dbg "st" "fromList"
in ([(a++b, mkDbgSym dbg st "fromList "++a++" "++b)], xs, (+2))
else let (a:xs) = l
st = mkBinds dbg "st" "fromNative"
in ([(a++"p", mkDbgSym dbg st "fromNative "++a)], xs, (+1))
mkBinds dbg st name
= if dbg
then "(pushStack " ++ st ++ " (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\"))"
else ""
mkCall dbg st name
= let st' = mkBinds dbg st name
in mkDbgSym dbg st' (name++" ")
rmFFI :: Munch
rmFFI _ _ [] _ = ([], [], id)
rmFFI dbg idx l i = if i `elem` idx
then let (a:xs) = l
st1 = mkBinds dbg "st" "toNative"
st2 = mkBinds dbg "st" "toNative"
in ([(a++"sp", mkDbgSym dbg st1 "toNative " ++ "$! length "++a)
,(a++ "p", mkDbgSym dbg st2 "toNative " ++ a)], xs, (+1))
else let (a:xs) = l
st = mkBinds dbg "st" "toNative"
in ([(a++"p", mkDbgSym dbg st "toNative "++a)], xs, (+1))
mkDbg :: Bool -> String -> String
mkDbg dbg = mkDbgSym dbg "st"
mkDbgSym :: Bool -> String -> String -> String
mkDbgSym dbg sym = if dbg
then (++sym++" ")
else id
munch :: Munch -> Bool -> [Int] -> [String] -> [(Key, String)]
munch f dbg idx list = munch' list 0
where munch' :: [String] -> Int -> [(Key, String)]
munch' [] _ = []
munch' x n = let (v, xs, g) = f dbg idx x n
in v ++ munch' xs (g n)
instance MShow Stable where
mshow (Stable nm ty monm) = unlines [ nm ++ "A :: " ++ mshowM 2 (mk ty)
, nm ++ "A = freeStablePtr"
]
where ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon))
mk ty = Exts.TyFun ty ctType
instance MShow HaskellCallback where
mshow (Callback name ty transty orig ann) =
let arr = tlength transty - 1
arr' = tlength orig - 1
idx = annArrayIndices ann
vars' = ['a':show x|x<- [1..arr]]
vars2 = ['a':show x|x<- [1..arr']]
isList = (arr - 1) `elem` idx
idx' = (arr - 1) `delete` idx
vars = if isList
then init vars'
else vars'
size = last vars'
debug = annDebug ann
pokesz = [(st `add` "s") ++ " <- toNative " ++ st ++ "$! length res"
,"poke " ++ size ++ " $! " ++ (st `add` "s")
]
ret = "toNative " ++ st ++ "res"
ret2 = if isList && not origIO then mkDbg debug "fromNative " ++ "(lld res)" else mkDbg debug "fromNative " ++ "res"
mkUsf b = if not b then (++" unsafePerformIO $") else id
transtyIO = isIO transty
origIO = isIO orig
st = if debug then "st " else ""
trim x = filter (/=' ') x
add x y = trim x ++ trim y
in unlines $
["instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ name ++ "Ptr where"
," toNative " ++ st ++ "x = mk" ++ name ++ " =<< toNative " ++ st ++ "x"
," fromNative " ++ st ++ "x = fromNative " ++ st ++ "(dyn" ++ name ++ " x)"
," freeFFI " ++ st ++ "x = freeHaskellFunPtr "
] ++ if False then [] -- null (annArrayIndices ann) then []
else [""
,"instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ mshowM 3 (addParen transty) ++ " where"
,unlines $ (unwords $ (" toFFI " ++ st ++ "f") : vars' ++ [mkUsf transtyIO "="]) : mkResult mkFFI vars ret pokesz isList transtyIO idx' True
,unlines $ (unwords $ (" fromFFI " ++ st ++ "f") : vars2 ++ [mkUsf origIO "="]) : mkResult rmFFI vars2 ret2 pokesz False origIO idx' (not isList)
]
where addDo :: [String] -> [String]
addDo [] = [" do "]
addDo (x:xs) = (" do " ++drop 8 x):xs
mkResult mnch vrs rt pk lst io dlst sat
= let indent = (replicate 8 ' ' ++)
lines = munch mnch (annDebug ann) dlst vrs
inner = ((maximum $ map (length.fst) lines)) `max` 3
binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-" , v])) lines
names = map fst lines
res = if io && sat
then ["res" ++ replicate (inner - 3) ' ', "<- f"] ++ names
else ["let res = f"] ++ names
defs = map indent $ [unwords res] ++ if lst then pk ++ [rt] else [rt]
in addDo (binds ++ defs)
instance MShow Include where
mshow = foldInclude ((\a->"#include <"++a++">")
,(\a->"#include \""++a++"\"")
)
instance MShow DataEnum where
mshow = foldDataEnum ((\a b->let a' = map toLower a
fix = init.foldr (\a b->a++","++b) [] . map (\n ->"c" ++a++n++" = " ++ ("c"++a++n))
in "#enum Int,,"++fix b))
where toHSC :: String -> String
toHSC [] = []
toHSC (x:xs) | isLower x = x : toHSC xs
| otherwise = '_' : toLower x : toHSC xs
instance MShow HaskellStorable where
mshow _ = error "HaskellStorable: mshow - please call mshowWithPath"
mshowWithPath dbg path nspace opath = foldHaskellStorable (hsstorable,hspoke,hspeek)
where
hsstorable _name _size _hsize _ptr _vars
_spec _pok _pek _ann = unlines' $
("instance " ++ inst_head ++ "Storable " ++ val_head ++ " where")
: (map indent $ (val_size _size) :
["alignment _ = #alignment " ++ _name ++ "_t"
,[]
-- ,"{-# INLINE poke #-}"
,inline (unlines' (map (unlines.adj.lines) _pok))
-- ,"{-# INLINE peek #-}"
,"peek " ++ _ptr ++ " = do "
++ if dbg
then "\n" ++ (indent $ indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(Storable "
++ val_head ++ "@peek)\")")
else ""
,unlines _pek
])
where inst_head = case (length _vars') `compare` 1 of
LT -> ""
EQ -> "Storable " ++ head _vars' ++ " => "
GT -> (mkHead ["Storable " ++ x|x<- nub _vars']) ++ " => "
-- _vars' = filter (maybe False (const True) . flip lookup convList) _vars
_var_ = [ getResult (parseType t) | t <- _vars ]
_vars' = [ mshowM 2 (translatePrimitive (annWorkingSet _ann) t) | t <- _var_ ]
val_head = case (length _vars) > 0 of
False -> _name
True -> "(" ++ _name ++ " " ++ unwords _vars ++")"
val_size [_] = "sizeOf _ = " ++ show _hsize
val_size xs = "sizeOf _ = 8 " -- hardcoded to 8, e.g one pointer + one int32 (tag + elt)
adj [] = []
adj (x:xs) = (indent $ "poke " ++ _ptr ++ " "++x):(map indent xs)
mkHead x = "(" ++ foldr1 (\a b->a++", "++b) x ++ ")"
hspoke _n modnm _i x = let f = map (unlines'.map indent.lines.mshow)
dat = unwords ["a"++show x|x<-[1.._i]]
var = let x = (if _i == 0 then _n else "("++_n++" "++dat++")") ++" = do"
x' = indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(Storable "
++ _n ++ "@poke)\")"
in if dbg then ((x:) . (x':)) else (x:)
in (unlines . var . f) $ if null x then [PokeReturn modnm] else x
hspeek x = inline $ unlines' $ map (unlines'.(map (indent.indent)).lines.mshow) x
instance MShow StorablePeek where
mshow = foldStorablePeek (tag,entry,value,ret)
where
tag _name _ptr _type = unlines'
["tag' <- (#peek " ++ _name ++ "_t, tag) " ++ _ptr ++ " :: IO CInt"
,"newptr <- (#peek " ++ _name ++ "_t, elt) " ++ _ptr ++ " :: IO (Ptr " ++ _type ++ ")"
,"case tag' of"
]
entry _i _childs = unlines' $
(indent' $ show _i ++ " -> do") :
(map (unlines'.map indent.lines) _childs)
value _var _type
_name _ptr
_typevar = _var ++ " <- (#peek " ++ _type ++ "_t, " ++ _name ++ ") " ++ _ptr ++ " :: IO " ++ _typevar
ret dbg _b _type
tlist modnm = let mk = if _b
then mkCall dbg "st" "fromNative"
else "return "
vars = map (('x':).show) [1..(length tlist)]
args = [ case annArrayIsList ann of
False -> mk++x++ "' :: IO " ++ paren y
True -> mkCall dbg "st" "fromList" ++ x ++"s " ++ x ++ "'" | (y,x,ann)<-tlist]
lines = zip vars args
paren = \v -> if ' ' `elem` v then "(" ++ v ++ ")" else v
inner = ((maximum $ map (length.fst) lines)) `max` 3
binds = map ((\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines
in unlines' $ binds ++ ["return $ " ++ _type ++ " " ++ unwords vars]
instance MShow StorablePoke where
mshow = foldStorablePoke (tag,new,val,var,ret)
where
tag _type _field _ptr _poke = let mk :: String -> String
mk x = "(#poke " ++ _type ++"_t, " ++ _field ++ ") " ++ _ptr ++ " " ++ x
in case lines (mshow _poke) of
[_name, _rest] -> unlines' [ _rest, mk _name ]
_rest -> mk $ unlines' _rest
new dbg _name _type _size = if dbg
then _name ++ " <- mallocBytes " ++ show _size ++ " (newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"()\")) :: IO (Ptr " ++ _type ++ ")"
else _name ++ " <- mallocBytes " ++ show _size ++ " :: IO (Ptr " ++ _type ++ ")"
val _val = _val
var dbg _b _name
_ren _type _ann = let mk = if _b
then mkCall dbg "st" "toNative"
else "return "
tr = if _b then translatePartial (annWorkingSet _ann) else id
_newname = _name ++ "x"
_value = maybe _name id _ren
in unlines' [_newname
,_newname ++ " <- " ++ mk ++ _value ++" :: IO " ++ (mshowM 4 $ tr _type)
]
ret modnm = "return ()"
instance MShow HaskellFile where
mshow _ = error "HaskellFile: mshow - please call mshowWithPath"
mshowWithPath dbg a b c hsfile =
unlines $
[init $ mshowList (comments hsfile)
,mshowList (pragmas hsfile)
,"module " ++ _hsname hsfile ++ " where"
,[]
,mshowList (imports hsfile)
,mshowList (hsclets hsfile)
,mshowList (includes hsfile)
,mshowList (hsenums hsfile)
,mshowList (hstypes hsfile)
,mshowList (hsexports hsfile)
,mshowList (hsimports hsfile)
,init $ mshowList (hsfuncs hsfile)
,mshowList (hscallbacks hsfile)
,mshowList (hsstables hsfile)
,mshowListWithPath dbg a b c (hsstorable hsfile)
]
-- | Variant of unlines that does not add a newline char after everyline, only inbetween
unlines' :: [String] -> String
unlines' [] = []
unlines' x = foldr1 (\a b->a++"\n"++b) x
maximum :: (Ord a, Num a) => [a] -> a
maximum = foldl' max 0
-- | Get The result of a parse action
getResult (ParseOk a) = a