From: Christiaan Baaij Date: Fri, 31 Jul 2009 11:27:12 +0000 (+0200) Subject: Use new TH.TypeLib for vectorTH X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=92cb4e3a487e88220aba94d7fc6003384e971e5c;p=matthijs%2Fmaster-project%2Fsupport%2Ftfvec.git Use new TH.TypeLib for vectorTH --- diff --git a/Data/Param/TFVec.hs b/Data/Param/TFVec.hs index 7a0fa1d..529c52c 100644 --- 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 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 7c8079f..1d54231 100644 --- 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