typeparams 0.0.1.0 → 0.0.2.0
raw patch · 3 files changed
+264/−175 lines, 3 files
Files
- src/Data/Params.hs +261/−21
- src/Data/Params/Vector/Unboxed.hs +2/−153
- typeparams.cabal +1/−1
src/Data/Params.hs view
@@ -37,6 +37,10 @@ , GetParam , SetParam , Base+ , _base+ , zoom+ , Zoom + , EyePiece , ApplyConstraint_GetType , ApplyConstraint_GetConstraint @@ -339,8 +343,6 @@ id = TypeLens a.b = TypeLens -class Base a - -- data family ParamDict (p::k) class HasDictionary p where@@ -358,9 +360,26 @@ type family ApplyConstraint_GetConstraint (p::k) :: * -> Constraint type family ApplyConstraint_GetType (p::k) t :: * -type family GetParam (p::k1) (t::k2) :: k3-type family SetParam (p::k1) (a::k2) (t::k3) :: k3+-- type family GetParam (p::k1) (t::k2) :: k3+-- type family SetParam (p::k1) (a::k2) (t:: *) :: *+type family GetParam (p::k1) (t:: *) :: k3+type family SetParam (p::k1) (a::k2) (t:: *) :: * +type family Zoom (p :: k1) :: k2+type family EyePiece (p :: k1) :: k2+-- type family Zoom (p :: * -> Constraint) :: * -> Constraint+-- type family EyePiece (p :: * -> Constraint) :: (* -> Constraint) -> * -> Constraint++zoom :: TypeLens a p -> TypeLens a (Zoom p)+zoom lens = TypeLens++class Base a ++_base :: TypeLens Base Base+_base = TypeLens+type instance GetParam Base t = t+type instance SetParam Base (c :: *) t = c+ type ParamIndex p = ( ReifiableConstraint (ApplyConstraint_GetConstraint p) , HasDictionary p@@ -561,7 +580,7 @@ filtergo (KindedTV _ (AppT (ConT maybe) _)) = nameBase maybe=="Config" filtergo _ = False - getterssetters <- mkGettersSetters dataname+-- getterssetters <- mkGettersSetters dataname configparams <- forM tyVarBndrL_Config $ \tyVarBndr -> do let paramstr = tyVarBndr2str tyVarBndr@@ -574,6 +593,7 @@ , mkApplyConstraint_Config paramstr dataname , mkHasDictionary_Config paramstr (kind2type k) , mkParamInstance paramstr (kind2type k) dataname+ , mkTypeFamilies_Common paramstr dataname ] starparams <- forM tyVarBndrL_Star $ \tyVarBndr -> do@@ -584,9 +604,11 @@ , mkApplyConstraint_Star paramstr dataname , mkHasDictionary_Star paramstr , mkParamClass_Star paramstr+ , mkTypeFamilies_Common paramstr dataname+ , mkTypeFamilies_Star paramstr dataname ] - return $ getterssetters + return $ [] ++ (concat $ concat $ configparams) ++ (concat $ concat $ starparams) @@ -657,31 +679,196 @@ -- -- > data Type v1 v2 ... vk = ... ----- creates "GetParam" instances of the form+-- Then for for paramstr vi, create instances of the form ----- > type instance GetParam Param_v1 (Type v1 v2 ... vk) = v1--- > type instance GetParam Param_v2 (Type v1 v2 ... vk) = v2--- > ...--- > type instnce GetParam Param_vk (Type v1 v2 ... vk) = vk+-- > type instance GetParam Param_vi (Type ... vi ... ) = vi+-- > type instance SetParam Param_vi vi' (Type ... vi ... ) = Type ... vi' ... ----- and "SetParam" instances of the form+-- This function requires that the @Param_@ classes have already been defined. ----- > type instance SetParam Param_v1 newparam (Type v1 v2 ... vk) = Type newparam v2 ... vk--- > type instance SetParam Param_v2 newparam (Type v1 v2 ... vk) = Type v1 newparam ... vk--- > ...--- > type instance SetParam Param_vk newparam (Type v1 v2 ... vk) = Type v1 v2 ... newparam+mkTypeFamilies_Common :: String -> Name -> Q [Dec]+mkTypeFamilies_Common paramstr dataName = do+ info <- TH.reify dataName+ let tyVarBndrL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs++ let getters = + [ TySynInstD+ ( mkName "GetParam" )+ ( TySynEqn+ [ ConT $ mkName $ "Param_" ++paramstr + , applyTyVarBndrL dataName tyVarBndrL+ ]+ ( VarT $ mkName $ paramstr+ )+ )+ ]++ let setters = + [ TySynInstD+ ( mkName "SetParam" )+ ( TySynEqn+ [ ConT $ mkName $ "Param_" ++paramstr + , VarT $ mkName $ "newparam"+ , applyTyVarBndrL dataName tyVarBndrL+ ]+ ( applyTyVarBndrL dataName $ map + (\a -> if tyVarBndr2str a==paramstr+ then PlainTV $ mkName "newparam"+ else a+ ) + tyVarBndrL + )+ )+ ]+ return $ getters++setters++-- | Given a data type of the form ----- This function requires that the Param_vk classes have already been defined.+-- > data Type v1 v2 ... vk = ... --+-- Then for paramstr vi, create instances of the form+--+-- > type instance GetParam (Param_vi p) (Type ... vi ... ) = GetParam p vi+--+-- > type instance SetParam (Param_vi p) vi' (Type ... vi ... )) +-- > = SetParam Param_vi (SetParam p vi' vi) t+--+-- > type instance Zoom (Param_vi a) = a+-- > type instance EyePiece (Param_vi a) = Param_vi+--+-- This function requires that the @Param_@ classes have already been defined.+--+mkTypeFamilies_Star :: String -> Name -> Q [Dec]+mkTypeFamilies_Star paramstr dataName = do+ info <- TH.reify dataName+ let tyVarBndrL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs++ let zooms =+ [ TySynInstD+ ( mkName "Zoom" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]+ ( VarT $ mkName "p" )++ )+ , TySynInstD+ ( mkName "EyePiece" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]+ ( ConT $ mkName $ "Param_"++paramstr )++ )+ ]++ let getters = + [ TySynInstD+ ( mkName "GetParam" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr ) (VarT $ mkName "p")+ , applyTyVarBndrL dataName tyVarBndrL+ ]+ ( AppT + ( AppT + ( ConT $ mkName "GetParam") + ( VarT $ mkName "p")+ ) + ( VarT $ mkName paramstr )+ )+ )+ ]++ let setters = + [ TySynInstD+ ( mkName "SetParam" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p")+ , VarT $ mkName $ "newparam"+ , VarT $ mkName "t" + ]+ ( AppT+ ( AppT+ ( AppT+ ( ConT $ mkName "SetParam" )+ ( ConT $ mkName $ "Param_"++paramstr)+ )+ ( AppT+ ( AppT+ ( AppT+ ( ConT $ mkName "SetParam" )+ ( VarT $ mkName "p" )+ )+ ( VarT $ mkName "newparam" )+ )+ ( AppT+ ( AppT+ ( ConT $ mkName "GetParam" )+ ( ConT $ mkName $ "Param_"++paramstr )+ )+ ( VarT $ mkName "t" )+ )+ )+ )+ ( VarT $ mkName "t" )+ )+ )+ ]++ return $ zooms++getters++setters++-- | Given a data type of the form+--+-- > data Type v1 v2 ... vk = ...+--+-- Then for each type param vi, create instances of the form+--+-- > type instance GetParam Param_vi (Type ... vi ... ) = vi+-- > type instance GetParam (Param_vi p) (Type ... vi ... ) = GetParam p vi+--+-- > type instance SetParam Param_vi vi' (Type ... vi ... )) +-- > = Type ... vi' ...+-- > type instance SetParam (Param_vi p) vi' (Type ... vi ... )) +-- > = SetParam Param_vi (SetParam p vi' vi) t+--+-- > type instance Zoom (Param_vi a) = a+-- > type instance EyePiece (Param_vi a) = Param_vi+--+-- This function requires that the @Param_@ classes have already been defined.+-- mkGettersSetters :: Name -> Q [Dec] mkGettersSetters dataName = do- c <- TH.reify dataName- let tyVarBndrL = case c of+ info <- TH.reify dataName+ let tyVarBndrL = case info of TyConI (NewtypeD _ _ xs _ _) -> xs TyConI (DataD _ _ xs _ _ ) -> xs FamilyI (FamilyD _ _ xs _) _ -> xs- otherwise -> error $ "Cannot mkGettersSetters on "++nameBase dataName++"; reify = "++show c + let zooms =+ [ TySynInstD+ ( mkName "Zoom" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++tyVarBndr2str x) (VarT $ mkName "p") ]+ ( VarT $ mkName "p" )++ )+ | x <- tyVarBndrL+ ]+ +++ [ TySynInstD+ ( mkName "EyePiece" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++tyVarBndr2str x) (VarT $ mkName "p") ]+ ( ConT $ mkName $ "Param_"++tyVarBndr2str x )++ )+ | x <- tyVarBndrL+ ]+ let getters = [ TySynInstD ( mkName "GetParam" )@@ -694,6 +881,23 @@ ) | x <- tyVarBndrL ]+ +++ [ TySynInstD+ ( mkName "GetParam" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_" ++ tyVarBndr2str x) (VarT $ mkName "p")+ , applyTyVarBndrL dataName tyVarBndrL+ ]+ ( AppT + ( AppT + ( ConT $ mkName "GetParam") + ( VarT $ mkName "p")+ ) + ( VarT $ mkName $ tyVarBndr2str x)+ )+ )+ | x <- tyVarBndrL+ ] let setters = [ TySynInstD@@ -713,8 +917,44 @@ ) | x <- tyVarBndrL ]+ +++ [ TySynInstD+ ( mkName "SetParam" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_" ++ tyVarBndr2str x) (VarT $ mkName "p")+ , VarT $ mkName $ "newparam"+ , VarT $ mkName "t" + ]+ ( AppT+ ( AppT+ ( AppT+ ( ConT $ mkName "SetParam" )+ ( ConT $ mkName $ "Param_" ++ tyVarBndr2str x)+ )+ ( AppT+ ( AppT+ ( AppT+ ( ConT $ mkName "SetParam" )+ ( VarT $ mkName "p" )+ )+ ( VarT $ mkName "newparam" )+ )+ ( AppT+ ( AppT+ ( ConT $ mkName "GetParam" )+ ( ConT $ mkName $ "Param_" ++ tyVarBndr2str x )+ )+ ( VarT $ mkName "t" )+ )+ )+ )+ ( VarT $ mkName "t" )+ )+ )+ | x <- tyVarBndrL+ ] - return $ getters++setters+ return $ zooms++getters++setters -- | Creates classes of the form --
src/Data/Params/Vector/Unboxed.hs view
@@ -38,10 +38,11 @@ import GHC.TypeLits import Data.Params-import Data.Params.Instances import Data.Params.Vector import Data.Params.PseudoPrim import Unsafe.Coerce++import Language.Haskell.TH.Syntax hiding (reify) import Debug.Trace @@ -68,101 +69,6 @@ {-#UNPACK#-}!(PseudoPrimInfo elem) {-#UNPACK#-}!ByteArray -type Veclen = 20-type Numvec = 100-veclen=fromIntegral $ natVal (Proxy::Proxy Veclen)-numvec=fromIntegral $ natVal (Proxy::Proxy Numvec)--dimLL1 :: [[Float]] = - [ evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen i) | i <- [1..numvec]]--dimLL2 :: [[Float]] = - [ evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen i) | i <- [2..numvec+1]]--vpusvpus1 = (VG.fromList $ map VG.fromList dimLL1- :: Vector (Static Numvec) (Vector (Static Veclen) Float))-vpusvpus2 = (VG.fromList $ map VG.fromList dimLL2- :: Vector (Static Numvec) (Vector (Static Veclen) Float))--v :: Vector (Static 1) (Vector (Static 1) (Vector (Static 10) Float))-v = VG.singleton $ VG.singleton $ VG.fromList [1..10] --v' :: Vector (Static 1) (Vector (Static 1) (Vector RunTime Float))-v' = with1Param (_elem._elem._len) 10 $ VG.singleton $ VG.singleton $ VG.fromList [1..10] --va :: Vector (Static 1) (Vector (Static 1) (Vector Automatic Float))-va = with1Param (_elem._elem._len) 10 $ VG.singleton $ VG.singleton $ VG.fromList [1..10] --vvv' :: Vector RunTime (Vector RunTime (Vector RunTime Float))-vvv' = with1Param (_elem._elem._len) 10 - $ with1Param (_elem._len) 1 - $ with1Param _len 1 - $ VG.singleton $ VG.singleton $ VG.fromList [1..10] --vvv'' :: Vector Automatic (Vector Automatic (Vector Automatic Float))-vvv'' = with1ParamAutomatic (_elem._elem._len) 10 --- $ with1ParamAutomatic (_elem._len) 1 --- $ with1ParamAutomatic _len 1 - $ VG.singleton $ VG.singleton $ VG.fromList [1..10] --vvv2 :: Vector (Static 1) (Vector (Static 1) (Vector RunTime Float))-vvv2 = with1Param (_elem._elem._len) 10 $ VG.singleton $ VG.singleton $ VG.fromList [1..10]--w :: Vector Automatic (Vector Automatic Float)-w = with1ParamAutomatic (_elem._len) 1- $ VG.singleton $ VG.singleton 1--v'' :: Vector (Static 1) (Vector (Static 1) (Vector Automatic Float))-v'' = runTimeToAutomatic (_elem._elem._len) 10 v'--test = viewParam (_a._a._b._b._a._elem._len) $ - Left $ Left $ Right $ Right $ Left $ v''--- test = viewParam (_b._a._elem._len) $ Right $ Left $ v''---- v'' = mkWith1Param --- (Proxy::Proxy (Vector (Static 1) (Vector (Static 1) (Vector RunTime Float))))--- (_elem._elem._len)--- 10--- (VG.singleton $ VG.singleton $ VG.fromList [1..10])--u :: Vector (Static 1) (Vector (Static 10) Float)-u = VG.singleton $ VG.fromList [1..10] ---- u' = mkWith1Param (Proxy::Proxy (Vector (Static 1) (Vector RunTime Float)))--- (_elem._len) 10 $ VG.singleton $ VG.fromList [1..10]--u'' :: Vector (Static 1) (Vector RunTime Float)-u'' = with1Param (_elem._len) 10 $ VG.singleton $ VG.fromList [1..10]--show_u'' = mkApWith1Param- (Proxy :: Proxy (Vector (Static 1) (Vector RunTime Float)))- (Proxy :: Proxy String)- (_elem._len)- 5- show- u''---- u' :: Vector (Static 1) (Vector RunTime Int)--- u' = withParam3 (_elem._len $ 10) $ VG.singleton $ VG.fromList [1..10] --- --- u'' :: Vector (Static 1) (Vector RunTime Int)--- u'' = withParam3 (_elem._len $ 10) $ VG.singleton $ VG.fromList [1..10] --- --- v' = withParam3 (_len 10) $ VG.fromList [1..10] :: Vector RunTime Int--- --- w :: Vector RunTime (Vector (Static 10) Int)--- w = withParam3 (_len 1) $ VG.singleton $ VG.fromList [1..10] --- --- w' :: Vector RunTime (Vector RunTime Int)--- w' = withParam3 (_len 1)--- $ withParam3 (_elem._len $ 10)--- $ VG.singleton $ VG.fromList [1..10] ---------------------------------- instance ( KnownNat len , PseudoPrim elem@@ -304,63 +210,6 @@ len size (mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi)------------------------- EndoFunctor--class EFBase m-_efbase :: TypeLens Base Base-_efbase = TypeLens---- efmap :: GetParam p t ~ a => TypeLens q p -> (a -> b) -> t -> SetParam p b t--- efmap = ---- class EFMap p t a b where--- efmap :: EndoFunctor p t => GetParam p t ~ a => TypeLens q p -> (a -> b) -> t -> SetParam p b t---- instance --- ( EFMap y t a b--- , SetParam (x y) (SetParam y b a) t ~ SetParam (x y) b y--- , GetParam y a ~ a--- ) => EFMap (x y) t a b where--- efmap lens f t = efmap (TypeLens::TypeLens q (x y)) (efmap (TypeLens::TypeLens r y) f) t--type instance GetParam EFBase a = a-type instance SetParam EFBase a t = a-type instance GetParam Base a = a-type instance SetParam Base a t = a---- instance EFMap Base t t t where--- efmap _ f a = f a--- -class EndoFunctor p t where - efmap :: GetParam p t ~ a => TypeLens q p -> (a -> b) -> t -> SetParam p b t--instance EndoFunctor Base t where- efmap _ f a = f a--type instance GetParam (Param_a q) (Either a b) = a-type instance SetParam (Param_a q) a' (Either a b) = Either a' b--- instance EndoFunctor (Param_a p) (Either a b) where--- efmap' _ f (Left a) = Left (f a)--- efmap' _ f (Right b) = Right b---- instance EndoFunctor (Param_a p) (Either a b) where--- efmap _ f (Left a) = Left (f a)--- efmap _ f (Right b) = Right b---- instance --- ( a ~ GetParam p a --- ) => EndoFunctor (Param_a p) (Either a b) where--- efmap _ f (Left a) = Left (efmap (TypeLens::TypeLens q p) f a)--- efmap _ f (Right b) = Right b---- instance EndoFunctor HasParam_b (Either a b) where--- efmap _ f (Left a) = Left a--- efmap _ f (Right b) = Right (f b)-- -------------------
typeparams.cabal view
@@ -1,5 +1,5 @@ Name: typeparams-Version: 0.0.1.0+Version: 0.0.2.0 Synopsis: Lens-like interface for type level parameters; allows unboxed unboxed vectors and supercompilation Description: This library provides a lens-like interface for working with type parameters. In the code: