Hs2lib-0.4.8: WinDll/Utils/TypeFolds.hs
-----------------------------------------------------------------------------
-- |
-- 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