----------------------------------------------------------------------------- -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 -- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental -- Portability : portable -- -- The scanner that reads the source file in via haskell-src-exts -- and then identifies the structures that need to be converted. -- And does priliminary scanning of these data structures. -- ----------------------------------------------------------------------------- module WinDll.Identifier where import GHC hiding (Type,DataType,NewType,Name,getName,Module) import GHC.Paths ( libdir ) import DynFlags import Data.Char import Data.Maybe import Data.List import Data.Monoid import Data.Generics hiding (DataType) import Data.Data hiding (DataType) import Data.Function(on) import WinDll.Structs.Structures import WinDll.Utils.Feedback import WinDll.Utils.Types (simplify) import WinDll.Builder import WinDll.Parsers.Hs2lib import WinDll.Session.Hs2lib import WinDll.Lib.Native import WinDll.Lib.Instances import WinDll.Lib.NativeMapping import WinDll.Structs.MShow.MShow import WinDll.Structs.MShow.HaskellSrcExts import qualified Language.Haskell.Exts.Syntax as Exts import Control.Arrow import qualified Debug.Trace as D -- | Generates the list of datatypes and functions needed in the merged files generateMain :: Exec ModInfo generateMain = do session <- get let cache = (mergeDep.pipeline) session cmds = filter (\(Pragma s _)->s=="INSTANCE") $ (pragmas.workingset) session args = map (\(Pragma _ x)->unwords x) cmds imps = map (\(Pragma _ x)->head x) cmds case cache of Just a -> return a Nothing -> do let _modules = ((map fst) . modules . workingset) session merged@(Module _ _ _ _ d f _ t) = subject args $ fixpoint (mergeModules _modules) (simple_datatypes, spec_datatypes) = partition isSimpleData d (t_mods,missing,spec) = traceModules spec_datatypes imps merged -- liftIO $ print spec_datatypes >> print spec >> print d -- liftIO $ print spec -- liftIO $ print t_mods -- liftIO $ print ( shifted simple_datatypes t_mods ) >> putStrLn "---- End ----" -- liftIO $ print spec_datatypes when (not $ null missing) $ warn ("Could not resolve the following " ++ show (length missing) ++ " type(s) which are needed: \n" ++ concatMap (\a->"\t - "++a++"\n") missing) when (null f) $ die "No functions have been marked to be exported. There's nothing to generate. Stopping..." defs <- makeSessionAnn let mexports = exports merged ++ generateFreeExports mstableptr mstableptr = (nubBy ((==) `on` stType) $ findStableRefs d ++ findStableRefs f ) mcallbacks = nubBy ((==) `on` simplify . cbInputType) $ generateCallbacksFromExports defs mexports ++ concatMap (genCallbacksFromDatatype defs) d mdep = ModInfo (map (resolveFunctionCallbacks mcallbacks) f) -- ++ generateFreeFuncs mstableptr) (resolveCallback False mcallbacks (shifted simple_datatypes t_mods ,shifted spec_datatypes $ map fst spec)) (resolveCallback True mcallbacks mexports) mcallbacks mstableptr -- liftIO $ print mdep -- liftIO $ print mcallbacks put (session { pipeline = (pipeline session) { mergeDep = Just mdep , specs = spec} }) return mdep where shifted :: DataTypes -> TypeNames -> DataTypes shifted d t = filter (\a->getName a `elem` t) d -- | Resolve callback types inside types if any. -- It looks inside types and try to resolve any -- type from the callback cache to a type synonym name. -- e.g. (Int -> Int -> String) -> Bool to FooType -> Bool -- The first parameter indicates if strict matching should be done -- e.g. exact matches to types, if false parenthesis are disgarded resolveCallback :: Data a => Bool -> [Callback] -> a -> a resolveCallback exact cache = everywhere (mkT $ lookup cache) where lookup :: [Callback] -> Type -> Type lookup [] t = t lookup ((Callback n ty ty' _ _):xs) t = if ((==) `on` if exact then id else addParen) ty t then Exts.TyCon (Exts.UnQual (Exts.Ident n)) else lookup xs t -- | Resolve functions callbacks, then rescan them for the presence oflists resolveFunctionCallbacks :: [Callback] -> Function -> Function resolveFunctionCallbacks cl fn = fn' { fnAnn = ann' } where ann' = (fnAnn fn') { annArrayIndices = findListIndices (fnType fn')} fn' = resolveCallback True cl fn -- | Generates callbacks for an Export type. This hides the original type -- b ecause if we don't, it'll generate too many specifications. generateCallbacksFromExports :: Ann -> [Export] -> [Callback] generateCallbacksFromExports defs xs = concatMap gen (zip xs [1..(length xs)]) where gen :: (Export,Int) -> [Callback] gen (exp,seed) = let cb1 = generateCallbacks defs seed (exType exp) cb2 = generateCallbacks defs seed (exOrgType exp) res = zipWith (\x y->update (x{cbInputType = cbOrigType y})) cb1 cb2 update = \x-> let ty = analyzeType True (cbNewType x) my = analyzeType False (cbOrigType x) in x{ cbNewType = ty , cbAnn = (cbAnn x){annArrayIndices = findListIndices ty} , cbOrigType = my} in if length cb1 /= length cb2 then error $ "Length mismatched, cannot generate callback types for " ++ show exp else res -- | Creates the list of callbacks found in function signatures. -- This relies on there not being unneeded parenthesis in types. e.g. -- a -> b -> (d -> d) will incorrectly generate a callback, which is never used generateCallbacks :: Data a => Ann -> Int -> a -> [Callback] generateCallbacks cfg seed exports = let types = listify isParen exports ids = [seed..(seed + length types)] in do (num, ty) <- zip ids types let name = "CBF" ++ show num newty = translatePartial (annWorkingSet cfg) ty return $ Callback name ty newty (Exts.TyCon (Exts.Special Exts.UnitCon)) (cfg{ annArrayIndices = [], annArrayIsList = False }) where isParen (Exts.TyParen a) = hasTyApp a isParen _ = False hasTyApp = everything (||) (False `mkQ` isFun) isFun (Exts.TyFun{}) = True isFun _ = False -- | Creates a list of callbacks from datatypes. This differs from general function -- in that to have a higher ordered function there is no need to have a parenthesis () -- in the type. Any abritrary function as type of one of the fields of a constructor -- indicated a higher order function. genCallbacksFromDatatype :: Ann -> DataType -> [Callback] genCallbacksFromDatatype defs (NewType a b c d) = genCallbacksFromDatatype defs (DataType a b [c] d) genCallbacksFromDatatype defs (DataType a _ c _) = concatMap findCallbacks c where findCallbacks :: DataType -> [Callback] findCallbacks (Constr n ft tys) = let values = filter (gIsFun . antType) tys mkC rec | a==n = Callback ("CBF" ++ a ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) -- ^ temporary black whole | otherwise = Callback ("CBF" ++ a ++ n ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) where _ty = addParen (antOrigType rec) ty = addParen (antType rec) nm = antName rec ann = antAnn rec in map mkC values -- | Find all TyApp beginning with StablePtr and return the right sides. findStableRefs :: (Data r, Typeable r) => r -> [Stable] findStableRefs x = let list = listify isRef x vals = nub $ map simplify list dats = simplify vals nms = map flattenToString dats in [Stable ("free"++x) y [] | x <- nms, y <- dats] where isRef (Exts.TyApp x y) | mshowM 2 x == "StablePtr" = True isRef _ = False -- | Generate free functions for stable ptrs found. generateFreeFuncs :: [Stable] -> [Function] generateFreeFuncs = map mkFun where mkFun (Stable nm ty modnm) = Function { fnName = nm , fnArity = 1 , fnType = mk ty , fnAnn = mempty , fnOrigType = mk ty } ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) mk ty = Exts.TyFun ty ctType -- | Generate free exports for stable ptrs found. generateFreeExports :: [Stable] -> [Export] generateFreeExports = map mkFun where mkFun (Stable nm ty modnm) = Export { exName = nm , exAs = nm , exType = mk ty , exOrgType = mk ty , exModule = modnm } ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) mk ty = Exts.TyFun ty ctType -- | Add the pragmas back into the generated AST subject :: TypeNames -> Module -> Module subject xs mod = mod { instances = instances mod ++ _inst , types = types mod ++ _type } where _inst = map (\x->Instance ([Exts.TyCon $ Exts.UnQual $ Exts.Ident $ head $ words x])) xs _type = map mkType xs mkType x = let (y:n:_) = words x 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.TyVar (Exts.Ident "Ptr")) (Exts.TyParen x) in TypeDecL (y++"Ptr") typenames $ mkPtr (foldr1 Exts.TyApp typevars) ------------------------------------------------------------------------------ -- | Fixpoint iteration to solve type synonyms. At first glance this may look -- like it's not needed but if it's not done then incorrect C code will be -- generated and we may not generate sufficient Haskell storable values. Look -- at the example: -- -- type Foo = Data String -- -- data Data a = Data a -- -- stub :: Foo -- stub = Data \"\" -- -- This would generate a warning that \"Foo\" could not be found, it would also -- not generate the needed C code or Haskell Storable instance (specialized) to -- Data String -- -- The current implementation is rather inefficient, but it's only proof of -- concept. -- -- This implementation has a bug: -- type F a = (Int,a) -- -- stub :: F String -- -- resolves to -- -- stub :: (Int,String) String ------------------------------------------------------------------------------ fixpoint :: Module -> Module fixpoint m@(Module _ _ _ e d f _ t) = let adj' t = everywhere (mkT (make t)) make t = case isClosed t of True -> swapTypes (typeName t) (repTypes t) False -> unifyType t adl = map adj' t m' = (apply adl m) { types = t } changed = m/=m' apply = flip (foldr ($)) in if changed then fixpoint m' else m' ------------------------------------------------------------------------------ -- | This is a hack to get a working first version. It basically merges all -- module declaration, which introduces various restrictions on the first -- version of WinDll. -- -- Current Restrictions: -- - Does not automatically resolve missing datatype declarations -- using hackage. Future releases will search library code for -- the types you need to resolve this but currently you'll -- get a missing instance error. -- -- - You cannot export functions which have the same name -- (even if they're in different modules because 1 big hsc -- file is generated at the moment, no conflict resolutions) -- -- - You cannot export datatypes with the same name, same -- restriction as above. ------------------------------------------------------------------------------ mergeModules :: [WinDll.Structs.Structures.Module] -> WinDll.Structs.Structures.Module mergeModules = fiximports . mconcat where fiximports m = m { imports = expand (imports m) 1 } expand (('@':nm):xs) n = ("qualified " ++ nm ++ " as S" ++ show n):expand xs (n+1) expand name _ = name -- | Find the structures needed in a module and returns the list of datatypes it needs -- to export, and the list of missing datatypes and the list of types to specialize -- we nub often in order to mininize the sets we generate. If we don't do this on large -- modules we'll end up consuming alot more memory, So it's a trade-off between speed and -- size. And I choose size. traceModules :: DataTypes -> TypeNames -> WinDll.Structs.Structures.Module -> (TypeNames,TypeNames,[(Name,Types)]) traceModules specs types (Module (Header name _) _ _ _ datatypes functions insts _) = let fun_s = nub $ concatMap (traceF True) functions existing = nub $ getStorableInstances insts datas = nub $ map topNameValue datatypes ++ types ++ existing funcs = filter (noPrimFilter True) $ force_resolve_fixpoint fun_s datatypes specials = let fun_s' = nub $ concatMap (traceF False) functions funcs' = force_resolve_fixpoint fun_s' datatypes ++ concatMap resolve datatypes typs = concatMap (splitType . fnType) functions ++ concatMap getTypes datatypes known = knownDataInstances ++ map getName specs filt = nub $ filter (`elem` known) funcs' safe = filt \\ knownPointerTypes in concat $ liftM2 selectTypePre safe typs -- $ D.trace (unlines $ map show typs) typs in (funcs,funcs\\datas, nub specials) -- | Find all the storable instances inside the current Instances list, returns the names getStorableInstances :: Instances -> TypeNames getStorableInstances [] = [] getStorableInstances (x:xs) = case x of Instance t -> map mshow t ++ getStorableInstances xs QualifiedInstance "Storable" t -> map mshow t ++ getStorableInstances xs _ -> getStorableInstances xs ------------------------------------------------------------------------------ -- | Fixpoint iteration to solve datatype dependencies as much as possible -- Basically this tries to also look into Datatypes to find all the type -- names needed. -- . -- . Example: -- . data Foo = Bar Tuu -- . data Tuu = V Int -- . -- . and stub :: Foo -- . -- . resolves to -- . [Foo,Tuu,Int] ------------------------------------------------------------------------------ force_resolve_fixpoint :: TypeNames -> DataTypes -> TypeNames force_resolve_fixpoint datas datatypes = let newdatas = catMaybes (map (flip find datatypes) datas) newtypes = nub $ datas ++ concatMap resolve newdatas in if newtypes == datas then newtypes else force_resolve_fixpoint newtypes datatypes where find :: TypeName -> DataTypes -> Maybe DataType find name [] = Nothing find name (x:xs) = case x of d@(NewType n _ _ _) | n==name -> Just d d@(DataType n _ _ _) | n==name -> Just d _ -> find name xs -- | Trace the structures needed for exporting this function traceF :: Bool -> Function -> TypeNames traceF full fn = scan $ collectTypes (fnType fn) -- collectTypesEx knownPointerTypes args where scan = (filter (\a->isNotPrim full a && filterTypeVars a)) -- | Checks if the given type is not a primitive type isNotPrim :: Bool -> TypeName -> Bool isNotPrim full a = a `notElem` (knownPrimitives ++ if full then knownDataInstances else []) -- | Function to filter out all type variabls from a type filterTypeVars :: TypeName -> Bool filterTypeVars [] = False filterTypeVars (x:_) = isUpper x -- | Combines isNotPrim and filterTypeVars noPrimFilter :: Bool -> TypeName -> Bool noPrimFilter b t = isNotPrim b t && filterTypeVars t -- | A function to resolve top level typenames, since these are the only ones that matter topNameValue :: DataType -> TypeName topNameValue = getName -- | Resolve the needed Abstract data types needed in order to marshal the given DataType definition resolve :: DataType -> TypeNames -- [(Name,ExportName)] resolve (NewType n t d tag) = resolve $ DataType n t [d] tag resolve (DataType n t xs tag) = n' : (filter check $ unwind xs) where check _type = (n' /= _type) && (_type `notElem` t) unwind = concatMap (\(Constr _ _ t) -> concatMap (collectTypes . antType) t) cast = (id :: Name -> TypeName) n' = cast n -- | Create a list of TypeTags for used when resolving the types with GHC api. (Not used in version 1.0) createList :: DataType -> [TypeTag] createList (NewType n t xs tag) = createList (DataType n t [xs] tag) createList (DataType n t xs tag) = tag : concatMap createList xs createList (Constr _ ft nt) = map (create.antType) $ sanitize nt where sanitize = filter (not.and.map isLower.head.collectTypes.antType) create = \n -> TypeTag (mshow n) False undefined -- | Lookup typing information using GHC API, in order to find out whether the type is a custom defined type, or a primitive type. lookupType :: Type -> Maybe Type lookupType _type = undefined -- | A list of the most frequently used types, It's much faster to do list lookup than query GHC, -- so we first look up in this list and then make a call to GHC knownPrimitives :: TypeNames knownPrimitives = [ "Int" , "Integer", "Float" , "Double" , "String" , "Char" ,"Word64" , "Int8" , "Int16" , "Int32" , "Int64" , "Word8" , "Word16" ,"Word32" , "Int#" , "Float#" , "Double#" , "CWString" , "Bool" , "IO" , "()" , "CInt" ] ++ knownPointerTypes -- | A list of known pointer types, if we find these we should not trace their dependencies. -- because they matter not. knownPointerTypes :: TypeNames knownPointerTypes = ["StablePtr", "Ptr"] -- | The first lookup venue to GHC is looking up based on the type classes that we've already covered by the FFI class. -- So if the type is an instance of the following classes it's safe to ignore them. knownClasses :: TypeNames knownClasses = ["Storable" , "IO" , "Num" , "FFIType" ] -- askGHC :: [Types] -> IO [String] -- askGHC