Use new TH.TypeLib for vectorTH

diff --git a/Data/Param/TFVec.hs b/Data/Param/TFVec.hs
index 7a0fa1dcc0ab1d1d000bd497097944ebbec64297..529c52c12a163dfb3b31397ddfbd987189e78ca4 100644 (file)
--- a/Data/Param/TFVec.hs
+++ b/Data/Param/TFVec.hs
@@ -57,12 +57,13 @@ module Data.Param.TFVec
   , copyn
   ) where
     
-
 import Types
+import Types.Data.Num
 import Types.Data.Num.Decimal.Literals.TH
 import Data.RangedWord
 
-import Data.Generics (Data, Typeable)
+import Data.Generics (Data)
+import Data.Typeable
 import qualified Prelude as P
 import Prelude hiding (
   null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
@@ -72,6 +73,8 @@ import qualified Data.Traversable as DT (Traversable(traverse))
 import Language.Haskell.TH hiding (Pred)
 import Language.Haskell.TH.Syntax (Lift(..))
 
+import Language.Haskell.TH.TypeLib
+
 newtype (NaturalT s) => TFVec s a = TFVec {unTFVec :: [a]}
   deriving (Eq, Typeable)
 
@@ -96,10 +99,10 @@ vectorCPS :: [a] -> (forall s . NaturalT s => TFVec s a -> w) -> w
 vectorCPS xs = unsafeVectorCPS (toInteger (P.length xs)) xs
 
 -- FIXME: Not the most elegant solution... but it works for now in clash
-vectorTH :: Lift a => [a] -> ExpQ
--- vectorTH xs = (vectorCPS xs) lift
-vectorTH [] = [| empty |]
-vectorTH (x:xs) = [| x +> $(vectorTH xs) |]
+vectorTH :: (Lift a, Typeable a) => [a] -> ExpQ
+vectorTH xs = sigE [| (TFVec xs) |] (decTFVecT (toInteger (P.length xs)) xs)
+-- vectorTH [] = [| empty |]
+-- vectorTH (x:xs) = [| x +> $(vectorTH xs) |]
 
 unsafeVector :: NaturalT s => s -> [a] -> TFVec s a
 unsafeVector l xs
@@ -282,10 +285,20 @@ instance NaturalT s => Functor (TFVec s) where
 instance NaturalT s => DT.Traversable (TFVec s) where 
   traverse f = (fmap TFVec).(DT.traverse f).unTFVec
 
-instance (Lift a, NaturalT nT) => Lift (TFVec nT a) where
-  lift (TFVec xs) = [|  unsafeTFVecCoerse 
-                        $(decLiteralV (fromIntegerT (undefined :: nT))) 
-                        (TFVec xs) |]
+-- instance (Lift a, NaturalT nT) => Lift (TFVec nT a) where
+--   lift (TFVec xs) = [|  unsafeTFVecCoerse
+--                         $(decLiteralV (fromIntegerT (undefined :: nT)))
+--                         (TFVec xs) |]
+
+instance (Lift a, Typeable a, NaturalT nT) => Lift (TFVec nT a) where
+  lift (TFVec xs) = sigE [| (TFVec xs) |] (decTFVecT (fromIntegerT (undefined :: nT)) xs)
+
+decTFVecT :: Typeable x => Integer -> x -> Q Type
+decTFVecT n a = appT (appT (conT (''TFVec)) (decLiteralT n)) elemT
+  where
+    (con,reps) = splitTyConApp (typeOf a)
+    elemT = typeRep2Type (P.head reps)
+
 
 -- ======================
 -- = Internal Functions =

diff --git a/Language/Haskell/TH/TypeLib.hs b/Language/Haskell/TH/TypeLib.hs
new file mode 100644 (file)
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

diff --git a/tfvec.cabal b/tfvec.cabal
index 7c8079f3ed903a00b665e0d430decf648465e8e7..1d54231bdc441481378603f323876592fac751d8 100644 (file)
--- a/tfvec.cabal
+++ b/tfvec.cabal
@@ -1,5 +1,5 @@
 name:                tfvec
-version:             0.1.3
+version:             0.1.4
 synopsis:            Fixed sized vectors.
 description:         Vectors with numerically parameterized size, using 
                      type-level numerals from 'tfp' library
@@ -16,5 +16,6 @@ Library
                      ScopedTypeVariables, TemplateHaskell, TypeOperators, 
                      FlexibleInstances, TypeFamilies, UndecidableInstances,
                      DeriveDataTypeable, RankNTypes
-  build-depends:     base >= 4.0, template-haskell >= 2.4, tfp > 0.3.2, syb
+  build-depends:     base >= 4.0, template-haskell >= 2.4, tfp > 0.3.2, syb, regex-posix, array
   exposed-modules:   Data.Param.TFVec
+  other-modules:     Language.Haskell.TH.TypeLib