{-# 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