Hs2lib-0.5.7: 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.Utils.KnownTypes
import WinDll.Utils.ListTypes
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) = updateModule
$ 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 ++
"\nIf these types are not to be exported try using the INSTANCE Hs2lib pragma\n")
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
expandedTy = resolveTypeSyn t
stables = findStableRefs expandedTy d ++ findStableRefs expandedTy f
mstableptr = nubBy ((==) `on` stType) stables
calls1 <- generateCallbacksFromExports defs mexports
calls2 <- mapM (genCallbacksFromDatatype defs) d
let mcallbacks = nubBy ((==) `on` simplify . cbInputType) $ calls1 ++ concat calls2
forM_ mcallbacks giveIOWarning
let 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] -> Exec [Callback]
generateCallbacksFromExports defs xs = fmap concat $ mapM gen (zip xs [1..(length xs)])
where gen :: (Export,Int) -> Exec [Callback]
gen (exp,seed) = do cb1 <- generateCallbacks defs seed (exType exp)
cb2 <- generateCallbacks defs seed (exOrgType exp)
let 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}
if length cb1 /= length cb2
then die $ "Length mismatched, cannot generate callback types for " ++ show exp
else return 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 -> Exec [Callback]
generateCallbacks cfg seed exports
= return gen
where gen = 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 })
isParen (Exts.TyParen a) = hasTyApp a
isParen _ = False
hasTyApp = everything (||) (False `mkQ` isFun)
isFun (Exts.TyFun{}) = True
isFun _ = False
-- | Generate a warning about a higher order type that are not in IO
giveIOWarning :: Callback -> Exec ()
giveIOWarning cb | isIO (cbOrigType cb) = return ()
giveIOWarning cb = do warn $ "The higher-order type argument '" ++ mshowM 2 ty ++ "' is not in IO," ++
"\n this will most likely result in a segfault since I cannot convert " ++
"\n between the expected type '" ++ mshowM 2 (mkIO ty) ++ "' and the given " ++
"\n non-IO type in the current version of the library. Please lift your argument" ++
"\n into IO to avoid the use of unsafePerformIO"
where ty = cbOrigType cb
-- | 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 -> Exec [Callback]
genCallbacksFromDatatype defs (NewType a b c d) = genCallbacksFromDatatype defs (DataType a b [c] d)
genCallbacksFromDatatype defs (DataType a _ c _) = fmap concat $ mapM findCallbacks c
where findCallbacks :: DataType -> Exec [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
result = map mkC values
in return result
-- | Find all TyApp beginning with StablePtr and return the right sides.
findStableRefs :: (Data r, Typeable r) => [TypeDecL] -> r -> [Stable]
findStableRefs tyL x = let list = listify isRef x
vals = nub $ map simplify list
dats = simplify vals
nms = map flattenToString dats
in [Stable ("free"++ getName x y tyL) y [] | x <- nms, y <- dats]
where isRef (Exts.TyApp x y)
| mshowM 2 x == "StablePtr" = True
isRef _ = False
getName base ty synL = let match = filter (==ty) . map repTypes $ synL
-- this is not working.. need to check why
in if null match then strip base else typeName (head synL)
strip = filter isAlphaNum
-- | 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 everywhere (mkT (simplify :: Type -> Type)) m' -- correct types
------------------------------------------------------------------------------
-- | Uses a fixpoint iteration to expand a type synonym to the maximum expanded
-- type that can be made from it:
--
-- For example:
--
-- type Session = Interpreter ()
-- type Context = StablePtr (IORef Session)
--
-- turns into:
--
-- type Session = Interpreter ()
-- type Context = StablePtr (IORef (Interpreter ()))
------------------------------------------------------------------------------
resolveTypeSyn :: [TypeDecL] -> [TypeDecL]
resolveTypeSyn 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 t
changed = t/=m'
apply = flip (foldr ($))
in if changed
then resolveTypeSyn m'
else everywhere (mkT (simplify :: Type -> Type)) m' -- correct types
------------------------------------------------------------------------------
-- | 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 $ collectTypesEx knownIgnorableTypes (fnType fn) -- collectTypes (fnType fn)
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
-- askGHC :: [Types] -> IO [String]
-- askGHC