{-# 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.Hs2lib 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 = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)" 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 = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)" 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 "" in unlines $ ["instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ name ++ "Ptr where" ," toNative " ++ st ++ "x = mk" ++ name ++ " (toFFI " ++ st ++ "x)" ," fromFFI " ++ st ++ "x = fromFFI " ++ st ++ "(dyn" ++ name ++ " x)" ," freeFFI " ++ st ++ "x = freeHaskellFunPtr " ] ++ if 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 _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 (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 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 = if dbg then _name ++ " <- malloc (newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"()\")) :: IO (Ptr " ++ _type ++ ")" else _name ++ " <- malloc :: 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