typeparams (empty) → 0.0.1.0
raw patch · 8 files changed
+2536/−0 lines, 8 filesdep +MonadRandomdep +basedep +constraintssetup-changed
Dependencies added: MonadRandom, base, constraints, deepseq, ghc-prim, primitive, reflection, tagged, template-haskell, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Data/Params.hs +1366/−0
- src/Data/Params/Frac.hs +36/−0
- src/Data/Params/PseudoPrim.hs +87/−0
- src/Data/Params/Vector.hs +33/−0
- src/Data/Params/Vector/Unboxed.hs +905/−0
- typeparams.cabal +77/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Michael Izbicki++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Params.hs view
@@ -0,0 +1,1366 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Params+ ( ++ -- * Basic + Config (..)+ , mkParams++ , with1Param+ , with1ParamAutomatic+ , apWith1Param+ , apWith2Param+ , apWith3Param++ , apWith1Param'+ , apWith2Param'+ , apWith3Param'++ , mkWith1Param+ , mkApWith1Param+ , mkApWith2Param+ , mkApWith3Param++ -- * Classes+ , HasDictionary (..)+ , ViewParam (..)+ , ParamDict (..)+ , ParamIndex+ , RunTimeToAutomatic (..)+ , StaticToAutomatic (..)+ , ApplyConstraint+ , TypeLens (..)+ , GetParam+ , SetParam+ , Base+ , ApplyConstraint_GetType+ , ApplyConstraint_GetConstraint++ -- * Internal coercion+ -- these functions must be exported for the template haskell code to work+ , coerceParamDict+ , mkRuleFrac+ , intparam + , floatparam+ , Float (..)++ -- * Advanced + -- | The code in this section is only for advanced users when the 'mkParams'+ -- function proves insufficient for some reason.+ -- Getting the types to work out by hand can be rather complicated...+ -- if you must use these functions, then you'll probably need some migraine+ -- medication afterward.++ -- ** Template haskell generating code+ , mkParamClass_Star+ , mkParamClass_Config+ , mkTypeLens_Star+ , mkTypeLens_Config+ , mkHasDictionary_Star+ , mkHasDictionary_Config+ , mkViewParam_Star+ , mkViewParam_Config+ , mkApplyConstraint_Star+ , mkApplyConstraint_Config+ , Param_Dummy++ , mkParamInstance+ , mkReifiableConstraint++ , mkGettersSetters++ -- ** General parameter classes+ -- | These classes were shamelessly stollen from <https://www.fpcomplete.com/user/thoughtpolice/using-reflection this excellent reflection tutorial>.+ -- If you want to understand how this library works, that's the place to start.+ , ReifiableConstraint(..)+ , ConstraintLift (..)++ -- * Modules+ , module GHC.TypeLits+ , module Data.Params.Frac++ , module Data.Reflection+ , module Data.Proxy+ , module Data.Constraint+ , module Data.Constraint.Unsafe+ )+ where++import Control.Category+import Control.Monad+import Data.Proxy+import Data.List (partition)+import Data.Monoid+import Data.Ratio+import Language.Haskell.TH hiding (reify)+import Language.Haskell.TH.Syntax hiding (reify)+import qualified Language.Haskell.TH as TH++import GHC.Float+import GHC.TypeLits+import Data.Params.Frac+import Data.Params.PseudoPrim++import Data.Constraint+import Data.Constraint.Unsafe+import Data.Reflection+import Unsafe.Coerce+import GHC.Base (Int(..))++import Debug.Trace+import Prelude hiding ((.),id)++-------------------------------------------------------------------------------++-- | Use this function for getting the type parameter value from an 'Int'.+-- It has proper inlining to ensure that the 'fromIntegral' gets computed+-- at compile time.++{-# INLINE intparam #-}+intparam :: forall n. KnownNat n => Proxy (n::Nat) -> Int+intparam _ = fromIntegral $ natVal (Proxy::Proxy n)+-- return $ +-- [ PragmaD $ RuleP +-- ("intparam "++show i)+-- [ ]+-- ( AppE +-- ( VarE $ mkName "intparam" )+-- ( SigE+-- ( ConE $ mkName "Proxy" )+-- ( AppT+-- ( ConT $ mkName "Proxy" )+-- ( LitT ( NumTyLit i ) )+-- )+-- )+-- )+-- ( AppE ( ConE $ mkName "I#" ) (LitE $ IntPrimL i ) )+-- AllPhases+-- | i <- [0..10000]+-- ]+++{-# NOINLINE floatparam #-}+floatparam :: forall n. KnownFrac n => Proxy (n::Frac) -> Float+floatparam _ = fromRational $ fracVal (Proxy::Proxy n)++mkRuleFrac :: Rational -> Q [Dec]+mkRuleFrac r = do+ let n=numerator r+ d=denominator r+ return $+ [ PragmaD $ RuleP+ ( "floatparam "++show r )+ [ ]+ ( AppE+ ( VarE $ mkName "floatparam" )+ ( SigE+ ( ConE $ mkName "Proxy" )+ ( AppT + ( ConT $ mkName "Proxy" )+ ( AppT + ( AppT + ( ConT $ mkName "/" ) + ( LitT $ NumTyLit n ) + )+ ( LitT $ NumTyLit d)+ )+ )+ )+ ) + ( AppE+ ( ConE $ mkName "F#" )+ ( LitE $ FloatPrimL r )+ )+ AllPhases+ ]++-- "floatparam 1" floatparam (Proxy::Proxy (1/1)) = 1 :: Float++-------------------------------------------------------------------------------+-- types++-- | (Kind) Specifies that the type parameter can be known either statically+-- or dynamically.+data Config a + = Static a -- ^ The parameter is statically set to 'a'+ | RunTime -- ^ The parameter is determined at run time using the 'withParam' functions+ | Automatic -- ^ The parameter is determined at run time and the value is inferred automatically without user specification++---------------------------------------++---------------------------------------+-- shamelessly stolen functions for internal use only++newtype ConstraintLift (p :: * -> Constraint) (a :: *) (s :: *) = ConstraintLift { lower :: a }++class ReifiableConstraint p where+ data Def (p :: * -> Constraint) (a:: *) :: *+ reifiedIns :: Reifies s (Def p a) :- p (ConstraintLift p a s)++asProxyOf :: f s -> Proxy s -> f s+asProxyOf v _ = v++using :: forall p a. ReifiableConstraint p => Def p a -> (p a => a) -> a+using d m = reify d $ \(_ :: Proxy s) ->+ let replaceProof :: Reifies s (Def p a) :- p a+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p (ConstraintLift p a s) :- p a+ in m \\ replaceProof++using' :: forall p a b. ReifiableConstraint p => Def p b -> (p b => a) -> a+using' def = unsafeCoerce (using def)++apUsing :: forall p a b. ReifiableConstraint p => Def p a -> (p a => a) -> (p a => a -> b) -> b+apUsing d m f = reify d $ \(_ :: Proxy s) ->+ let replaceProof :: Reifies s (Def p a) :- p a+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p (ConstraintLift p a s) :- p a+ in (f m) \\ replaceProof ++apUsing' :: forall p a1 a2 b. ReifiableConstraint p => Def p a2 -> (p a2 => a1) -> (p a2 => a1 -> b) -> b+apUsing' def = unsafeCoerce $ apUsing def+ +apUsing2 :: forall p1 p2 a a1 a2 b. + ( ReifiableConstraint p1+ , ReifiableConstraint p2+ ) => Def p1 a1 + -> Def p2 a2+ -> ((p1 a1,p2 a2) => a) + -> ((p1 a1,p2 a2) => a -> b) + -> b+apUsing2 d1 d2 m f = reify d2 $ \(_ :: Proxy s2) -> reify d1 $ \(_ :: Proxy s1) ->+ let replaceProof :: Reifies s1 (Def p1 a1) :- p1 a1+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p1 (ConstraintLift p1 a1 s1) :- p1 a1+ replaceProof2 :: Reifies s2 (Def p2 a2) :- p2 a2+ replaceProof2 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p2 (ConstraintLift p2 a2 s2) :- p2 a2+ in (f m) \\ replaceProof \\ replaceProof2++apUsing3 :: forall p1 p2 p3 a a1 a2 a3 b. + ( ReifiableConstraint p1+ , ReifiableConstraint p2+ , ReifiableConstraint p3+ ) => Def p1 a1 + -> Def p2 a2+ -> Def p3 a3+ -> ((p1 a1,p2 a2,p3 a3) => a) + -> ((p1 a1,p2 a2,p3 a3) => a -> b) + -> b+apUsing3 d1 d2 d3 m f = reify d3 $ \(_ :: Proxy s3) -> + reify d2 $ \(_ :: Proxy s2) -> + reify d1 $ \(_ :: Proxy s1) ->+ let replaceProof :: Reifies s1 (Def p1 a1) :- p1 a1+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p1 (ConstraintLift p1 a1 s1) :- p1 a1+ replaceProof2 :: Reifies s2 (Def p2 a2) :- p2 a2+ replaceProof2 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p2 (ConstraintLift p2 a2 s2) :- p2 a2+ replaceProof3 :: Reifies s3 (Def p3 a3) :- p3 a3+ replaceProof3 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p3 (ConstraintLift p3 a3 s3) :- p3 a3+ in (f m) \\ replaceProof \\ replaceProof2 \\ replaceProof3++apUsing4 :: forall p1 p2 p3 p4 a a1 a2 a3 a4 b. + ( ReifiableConstraint p1+ , ReifiableConstraint p2+ , ReifiableConstraint p3+ , ReifiableConstraint p4+ ) => Def p1 a1 + -> Def p2 a2+ -> Def p3 a3+ -> Def p4 a4+ -> ((p1 a1,p2 a2,p3 a3,p4 a4) => a) + -> ((p1 a1,p2 a2,p3 a3,p4 a4) => a -> b) + -> b+apUsing4 d1 d2 d3 d4 m f = reify d4 $ \(_ :: Proxy s4) ->+ reify d3 $ \(_ :: Proxy s3) -> + reify d2 $ \(_ :: Proxy s2) -> + reify d1 $ \(_ :: Proxy s1) ->+ let replaceProof :: Reifies s1 (Def p1 a1) :- p1 a1+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p1 (ConstraintLift p1 a1 s1) :- p1 a1+ replaceProof2 :: Reifies s2 (Def p2 a2) :- p2 a2+ replaceProof2 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p2 (ConstraintLift p2 a2 s2) :- p2 a2+ replaceProof3 :: Reifies s3 (Def p3 a3) :- p3 a3+ replaceProof3 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p3 (ConstraintLift p3 a3 s3) :- p3 a3+ replaceProof4 :: Reifies s4 (Def p4 a4) :- p4 a4+ replaceProof4 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p4 (ConstraintLift p4 a4 s4) :- p4 a4+ in (f m) \\ replaceProof \\ replaceProof2 \\ replaceProof3 \\ replaceProof4++apUsing5 :: forall p1 p2 p3 p4 p5 a a1 a2 a3 a4 a5 b. + ( ReifiableConstraint p1+ , ReifiableConstraint p2+ , ReifiableConstraint p3+ , ReifiableConstraint p4+ , ReifiableConstraint p5+ ) => Def p1 a1 + -> Def p2 a2+ -> Def p3 a3+ -> Def p4 a4+ -> Def p5 a5+ -> ((p1 a1,p2 a2,p3 a3,p4 a4,p5 a5) => a) + -> ((p1 a1,p2 a2,p3 a3,p4 a4,p5 a5) => a -> b) + -> b+apUsing5 d1 d2 d3 d4 d5 m f = reify d5 $ \(_ :: Proxy s5) ->+ reify d4 $ \(_ :: Proxy s4) ->+ reify d3 $ \(_ :: Proxy s3) -> + reify d2 $ \(_ :: Proxy s2) -> + reify d1 $ \(_ :: Proxy s1) ->+ let replaceProof :: Reifies s1 (Def p1 a1) :- p1 a1+ replaceProof = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p1 (ConstraintLift p1 a1 s1) :- p1 a1+ replaceProof2 :: Reifies s2 (Def p2 a2) :- p2 a2+ replaceProof2 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p2 (ConstraintLift p2 a2 s2) :- p2 a2+ replaceProof3 :: Reifies s3 (Def p3 a3) :- p3 a3+ replaceProof3 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p3 (ConstraintLift p3 a3 s3) :- p3 a3+ replaceProof4 :: Reifies s4 (Def p4 a4) :- p4 a4+ replaceProof4 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p4 (ConstraintLift p4 a4 s4) :- p4 a4+ replaceProof5 :: Reifies s5 (Def p5 a5) :- p5 a5+ replaceProof5 = trans proof reifiedIns+ where proof = unsafeCoerceConstraint :: p5 (ConstraintLift p5 a5 s5) :- p5 a5+ in (f m) \\ replaceProof \\ replaceProof2 \\ replaceProof3 \\ replaceProof4 \\ replaceProof5+-------------------+-- for external use++data TypeLens (a:: * -> Constraint) (b:: * -> Constraint) = TypeLens++instance Category TypeLens where+ id = TypeLens+ a.b = TypeLens+ +class Base a ++-- data family ParamDict (p::k)++class HasDictionary p where+ type ParamType p :: *+ data ParamDict p+ typeLens2dictConstructor :: TypeLens base p -> (ParamType p -> ParamDict p)++class ViewParam p t where+ viewParam :: TypeLens Base p -> t -> ParamType p++coerceParamDict :: (ParamType p -> ParamDict p) -> (ParamType p -> ParamDict (a p))+coerceParamDict = unsafeCoerce++type ApplyConstraint p m = (ApplyConstraint_GetConstraint p) (ApplyConstraint_GetType p m)+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 ParamIndex p = + ( ReifiableConstraint (ApplyConstraint_GetConstraint p)+ , HasDictionary p+ )++class StaticToAutomatic p ts ta | p ts -> ta where+ staticToAutomatic :: TypeLens Base p -> ts -> ta+ mkPseudoPrimInfoFromStatic :: TypeLens Base p -> PseudoPrimInfo ts -> PseudoPrimInfo ta++class RunTimeToAutomatic p tr ta | p tr -> ta, p ta -> tr where+ runTimeToAutomatic :: TypeLens Base p -> ParamType p -> (ApplyConstraint p tr => tr) -> ta+ mkPseudoPrimInfoFromRuntime :: TypeLens Base p -> ParamType p -> PseudoPrimInfo tr -> PseudoPrimInfo ta++---------++newtype DummyNewtype a = DummyNewtype a++mkWith1Param :: proxy m -> (+ ( ParamIndex p+ ) => TypeLens Base p+ -> ParamType p+ -> (ApplyConstraint p m => m)+ -> m+ )+mkWith1Param _ = with1Param++with1Param :: forall p m.+ ( ParamIndex p+ ) => TypeLens Base p+ -> ParamType p+ -> (ApplyConstraint p m => m) + -> m+with1Param lens v = using' (unsafeCoerce DummyNewtype (\x -> p) :: + Def + (ApplyConstraint_GetConstraint p) + (ApplyConstraint_GetType p m)+ ) + where+ p = typeLens2dictConstructor lens v :: ParamDict p ++with1ParamAutomatic :: forall p tr ta.+ ( ParamIndex p+ , RunTimeToAutomatic p tr ta+ ) => TypeLens Base p+ -> ParamType p+ -> (ApplyConstraint p tr => tr) + -> ta+with1ParamAutomatic lens v tr = runTimeToAutomatic lens v tr ++mkApWith1Param :: proxy m -> proxy n -> (+ ( ParamIndex p+ ) => TypeLens Base p+ -> ParamType p+ -> (ApplyConstraint p m => m -> n)+ -> (ApplyConstraint p m => m)+ -> n+ )+mkApWith1Param _ _ = apWith1Param++apWith1Param' :: m -> (+ ( ParamIndex p+ ) => TypeLens Base p+ -> ParamType p+ -> (ApplyConstraint p m => m -> n)+ -> (ApplyConstraint p m => m)+ -> n+ )+apWith1Param' _ = apWith1Param++apWith1Param :: forall p m n.+ ( ParamIndex p+ ) => TypeLens Base p+ -> ParamType p+ -> (ApplyConstraint p m => m -> n) + -> (ApplyConstraint p m => m) + -> n+apWith1Param lens v = flip $ apUsing' + (unsafeCoerce DummyNewtype (\x -> p) :: Def (ApplyConstraint_GetConstraint p) (ApplyConstraint_GetType p m))+ where+ p = typeLens2dictConstructor lens v :: ParamDict p ++mkApWith2Param :: proxy m -> proxy n -> (+ ( ParamIndex p1+ , ParamIndex p2+ ) => TypeLens Base p1+ -> ParamType p1+ -> TypeLens Base p2+ -> ParamType p2+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m) => m -> n)+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m) => m)+ -> n+ )+mkApWith2Param _ _ = apWith2Param++apWith2Param' :: m -> (+ ( ParamIndex p1+ , ParamIndex p2+ ) => TypeLens Base p1+ -> ParamType p1+ -> TypeLens Base p2+ -> ParamType p2+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m) => m -> n)+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m) => m)+ -> n+ )+apWith2Param' _ = apWith2Param++apWith2Param :: forall p1 p2 m n.+ ( ParamIndex p1+ , ParamIndex p2+ ) => TypeLens Base p1+ -> ParamType p1+ -> TypeLens Base p2+ -> ParamType p2+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m) => m -> n)+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m) => m)+ -> n+apWith2Param lens1 v1 lens2 v2 = flip $ apUsing2+ (unsafeCoerce DummyNewtype (\x -> unsafeCoerce p1)) + (unsafeCoerce DummyNewtype (\x -> unsafeCoerce p2))+ where+ p1 = typeLens2dictConstructor lens1 v1 :: ParamDict p1+ p2 = typeLens2dictConstructor lens2 v2 :: ParamDict p2++mkApWith3Param :: proxy m -> proxy n -> (+ ( ParamIndex p1+ , ParamIndex p2+ , ParamIndex p3+ ) => TypeLens Base p1+ -> ParamType p1+ -> TypeLens Base p2+ -> ParamType p2+ -> TypeLens Base p3+ -> ParamType p3+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m, ApplyConstraint p3 m) => m -> n)+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m, ApplyConstraint p3 m) => m)+ -> n+ )+mkApWith3Param _ _ = apWith3Param++apWith3Param' :: m -> (+ ( ParamIndex p1+ , ParamIndex p2+ , ParamIndex p3+ ) => TypeLens Base p1+ -> ParamType p1+ -> TypeLens Base p2+ -> ParamType p2+ -> TypeLens Base p3+ -> ParamType p3+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m, ApplyConstraint p3 m) => m -> n)+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m, ApplyConstraint p3 m) => m)+ -> n+ )+apWith3Param' _ = apWith3Param++apWith3Param :: forall p1 p2 p3 m n.+ ( ParamIndex p1+ , ParamIndex p2+ , ParamIndex p3+ ) => TypeLens Base p1+ -> ParamType p1+ -> TypeLens Base p2+ -> ParamType p2+ -> TypeLens Base p3+ -> ParamType p3+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m, ApplyConstraint p3 m) => m -> n)+ -> ((ApplyConstraint p1 m, ApplyConstraint p2 m, ApplyConstraint p3 m) => m)+ -> n+apWith3Param lens1 v1 lens2 v2 lens3 v3 = flip $ apUsing3+ (unsafeCoerce DummyNewtype (\x -> unsafeCoerce p1)) + (unsafeCoerce DummyNewtype (\x -> unsafeCoerce p2))+ (unsafeCoerce DummyNewtype (\x -> unsafeCoerce p3))+ where+ p1 = typeLens2dictConstructor lens1 v1 :: ParamDict p1+ p2 = typeLens2dictConstructor lens2 v2 :: ParamDict p2+ p3 = typeLens2dictConstructor lens3 v3 :: ParamDict p3++-------------------------------------------------------------------------------+-- template haskell+ +-- | Constructs all the needed type classes and instances in order to use+-- typeparams in a simple manner. Example usage:+--+-- > data NearestNeighbor (k :: Param Nat) (maxdist :: Param Float) elem = ...+-- > mkParams ''NearestNeighbor+--++mkParams :: Name -> Q [Dec]+mkParams dataname = do+ info <- TH.reify dataname+ let tyVarBndrL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs++ let (tyVarBndrL_Config,tyVarBndrL_Star) = partition filtergo tyVarBndrL + filtergo (KindedTV _ (AppT (ConT maybe) _)) = nameBase maybe=="Config"+ filtergo _ = False+ + getterssetters <- mkGettersSetters dataname++ configparams <- forM tyVarBndrL_Config $ \tyVarBndr -> do+ let paramstr = tyVarBndr2str tyVarBndr+ let ( KindedTV _ k ) = tyVarBndr+ sequence+ [ mkParamClass_Config paramstr (kind2type k)+ , mkReifiableConstraint' paramstr [ paramClass_getParam paramstr (kind2type k) ]+ , mkTypeLens_Config paramstr+ , mkViewParam_Config paramstr dataname+ , mkApplyConstraint_Config paramstr dataname+ , mkHasDictionary_Config paramstr (kind2type k)+ , mkParamInstance paramstr (kind2type k) dataname+ ]++ starparams <- forM tyVarBndrL_Star $ \tyVarBndr -> do+ let paramstr = tyVarBndr2str tyVarBndr+ sequence+ [ mkTypeLens_Star paramstr+ , mkViewParam_Star paramstr dataname+ , mkApplyConstraint_Star paramstr dataname+ , mkHasDictionary_Star paramstr+ , mkParamClass_Star paramstr+ ]++ return $ getterssetters + ++ (concat $ concat $ configparams) + ++ (concat $ concat $ starparams)++---------------------------------------+-- convert kinds into other objects++kind2type :: Type -> Type+kind2type (AppT ListT t) = AppT ListT $ kind2type t+kind2type (AppT (ConT c) t) = if nameBase c=="Config"+ then kind2type t+ else error "kind2type nameBase c"+kind2type (ConT n) = ConT $ mkName $ case nameBase n of+ "Nat" -> "Int"+ "Frac" -> "Float"+-- "Frac" -> "Rational"+ "Symbol" -> "String"+ str -> error $ "mkParams does not currently support custom type "++str+kind2type x = error $ "kind2type on x="++show x+-- kind -> kind++kind2constraint :: Type -> Name+kind2constraint (AppT _ t) = kind2constraint t+kind2constraint (ConT n) = mkName $ case nameBase n of+ "Nat" -> "KnownNat"+ "Frac" -> "KnownFrac"+ "Symbol" -> "KnownSymbol"++kind2val :: Type -> Name+kind2val (AppT _ t) = kind2val t+kind2val (ConT n) = mkName $ case nameBase n of+ "Nat" -> "intparam"+ "Frac" -> "floatparam"+-- "Frac" -> "fracVal"+ "Symbol" -> "symbolVal"++kind2convert :: Type -> Name+kind2convert (AppT _ t) = kind2convert t+kind2convert (ConT n) = mkName $ case nameBase n of+ "Nat" -> "id"+ "Frac" -> "id"+-- "Frac" -> "fromRational"+ "Symbol" -> "id"+ _ -> "id"++param2class :: Name -> Name+param2class p = mkName $ "Param_" ++ nameBase p++param2func :: Name -> Name+param2func p = mkName $ "getParam_" ++ nameBase p++---------------------------------------+-- helper TH functions++tyVarBndr2str :: TyVarBndr -> String+tyVarBndr2str (PlainTV n) = nameBase n+tyVarBndr2str (KindedTV n _) = nameBase n++applyTyVarBndrL :: Name -> [ TyVarBndr ] -> Type+applyTyVarBndrL name xs = go xs (ConT name)+ where+ go [] t = t+ go (x:xs) t = go xs (AppT t (VarT $ mkName $ tyVarBndr2str x))++-------------------------------------------------------------------------------+-- template haskell++-- | Given a data type of the form+--+-- > data Type v1 v2 ... vk = ...+--+-- creates "GetParam" 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+--+-- and "SetParam" instances of the form+--+-- > 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+--+-- This function requires that the Param_vk classes have already been defined.+--+mkGettersSetters :: Name -> Q [Dec]+mkGettersSetters dataName = do+ c <- TH.reify dataName+ let tyVarBndrL = case c of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs+ otherwise -> error $ "Cannot mkGettersSetters on "++nameBase dataName++"; reify = "++show c++ let getters = + [ TySynInstD+ ( mkName "GetParam" )+ ( TySynEqn+ [ ConT $ mkName $ "Param_" ++ tyVarBndr2str x+ , applyTyVarBndrL dataName tyVarBndrL+ ]+ ( VarT $ mkName $ tyVarBndr2str x+ )+ )+ | x <- tyVarBndrL+ ]++ let setters = + [ TySynInstD+ ( mkName "SetParam" )+ ( TySynEqn+ [ ConT $ mkName $ "Param_" ++ tyVarBndr2str x+ , VarT $ mkName $ "newparam"+ , applyTyVarBndrL dataName tyVarBndrL+ ]+ ( applyTyVarBndrL dataName $ map + (\a -> if tyVarBndr2str a==tyVarBndr2str x+ then PlainTV $ mkName "newparam"+ else a+ ) + tyVarBndrL + )+ )+ | x <- tyVarBndrL+ ]++ return $ getters++setters++-- | Creates classes of the form+--+-- > class Param_paramname t where+-- > getParam_paramname :: t -> paramT+-- > {-# INLINE getParam_paramname #-}+--+-- NOTE: this function should probably not be called directly+mkParamClass_Config :: String -> Type -> Q [Dec]+mkParamClass_Config paramstr paramT = do+ isDef <- lookupTypeName $ "Param_"++paramstr+ return $ case isDef of+ Just _ -> []+ Nothing -> + [ ClassD+ [ ]+ ( mkName $ "Param_"++paramstr ) + [ PlainTV $ mkName "t" ]+ [ ]+ [ paramClass_getParam paramstr paramT ] + ]++paramClass_getParam :: String -> Type -> Dec+paramClass_getParam paramstr paramT+ = SigD+ (mkName $ "getParam_"++paramstr) + (AppT+ (AppT+ ArrowT+ (VarT $ mkName "t"))+ paramT)++-- | Creates classes of the form+--+-- > class Param_paramname (p :: * -> Constraint) (t :: *) where+--+-- NOTE: this function should probably not be called directly+mkParamClass_Star :: String -> Q [Dec]+mkParamClass_Star paramname = do+ isDef <- lookupTypeName $ "Param_"++paramname+ return $ case isDef of+ Just _ -> []+ Nothing -> + [ ClassD+ [ ]+ ( mkName $ "Param_"++paramname )+ [ KindedTV (mkName "_p") (AppT (AppT ArrowT StarT) ConstraintT)+ , KindedTV (mkName "t") StarT+ ] + [ ]+ [ ]+ ]++-- | returns True if the parameter has kind *, False otherwise+-- isStarParam :: String -> Q Bool+-- isStarParam paramname = do+-- info <- TH.reify $ mkName $ "Param_"++paramname+-- return $ case info of+-- ClassI (ClassD _ _ xs _ _) _ -> length xs == 2 ++-- | Creates a "TypeLens" for the given star paramname of the form+--+-- > _paramname :: TypeLens p (Param_paramname p)+-- > _paramname = TypeLens+--+mkTypeLens_Star :: String -> Q [Dec]+mkTypeLens_Star paramname = do+ isDef <- lookupValueName $ "_"++paramname+ return $ case isDef of+ Just _ -> []+ Nothing -> + [ ValD+ ( SigP+ ( VarP $ mkName $ "_"++paramname )+ ( ForallT + [ PlainTV $ mkName "_p" ]+ [ ]+ ( AppT + ( AppT + ( ConT $ mkName "TypeLens" ) + ( VarT $ mkName "_p" )+ )+ ( AppT+ ( ConT $ mkName $ "Param_" ++ paramname )+ ( VarT $ mkName "_p" )+ )+ )+ )+ )+ ( NormalB+ ( VarE $ mkName $ "undefined" )+ )+ [ ]+ ]++-- | Creates a "TypeLens" for the given config paramname of the form+--+-- > _paramname :: TypeLens Base Param_paramname+-- > _paramname = TypeLens+--+mkTypeLens_Config :: String -> Q [Dec]+mkTypeLens_Config paramname = do+ isDef <- lookupValueName $ "_"++paramname+ return $ case isDef of+ Just _ -> []+ Nothing -> + [ ValD+ ( SigP+ ( VarP $ mkName $ "_"++paramname )+ ( ForallT + [ ]+ [ ]+ ( AppT + ( AppT + ( ConT $ mkName "TypeLens" ) + ( ConT $ mkName "Base" )+ )+ ( ConT $ mkName $ "Param_" ++ paramname )+ )+ )+ )+ ( NormalB+ ( VarE $ mkName $ "undefined" )+ )+ [ ]+ ]++-- | This class is needed because I can't get type variables to work in "reifyInstances"+class Param_Dummy t++-- | Given the class Param_paramname that indexes a star parameter paramname, +-- create an instance of the form+--+-- > instance +-- > ( HasDictionary p+-- > ) => HasDictionary (Param_paramname p)+-- > where+-- > type ParamType (Param_paramname p) = ParamType p+-- > newtype ParamDict (Param_paramname p) = ParamDict_paramname +-- > { unParamDict_paramname :: ParamType (Param_paramname) }+-- > typeLens2dictConstructor _ = coerceParamDict $ typeLens2dictConstructor (TypeLens::TypeLens Base p)+-- > {#- INLINE typeLens2dictConstructor #-}+--+mkHasDictionary_Star :: String -> Q [Dec]+mkHasDictionary_Star paramstr = do+ let paramname = mkName $ "Param_"++paramstr++ alreadyInstance <- do+ isDef <- lookupTypeName (nameBase paramname)+ case isDef of+ Nothing -> return False+ Just _ -> isInstance+ ( mkName "HasDictionary" ) + [ (AppT (ConT paramname) (ConT $ mkName "Param_Dummy")) ]++ return $ if alreadyInstance+ then [ ]+ else [ InstanceD+ [ ClassP (mkName "HasDictionary") [VarT $ mkName "_p"] ]+ ( AppT + ( ConT $ mkName "HasDictionary" )+ ( AppT (ConT paramname) (VarT $ mkName "_p") )+ )+ [ TySynInstD+ ( mkName "ParamType" )+ ( TySynEqn+ [ AppT (ConT paramname) (VarT $ mkName "_p") ]+ ( AppT (ConT $ mkName "ParamType") (VarT $ mkName "_p") )+ )+ , NewtypeInstD+ [ ]+ ( mkName "ParamDict" )+ [ AppT (ConT paramname) (VarT $ mkName "_p") ]+ ( RecC+ ( mkName $ "ParamDict_"++nameBase paramname )+ [ ( mkName ("unParamDict_"++nameBase paramname)+ , NotStrict+ , AppT (ConT $ mkName "ParamType") (VarT $ mkName "_p")+ ) + ]+ )+ [ ]+ , FunD+ ( mkName "typeLens2dictConstructor" )+ [ Clause+ [ VarP $ mkName "x" ]+ ( NormalB $ AppE+ ( VarE $ mkName "coerceParamDict" )+ ( AppE+ ( VarE $ mkName "typeLens2dictConstructor" )+ ( SigE+ ( ConE $ mkName "TypeLens" ) + ( AppT+ ( AppT+ ( ConT $ mkName "TypeLens" )+ ( ConT $ mkName "Base" )+ )+ ( VarT $ mkName "_p" )+ )+ )+ )+ )+ [ ]+ ]+ , PragmaD $ InlineP+ ( mkName "typeLens2dictConstructor" )+ Inline+ FunLike+ AllPhases+ ]+ ]++-- | Given the class Param_paramname that indexes a config parameter paramname+-- create an instance of the form+--+-- > instance HasDictionary Param_paramname where+-- > type ParamType Param_paramname = paramtype+-- > newtype ParamDict Param_len = ParamDict_paramname { getParamDict_paramname :: paramtype } +-- > typeLens2dictConstructor _ = ParamDict_paramname+--+mkHasDictionary_Config :: String -> Type -> Q [Dec]+mkHasDictionary_Config paramstr paramtype = do+ let paramname = mkName $ "Param_"++paramstr++ alreadyInstance <- do+ isDef <- lookupTypeName (nameBase paramname)+ case isDef of+ Nothing -> return False+ Just _ -> isInstance + ( mkName "HasDictionary" ) + [ ConT paramname ]++ return $ if alreadyInstance+ then [ ]+ else [ InstanceD+ [ ]+ ( AppT + ( ConT $ mkName "HasDictionary" )+ ( ConT paramname )+ )+ [ TySynInstD+ ( mkName "ParamType" )+ ( TySynEqn+ [ ConT paramname ]+ ( paramtype )+ )+ , NewtypeInstD+ [ ]+ ( mkName "ParamDict" )+ [ ConT paramname ]+ ( RecC+ ( mkName $ "ParamDict_"++nameBase paramname )+ [ ( mkName ("unParamDict_"++nameBase paramname)+ , NotStrict+ , paramtype+ ) + ]+ )+ [ ]+ , FunD+ ( mkName "typeLens2dictConstructor" )+ [ Clause+ [ VarP $ mkName "x" ]+ ( NormalB $ ConE $ mkName $ "ParamDict_"++nameBase paramname )+ [ ]+ ]+ , PragmaD $ InlineP+ ( mkName $ "typeLens2dictConstructor" )+ Inline+ FunLike+ AllPhases+ ]+ ]+++-- | Given star parameter paramname and data type dataname that has parameter paramname,+-- create type instances of the form+--+-- > type instance ApplyConstraint_GetConstraint (Param_paramname p) +-- > = ApplyConstraint_GetConstraint p +-- >+-- > type instance ApplyConstraint_GetType (Param_paramname p) (dataname v1 v2 ... paramname ... vk) +-- > = ApplyConstraint_GetType p paramname+-- +mkApplyConstraint_Star :: String -> Name -> Q [Dec]+mkApplyConstraint_Star paramstr dataname = do+ let paramname = mkName $ "Param_"++paramstr+ info <- TH.reify dataname+ let tyVarBndrL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs++ return + [ TySynInstD+ ( mkName "ApplyConstraint_GetConstraint" )+ ( TySynEqn+ [ (AppT (ConT paramname) (VarT $ mkName "_p")) ]+ ( AppT (ConT $ mkName "ApplyConstraint_GetConstraint" ) (VarT $ mkName "_p") )+ )+ , TySynInstD+ ( mkName "ApplyConstraint_GetType" )+ ( TySynEqn+ [ (AppT (ConT paramname) (VarT $ mkName "_p"))+ , applyTyVarBndrL dataname tyVarBndrL+ ]+ ( AppT+ ( AppT+ ( ConT $ mkName "ApplyConstraint_GetType" )+ ( VarT $ mkName "_p" )+ )+ ( VarT $ mkName paramstr )+ )+ ) + ]++-- | Given star parameter paramname and data type dataname that has parameter paramname,+-- create type instances of the form+--+-- > type instance ApplyConstraint_GetConstraint Param_paramname+-- > = ApplyConstraint_GetConstraint Param_paramname+-- >+-- > type instance ApplyConstraint_GetType Param_paramname (dataname v1 v2 ... paramname ... vk) +-- > = ApplyConstraint_GetType Param_paramname (dataname v1 v2 ... paramname ... vk)+-- +mkApplyConstraint_Config :: String -> Name -> Q [Dec]+mkApplyConstraint_Config paramstr dataname = do+ let paramname = mkName $ "Param_"++paramstr+ info <- TH.reify dataname+ let tyVarBndrL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs++ return + [ TySynInstD+ ( mkName "ApplyConstraint_GetConstraint" )+ ( TySynEqn+ [ ConT paramname ]+ ( ConT paramname )+ )+ , TySynInstD+ ( mkName "ApplyConstraint_GetType" )+ ( TySynEqn+ [ ConT paramname + , applyTyVarBndrL dataname tyVarBndrL+ ]+ ( applyTyVarBndrL dataname tyVarBndrL )+ ) + ]++-- | Given star parameter paramname and data type dataname that has parameter paramname,+-- create an instance of the form+--+-- > instance +-- > ( ViewParam p paramname +-- > ) => ViewParam (Param_paramname p) (dataname v1 v2 ... paramname ... vk)+-- > where+-- > viewParam _ _ = viewParam (undefined::TypeLens Base p) (undefined :: paramname)+--+mkViewParam_Star :: String -> Name -> Q [Dec]+mkViewParam_Star paramstr dataname = do+ let paramname = mkName $ "Param_"++paramstr++ info <- TH.reify dataname+ let tyVarBndrL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs++ return $+ [ InstanceD+ [ ClassP + (mkName "ViewParam") + [ VarT $ mkName "_p"+ , VarT $ mkName paramstr+ ]+ ]+ ( AppT + ( AppT+ ( ConT $ mkName "ViewParam" )+ ( AppT (ConT paramname) (VarT $ mkName "_p") )+ )+ ( applyTyVarBndrL dataname tyVarBndrL )+ )+ [ FunD+ ( mkName "viewParam" )+ [ Clause+ [ VarP $ mkName "x", VarP $ mkName "y" ]+ ( NormalB $ AppE+ ( AppE+ ( VarE $ mkName "viewParam" )+ ( SigE + ( VarE $ mkName "undefined" )+ ( AppT+ ( AppT + ( ConT $ mkName "TypeLens" ) + ( ConT $ mkName "Base") + ) + ( VarT $ mkName "_p" )+ )+ )+ )+ ( SigE+ ( VarE $ mkName "undefined" )+ ( VarT $ mkName paramstr )+ )+ )+ [ ]+ ] + , PragmaD $ InlineP+ ( mkName $ "viewParam" )+ Inline+ FunLike+ AllPhases+ ]+ ]++-- | Given star parameter paramname and data type dataname that has parameter paramname,+-- create an instance of the form+--+-- > instance+-- > ( Param_paramname (dataname v1 v2 ... paramname ... vk)+-- > ) => ViewParam Param_paramname (dataname v1 v2 ... paramname ... vk) where+-- > viewParam _ _ = getParam_paramname (undefined::dataname v1 v2 ... paramname ... vk)+--+mkViewParam_Config :: String -> Name -> Q [Dec]+mkViewParam_Config paramstr dataname = do+ info <- TH.reify dataname+ let tyVarBndrL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs+ return + [ InstanceD+ [ ClassP + ( mkName $ "Param_"++paramstr) + [ applyTyVarBndrL dataname tyVarBndrL ]+ ]+ ( AppT + ( AppT+ ( ConT $ mkName "ViewParam" )+ (ConT $ mkName $ "Param_"++paramstr) + )+ ( applyTyVarBndrL dataname tyVarBndrL )+ )+ [ FunD+ ( mkName "viewParam" )+ [ Clause+ [ VarP $ mkName "x", VarP $ mkName "y" ]+ ( NormalB $ AppE+ ( VarE $ kind2convert $ AppT (ConT $ mkName "ParamType") (ConT $ mkName $ "Param_"++paramstr) )+ ( AppE+ ( VarE $ mkName $ "getParam_"++paramstr)+ ( SigE+ ( VarE $ mkName "undefined" )+ ( applyTyVarBndrL dataname tyVarBndrL )+ )+ )+ )+ [ ]+ ] + , PragmaD $ InlineP+ ( mkName $ "viewParam" )+ Inline+ FunLike+ AllPhases+ ]+ ]++-- | creates instances of the form+--+-- > instance (KnownNat paramName) => Param_paramName (Static paramName) where+-- > param_paramName m = fromIntegral $ natVal (Proxy::Proxy paramName)+--+mkParamInstance :: String -> Type -> Name -> Q [Dec]+mkParamInstance paramStr paramType dataName = do+ info <- TH.reify dataName+ let tyVarL = case info of+ TyConI (NewtypeD _ _ xs _ _) -> xs+ TyConI (DataD _ _ xs _ _ ) -> xs+ FamilyI (FamilyD _ _ xs _) _ -> xs++ let tyVarL' = filter filtergo tyVarL+ filtergo (KindedTV n k) = nameBase n==paramStr+ filtergo (PlainTV n) = nameBase n == paramStr++ let [KindedTV paramName paramKind] = tyVarL'++ return+ [ InstanceD+ [ ClassP+ ( kind2constraint paramKind )+ [ VarT paramName ]+ ]+ (AppT + (ConT $ param2class paramName)+ (tyVarL2Type tyVarL (AppT (PromotedT $ mkName "Static") (VarT paramName))))+ [ FunD+ ( mkName $ "getParam_"++nameBase paramName )+ [ Clause+ [ VarP $ mkName "m" ]+ (NormalB $+ (AppE+ (VarE $ kind2convert paramKind)+ (AppE+ (VarE $ kind2val paramKind)+ (SigE+ (ConE $ mkName "Proxy")+ (AppT+ (ConT $ mkName "Proxy")+ (VarT paramName)+ )+ )+ )+ )+ )+ []+ ]+ , PragmaD $ InlineP+ ( mkName $ "getParam_"++nameBase paramName )+ Inline+ FunLike+ AllPhases+ ]+ ]+ where+ tyVarL2Type xs matchType = go $ reverse xs+ where+ go [] = ConT $ mkName $ nameBase dataName+ go ((PlainTV n):xs) = AppT (go xs) (VarT n)+ go ((KindedTV n k):xs) = AppT (go xs) $ if nameBase n==paramStr+ then matchType + else (VarT n)++++-- | helper for 'mkReifiableConstraints''+mkReifiableConstraint :: String -> Q [Dec]+mkReifiableConstraint paramstr = do+ let name = mkName $ "Param_"++paramstr+ info <- TH.reify name+ let funcL = case info of+ ClassI (ClassD _ _ _ _ xs) _ -> xs+ otherwise -> error "mkReifiableConstraint parameter must be a type class"+ mkReifiableConstraint' paramstr funcL++-- | creates instances of the form+--+-- > instance ReifiableConstraint Def_Param_paramName where+-- > data Def (Def_Param_paramName) a = Param_paramName {} +--+mkReifiableConstraint' :: String -> [Dec] -> Q [Dec] +mkReifiableConstraint' paramstr funcL = do+ let paramname = mkName $ "Param_"++paramstr+-- isDef <- isInstance (mkName "ReifiableConstraint") [ConT paramname]+ alreadyInstance <- do+ isDef <- lookupTypeName (nameBase paramname)+ case isDef of+ Nothing -> return False+ Just _ -> isInstance + ( mkName "ReifiableConstraint" ) + [ ConT paramname ]++ return $ if alreadyInstance+ then [ ]+ else [ InstanceD + []+ (AppT (ConT $ mkName "ReifiableConstraint") (ConT paramname))+ [ NewtypeInstD + []+ (mkName "Def")+ [ ConT paramname, VarT tyVar]+ ( RecC + (mkName $ "Def_"++nameBase paramname) + [ (mkName $ nameBase fname ++ "_", NotStrict, insertTyVar (tyVar) ftype) + | SigD fname ftype <- funcL+ ]+ )+ []+ , ValD + (VarP $ mkName "reifiedIns") + (NormalB $ + (AppE + (ConE $ mkName "Sub")+ (ConE $ mkName "Dict"))+ ) + []+ ]+ , InstanceD+ [ ClassP + ( mkName "Reifies" )+ [ VarT $ mkName "s"+ , AppT+ (AppT+ (ConT $ mkName "Def")+ (ConT paramname))+ (VarT $ mkName "a")+ ]+ ]+ (AppT + (ConT paramname) + (AppT + (AppT + (AppT (ConT $ mkName "ConstraintLift") (ConT paramname))+ (VarT tyVar))+ (VarT $ mkName "s"))+ )+ ( concat [ + [ FunD + fname + [ Clause+ [ VarP $ mkName "a" ]+ (NormalB $+ AppE+ (AppE+ (VarE $ mkName $ nameBase fname++"_")+ (AppE + (VarE (mkName "reflect"))+ (VarE (mkName "a"))))+ (AppE+ (VarE $ mkName "lower")+ (VarE $ mkName "a"))+ )+ [] + ]+ , PragmaD $ InlineP+ fname + Inline+ FunLike+ AllPhases+ ]+ | SigD fname ftype <- funcL+ ] )+ ]+ where++ tyVar = mkName "a"++ insertTyVar :: Name -> Type -> Type+ insertTyVar name (ForallT xs cxt t) = ForallT [] [] (insertTyVar name t)+ insertTyVar name (AppT t1 t2) = AppT (insertTyVar name t1) (insertTyVar name t2)+ insertTyVar name (VarT _) = VarT name+ insertTyVar name ArrowT = ArrowT+ insertTyVar name a = a++-------------------------------------------------------------------------------+-- test+
+ src/Data/Params/Frac.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DataKinds #-}++-- | Provides type level fractions based on type nats+module Data.Params.Frac+ ( Frac (..)+ , KnownFrac (..)+ , fracVal+ )+ where++import GHC.TypeLits+import Data.Proxy++-- | (Kind) This is the kind of type-level fractions. +-- It is not built in to GHC, but instead defined in terms of 'Nat'+data Frac = (/) Nat Nat++-- | This class gives the 'Rational' associated with a type-level fraction.+class KnownFrac (n :: Frac) where+ fracSing :: SFrac n ++instance (KnownNat a, KnownNat b) => KnownFrac (a/b) where+ fracSing = SFrac + (fromIntegral $ natVal (Proxy::Proxy a)) + (fromIntegral $ natVal (Proxy::Proxy b))++-- | get the value from a type frac+-- fracVal :: forall n proxy. (KnownFrac n) => proxy n -> Rational+fracVal :: forall f n proxy. (KnownFrac n, Fractional f) => proxy n -> f +fracVal _ = case fracSing :: SFrac n of+ SFrac a b -> fromIntegral a / fromIntegral b ++data SFrac (n :: Frac) = SFrac + {-#UNPACK#-}!Int+ {-#UNPACK#-}!Int+-- data SFrac (n :: Frac) = SFrac Integer Integer
+ src/Data/Params/PseudoPrim.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++-- | This modules extends the 'Prim' from "Data.Primitive" class to cases+-- where we don't know the primitive information (like the size) at compile+-- time. Instead, we must pass in a 'PseudoPrimInfo' object that will get+-- evaluated on every function call and that contains the needed information.+--+-- For 'PseudoPrim' instances that are also 'Prim' instances, this involves +-- no run time overhead. For 'PseudoPrim' instances that cannot be made+-- 'Prim' instances, this involves a mild memory and speed bookkeeping +-- overhead.+module Data.Params.PseudoPrim+ where++import GHC.Base (Int (..))+import GHC.Int+import GHC.Prim+import Data.Word++import Control.Monad.Primitive+import Data.Primitive++-------------------------------------------------------------------------------+-- PseudoPrim class++class PseudoPrim a where+ data family PseudoPrimInfo a+ pp_sizeOf# :: PseudoPrimInfo a -> Int#+ pp_alignment# :: PseudoPrimInfo a -> Int#+ pp_indexByteArray# :: PseudoPrimInfo a -> ByteArray# -> Int# -> a+ pp_readByteArray# :: PseudoPrimInfo a -> MutableByteArray# s -> Int# -> State# s -> (# State# s, a #)+ pp_writeByteArray# :: PseudoPrimInfo a -> MutableByteArray# s -> Int# -> a -> State# s -> State# s++ -- | Do we need to evaluate the info in order to call these functions?+ seqInfo :: a -> Bool++ -- | If 'seqInfo' returns 'True', then this function is undefined.+ -- Otherwise, it containes an empty 'PseudoPrimInfo' whose type is+ -- sufficient to determine all the needed information.+ emptyInfo :: PseudoPrimInfo a++#define mkPseudoPrim(t,ppi) \+instance PseudoPrim t where\+ newtype PseudoPrimInfo t = ppi () ;\+ pp_sizeOf# a = sizeOf# (undefined :: t) ;\+ pp_alignment# a = alignment# (undefined :: t) ;\+ pp_indexByteArray# a = indexByteArray# ;\+ pp_readByteArray# _ = readByteArray# ;\+ pp_writeByteArray# _ = writeByteArray# ;\+ seqInfo _ = False ;\+ emptyInfo = ppi () ++mkPseudoPrim(Double,PseudoPrimInfo_Double)+mkPseudoPrim(Float,PseudoPrimInfo_Float)+mkPseudoPrim(Int,PseudoPrimInfo_Int)+mkPseudoPrim(Char,PseudoPrimInfo_Char)+mkPseudoPrim(Word8,PseudoPrimInfo_Word8)+mkPseudoPrim(Word16,PseudoPrimInfo_Word16)+mkPseudoPrim(Word32,PseudoPrimInfo_Word32)+mkPseudoPrim(Word64,PseudoPrimInfo_Word64)++-------------------------------------------------------------------------------+-- helper functions++{-# INLINE pp_sizeOf #-}+pp_sizeOf :: PseudoPrim a => PseudoPrimInfo a -> Int+pp_sizeOf x = I# (pp_sizeOf# x)++{-# INLINE pp_alignment #-}+pp_alignment :: PseudoPrim a => PseudoPrimInfo a -> Int+pp_alignment x = I# (pp_alignment# x)++{-# INLINE pp_readByteArray #-}+pp_readByteArray+ :: (PseudoPrim a, PrimMonad m) => PseudoPrimInfo a -> MutableByteArray (PrimState m) -> Int -> m a+pp_readByteArray ppi (MutableByteArray arr#) (I# i#) = primitive (pp_readByteArray# ppi arr# i#)++{-# INLINE pp_writeByteArray #-}+pp_writeByteArray+ :: (PseudoPrim a, PrimMonad m) => PseudoPrimInfo a -> MutableByteArray (PrimState m) -> Int -> a -> m ()+pp_writeByteArray ppi (MutableByteArray arr#) (I# i#) x = primitive_ (pp_writeByteArray# ppi arr# i# x)++{-# INLINE pp_indexByteArray #-}+pp_indexByteArray :: PseudoPrim a => PseudoPrimInfo a -> ByteArray -> Int -> a+pp_indexByteArray ppi (ByteArray arr#) (I# i#) = pp_indexByteArray# ppi arr# i#
+ src/Data/Params/Vector.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Provides the infrastructure that is common to all types of parameterized+-- vectors.+module Data.Params.Vector+ (++ -- * Type lenses+ _len+ , _elem++ -- * Classes+ , Param_len (..)+ , Param_elem (..)+ , Def (..)++ )+ where++import Language.Haskell.TH hiding (reify)+import Language.Haskell.TH.Syntax hiding (reify)+import qualified Language.Haskell.TH as TH++import Data.Params++mkParamClass_Config "len" (ConT ''Int)+mkParamClass_Star "elem" +mkReifiableConstraint "len"+mkTypeLens_Config "len"+mkTypeLens_Star "elem"+mkHasDictionary_Star "elem"+mkHasDictionary_Config "len" (ConT ''Int)+
+ src/Data/Params/Vector/Unboxed.hs view
@@ -0,0 +1,905 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-}+module Data.Params.Vector.Unboxed+ ( Vector + , module Data.Params.Vector+ )+ where++import Control.Category+import Prelude hiding ((.),id)++import Control.Monad+import Control.Monad.Primitive+import Control.Monad.Random+import Control.DeepSeq+import Data.Primitive+import Data.Primitive.ByteArray+-- import Data.Primitive.Types+-- import GHC.Ptr+-- import Foreign.Ptr+-- import Foreign.ForeignPtr hiding (unsafeForeignPtrToPtr)+-- import Foreign.ForeignPtr.Unsafe+-- import Foreign.Marshal.Array+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Primitive.Mutable as VPM++import GHC.Base (Int (..))+import GHC.Int+import GHC.Prim+import GHC.TypeLits++import Data.Params+import Data.Params.Instances+import Data.Params.Vector+import Data.Params.PseudoPrim+import Unsafe.Coerce+import Debug.Trace+++-------------------------------------------------------------------------------+-- immutable automatically sized vector++data family Vector (len::Config Nat) elem+mkParams ''Vector++instance (Show elem, VG.Vector (Vector len) elem) => Show (Vector len elem) where+ show v = "fromList "++show (VG.toList v)++instance (Eq elem, VG.Vector (Vector len) elem) => Eq (Vector len elem) where+ a == b = (VG.toList a) == (VG.toList b)++instance (Ord elem, VG.Vector (Vector len) elem) => Ord (Vector len elem) where+ compare a b = compare (VG.toList a) (VG.toList b)++---------------------------------------+-- Static size ++data instance Vector (Static len) elem = Vector + {-#UNPACK#-}!Int + {-#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+ ) => StaticToAutomatic + Param_len + (Vector (Static len) elem)+ (Vector Automatic elem)+ where+ + staticToAutomatic _ (Vector off ppi arr) = Vector_Automatic off len ppi arr+ where+ len = fromIntegral $ natVal (Proxy::Proxy len)++ mkPseudoPrimInfoFromStatic _ (PseudoPrimInfo_VectorStatic ppi) + = PseudoPrimInfo_VectorAutomatic len (len*size) ppi+ where+ len = fromIntegral $ natVal (Proxy::Proxy len)+ size = pp_sizeOf ppi++instance+ ( KnownNat len + , StaticToAutomatic p elem elem'+ ) => StaticToAutomatic+ (Param_elem p)+ (Vector (Static len) elem)+ (Vector (Static len) elem')+ where+ + staticToAutomatic _ (Vector off ppi arr) = Vector off ppi' arr+ where+ ppi' = mkPseudoPrimInfoFromStatic (TypeLens::TypeLens Base p) ppi++ mkPseudoPrimInfoFromStatic _ (PseudoPrimInfo_VectorStatic ppi)+ = PseudoPrimInfo_VectorStatic $ mkPseudoPrimInfoFromStatic (TypeLens :: TypeLens Base p) ppi ++instance+ ( PseudoPrim elem+ ) => RunTimeToAutomatic+ Param_len+ (Vector RunTime elem)+ (Vector Automatic elem)+ where+ + runTimeToAutomatic lens p v = mkApWith1Param + (Proxy::Proxy (Vector RunTime elem))+ (Proxy::Proxy (Vector Automatic elem))+ lens + p+ go+ v+ where+ go v@(Vector_RunTime off ppi arr) = Vector_Automatic off len ppi arr+ where+ len = VG.length v++ mkPseudoPrimInfoFromRuntime _ len (PseudoPrimInfo_VectorRunTime ppi) + = PseudoPrimInfo_VectorAutomatic len (len*pp_sizeOf ppi) ppi++instance+ ( RunTimeToAutomatic p elem elem'+ , HasDictionary p+ , ReifiableConstraint (ApplyConstraint_GetConstraint p)+ ) => RunTimeToAutomatic+ (Param_elem p)+ (Vector (Static len) elem)+ (Vector (Static len) elem')+ where++ runTimeToAutomatic lens p v = mkApWith1Param+ (Proxy::Proxy (Vector (Static len) elem))+ (Proxy::Proxy (Vector (Static len) elem'))+ lens+ p+ go+ v+ where+ go :: Vector (Static len) elem -> Vector (Static len) elem'+ go (Vector off ppi arr) = Vector off ppi' arr+ where + ppi' = mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi+ :: PseudoPrimInfo elem'++ mkPseudoPrimInfoFromRuntime _ p (PseudoPrimInfo_VectorStatic ppi)+ = PseudoPrimInfo_VectorStatic $ mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi++instance+ ( RunTimeToAutomatic p elem elem'+ , HasDictionary p+ , ReifiableConstraint (ApplyConstraint_GetConstraint p)+ ) => RunTimeToAutomatic+ (Param_elem p)+ (Vector RunTime elem)+ (Vector RunTime elem')+ where++ runTimeToAutomatic lens p v = mkApWith1Param+ (Proxy::Proxy (Vector RunTime elem))+ (Proxy::Proxy (Vector RunTime elem'))+ lens+ p+ go+ v+ where+ go :: Vector RunTime elem -> Vector RunTime elem'+ go (Vector_RunTime off ppi arr) = Vector_RunTime off ppi' arr+ where+ ppi' = mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi+ :: PseudoPrimInfo elem'++ mkPseudoPrimInfoFromRuntime _ p (PseudoPrimInfo_VectorRunTime ppi)+ = PseudoPrimInfo_VectorRunTime $ mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi++instance+ ( RunTimeToAutomatic p elem elem'+ , HasDictionary p+ , ReifiableConstraint (ApplyConstraint_GetConstraint p)+ ) => RunTimeToAutomatic+ (Param_elem p)+ (Vector Automatic elem)+ (Vector Automatic elem')+ where++ runTimeToAutomatic lens p v = mkApWith1Param+ (Proxy::Proxy (Vector Automatic elem))+ (Proxy::Proxy (Vector Automatic elem'))+ lens+ p+ go+ v+ where+ go :: Vector Automatic elem -> Vector Automatic elem'+ go (Vector_Automatic len off ppi arr) = Vector_Automatic len off ppi' arr+ where+ ppi' = mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi+ :: PseudoPrimInfo elem'++ mkPseudoPrimInfoFromRuntime _ p (PseudoPrimInfo_VectorAutomatic len size ppi)+ = PseudoPrimInfo_VectorAutomatic + 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)++++-------------------++instance NFData (Vector (Static len) elem) where+ rnf a = seq a ()++instance + ( PseudoPrim elem + , KnownNat len+ ) => VG.Vector (Vector (Static len)) elem + where+ + {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeFreeze (MVector i ppi marr) = Vector i ppi `liftM` unsafeFreezeByteArray marr++ {-# INLINE basicUnsafeThaw #-}+ basicUnsafeThaw (Vector i ppi arr) = MVector i ppi `liftM` unsafeThawByteArray arr++ {-# INLINE [2] basicLength #-}+ basicLength _ = viewParam _len (undefined::Vector (Static len) elem) ++ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice j n v = if n /= viewParam _len (undefined::Vector (Static len) elem) || j /= 0+ then error $ "Vector.basicUnsafeSlice not allowed to change size"+ else v ++ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeIndexM (Vector i ppi arr) j = return $! pp_indexByteArray ppi arr (i+j)++-- {-# INLINE basicUnsafeCopy #-}+-- basicUnsafeCopy (MVector i ppi1 dst) (Vector j ppi2src) = +-- copyByteArray dst (i*sz) src (j*sz) (len*sz)+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- len = getParam_len (undefined::Vector (Static len) elem)++ {-# INLINE elemseq #-}+ elemseq _ = seq++-------------------+-- primitive instance allows unboxing unboxed vectors++unInt :: Int -> Int#+unInt (I# i) = i++instance+ ( Prim elem+ , PseudoPrim elem+ , KnownNat len+ ) => Prim (Vector (Static len) elem)+ where+ + {-# INLINE sizeOf# #-}+ sizeOf# _ = + unInt (sizeOf (undefined::elem)* (intparam (Proxy::Proxy len)))++ {-# INLINE alignment# #-}+ alignment# _ = + unInt (alignment (undefined :: elem))+-- unInt (sizeOf ppi * (intparam (Proxy::Proxy len)))++ {-# INLINE indexByteArray# #-}+ indexByteArray# arr# i# = + Vector ((I# i#)*(intparam (Proxy::Proxy len))) (emptyInfo::PseudoPrimInfo elem) (ByteArray arr#)++ {-# INLINE readByteArray# #-}+ readByteArray# marr# i# s# = + (# s#, Vector (I# i#) (emptyInfo::PseudoPrimInfo elem) (ByteArray (unsafeCoerce# marr#)) #)++ {-# INLINE writeByteArray# #-}+ writeByteArray# marr# i# x s# = go 0 s#+ where+ go i s = ( if i >= intparam (Proxy::Proxy len)+ then s+ else go (i+1) + (writeByteArray# marr# + (i# *# (unInt ( intparam (Proxy::Proxy len))) +# (unInt i)) +-- (x VG.! i)+ (x `VG.unsafeIndex` i)+ s+ )+ )+ where + iii = I# (i# *# (sizeOf# (undefined::elem)) +# (unInt i)) ++instance+ ( PseudoPrim elem+ , KnownNat len+ , Show elem+ ) => PseudoPrim (Vector (Static len) elem)+ where+ + newtype PseudoPrimInfo (Vector (Static len) elem) = + PseudoPrimInfo_VectorStatic (PseudoPrimInfo elem)++ {-# INLINE pp_sizeOf# #-}+ pp_sizeOf# (PseudoPrimInfo_VectorStatic ppi) = + unInt (pp_sizeOf ppi * (intparam (Proxy::Proxy len)))++ {-# INLINE pp_alignment# #-}+ pp_alignment# (PseudoPrimInfo_VectorStatic ppi) = + unInt (pp_alignment ppi)+-- unInt (pp_sizeOf ppi * (intparam (Proxy::Proxy len)))++ {-# INLINE pp_indexByteArray# #-}+ pp_indexByteArray# (PseudoPrimInfo_VectorStatic ppi) arr# i# = + Vector ((I# i#)*(intparam (Proxy::Proxy len))) ppi (ByteArray arr#)++ {-# INLINE pp_readByteArray# #-}+ pp_readByteArray# (PseudoPrimInfo_VectorStatic ppi) marr# i# s# = + (# s#, Vector (I# i#) ppi (ByteArray (unsafeCoerce# marr#)) #)++ {-# INLINE pp_writeByteArray# #-}+ pp_writeByteArray# (PseudoPrimInfo_VectorStatic ppi) marr# i# x s# = go 0 s#+ where+ go i s = ( if i >= intparam (Proxy::Proxy len)+ then s+ else go (i+1) + (pp_writeByteArray# ppi marr# + (i# *# (unInt ( intparam (Proxy::Proxy len))) +# (unInt i)) +-- (x VG.! i)+ (x `VG.unsafeIndex` i)+ s+ )+ )+ where + iii = I# (i# *# (pp_sizeOf# ppi) +# (unInt i)) ++ {-# INLINE seqInfo #-}+ seqInfo _ = seqInfo (undefined::elem)++ {-# INLINE emptyInfo #-}+ emptyInfo = PseudoPrimInfo_VectorStatic emptyInfo ++----------------------------------------+-- RunTime size ++data instance Vector RunTime elem = Vector_RunTime + {-#UNPACK#-}!Int + {-#UNPACK#-}!(PseudoPrimInfo elem)+ {-#UNPACK#-}!ByteArray++instance NFData (Vector RunTime elem) where+ rnf a = seq a ()+++instance + ( PseudoPrim elem +-- , GetParam_len (Vector RunTime elem)+-- , ViewParam GetParam_len (Vector RunTime elem)+ , ViewParam Param_len (Vector RunTime elem)+ ) => VG.Vector (Vector RunTime) elem + where+ + {-# INLINE basicUnsafeFreeze #-}+-- basicUnsafeFreeze (MVector_RunTime len i marr) = if len==getParam_len (undefined::Vector RunTime elem)+ basicUnsafeFreeze (MVector_RunTime len i ppi marr) = + if len == viewParam _len (undefined::Vector RunTime elem)+ then Vector_RunTime i ppi `liftM` unsafeFreezeByteArray marr+ else error $ "basicUnsafeFreeze cannot change RunTime vector size"+ ++ "; len="++show len+ ++ "; getParam_len="++show (viewParam _len (undefined::Vector RunTime elem))++ {-# INLINE basicUnsafeThaw #-}+ basicUnsafeThaw (Vector_RunTime i ppi arr) = + MVector_RunTime (viewParam _len (undefined::Vector RunTime elem)) i ppi `liftM` unsafeThawByteArray arr+-- MVector_RunTime (getParam_len (undefined::Vector RunTime elem)) i `liftM` unsafeThawByteArray arr++ {-# INLINE [2] basicLength #-}+ basicLength _ = viewParam _len (undefined::Vector RunTime elem) +-- basicLength _ = getParam_len (undefined::Vector RunTime elem) ++ {-# INLINE basicUnsafeSlice #-}+-- basicUnsafeSlice j n v = if n /= getParam_len (undefined::Vector RunTime elem) || j /= 0+ basicUnsafeSlice j n v = + if n /= viewParam _len (undefined::Vector RunTime elem) || j /= 0+ then error $ "Vector_RunTime.basicUnsafeSlice not allowed to change size"+ else v ++ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeIndexM (Vector_RunTime i ppi arr) j = return $! pp_indexByteArray ppi arr (i+j)++-- {-# INLINE basicUnsafeCopy #-}+-- basicUnsafeCopy (MVector_RunTime n i dst) (Vector_RunTime j src) = if n==len+-- then copyByteArray dst (i*sz) src (j*sz) (len*sz)+-- else error "basicUnsafeCopy cannot change RunTime vector size"+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- -- len = getParam_len (undefined::Vector RunTime elem)+-- len = viewParam _len (undefined::Vector RunTime elem)++ {-# INLINE elemseq #-}+ elemseq _ = seq++-------------------++instance+ ( PseudoPrim elem+-- , GetParam_len (Vector RunTime elem)+ , ViewParam Param_len (Vector RunTime elem)+ ) => PseudoPrim (Vector RunTime elem)+ where++ newtype PseudoPrimInfo (Vector RunTime elem) = + PseudoPrimInfo_VectorRunTime (PseudoPrimInfo elem)+ + {-# INLINE pp_sizeOf# #-}+ pp_sizeOf# (PseudoPrimInfo_VectorRunTime ppi) = +-- unInt (pp_sizeOf ppi * (getParam_len (undefined::Vector RunTime elem)))+ unInt (pp_sizeOf ppi * (viewParam _len (undefined::Vector RunTime elem)))++ {-# INLINE pp_alignment# #-}+ pp_alignment# (PseudoPrimInfo_VectorRunTime ppi) = + unInt (pp_alignment ppi)+-- unInt (pp_sizeOf (undefined::elem) * (getParam_len (undefined::Vector RunTime elem)))++ {-# INLINE pp_indexByteArray# #-}+ pp_indexByteArray# (PseudoPrimInfo_VectorRunTime ppi)arr# i# = +-- Vector_RunTime ((I# i#)*(getParam_len (undefined::Vector RunTime elem))) ppi (ByteArray arr#)+ Vector_RunTime ((I# i#)*(viewParam _len (undefined::Vector RunTime elem))) ppi (ByteArray arr#)++ {-# INLINE pp_readByteArray# #-}+ pp_readByteArray# (PseudoPrimInfo_VectorRunTime ppi) marr# i# s# = + (# s#, Vector_RunTime (I# i#) ppi (ByteArray (unsafeCoerce# marr#)) #)++ {-# INLINE pp_writeByteArray# #-}+ pp_writeByteArray# (PseudoPrimInfo_VectorRunTime ppi) marr# i# x s# = go 0 s#+ where+ go i s = ( if i >= len+ then s+ else go (i+1) + (pp_writeByteArray# ppi marr# + (i# *# (unInt len) +# (unInt i)) + (x VG.! i)+ s+ )+ )+ where + len = viewParam _len (undefined::Vector RunTime elem)+-- len = getParam_len (undefined::Vector RunTime elem)+ iii = I# (i# *# (pp_sizeOf# ppi) +# (unInt i)) ++ {-# INLINE seqInfo #-}+ seqInfo _ = seqInfo (undefined::elem)++ {-# INLINE emptyInfo #-}+ emptyInfo = PseudoPrimInfo_VectorRunTime emptyInfo++---------------------------------------+-- Automatic sized++data instance Vector Automatic elem = Vector_Automatic+ {-#UNPACK#-}!Int + {-#UNPACK#-}!Int + {-#UNPACK#-}!(PseudoPrimInfo elem)+ {-#UNPACK#-}!ByteArray++instance NFData (Vector Automatic elem) where+ rnf v = seq v ()++instance PseudoPrim elem => VG.Vector (Vector Automatic) elem where++ {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeFreeze (MVector_Automatic i n ppi marr)+ = Vector_Automatic i n ppi `liftM` unsafeFreezeByteArray marr++ {-# INLINE basicUnsafeThaw #-}+ basicUnsafeThaw (Vector_Automatic i n ppi arr)+ = MVector_Automatic i n ppi `liftM` unsafeThawByteArray arr++ {-# INLINE basicLength #-}+ basicLength (Vector_Automatic _ n _ _) = n++ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice j n (Vector_Automatic i _ ppi arr) = Vector_Automatic (i+j) n ppi arr++ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeIndexM (Vector_Automatic i _ ppi arr) j = return $! pp_indexByteArray ppi arr (i+j)++-- {-# INLINE basicUnsafeCopy #-}+-- basicUnsafeCopy (MVector_Automatic i n dst) (Vector_Automatic j _ src)+-- = copyByteArray dst (i*sz) src (j*sz) (n*sz)+-- where+-- sz = sizeOf (indefinido :: a)++ {-# INLINE elemseq #-}+ elemseq _ = seq++instance PseudoPrim elem => PseudoPrim (Vector Automatic elem) where+ data PseudoPrimInfo (Vector Automatic elem) = PseudoPrimInfo_VectorAutomatic+ {-#UNPACK#-}!(Int) -- length+ {-#UNPACK#-}!(Int) -- sizeOf+ {-#UNPACK#-}!(PseudoPrimInfo elem)+ + {-# INLINE pp_sizeOf# #-}+ pp_sizeOf# (PseudoPrimInfo_VectorAutomatic _ s _) = unInt s++ {-# INLINE pp_alignment# #-}+ pp_alignment# (PseudoPrimInfo_VectorAutomatic _ _ ppi) = + unInt (pp_alignment ppi)++ {-# INLINE pp_indexByteArray# #-}+ pp_indexByteArray# (PseudoPrimInfo_VectorAutomatic len _ ppi) arr# i# = + Vector_Automatic ((I# i#)*len) len ppi (ByteArray arr#)++ {-# INLINE pp_readByteArray# #-}+ pp_readByteArray# (PseudoPrimInfo_VectorAutomatic len _ ppi) marr# i# s# = + (# s#, Vector_Automatic (I# i#) len ppi (ByteArray (unsafeCoerce# marr#)) #)++ {-# INLINE pp_writeByteArray# #-}+ pp_writeByteArray# (PseudoPrimInfo_VectorAutomatic len _ ppi) marr# i# x s# = go 0 s#+ where+ go i s = ( if i >= len+ then s+ else go (i+1) + (pp_writeByteArray# ppi marr# + (i# *# (unInt len) +# (unInt i)) + (x VG.! i)+ s+ )+ )+ where + iii = I# (i# *# (pp_sizeOf# ppi) +# (unInt i)) ++ {-# INLINE seqInfo #-}+ seqInfo _ = False++ {-# INLINE emptyInfo #-}+ emptyInfo = error "emptyInfo of PseudoPrimInfo_VectorAutomatic"+++-------------------------------------------------------------------------------+-- mutable vector++data family MVector (len::Config Nat) s elem++type instance VG.Mutable (Vector len) = MVector len++---------------------------------------+-- static size++data instance MVector (Static len) s elem = MVector + {-#UNPACK#-}!Int + {-#UNPACK#-}!(PseudoPrimInfo elem)+ {-#UNPACK#-}!(MutableByteArray s)++instance + ( PseudoPrim elem+ , KnownNat len+ ) => VGM.MVector (MVector (Static len)) elem + where++ {-# INLINE basicLength #-}+ basicLength _ = fromIntegral $ natVal (Proxy::Proxy len)+ + {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice i m v = if m /= len+ then error $ "MVector (Static len) .basicUnsafeSlice not allowed to change size"+ ++"; i="++show i+ ++"; m="++show m+ ++"; len="++show len + else v+ where+-- len = getParam_len (undefined::MVector (Static len) s elem)+ len = intparam (Proxy::Proxy len)+ + {-# INLINE basicOverlaps #-}+ basicOverlaps (MVector i ppi1 arr1) (MVector j ppi2 arr2)+ = sameMutableByteArray arr1 arr2+ && (between i j (j+len) || between j i (i+len))+ where+ len = intparam (Proxy::Proxy len)+ between x y z = x >= y && x < z++ {-# INLINE basicUnsafeNew #-}+ basicUnsafeNew n = if seqInfo (undefined::elem)+ then error "basicUnsafeNew: seqInfo"+ else do+ arr <- newPinnedByteArray (len * pp_sizeOf (emptyInfo :: PseudoPrimInfo elem))+ return $ MVector 0 (emptyInfo::PseudoPrimInfo elem) arr+ where+ len = intparam (Proxy::Proxy len)++ {-# INLINE basicUnsafeRead #-}+ basicUnsafeRead (MVector i ppi arr) j = pp_readByteArray ppi arr (i+j)++ {-# INLINE basicUnsafeWrite #-}+ basicUnsafeWrite (MVector i ppi arr) j x = pp_writeByteArray ppi arr (i+j) x++-- {-# INLINE basicUnsafeCopy #-}+-- basicUnsafeCopy (MVector i ppi dst) (MVector j ppi src) = +-- copyMutableByteArray ppi dst (i*sz) src (j*sz) (len*sz)+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- len = intparam (Proxy::Proxy len)+-- +-- {-# INLINE basicUnsafeMove #-}+-- basicUnsafeMove (MVector i dst) (MVector j src) = moveByteArray dst (i*sz) src (j*sz) (len * sz)+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- len = intparam (Proxy::Proxy len)+-- +-- {-# INLINE basicSet #-}+-- basicSet (MVector i arr) x = setByteArray arr i (intparam(Proxy::Proxy len)) x+ ++---------------------------------------+-- RunTime size++data instance MVector RunTime s elem = MVector_RunTime+ {-#UNPACK#-}!Int + {-#UNPACK#-}!Int + {-#UNPACK#-}!(PseudoPrimInfo elem)+ {-#UNPACK#-}!(MutableByteArray s)++instance + ( PseudoPrim elem+ ) => VGM.MVector (MVector RunTime) elem + where++ {-# INLINE basicLength #-}+ basicLength (MVector_RunTime n _ ppi _) = n+ + {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice i m (MVector_RunTime n j ppi v) = MVector_RunTime m (i+j) ppi v+-- basicUnsafeSlice i m v = if m /= len+-- then error $ "MVector.basicUnsafeSlice not allowed to change size"+-- ++"; i="++show i+-- ++"; m="++show m+-- ++"; len="++show len +-- else v+-- where+-- len = VGM.length v+ + {-# INLINE basicOverlaps #-}+ basicOverlaps (MVector_RunTime m i ppi1 arr1) (MVector_RunTime n j ppi2 arr2)+ = sameMutableByteArray arr1 arr2+ && (between i j (j+m) || between j i (i+n))+ where+ between x y z = x >= y && x < z++ {-# INLINE basicUnsafeNew #-}+ basicUnsafeNew n = if seqInfo (undefined::elem)+ then error "basicUnsafeNew: seqInfo"+ else do+ arr <- newPinnedByteArray (n * pp_sizeOf (emptyInfo :: PseudoPrimInfo elem))+ return $ MVector_RunTime n 0 emptyInfo arr++ {-# INLINE basicUnsafeRead #-}+ basicUnsafeRead (MVector_RunTime _ i ppi arr) j = pp_readByteArray ppi arr (i+j)++ {-# INLINE basicUnsafeWrite #-}+ basicUnsafeWrite (MVector_RunTime _ i ppi arr) j x = pp_writeByteArray ppi arr (i+j) x+++-- {-# INLINE basicUnsafeCopy #-}+-- basicUnsafeCopy (MVector_RunTime n i dst) (MVector_RunTime m j src) +-- = if n==m+-- then copyMutableByteArray dst (i*sz) src (j*sz) (n*sz)+-- else error "basicUnsafeCopy cannot change size of RunTime MVector"+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- +-- {-# INLINE basicUnsafeMove #-}+-- basicUnsafeMove (MVector_RunTime n i dst) (MVector_RunTime m j src) +-- = if n==m+-- then moveByteArray dst (i*sz) src (j*sz) (n * sz)+-- else error "basicUnsafeMove cannot change size of RunTime MVector"+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- +-- {-# INLINE basicSet #-}+-- basicSet (MVector_RunTime n i arr) x = setByteArray arr i n x+ ++---------------------------------------+-- Automatic size++data instance MVector Automatic s elem = MVector_Automatic+ {-#UNPACK#-}!Int + {-#UNPACK#-}!Int + {-#UNPACK#-}!(PseudoPrimInfo elem)+ {-#UNPACK#-}!(MutableByteArray s)++instance + ( PseudoPrim elem+ ) => VGM.MVector (MVector Automatic) elem + where++ {-# INLINE basicLength #-}+ basicLength (MVector_Automatic _ n ppi _) = n+ + {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice i m (MVector_Automatic j n ppi v) = MVector_Automatic (i+j) m ppi v+-- basicUnsafeSlice i m v = if m /= len+-- then error $ "MVector.basicUnsafeSlice not allowed to change size"+-- ++"; i="++show i+-- ++"; m="++show m+-- ++"; len="++show len +-- else v+-- where+-- len = VGM.length v+ + {-# INLINE basicOverlaps #-}+ basicOverlaps (MVector_Automatic i m ppi1 arr1) (MVector_Automatic j n ppi2 arr2)+ = sameMutableByteArray arr1 arr2+ && (between i j (j+m) || between j i (i+n))+ where+ between x y z = x >= y && x < z++ {-# INLINE basicUnsafeNew #-}+ basicUnsafeNew n = if seqInfo (undefined::elem)+ then error "basicUnsafeNew: seqInfo"+ else do+ arr <- newPinnedByteArray (n * pp_sizeOf (emptyInfo :: PseudoPrimInfo elem))+ return $ MVector_Automatic 0 n emptyInfo arr++ {-# INLINE basicUnsafeRead #-}+ basicUnsafeRead (MVector_Automatic i _ ppi arr) j = pp_readByteArray ppi arr (i+j)++ {-# INLINE basicUnsafeWrite #-}+ basicUnsafeWrite (MVector_Automatic i _ ppi arr) j x = pp_writeByteArray ppi arr (i+j) x+++-- {-# INLINE basicUnsafeCopy #-}+-- basicUnsafeCopy (MVector_Automatic i n dst) (MVector_Automatic j m src) +-- = if n==m+-- then copyMutableByteArray dst (i*sz) src (j*sz) (n*sz)+-- else error "basicUnsafeCopy cannot change size of Automatic MVector"+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- +-- {-# INLINE basicUnsafeMove #-}+-- basicUnsafeMove (MVector_Automatic i n dst) (MVector_Automatic j m src) +-- = if n==m+-- then moveByteArray dst (i*sz) src (j*sz) (n * sz)+-- else error "basicUnsafeMove cannot change size of Automatic MVector"+-- where+-- sz = pp_sizeOf (undefined :: elem)+-- +-- {-# INLINE basicSet #-}+-- basicSet (MVector_Automatic i n arr) x = setByteArray arr i n x
+ typeparams.cabal view
@@ -0,0 +1,77 @@+Name: typeparams+Version: 0.0.1.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:+ .+ > data Example p1 (p2::Config Nat) (p3::Constraint) = Example+ .+ @p1@, @p2@, and @p3@ are the type parameters. + .+ Two example uses of this library are for unboxing unboxed vectors and supercompilation-like optimizations. Please see the <https://github.com/mikeizbicki/typeparams#the-typeparams-library README file on github> for a detailed description and tutorial. After reading through that, the haddock documentation will make more sense.++Category: Configuration, Dependent Types, Data, Optimization+License: BSD3+License-file: LICENSE+Author: Mike izbicki+Maintainer: mike@izbicki.me+Build-Type: Simple+Cabal-Version: >=1.8+homepage: http://github.com/mikeizbicki/params/+bug-reports: http://github.com/mikeizbicki/params/issues++Library+ Build-Depends: + -- common dependencies+ base >= 3 && < 5,+ template-haskell,+ deepseq >= 1.3,++ -- + tagged >= 0.7,+ reflection >= 1.3,+ constraints >= 0.3.4,++ primitive >= 0.5,+ ghc-prim ,++ -- examples+ vector >= 0.10,+ MonadRandom >= 0.1.13+ + hs-source-dirs: + src++ ghc-options: + -fllvm+ -O2+ -funbox-strict-fields++ Exposed-modules:+ Data.Params+ Data.Params.Frac+ Data.Params.PseudoPrim+ -- Data.Params.Instances+ Data.Params.Vector+ -- Data.Params.Vector.Storable+ -- Data.Params.Vector.StorableRaw+ Data.Params.Vector.Unboxed+ -- Data.Params.Vector.UnboxedRaw++ Extensions:+ FlexibleInstances+ FlexibleContexts+ MultiParamTypeClasses+ FunctionalDependencies+ UndecidableInstances+ ScopedTypeVariables+ BangPatterns+ TypeOperators+ GeneralizedNewtypeDeriving+ TypeFamilies+ StandaloneDeriving+ GADTs+ KindSignatures+ ConstraintKinds+ RankNTypes+