{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Bookkeeper.Internal where
import GHC.OverloadedLabels
import GHC.Generics (Generic)
import qualified Data.Type.Map as Map
import GHC.TypeLits (Symbol)
import Data.Kind (Type)
import Data.Type.Map (Map, Mapping((:->)))
import Data.Coerce
import Data.Proxy
import Bookkeeper.Errors
type Book a = Book' (Map.AsMap a)
newtype Book' (a :: [Mapping Symbol Type]) = Book { getBook :: Map a }
emptyBook :: Book '[]
emptyBook = Book Map.Empty
-- | An alias for ':->' because otherwise you'll have to tick your
-- constructors.
type a :=> b = a ':-> b
instance Monoid (Book' '[]) where
mempty = emptyBook
_ `mappend` _ = emptyBook
instance (s ~ s') => IsLabel s (Key s') where
fromLabel _ = Key
-- | 'Key' is simply a proxy. You will usually not need to generate it
-- directly, as it is generated by the OverlodadedLabels magic.
data Key (a :: Symbol) = Key
deriving (Eq, Show, Read, Generic)
-- | Get a value by key, if it exists.
--
-- >>> get #age julian
-- 28
--
-- If the key does not exist, throws a type error
-- >>> get #moneyFrom julian
-- ...
-- ... • The provided Book does not contain the field "moneyFrom"
-- ... Book type:
-- ... '["age" ':-> Int, "name" ':-> String]
-- ... • In the expression: get #moneyFrom julian
-- ...
get :: forall field book val. (Map.Submap '[field :=> val] book, Contains book field val)
=> Key field -> Book' book -> val
get _ (Book bk) = case (Map.submap bk :: Map '[field :=> val]) of
Map.Ext _ v Map.Empty -> v
-- | Flipped and infix version of 'get'.
--
-- >>> julian ?: #name
-- "Julian K. Arni"
(?:) :: forall field book val. (Map.Submap '[field :=> val] book, Contains book field val )
=> Book' book -> Key field -> val
(?:) = flip get
infixl 3 ?:
-- | Sets or updates a field to a value.
--
-- >>> let julian' = set #likesDoctest True julian
-- >>> get #likesDoctest julian'
-- True
set :: forall field val old mid1 mid2 new .
( Map.Unionable '[field :=> ChooseFirst val] mid1
, Mappable ChooseFirst old mid1
, Mappable ChooseFirst new mid2
, mid1 ~ (MapThere ChooseFirst old)
, mid2 ~ (Map.Union '[field :=> ChooseFirst val] mid1)
, new ~ MapBack ChooseFirst mid2
)
=> Key field -> val -> Book' old -> Book' new
set _ v (Book bk)
= Book $ mapBack p
$ Map.union new
$ mapThere p bk
where
new = Map.Ext (Map.Var :: Map.Var field) (ChooseFirst v) Map.Empty
p = Proxy :: Proxy ChooseFirst
-- | Infix version of 'set'
--
-- >>> let julian' = julian & #age =: 29
-- >>> get #age julian'
-- 29
(=:) :: forall field val old mid1 mid2 new .
( Map.Unionable '[field :=> ChooseFirst val] mid1
, Mappable ChooseFirst old mid1
, Mappable ChooseFirst new mid2
, mid1 ~ (MapThere ChooseFirst old)
, mid2 ~ (Map.Union '[field :=> ChooseFirst val] mid1)
, new ~ MapBack ChooseFirst mid2
)
=> Key field -> val -> Book' old -> Book' new
(=:) = set
infix 3 =:
-- | Apply a function to a field.
--
-- >>> let julian' = julian & modify #name (fmap toUpper)
-- >>> get #name julian'
-- "JULIAN K. ARNI"
--
-- If the key does not exist, throws a type error
-- >>> modify #height (\_ -> 132) julian
-- ...
-- ... • The provided Book does not contain the field "height"
-- ... Book type:
-- ... '["age" ':-> Int, "name" ':-> String]
-- ... • In the expression: modify #height (\ _ -> 132) julian
-- ...
modify :: forall field val val' old mid1 mid2 new .
( Map.Unionable '[field :=> ChooseFirst val'] mid1
, Mappable ChooseFirst old mid1
, Mappable ChooseFirst new mid2
, (Map.Submap '[field :=> val] old
, Contains old field val )
, mid1 ~ (MapThere ChooseFirst old)
, mid2 ~ (Map.Union '[field :=> ChooseFirst val'] mid1)
, new ~ MapBack ChooseFirst mid2
, Map.AsMap new ~ new
) => Key field -> (val -> val') -> Book' old -> Book new
modify p f b = set p v b
where v = f $ get p b
-- | Infix version of 'modify'.
--
-- >>> let julian' = julian & #name %: fmap toUpper
-- >>> get #name julian'
-- "JULIAN K. ARNI"
(%:) :: forall field val val' old mid1 mid2 new .
( Map.Unionable '[field :=> ChooseFirst val'] mid1
, Mappable ChooseFirst old mid1
, Mappable ChooseFirst new mid2
, (Map.Submap '[field :=> val] old
, Contains old field val )
, mid1 ~ (MapThere ChooseFirst old)
, mid2 ~ (Map.Union '[field :=> ChooseFirst val'] mid1)
, new ~ MapBack ChooseFirst mid2
, Map.AsMap new ~ new
) => Key field -> (val -> val') -> Book' old -> Book new
(%:) = modify
infixr 3 %:
-- | Delete a field from a 'Book', if it exists. If it does not, returns the
-- @Book@ unmodified.
--
-- >>> get #name $ delete #name julian
-- ...
-- ... • The provided Book does not contain the field "name"
-- ... Book type:
-- ... '["age" ':-> Int]
-- ... • In the expression: get #name
-- ...
delete :: forall field old .
( Map.Submap (Map.AsMap (old Map.:\ field)) old
) => Key field -> Book' old -> Book (old Map.:\ field)
delete _ (Book bk) = Book $ Map.submap bk
-- * Mapping
--
-- | In order to be able to establish how maps are to combined, we need to a
-- little song and dance.
type family MapThere (f :: Type -> Type) (map :: [Mapping Symbol Type]) where
MapThere f '[] = '[]
MapThere f ((k :=> a) ': as) = (k :=> f a) ': MapThere f as
type family MapBack f (map :: [Mapping Symbol Type]) where
MapBack f '[] = '[]
MapBack f ((k :=> f a) ': as) = k :=> a ': MapBack f as
class (MapThere f a ~ b, MapBack f b ~ a ) => Mappable f a b | f a -> b, f b -> a where
mapThere :: proxy f -> Map a -> Map b
mapBack :: proxy f -> Map b -> Map a
instance Mappable f '[] '[] where
mapThere _ x = x
mapBack _ x = x
instance (Coercible a (f a), Coercible (f a) a, Mappable f as fas )
=> Mappable f ((k :=> a) ': as) ((k :=> f a) ': fas) where
mapThere p (Map.Ext v k r) = Map.Ext v (coerce k) $ mapThere p r
mapBack p (Map.Ext v k r) = Map.Ext v (coerce k) $ mapBack p r
class MapMap f map where
type MapMapT f map :: [Mapping Symbol Type]
mapMap :: f -> Map map -> Map (MapMapT f map)
instance MapMap f '[] where
type MapMapT f '[] = '[]
mapMap _ m = m
{-# WARNING ChooseFirst "This should not be used" #-}
newtype ChooseFirst a = ChooseFirst { getChooseFirst :: a }
deriving (Eq, Show, Read, Generic)
instance Map.Combinable (ChooseFirst a) (ChooseFirst b) where
combine a _ = a
type instance Map.Combine (ChooseFirst a) (ChooseFirst b) = ChooseFirst a
-- $setup
-- >>> import Data.Function ((&))
-- >>> import Data.Char (toUpper)
-- >>> type Person = Book '[ "name" :=> String , "age" :=> Int ]
-- >>> let julian :: Person = emptyBook & #age =: 28 & #name =: "Julian K. Arni"