diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Params.hs b/src/Data/Params.hs new file mode 100644 --- /dev/null +++ b/src/Data/Params.hs @@ -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 . + -- 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 + diff --git a/src/Data/Params/Frac.hs b/src/Data/Params/Frac.hs new file mode 100644 --- /dev/null +++ b/src/Data/Params/Frac.hs @@ -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 diff --git a/src/Data/Params/PseudoPrim.hs b/src/Data/Params/PseudoPrim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Params/PseudoPrim.hs @@ -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# diff --git a/src/Data/Params/Vector.hs b/src/Data/Params/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Data/Params/Vector.hs @@ -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) + diff --git a/src/Data/Params/Vector/Unboxed.hs b/src/Data/Params/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Params/Vector/Unboxed.hs @@ -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 diff --git a/typeparams.cabal b/typeparams.cabal new file mode 100644 --- /dev/null +++ b/typeparams.cabal @@ -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 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 +