> {-# OPTIONS_GHC -XDisambiguateRecordFields -XNamedFieldPuns -XRecordWildCards #-} > {-# OPTIONS_GHC -XTypeFamilies -XFlexibleContexts #-} > {-# OPTIONS_GHC -XRankNTypes -XImpredicativeTypes -XGADTs -XEmptyDataDecls #-} > {-# OPTIONS_GHC -XMultiParamTypeClasses -XFlexibleInstances -XUndecidableInstances #-} > module DORF where > > import HRrev_ -- SPJ's example of a higher-ranked data type -- imported so that we have clashing declarations of `rev' -- see below --------------- The Has class, methods get and set ----------------------------------------- here's the mechanism -- declarations for Has/get/set, and type families > class Has r fld t where > get :: r -> fld -> GetResult r fld t -- result is t in the simple cases > set :: (Has (SetResult r fld t) fld t) => fld -> t -> r -> SetResult r fld t -- result is r in the simple cases > -- set :: fld -> t -> r -> SetResult r fld t -- result is r in the simple cases > > type family GetResult r fld t :: * -- type of t get from r at fld, or to set in set's result > type family SetResult r fld t :: * -- type of r updated with t Using type family rather than associated type, because: * often the same GetResult for a given fld (all records) -- such as non-changeable fields, see next * often the same SetResult for a given record (all fields) -- such as non-changeable records ------------------ fieldLabel decls (for 'monomorphic' fields) ------------------------------------- fieldLabel customer_id :: r -> Int > data Proxy_customer_id > -- customer_id :: (Has r Proxy_customer_id t, t ~ Int) => r -> t -- GHC can't infer this > -- customer_id :: (Has r Proxy_customer_id t) => r -> Int -- type inferred, but can't verify > customer_id r = get r (undefined :: Proxy_customer_id) > > type instance GetResult r Proxy_customer_id t = Int -- customer_id always an Int, for all record types > > -- ?? type instance SetResult r Proxy_customer_id t = r -- changing customer_id doesn't change the record type > fieldLabel firstName :: r -> String > data Proxy_firstName > -- firstName :: (Has r Proxy_firstName t, t ~ String) => r -> String > firstName r = get r (undefined :: Proxy_firstName) > > type instance GetResult r Proxy_firstName t = String -- firstName always a String, for all record types > fieldLabel lastName :: r -> String > data Proxy_lastName > -- lastName :: (Has r Proxy_lastName t, t ~ String) => r -> String > lastName r = get r (undefined :: Proxy_lastName) > > type instance GetResult r Proxy_lastName t = String -- firstName always a String, for all record types ------------------Virtual field definition (note no Has instance needed, so no need to worry about set) ---- > fullName r = firstName r ++ " " ++ lastName r -- per SPJ, avoiding dot notation fullName :: (Has r Proxy_firstName t1, Has r Proxy_lastName t2) => r -> String -- inferred from def'n -- but GHC can't validate <===> :: r{ firstName, lastName :: String } => r -> String ------------------Record decl, and Has instance generated (for 'monomorphic' fields)---------------------------- > data Customer_NameAddress = Cust_NA { customer_id_ :: Int, firstName_, lastName_ :: String } > deriving (Eq, Show, Read) > -- suffixing the field name to avoid clash > > type instance SetResult Customer_NameAddress fld t = Customer_NameAddress > -- Customer_NameAddress has no type params > > -- note: GetResult type instances already decl'd, by field > > instance (t ~ Int) => Has Customer_NameAddress Proxy_customer_id t where > get Cust_NA{customer_id_} _ = customer_id_ > set _ x Cust_NA{..} = Cust_NA{customer_id_ = x, .. } > > instance (t ~ String) => Has Customer_NameAddress Proxy_firstName t where > get Cust_NA{firstName_} _ = firstName_ > set _ x Cust_NA{..} = Cust_NA{firstName_ = x, .. } > > instance (t ~ String) => Has Customer_NameAddress Proxy_lastName t where > get Cust_NA{lastName_} _ = lastName_ > set _ x Cust_NA{..} = Cust_NA{lastName_ = x, .. } ------------------fieldLabel and Record decl for changeable (constrained) field ------------------------------- fieldLabel unitPrice :: Num t => r -> t -- t is constrained/changeable > data Proxy_unitPrice > -- unitPrice :: (Has r Proxy_unitPrice t, Num t) => r -> t > unitPrice r = get r (undefined :: Proxy_unitPrice) > > -- Note: no type instance for GetResult because may vary per record type > > data Customer_Price a = Num a => Cust_Price { customer_id__ :: Int, > product_id__ :: Int, > unitPrice_ :: a } -- polymorphic (constrained) > > instance (t ~ Int) => Has (Customer_Price a) Proxy_customer_id t where > get Cust_Price{customer_id__} _ = customer_id__ > set _ x Cust_Price{..} = Cust_Price{customer_id__ = x, .. } > > type instance SetResult (Customer_Price a) Proxy_customer_id t = Customer_Price a > > > type instance GetResult (Customer_Price a) Proxy_unitPrice t = a -- field's type is whatever's there > type instance SetResult (Customer_Price _a) Proxy_unitPrice t = Customer_Price t -- updating record type per arg to set > > instance (Num t) => Has (Customer_Price a) Proxy_unitPrice t where > get Cust_Price{unitPrice_} _ = unitPrice_ > set _ x Cust_Price{..} = Cust_Price{ unitPrice_ = x, .. } > > > > rCP0 = Cust_Price{ customer_id__ = 27, product_id__ = 54321, unitPrice_ = (92 :: Num a => a) } > -- ?? but GHCi :: Integer > rCP1 = set (undefined :: Proxy_unitPrice) (131.7) rCP0 > -- ?? but GHCi :: Double > up1 = unitPrice rCP1 -- ==> 131.7 :: Double > > rCN0 = Cust_NA{ customer_id_ = 35, firstName_ = "John", lastName_ = "Smith" } > ---------------------- HR: Higher-ranked type, per SPJ ------------------------------ > -- import HRrev_ > {- data HR = HR {rev_ :: forall a_. [a_] -> [a_]} -} fieldLabel rev :: r -> (forall a_. [a_] -> [a_]) > data Proxy_rev -- phantom, same role as SPJ's String Kind "rev" > rev :: Has r Proxy_rev t => r -> t -- is type inferred > rev r = get r (undefined :: Proxy_rev) > type instance GetResult r Proxy_rev t = t -- field's type is whatever's there (it's opaque) > type instance SetResult HR Proxy_rev t = HR -- the H-R type is hidded inside HR > instance (t ~ ([a_] -> [a_])) => Has HR Proxy_rev t where > get HR{rev_} _ = rev_ > -- set _ fn HR{..} = HR{ rev_ = fn, ..} > -- set = setHRrev -- can't match the forall > > setHRrev :: fld -> (forall a_. [a_] -> [a_]) -> HR -> HR > setHRrev _fld fn HR{..} = HR{ rev_ = fn, ..} > > > testrev r = (rev r [True, False, False], rev r "hello") > > rHR0 = HR{} -- field `rev_' is undefined, to show we can update it > rHR1 = setHRrev (undefined :: Proxy_rev) reverse rHR0 -- equivalent to rHR0{rev = reverse} > -- testrev rHR1 ==> ([False,False,True],"olleh") > rHR2 = setHRrev (undefined :: Proxy_rev) (drop 1 . reverse) rHR1 > -- testrev rHR2 ==> ([False,True],"lleh") ---------------------- type Tab -- more complex example, including clash of field rev_ ------------------------------ > data Tab a b where -- a different data type with a HR field `rev' > Ta :: {tag_ :: String, rev_ :: forall a_.([a_] -> [a_]), flda_ :: a } > -> Tab a b > Tb :: (Num n, Show b) => {tag_ :: String, fldn_ :: n, fldnb_ :: n -> b} > -> Tab a b > -- Existential fields (GADT syntax) fieldLabel tag :: r -> String > data Proxy_tag > tag r = get r (undefined :: Proxy_tag) > type instance GetResult r Proxy_tag t = String > instance (t ~ String) => Has (Tab a b) Proxy_tag t where > get Ta{tag_} _ = tag_ > get Tb{tag_} _ = tag_ > set _ x Ta{..} = Ta{tag_ = x, ..} > set _ x Tb{..} = Tb{tag_ = x, ..} > > type instance SetResult (Tab a b) Proxy_tag t = Tab a b > instance (t ~ ([a_]->[a_])) => Has (Tab a b) Proxy_rev t where > get Ta{rev_} _ = rev_ > -- set _ fn Ta{..} = Ta{rev_ = fn, ..} > > type instance SetResult (Tab a b) Proxy_rev t = Tab a b -- the H-R type is hidded inside Tab fieldLabel flda :: r -> t > data Proxy_flda -- `flda's type is a parameter to data type (Tab a b) > flda r = get r (undefined :: Proxy_flda) > instance Has (Tab a b) Proxy_flda t where -- note constraint on `t', > -- might be different to `a' for update > get Ta{flda_} _ = flda_ > set _ x Ta{..} = Ta{flda_ = x, ..} > > type instance GetResult (Tab a b) Proxy_flda t = a -- result is what comes from Tab > type instance SetResult (Tab a b) Proxy_flda t = Tab t b -- type to set is whatever we're given > > setTabrev :: fld -> (forall a_. [a_] -> [a_]) -> Tab a b -> Tab a b > setTabrev _fld fn Ta{..} = Ta{ rev_ = fn, ..} > > rTab0 = Ta{tag_ = "tagged"} -- `rev_' is undefined > rTab1 = setTabrev (undefined :: Proxy_rev) reverse rTab0 > -- testrev rTab1 ==> ([False,False,True],"olleh") > rTab2 = set (undefined :: Proxy_flda) 'a' (setTabrev (undefined :: Proxy_rev) (reverse . take 3) rTab1) > -- rTab1 :: Tab a b ; rTab2 :: Tab Char b > -- testrev rTab2 ==> ([False,False,True],"leh") fieldLabel fldn :: r -> t fieldLabel fldnb :: r -> t > data Proxy_fldn -- } the Existential fields must be set together > data Proxy_fldnb -- } possible approach for multiple update > fldn r = get r (undefined :: Proxy_fldn) > fldnb r = get r (undefined :: Proxy_fldnb) > -- no point in a 'getter' function: the types would escape ------------------------ get/set 2 fields at the same time ---------------------------- possible approach for r{ fldn = ..., fldnb = ... } > instance (t ~ (tn, tn -> b'), Show b', Num tn) > -- needs -XUndecidableInstances > => Has (Tab a b) (Proxy_fldn, Proxy_fldnb) t where > -- get Tb{fldn_, fldnb_} _ = (fldn_, fldnb_) -- No! types would escape > get Tb{fldn_, fldnb_} _ = fldnb_ fldn_ -- all we can do is apply > set _ (n, nb) Tb{..} = Tb{fldn_ = n, fldnb_ = nb, ..} > -- the use case is: r{fldn = n, fldnb = nb} > > type instance GetResult (Tab a b) (Proxy_fldn, Proxy_fldnb) t = b > type instance SetResult (Tab a b) (Proxy_fldn, Proxy_fldnb) (tn, tn -> b') = Tab a b' > > nb' Tb{fldn_, fldnb_} = fldnb_ fldn_ -- test rig > -- nb' r = get r (undefined :: (Proxy_fldn, Proxy_fldnb)) -- ambiguous typevar in (Show b') constraint > -- deriving from use of get > rTab3 = Tb{tag_ = "tagged", fldn_ = 6 :: Double, fldnb_ = negate} > -- nb' rTab3 ==> -6.0 :: Double > rTab4 = set (undefined :: (Proxy_fldn, Proxy_fldnb)) (5::Int, (6 +)) rTab3 > -- rTab3{fldn = 5, fldnb = (6 +)} > -- nb' rTab4 ==> 11 :: Int