module Language.Haskell.TH.TypeLib
(Context,
mkContext,
monoContext,
isPoly,
contextVarNames,
contextConstraints,
mkForallT,
unArrowT,
unAppT,
(-->),
reAppT,
reArrowT,
dynTHType,
thTypeOf,
typeRep2Type,
tyCon2Type,
type2TypeRep)
where
import Data.Dynamic
import Language.Haskell.TH (Type(..), Cxt, TyVarBndr(..), pprint, mkName)
import Text.Regex.Posix ((=~))
import Data.Maybe(isJust)
import GHC.Exts (RealWorld)
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.Array (Array)
import Control.Exception (Exception,
AsyncException,
ArrayException,
ArithException,
IOException)
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
-> Type
arg --> ret = (ArrowT `AppT` arg) `AppT` ret
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 (-->) (args ++ [ret])
type2TypeRep :: Type -> Maybe TypeRep
type2TypeRep (ForallT (_:_) _ _) = Nothing
type2TypeRep (ForallT _ (_:_) _) = Nothing
type2TypeRep (ForallT _ _ t) = type2TypeRep t
type2TypeRep (VarT _) = Nothing
type2TypeRep (TupleT n) = Just $ strCon ('(':replicate (n1) ','++")")
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 ()) ),
(''IOException , typeableCon (undefined :: IOException) ),
(''ArithException , typeableCon (undefined :: ArithException) ),
(''ArrayException , typeableCon (undefined :: ArrayException) ),
(''AsyncException , typeableCon (undefined :: AsyncException) ),
(''Array , typeableCon (undefined :: Array () ()) ),
(''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) ),
(''RealWorld , typeableCon (undefined :: RealWorld) )]
dynTHType :: Dynamic -> Type
dynTHType = typeRep2Type . dynTypeRep
thTypeOf :: Typeable a => a -> Type
thTypeOf = typeRep2Type . typeOf
typeRep2Type :: TypeRep -> Type
typeRep2Type rep = let (con, reps) = splitTyConApp rep
in reAppT (tyCon2Type con, map typeRep2Type reps, monoContext)
tyCon2Type :: TyCon -> Type
tyCon2Type = tyConStr2Type . tyConString
tyConStr2Type :: String -> Type
tyConStr2Type "->" = ArrowT
tyConStr2Type tupStr | tupStr =~ "^,+$" =
ConT (mkName $ "Data.Tuple.(" ++ tupStr ++ ")")
tyConStr2Type str = ConT $ mkName str
strCon :: String -> TypeRep
strCon str = mkTyCon str `mkTyConApp` []
typeableCon :: Typeable a => a -> TypeRep
typeableCon t = (typeRepTyCon . typeOf) t `mkTyConApp` []