{-# LANGUAGE TemplateHaskell #-}
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)
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 Data.Ratio (Ratio)
import Control.Concurrent.MVar (MVar)
data Context = Context
[TyVarBndr]
Cxt
instance Show Context where
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
mkContext :: [TyVarBndr] -> Cxt -> Context
mkContext tvb c = Context tvb c
monoContext :: Context
monoContext = Context [] []
isPoly :: Context -> Bool
isPoly (Context [] _) = False
isPoly _ = True
contextVarNames :: Context -> [TyVarBndr]
contextVarNames (Context tvb _) = tvb
contextConstraints :: Context -> Cxt
contextConstraints (Context _ cxt) = cxt
mkForallT :: Context -> Type -> Type
mkForallT (Context tvb cxt) t = ForallT tvb cxt t
unArrowT :: Type
-> ([Type], 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' :: Type -> ([Type], Type)
unArrowT' ((ArrowT `AppT` first) `AppT` rest) = let (args, ret) = unArrowT' rest
in (first:args, ret)
unArrowT' t = ([],t)
unAppT :: Type
-> (Type, [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' :: Type -> (Type, [Type])
unAppT' t = (first,rest)
where first:rest = unAppT'ac [] t
unAppT'ac :: [Type] -> Type -> [Type]
unAppT'ac acum (prefix `AppT` lastarg) = unAppT'ac (lastarg:acum) prefix
unAppT'ac acum cons = cons:acum
(
-> Type
-> Type
arg
reAppT :: (Type, [Type], Context)
-> Type
reAppT (cons, args, cxt) | isPoly cxt =
mkForallT cxt (reAppT (cons, args, monoContext))
reAppT (cons, args, _) = foldl1 AppT (cons:args)
reArrowT :: ([Type], Type, Context)
-> Type
reArrowT (args, ret, cxt) | isPoly cxt =
mkForallT cxt (reArrowT (args, ret, monoContext))
reArrowT (args, ret, _) = foldr1 (
type2TypeRep :: Type -> Maybe TypeRep
type2TypeRep (ForallT (_:_) _ _) = Nothing
type2TypeRep (ForallT _ (_:_) _) = Nothing
type2TypeRep (ForallT _ _ t) = type2TypeRep t
type2TypeRep (VarT _) = Nothing
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
type2TypeRep (ConT name)
| isJust mSpecialTypeRep = mSpecialTypeRep
| isTup = Just $ strCon tupCons
| otherwise = Just $ strCon (show name)
where (isTup, tupCons) =
case (show name =~ "^Data\\.Tuple\\.\\((,+)\\)$")
:: (String, String, String, [String]) of
(_, _, _, [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` []