Records/DeclaredOverloadedRecordFields/ImplementorsView: DORF Prototype ADC5 15Feb2012.lhs

> {-# 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