Hs2lib-0.4.8: WinDll/Identifier.hs
-----------------------------------------------------------------------------
-- |
-- 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
import WinDll.Session
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 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) = 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) = Export { exName = nm
, exAs = nm
, exType = mk ty
, exOrgType = mk ty
}
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 = mconcat
-- | 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 _ 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