typeparams 0.0.3.1 → 0.0.4
raw patch · 4 files changed
+212/−6 lines, 4 files
Files
- src/Data/Params.hs +85/−5
- src/Data/Params/Applicative.hs +112/−0
- src/Data/Params/Functor.hs +13/−0
- typeparams.cabal +2/−1
src/Data/Params.hs view
@@ -37,9 +37,13 @@ , GetParam , SetParam , SetParam'+ , Objective+ , RemoveObjective , Base , _base , zoom+ , objective+ , removeObjective , Zoom , EyePiece , ApplyConstraint_GetType@@ -335,6 +339,7 @@ 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 @@ -369,12 +374,21 @@ type family Zoom (p :: k1) :: k2 type family EyePiece (p :: k1) :: k2--- type family Zoom (p :: * -> Constraint) :: * -> Constraint--- type family EyePiece (p :: * -> Constraint) :: (* -> Constraint) -> * -> Constraint +type family Objective (lens :: * -> Constraint) :: * -> Constraint+type instance Objective Base = Base++type family RemoveObjective (lens :: * -> Constraint) :: * -> Constraint+ zoom :: TypeLens a p -> TypeLens a (Zoom p) zoom lens = TypeLens +objective :: TypeLens q p -> TypeLens q (Objective p)+objective _ = TypeLens++removeObjective :: TypeLens p q -> TypeLens p (RemoveObjective q)+removeObjective _ = TypeLens+ class Base a _base :: TypeLens Base Base@@ -759,6 +773,16 @@ -- > type instance Zoom (Param_vi a) = a -- > type instance EyePiece (Param_vi a) = Param_vi --+-- > type instance Objective (Param_vi p) = Objective_Param_vi (Param_vi p)+-- > type family Objective_Param_vi (lens :: * -> Constraint) :: * -> Constraint where+-- > Objective_Param_vi (Param_vi Base) = Param_vi Base+-- > Objective_Param_vi (Param_vi p) = Objective p+--+-- > type instance RemoveObjective (Param_vi p) = RemoveObjective_Param_vi (Param_vi p)+-- > type family RemoveObjective_Param_vi (lens :: * -> Constraint) :: * -> Constraint where+-- > RemoveObjective_Param_vi (Param_vi Base) = Base+-- > RemoveObjective_Param_vi (Param_vi p) = Param_vi (RemoveObjective p)+-- -- This function requires that the @Param_@ classes have already been defined. -- mkTypeFamilies_Star :: String -> Name -> Q [Dec]@@ -775,17 +799,73 @@ ( TySynEqn [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ] ( VarT $ mkName "p" )- ) , TySynInstD ( mkName "EyePiece" ) ( TySynEqn [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ] ( ConT $ mkName $ "Param_"++paramstr )- ) ] + isdef <- lookupTypeName $ "Objective_Param_"++paramstr+ let objective = case isdef of+ Just _ -> []+ Nothing ->+ [ ClosedTypeFamilyD+ ( mkName $ "Objective_Param_"++paramstr )+ [ KindedTV ( mkName "lens" ) ( AppT (AppT ArrowT StarT) ConstraintT) ]+ ( Just ( AppT (AppT ArrowT StarT) ConstraintT) )+ [ TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (ConT $ mkName "Base") ]+ ( AppT (ConT $ mkName $ "Param_"++paramstr) (ConT $ mkName "Base") )+ , TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]+ ( AppT (ConT $ mkName "Objective" ) (VarT $ mkName "p") )+ ]+ , TySynInstD+ ( mkName "Objective" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]+ ( AppT + ( ConT $ mkName $ "Objective_Param_"++paramstr ) + ( AppT+ ( ConT $ mkName $ "Param_"++paramstr )+ ( VarT $ mkName "p") + )+ )+ )+ , ClosedTypeFamilyD+ ( mkName $ "RemoveObjective_Param_"++paramstr )+ [ KindedTV ( mkName "lens" ) ( AppT (AppT ArrowT StarT) ConstraintT) ]+ ( Just ( AppT (AppT ArrowT StarT) ConstraintT) )+ [ TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (ConT $ mkName "Base") ]+ ( ConT $ mkName "Base")+ , TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]+ ( AppT + ( ConT $ mkName $ "Param_"++paramstr ) + ( AppT+ ( ConT $ mkName $ "RemoveObjective" )+ ( VarT $ mkName "p") + )+ )+ ]+ , TySynInstD+ ( mkName "RemoveObjective" )+ ( TySynEqn+ [ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]+ ( AppT + ( ConT $ mkName $ "RemoveObjective_Param_"++paramstr ) + ( AppT+ ( ConT $ mkName $ "Param_"++paramstr )+ ( VarT $ mkName "p") + )+ )+ )+ ]+ let getters = [ TySynInstD ( mkName "GetParam" )@@ -872,7 +952,7 @@ ) ] - return $ zooms++getters++setters+ return $ zooms++getters++setters++objective -- | Given a data type of the form --
+ src/Data/Params/Applicative.hs view
@@ -0,0 +1,112 @@+module Data.Params.Applicative+ where++import Control.Category+import Prelude hiding ( (.), id, Functor(..), Applicative(..) )++import Data.Params+import Data.Params.Functor++-------------------------------------------------------------------------------+-- Applicative class++class Functor lens tb => Applicative lens tb where++ pure :: GetParam lens tb -> TypeLens Base lens -> tb++ ap :: + ( tf ~ SetParam lens (a -> b) tb+ , ta ~ SetParam lens a tb+ , a ~ GetParam lens ta+ , b ~ GetParam lens tb+ )+ => TypeLens Base lens + -> tf+ -> ta+ -> tb++---------------------------------------+-- instances++instance Applicative Base t where+ pure a _ = a+ ap _ f = f++-------------------++instance Applicative p a => Applicative (Param_a p) (Maybe a) where+ pure a lens = Just $ pure a (zoom lens)+ ap lens Nothing _ = Nothing+ ap lens (Just f) Nothing = Nothing+ ap lens (Just f) (Just b) = Just $ ap (zoom lens) f b++-------------------++instance Applicative p a => Applicative (Param_a p) (Either a b) where+ pure a lens = Left $ pure a (zoom lens)+ ap lens (Right a) _ = Right a+ ap lens (Left f) (Right a) = Right a+ ap lens (Left f) (Left b) = Left $ ap (zoom lens) f b++instance Applicative p b => Applicative (Param_b p) (Either a b) where+ pure b lens = Right $ pure b (zoom lens)+ ap lens (Left a) _ = Left a+ ap lens (Right f) (Left a) = Left a+ ap lens (Right f) (Right b) = Right $ ap (zoom lens) f b++-------------------------------------------------------------------------------+-- combinators++infixl 4 <$>+(<$>) :: + ( Functor lens tb+ , b ~ GetParam lens tb+ , ta ~ SetParam lens a tb+ ) => (a -> b) + -> ta+ -> TypeLens Base lens+ -> tb+(f <$> t) lens = fmap lens f t++infixr 0 @@+(@@) :: (TypeLens p q -> b) -> TypeLens p q -> b+(@@) = id++at :: TypeLens q p -> (TypeLens q p -> t) -> t+at lens f = f lens++infixl 4 <*>+(<*>) ::+ ( Applicative lens tb+ , tf ~ SetParam lens (a -> b) tb+ , ta ~ SetParam lens a tb+ , a ~ GetParam lens ta+ , b ~ GetParam lens tb+ ) => (TypeLens Base lens -> tf)+ -> ta+ -> (TypeLens Base lens -> tb)+(<*>) tf ta lens = ap lens (tf lens) ta++infixl 4 <*>-+(tf <*>- ta) lens = (tf <*> ta lens) lens++infixl 4 <*+(u <* v) lens = pure const <*> u <*> v @@ lens++infixl 4 *>+(u *> v) lens = pure (const id) <*> u <*> v @@ lens++infixl 4 <*-+infixl 4 -<*-+infixl 4 -<*+(u <*- v) lens = ( u <* v lens ) lens+(u -<*- v) lens = ( u lens <* v lens ) lens+(u -<* v) lens = ( u lens <* v ) lens++infixl 4 *>-+infixl 4 -*>-+infixl 4 -*>+(u *>- v) lens = ( u *> v lens ) lens+(u -*>- v) lens = ( u lens *> v lens ) lens+(u -*> v) lens = ( u lens *> v ) lens+
src/Data/Params/Functor.hs view
@@ -9,6 +9,8 @@ import Data.Maybe import Data.Params +import GHC.Exts+ ------------------------------------------------------------------------------- class Functor lens tb where@@ -28,6 +30,17 @@ -- Either mkParams ''Either++-- type instance Objective (Param_a p) = Objective_Param_a (Param_a p)+-- type family Objective_Param_a (lens :: * -> Constraint) :: * -> Constraint where+-- Objective_Param_a (Param_a Base) = Param_a Base+-- Objective_Param_a (Param_a p) = Objective p+-- +-- type instance Objective (Param_b p) = Objective_Param_b (Param_b p)+-- type family Objective_Param_b (lens :: * -> Constraint) :: * -> Constraint where+-- Objective_Param_b (Param_b Base) = Param_b Base+-- Objective_Param_b (Param_b p) = Objective p+ instance Functor p b => Functor (Param_b p) (Either a b) where fmap' lens f (Left a) = Left a
typeparams.cabal view
@@ -1,5 +1,5 @@ Name: typeparams-Version: 0.0.3.1+Version: 0.0.4 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:@@ -44,6 +44,7 @@ Exposed-modules: Data.Params+ Data.Params.Applicative Data.Params.Frac Data.Params.PseudoPrim Data.Params.Functor