{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.TypeLib -- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : forsyde-dev@ict.kth.se -- Stability : experimental -- Portability : portable -- -- This module provides basic functions related to Template-Haskell's 'Type'. -- ----------------------------------------------------------------------------- module Language.Haskell.TH.TypeLib (Context, mkContext, monoContext, isPoly, contextVarNames, contextConstraints, mkForallT, unArrowT, unAppT, (-->), reAppT, reArrowT, dynTHType, thTypeOf, typeRep2Type, tyCon2Type, type2TypeRep) where import Data.Typeable.Internal import Data.Dynamic import Language.Haskell.TH (Type(..), Cxt, TyVarBndr(..), pprint, mkName, nameModule, nameBase) import Text.Regex.Posix ((=~)) import Data.Maybe(isJust, fromMaybe) -- Due to type translations import Data.Word (Word, Word8, Word16, Word32, Word64) import Data.Int (Int8, Int16, Int32, Int64) import System.IO (Handle) import Data.IORef (IORef) import Foreign (Ptr, FunPtr, StablePtr, ForeignPtr) --import Control.OldException (Exception, -- AsyncException, -- ArrayException, -- ArithException, -- IOException) import Data.Ratio (Ratio) import Control.Concurrent.MVar (MVar) ----------- -- Context ----------- -- | A 'Context' represents the forall part and constraints of a type -- (see 'ForallT') -- For instance, the context of the type -- @ -- forall a b. (Show a, Show b) => (a,b) -- @ -- is @forall a b. (Show a, Show b) =>@ -- where @a@ and @b@ are the the context variables and -- @(Show a, Show b)@ are the context constraints data Context = Context [TyVarBndr] -- Variable names Cxt -- Constraints (the context itself) instance Show Context where -- FIXME: this is really ugly, refactor and improve its look showsPrec _ (Context tvb cxt) = showVars tvb . showConstraints cxt where showVars tvb = showForall (not (null tvb)) (showVars' tvb) showVars' ((PlainTV n):tvbs) = shows n . showChar ' ' . showVars' tvbs showVars' [] = id showConstraints c = (\s -> if not (null c) then ' ':s else s). showParen (length c > 1) (showConstraints' c) . (\s -> if not (null c) then s ++ " =>" else s) showConstraints' [c] = shows c showConstraints' (c:cx) = showString (pprint c) . showString ", " . showConstraints' cx showConstraints' [] = id showForall b s = if b then showString "forall " . s . showChar '.' else s -- | 'Context' constructor mkContext :: [TyVarBndr] -> Cxt -> Context mkContext tvb c = Context tvb c -- | Empty context for monomorphic types monoContext :: Context monoContext = Context [] [] -- | Tells if the context corresponds to a polymorphic type isPoly :: Context -> Bool isPoly (Context [] _) = False isPoly _ = True -- | Returns the variable names related to a context contextVarNames :: Context -> [TyVarBndr] contextVarNames (Context tvb _) = tvb -- | Returns the context constraints contextConstraints :: Context -> Cxt contextConstraints (Context _ cxt) = cxt -- | Builds a 'ForallT' type out of a context and a type mkForallT :: Context -> Type -> Type mkForallT (Context tvb cxt) t = ForallT tvb cxt t -------------------------------- -- Functions to observe a 'Type' -------------------------------- -- | Obtains the arguments and return type of a given 'Type' -- (normally a function) -- together with its 'Context' (non-empty if the type is polymorphic) unArrowT :: Type -- ^ Type to observe -> ([Type], Type, Context) -- ^ (args 'Type', ret 'Type', 'Context') unArrowT (ForallT names cxt t) = let (args,ret) = unArrowT' t in (args, ret, Context names cxt) unArrowT t = let (args,ret) = unArrowT' t in (args, ret, Context [] []) -- unArrowT for non-Forall Types unArrowT' :: Type -> ([Type], Type) unArrowT' ((ArrowT `AppT` first) `AppT` rest) = let (args, ret) = unArrowT' rest in (first:args, ret) unArrowT' t = ([],t) -- | Obtains the type constructor of a 'Type' together with its -- arguments and its 'Context' (non-empty if the type is polymorphic) unAppT :: Type -- ^ Type to observe -> (Type, [Type], Context) -- ^ (Constructor, args 'Type', Context) unAppT (ForallT names cxt t) = let (cons, args) = unAppT' t in (cons, args, Context names cxt) unAppT t = let (cons, args) = unAppT' t in (cons, args, Context [] []) -- unAppT for non-Forall Types unAppT' :: Type -> (Type, [Type]) unAppT' t = (first,rest) where first:rest = unAppT'ac [] t -- Since the constructor is a leaf of the Type tree representation, -- it is the last element to be gathered and thus, an accumulator -- is used to reverse the list to be returned unAppT'ac :: [Type] -> Type -> [Type] unAppT'ac acum (prefix `AppT` lastarg) = unAppT'ac (lastarg:acum) prefix unAppT'ac acum cons = cons:acum ------------------------------ -- Functions to build a 'Type' ------------------------------ -- | Form a function type out of two types (-->) :: Type -- ^ Argument type -> Type -- ^ Return type -> Type -- ^ Resulting function arg --> ret = (ArrowT `AppT` arg) `AppT` ret -- | Rebuild a type out of a constructor, its argument types and its context -- (inverse of 'unAppT') reAppT :: (Type, [Type], Context) -- ^ (Constructor, type arguments, context) -> Type -- ^ resulting 'Type' -- Polymorphic types reAppT (cons, args, cxt) | isPoly cxt = mkForallT cxt (reAppT (cons, args, monoContext)) -- Monomorphic types reAppT (cons, args, _) = foldl1 AppT (cons:args) -- | Rebuild a function type out of its argument types, return type -- and context (inverse of 'ArrowT') reArrowT :: ([Type], Type, Context) -- ^ (Constructor, type arguments, context) -> Type -- ^ resulting 'Type' -- Polymorphic types reArrowT (args, ret, cxt) | isPoly cxt = mkForallT cxt (reArrowT (args, ret, monoContext)) -- Monomorphic types reArrowT (args, ret, _) = foldr1 (-->) (args ++ [ret]) ------------------------------------------------------------------- -- Transforming Language.Haskell.TH.Type into Data.Typeable.TypeRep ------------------------------------------------------------------- -- | Translate monomorphic Template Haskell Types to TypeReps -- If the type os polymorhpic 'Nothing' will be returned type2TypeRep :: Type -> Maybe TypeRep -- Note: In the case of constructors, we don't need to translate to a TyCon first -- because: -- -- mkTyConApp tCon [t1 .. tn] = mkTyConApp tCon [] `mkAppTy` t1 ... `mkAppTy` tn type2TypeRep (ForallT (_:_) _ _) = Nothing type2TypeRep (ForallT _ (_:_) _) = Nothing type2TypeRep (ForallT _ _ t) = type2TypeRep t type2TypeRep (VarT _) = Nothing -- Tuple tyCon strings don't correspond to hierarchical names. They are -- simply sequences of commas plus paranthesis: e.g. 2-tuple "(,)" 3-tuple "(,,)" .... type2TypeRep (TupleT n) = Just $ strCon ('(':replicate (n-1) ','++")") type2TypeRep ArrowT = Just $ typeableCon (undefined :: () -> ()) type2TypeRep ListT = Just $ typeableCon (undefined :: [()]) type2TypeRep (t1 `AppT` t2) = do tRep1 <- type2TypeRep t1 tRep2 <- type2TypeRep t2 return $ tRep1 `mkAppTy` tRep2 -- Constructors type2TypeRep (ConT name) -- FIXME: This should not be needed in the newer versions of ghc: -- There are certain TyCons whose string does not correspond -- to the hierarchical name of the constructor (the instances generated -- in Data.Typeable), we have to cover all those cases by hand -- See http://hackage.haskell.org/trac/ghc/ticket/1841 for details | isJust mSpecialTypeRep = mSpecialTypeRep -- Tuples (they cannot be put in the table) | isTup = Just $ strCon tupCons -- General case | otherwise = Just $ strCon (show name) where (isTup, tupCons) = case (show name =~ "^Data\\.Tuple\\.\\((,+)\\)$") :: (String, String, String, [String]) of -- it's a tuple, we get the commas subpart (,+) (_, _, _, [commas]) -> (True, commas) _ -> (False, "") mSpecialTypeRep = lookup name specialConTable specialConTable = [(''() , typeableCon (undefined :: ()) ), (''[] , typeableCon (undefined :: [()]) ), (''Maybe , typeableCon (undefined :: Maybe ()) ), (''Ratio , typeableCon (undefined :: Ratio ()) ), (''Either , typeableCon (undefined :: Either () ()) ), (''(->) , typeableCon (undefined :: () -> ()) ), (''MVar , typeableCon (undefined :: MVar ()) ), --(''Exception , typeableCon (undefined :: Exception) ), --(''IOException , typeableCon (undefined :: IOException) ), --(''ArithException , typeableCon (undefined :: ArithException) ), --(''ArrayException , typeableCon (undefined :: ArrayException) ), --(''AsyncException , typeableCon (undefined :: AsyncException) ), (''Ptr , typeableCon (undefined :: Ptr ()) ), (''FunPtr , typeableCon (undefined :: FunPtr ()) ), (''ForeignPtr , typeableCon (undefined :: ForeignPtr ()) ), (''StablePtr , typeableCon (undefined :: StablePtr ()) ), (''IORef , typeableCon (undefined :: IORef ()) ), (''Bool , typeableCon (undefined :: Bool) ), (''Char , typeableCon (undefined :: Char) ), (''Float , typeableCon (undefined :: Float) ), (''Double , typeableCon (undefined :: Double) ), (''Int , typeableCon (undefined :: Int) ), (''Word , typeableCon (undefined :: Word) ), (''Integer , typeableCon (undefined :: Integer) ), (''Ordering , typeableCon (undefined :: Ordering) ), (''Handle , typeableCon (undefined :: Handle) ), (''Int8 , typeableCon (undefined :: Int8) ), (''Int16 , typeableCon (undefined :: Int16) ), (''Int32 , typeableCon (undefined :: Int32) ), (''Int64 , typeableCon (undefined :: Int64) ), (''Word8 , typeableCon (undefined :: Word8) ), (''Word16 , typeableCon (undefined :: Word16) ), (''Word32 , typeableCon (undefined :: Word32) ), (''Word64 , typeableCon (undefined :: Word64) ), (''TyCon , typeableCon (undefined :: TyCon) ), (''TypeRep , typeableCon (undefined :: TypeRep) )] ------------------------------------------------------------------- -- Transforming Data.Typeable.TypeRep into Language.Haskell.TH.Type ------------------------------------------------------------------- -- | Obtain the Template Haskel type of a dynamic object dynTHType :: Dynamic -> Type dynTHType = typeRep2Type . dynTypeRep -- | Give the template haskell 'Type' of a Typeable object thTypeOf :: Typeable a => a -> Type thTypeOf = typeRep2Type . typeOf -- | Translate a 'TypeRep' to a Template Haskell 'Type' typeRep2Type :: TypeRep -> Type typeRep2Type rep = let (con, reps) = splitTyConApp rep in reAppT (tyCon2Type con, map typeRep2Type reps, monoContext) -- | Gives the corresponding Template Haskell 'Type' of a 'TyCon' tyCon2Type :: TyCon -> Type tyCon2Type = tyConStr2Type . tyConName ---------------------------- -- Internal Helper Functions ---------------------------- -- | transfrom a Typeable type constructor to a Template Haskell Type tyConStr2Type :: String -> Type -- NOTE: The tyCon strings of basic types are not qualified and buggy in -- some cases. -- See http://hackage.haskell.org/trac/ghc/ticket/1841 -- FIXME: update this function whenever the bug is fixed -- FIXME FIXME: This code is incorrect: -- mkName doesn't generate global names! ''Maybe /= mkName "Data.Maybe.Maybe" -- in addition global names contain a packagename which cannot be guessed from -- the type representation. tyConStr2Type "->" = ArrowT tyConStr2Type tupStr | tupStr =~ "^,+$" = ConT (mkName $ "Data.Tuple.(" ++ tupStr ++ ")") tyConStr2Type str = ConT $ mkName str -- Get the type constructor corresponding to a String -- in form of a type representation strCon :: String -> TypeRep strCon str = mkTyCon3 pkg mod base `mkTyConApp` [] where name = mkName str pkg = "" mod = fromMaybe "" (nameModule name) base = nameBase name -- Get the type constructor corresponding to a typeable value -- in form of a type representation typeableCon :: Typeable a => a -> TypeRep typeableCon t = (typeRepTyCon . typeOf) t `mkTyConApp` []