Hs2lib-0.4.8: 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.Structs.MShow.Alignment
import WinDll.Parsers
import WinDll.Session(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)) =
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)) =
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'
pokesz = "poke " ++ size ++ " (toFFI $! length res)"
idx = annArrayIndices ann
front = unwords [name, unwords vars',"="]
indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++)
lines = munch mkFFI ((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 res"
defs = map indent $ [unwords res] ++ if isList then [pokesz, ret] else [ret]
in unlines $ [line1,front] ++ addDo (binds ++ defs)
where addDo :: [String] -> [String]
addDo [] = [" do "]
addDo (x:xs) = (" do " ++drop 5 x):xs
type Key = String
type Munch = [Int] -> [String] -> Int -> ([(Key, String)], [String], Int -> Int)
mkFFI :: Munch
mkFFI _ [] _ = ([], [], id)
mkFFI idx l i = if i `elem` idx
then let (a:b:xs) = l
in ([(a++b, "fromList "++a++" "++b)], xs, (+2))
else let (a:xs) = l
in ([(a++"'", "fromNative "++a)], xs, (+1))
rmFFI :: Munch
rmFFI _ [] _ = ([], [], id)
rmFFI idx l i = if i `elem` idx
then let (a:xs) = l
in ([(a++"s'", "toNative $ length "++a)
,(a++ "'","toNative "++a)], xs, (+1))
else let (a:xs) = l
in ([(a++"'", "toNative "++a)], xs, (+1))
munch :: Munch -> [Int] -> [String] -> [(Key, String)]
munch f idx list = munch' list 0
where munch' :: [String] -> Int -> [(Key, String)]
munch' [] _ = []
munch' x n = let (v, xs, g) = f idx x n
in v ++ munch' xs (g n)
instance MShow Stable where
mshow (Stable nm ty) = 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'
pokesz = "poke " ++ size ++ " (toFFI $! length res)"
ret = "toNative res"
ret2 = if isList && not origIO then "fromNative (lld res)" else "fromNative res"
mkUsf b = if not b then (++" unsafePerformIO $") else id
transtyIO = isIO transty
origIO = isIO orig
in unlines $
["instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ name ++ "Ptr where"
," toNative x = mk" ++ name ++ " (toFFI x)"
," fromFFI x = fromFFI (dyn" ++ name ++ " x)"
," freeFFI x = freeHaskellFunPtr "
] ++ if null (annArrayIndices ann) then []
else [""
,"instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ mshowM 3 (addParen transty) ++ " where"
,unlines $ (unwords $ " toFFI f" : vars' ++ [mkUsf transtyIO "="]) : mkResult mkFFI vars ret pokesz isList transtyIO idx' True
,unlines $ (unwords $ " fromFFI 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 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 path nspace opath = foldHaskellStorable (hsstorable,hspoke,hspeek)
where
hsstorable _name _size _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 "
,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 (resolveAlignment path nspace opath _name [])
val_size xs = "sizeOf _ = " ++ show (resolveAlignment path nspace opath _name xs)
adj [] = []
adj (x:xs) = (indent $ "poke " ++ _ptr ++ " "++x):(map indent xs)
mkHead x = "(" ++ foldr1 (\a b->a++", "++b) x ++ ")"
hspoke _n _i x = let f = map (unlines'.map indent.lines.mshow)
dat = unwords ["a"++show x|x<-[1.._i]]
var = (if _i == 0 then _n else "("++_n++" "++dat++")") ++" = do"
in (unlines . (var:) . f) $ if null x then [PokeReturn] 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 _b _type tlist = let mk = if _b then "fromNative" else "return"
vars = map (('x':).show) [1..(length tlist)]
args = [ case annArrayIsList ann of
False -> mk++" " ++x++ "' :: IO " ++ paren y
True -> "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 _name _type = _name ++ " <- malloc :: IO (Ptr " ++ _type ++ ")"
val _val = _val
var _b _name _ren
_type _ann = let mk = if _b then "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 = "return ()"
instance MShow HaskellFile where
mshow _ = error "HaskellFile: mshow - please call mshowWithPath"
mshowWithPath 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 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