----------------------------------------------------------------------------- -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 -- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental -- Portability : portable -- -- Structures used in WinDll -- ----------------------------------------------------------------------------- module WinDll.Utils.TypeFolds where import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.SrcLoc as Span import Data.Data hiding (DataType) import Data.Typeable import Data.Monoid import Data.Maybe import Data.List import Control.Arrow import Data.Generics hiding (DataType) import WinDll.Structs.Folds.HaskellSrcExts import WinDll.Structs.MShow.HaskellSrcExts import WinDll.Structs.MShow.MShow import WinDll.Structs.Types -- | A length function to determine the arrity of a type tlength :: Type -> Int tlength = foldType (const . const id ,(+) ,const . const 1 ,const 1 ,const . const 1 ,const 1 ,const 1 ,id ,const . const . const 1 ,const . id ) -- | Split a type up at the TyFun's. So we can determine the different parts of a function -- This function has clearly a problem with higher-rank functions. But since we don't support -- those anyway. No Harm no foul for now. splitType :: Type -> [Type] splitType = foldType ((\a b c->map (Exts.TyForall a b) c) ,(++) ,(\a b-> [Exts.TyTuple a (concat b)]) ,map Exts.TyList ,zipWith Exts.TyApp ,(:[]) . Exts.TyVar ,(:[]) . Exts.TyCon ,map Exts.TyParen ,(\a c b->zipWith (flip Exts.TyInfix c) a b) ,(\a b-> map (flip Exts.TyKind b) a) ) -- | Flattens a Type down to a single string by concatening the elements it's composed of flattenToString :: Type -> String flattenToString = foldType ((\a b c-> "Forall" ++ c) ,(\a b-> a ++ "To" ++ b) ,(\a b -> "Tuple" ++ concat b) ,(\a -> "List" ++ a) ,(++) ,mshowM 2 ,mshowM 2 ,id -- (\a -> "Parens" ++ a) ,(\a b c->"Infix" ++ a ++ show b) ,(\a b -> "Kind" ++ a) ) -- | A function to collect all types from a type collectTypeVars :: Type -> TypeNames collectTypeVars = foldType (const . const id ,(++) ,const concat ,id ,(++) ,(:[]).mshow ,const [] ,id ,(\a _ b->a++b) ,const ) -- | A function to collect all type variables from a type collectTypes :: Type -> TypeNames collectTypes = foldType (const . const id ,(++) ,const concat ,id ,(++) ,(:[]).mshow ,(:[]).mshow ,id ,(\a _ b->a++b) ,const ) -- | A function to collect all type variables from a type, -- except type applications are stucturally preserved. collectLessTypes :: Type -> TypeNames collectLessTypes = foldType (const . const id ,(++) ,const concat ,id ,\x -> (:[]) . unwords . (++) x ,(:[]).mshow ,(:[]).mshow ,id ,(\a _ b->a++b) ,const ) -- | A function to collect all type variables from a type but -- any applied type in the excempt list will be ignored. collectTypesEx :: TypeNames -> Type -> TypeNames collectTypesEx h = foldType (const . const id ,(++) ,const concat ,id ,mk ,(:[]).mshow ,(:[]).mshow ,id ,(\a _ b->a++b) ,const ) where mk a b = if any (flip elem h) a then [] else a ++ b collectRealTypes :: Type -> [Type] collectRealTypes = foldType (const . const id ,(++) ,const concat ,map Exts.TyList ,(++) ,(:[]). Exts.TyVar ,(:[]). Exts.TyCon ,id ,(\a _ b->a++b) ,const ) -- | A function to find the Type at the left side of TyApp and return the RHS and the original in a tuple selectType :: TypeName -> Type -> [(Name,TypeNames)] selectType name = everything (++) ([] `mkQ` adj) where cast = id :: TypeName -> Name adj :: Type -> [(Name,TypeNames)] adj (Exts.TyApp h t) = case collectTypes h of [] -> [] -- should never happen (x:_) -> case x == (cast name) of True -> [(cast name,collectTypes t)] False -> selectType name t adj _ = [] -- | A function to find the Type at the left side of TyApp and return the RHS and the original in a tuple -- But preserving semantics, needed for specializations. selectTypePre :: TypeName -> Type -> [(Name,Types)] selectTypePre name = adj True where cast = id :: TypeName -> Name adj :: Bool -> Type -> [(Name,Types)] adj _ z@(Exts.TyApp h t) = case collectTypes h of [] -> [] -- should never happen (x:_) -> case x == (cast name) of True -> let value = case isComplex t of True -> [t] False -> tail (make z) in [(cast name,value)] False -> adj False t adj _ (Exts.TyForall a b c) = adj False c adj _ (Exts.TyFun a b) = (adj False a) ++ (adj False b) adj f (Exts.TyTuple a b) = let val = concatMap (adj f) b in case f of True -> val False -> map (second ((:[]) . Exts.TyTuple a)) val adj f (Exts.TyList a) = let val = adj f a in case f of True -> val False -> map (second (map Exts.TyList)) val adj _ (Exts.TyVar a) = [] adj _ (Exts.TyCon a) = [] adj _ (Exts.TyParen a) = adj True a adj _ (Exts.TyInfix a b c) = (adj False a) ++ (adj False c) adj _ (Exts.TyKind a b) = adj False a make :: Type -> [Type] make = listify isSimple isComplex (Exts.TyParen a) = isComplex a isComplex (Exts.TyList{} ) = True isComplex (Exts.TyTuple{}) = True isComplex (Exts.TyApp{} ) = True isComplex _ = False isSimple (Exts.TyVar _) = True isSimple (Exts.TyCon _) = True isSimple _ = False -- | A function to find swap out whole type declarations -- This is wrong, It should be type unification. -- TODO: Fix it, It's critical swapTypes :: TypeName -> Type -> Type -> Type swapTypes name template t = (\(Exts.TyParen f)->f) $ foldType ((\a b c->Exts.TyForall a b (rep c)) ,(\a b->Exts.TyFun (rep a) (rep b)) ,(\a b->Exts.TyTuple a (map rep b)) ,Exts.TyList . rep ,(\a b->Exts.TyApp (rep a) (rep b)) ,Exts.TyVar ,Exts.TyCon ,Exts.TyParen . rep ,(\a c b->Exts.TyInfix (rep a) c (rep b)) ,(\a b->Exts.TyKind (rep a) b) ) (Exts.TyParen t) where rep :: Type -> Type rep p = if adj p then template else p adj :: Type -> Bool adj t@(Exts.TyCon h) = mshow h == name adj t@(Exts.TyVar h) = mshow h == name adj x = False