X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fsupport%2Ftfvec.git;a=blobdiff_plain;f=Language%2FHaskell%2FTH%2FTypeLib.hs;fp=Language%2FHaskell%2FTH%2FTypeLib.hs;h=bd25b0ea3cb0cfe89bb7ef7764bdcff0de85ad37;hp=0000000000000000000000000000000000000000;hb=92cb4e3a487e88220aba94d7fc6003384e971e5c;hpb=74aad9e23f7b911124ece69b2886f4ec0c88e390

diff --git a/Language/Haskell/TH/TypeLib.hs b/Language/Haskell/TH/TypeLib.hs
new file mode 100644
index 0000000..bd25b0e
--- /dev/null
+++ b/Language/Haskell/TH/TypeLib.hs
@@ -0,0 +1,81 @@
+{-# 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 
+ (reAppT,
+  dynTHType,
+  thTypeOf,
+  typeRep2Type,
+  tyCon2Type) 
+ where
+
+import Data.Dynamic
+import Data.Typeable
+import Language.Haskell.TH
+import Language.Haskell.TH.Lib
+import Text.Regex.Posix ((=~))
+
+-- | Rebuild a type out of a constructor, its argument types and its context
+--   (inverse of 'unAppT')
+reAppT :: (TypeQ, [TypeQ])  -- ^ (Constructor, type arguments, context)
+       -> TypeQ                     -- ^ resulting 'Type'
+-- Monomorphic types
+reAppT (cons, args) = foldl1 appT (cons:args)
+
+-------------------------------------------------------------------
+-- Transforming Data.Typeable.TypeRep into Language.Haskell.TH.Type
+-------------------------------------------------------------------  
+
+-- | Obtain the Template Haskel type of a dynamic object
+dynTHType :: Dynamic -> TypeQ
+dynTHType = typeRep2Type . dynTypeRep
+
+-- | Give the template haskell 'Type' of a Typeable object
+thTypeOf :: Typeable a => a -> TypeQ
+thTypeOf = typeRep2Type . typeOf
+
+-- | Translate a 'TypeRep' to a Template Haskell 'Type'
+typeRep2Type :: TypeRep -> TypeQ
+typeRep2Type rep = let (con, reps) = splitTyConApp rep
+  in reAppT (tyCon2Type con, map typeRep2Type reps)
+ 
+-- | Gives the corresponding Template Haskell 'Type' of a 'TyCon'
+tyCon2Type :: TyCon -> TypeQ
+tyCon2Type = tyConStr2Type . tyConString
+
+----------------------------
+-- Internal Helper Functions
+----------------------------
+
+-- | transfrom a Typeable type constructor to a Template Haskell Type
+tyConStr2Type :: String -> TypeQ
+-- 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
+
+tyVarToName :: TyVarBndr -> Name
+tyVarToName tyvar = name
+  where
+    name = case tyvar of
+      (PlainTV n) -> n
+      (KindedTV n _) -> n
\ No newline at end of file