module Data.Params
(
Config (..)
, mkParams
, with1Param
, with1ParamAutomatic
, apWith1Param
, apWith2Param
, apWith3Param
, apWith1Param'
, apWith2Param'
, apWith3Param'
, mkWith1Param
, mkApWith1Param
, mkApWith2Param
, mkApWith3Param
, HasDictionary (..)
, ViewParam (..)
, ParamDict (..)
, ParamIndex
, RunTimeToAutomatic (..)
, StaticToAutomatic (..)
, ApplyConstraint
, TypeLens (..)
, GetParam
, SetParam
, Base
, _base
, zoom
, Zoom
, EyePiece
, ApplyConstraint_GetType
, ApplyConstraint_GetConstraint
, coerceParamDict
, mkRuleFrac
, intparam
, floatparam
, Float (..)
, 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
, ReifiableConstraint(..)
, ConstraintLift (..)
, 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)
intparam :: forall n. KnownNat n => Proxy (n::Nat) -> Int
intparam _ = fromIntegral $ natVal (Proxy::Proxy n)
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
]
data Config a
= Static a
| RunTime
| Automatic
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
data TypeLens (a:: * -> Constraint) (b:: * -> Constraint) = TypeLens
instance Category TypeLens where
id = TypeLens
a.b = TypeLens
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:: *) :: k3
type family SetParam (p::k1) (a::k2) (t:: *) :: *
type family Zoom (p :: k1) :: k2
type family EyePiece (p :: k1) :: k2
zoom :: TypeLens a p -> TypeLens a (Zoom p)
zoom lens = TypeLens
class Base a
_base :: TypeLens Base Base
_base = TypeLens
type instance GetParam Base t = t
type instance SetParam Base (c :: *) t = c
type ParamIndex p =
( ReifiableConstraint (ApplyConstraint_GetConstraint p)
, HasDictionary p
)
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
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
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
, mkTypeFamilies_Common paramstr 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
, mkTypeFamilies_Common paramstr dataname
, mkTypeFamilies_Star paramstr dataname
]
return $ []
++ (concat $ concat $ configparams)
++ (concat $ concat $ starparams)
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"
"Symbol" -> "String"
str -> error $ "mkParams does not currently support custom type "++str
kind2type x = error $ "kind2type on x="++show x
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"
"Symbol" -> "symbolVal"
kind2convert :: Type -> Name
kind2convert (AppT _ t) = kind2convert t
kind2convert (ConT n) = mkName $ case nameBase n of
"Nat" -> "id"
"Frac" -> "id"
"Symbol" -> "id"
_ -> "id"
param2class :: Name -> Name
param2class p = mkName $ "Param_" ++ nameBase p
param2func :: Name -> Name
param2func p = mkName $ "getParam_" ++ nameBase p
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))
mkTypeFamilies_Common :: String -> Name -> Q [Dec]
mkTypeFamilies_Common paramstr dataName = do
info <- TH.reify dataName
let tyVarBndrL = case info of
TyConI (NewtypeD _ _ xs _ _) -> xs
TyConI (DataD _ _ xs _ _ ) -> xs
FamilyI (FamilyD _ _ xs _) _ -> xs
let getters =
[ TySynInstD
( mkName "GetParam" )
( TySynEqn
[ ConT $ mkName $ "Param_" ++paramstr
, applyTyVarBndrL dataName tyVarBndrL
]
( VarT $ mkName $ paramstr
)
)
]
let setters =
[ TySynInstD
( mkName "SetParam" )
( TySynEqn
[ ConT $ mkName $ "Param_" ++paramstr
, VarT $ mkName $ "newparam"
, applyTyVarBndrL dataName tyVarBndrL
]
( applyTyVarBndrL dataName $ map
(\a -> if tyVarBndr2str a==paramstr
then PlainTV $ mkName "newparam"
else a
)
tyVarBndrL
)
)
]
return $ getters++setters
mkTypeFamilies_Star :: String -> Name -> Q [Dec]
mkTypeFamilies_Star paramstr dataName = do
info <- TH.reify dataName
let tyVarBndrL = case info of
TyConI (NewtypeD _ _ xs _ _) -> xs
TyConI (DataD _ _ xs _ _ ) -> xs
FamilyI (FamilyD _ _ xs _) _ -> xs
let zooms =
[ TySynInstD
( mkName "Zoom" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]
( VarT $ mkName "p" )
)
, TySynInstD
( mkName "EyePiece" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p") ]
( ConT $ mkName $ "Param_"++paramstr )
)
]
let getters =
[ TySynInstD
( mkName "GetParam" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_"++paramstr ) (VarT $ mkName "p")
, applyTyVarBndrL dataName tyVarBndrL
]
( AppT
( AppT
( ConT $ mkName "GetParam")
( VarT $ mkName "p")
)
( VarT $ mkName paramstr )
)
)
]
let setters =
[ TySynInstD
( mkName "SetParam" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_"++paramstr) (VarT $ mkName "p")
, VarT $ mkName $ "newparam"
, VarT $ mkName "t"
]
( AppT
( AppT
( AppT
( ConT $ mkName "SetParam" )
( ConT $ mkName $ "Param_"++paramstr)
)
( AppT
( AppT
( AppT
( ConT $ mkName "SetParam" )
( VarT $ mkName "p" )
)
( VarT $ mkName "newparam" )
)
( AppT
( AppT
( ConT $ mkName "GetParam" )
( ConT $ mkName $ "Param_"++paramstr )
)
( VarT $ mkName "t" )
)
)
)
( VarT $ mkName "t" )
)
)
]
return $ zooms++getters++setters
mkGettersSetters :: Name -> Q [Dec]
mkGettersSetters dataName = do
info <- TH.reify dataName
let tyVarBndrL = case info of
TyConI (NewtypeD _ _ xs _ _) -> xs
TyConI (DataD _ _ xs _ _ ) -> xs
FamilyI (FamilyD _ _ xs _) _ -> xs
let zooms =
[ TySynInstD
( mkName "Zoom" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_"++tyVarBndr2str x) (VarT $ mkName "p") ]
( VarT $ mkName "p" )
)
| x <- tyVarBndrL
]
++
[ TySynInstD
( mkName "EyePiece" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_"++tyVarBndr2str x) (VarT $ mkName "p") ]
( ConT $ mkName $ "Param_"++tyVarBndr2str x )
)
| x <- tyVarBndrL
]
let getters =
[ TySynInstD
( mkName "GetParam" )
( TySynEqn
[ ConT $ mkName $ "Param_" ++ tyVarBndr2str x
, applyTyVarBndrL dataName tyVarBndrL
]
( VarT $ mkName $ tyVarBndr2str x
)
)
| x <- tyVarBndrL
]
++
[ TySynInstD
( mkName "GetParam" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_" ++ tyVarBndr2str x) (VarT $ mkName "p")
, applyTyVarBndrL dataName tyVarBndrL
]
( AppT
( AppT
( ConT $ mkName "GetParam")
( VarT $ mkName "p")
)
( VarT $ mkName $ tyVarBndr2str x)
)
)
| x <- tyVarBndrL
]
let setters =
[ TySynInstD
( 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
]
++
[ TySynInstD
( mkName "SetParam" )
( TySynEqn
[ AppT (ConT $ mkName $ "Param_" ++ tyVarBndr2str x) (VarT $ mkName "p")
, VarT $ mkName $ "newparam"
, VarT $ mkName "t"
]
( AppT
( AppT
( AppT
( ConT $ mkName "SetParam" )
( ConT $ mkName $ "Param_" ++ tyVarBndr2str x)
)
( AppT
( AppT
( AppT
( ConT $ mkName "SetParam" )
( VarT $ mkName "p" )
)
( VarT $ mkName "newparam" )
)
( AppT
( AppT
( ConT $ mkName "GetParam" )
( ConT $ mkName $ "Param_" ++ tyVarBndr2str x )
)
( VarT $ mkName "t" )
)
)
)
( VarT $ mkName "t" )
)
)
| x <- tyVarBndrL
]
return $ zooms++getters++setters
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)
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
]
[ ]
[ ]
]
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" )
)
[ ]
]
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" )
)
[ ]
]
class Param_Dummy t
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
]
]
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
]
]
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 )
)
)
]
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 )
)
]
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
]
]
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
]
]
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)
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
mkReifiableConstraint' :: String -> [Dec] -> Q [Dec]
mkReifiableConstraint' paramstr funcL = do
let paramname = mkName $ "Param_"++paramstr
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