{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Records.Generic.Subtype -- Copyright : (C) 2017 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental -- Portability : non-portable -- -- Structural subtyping -- ----------------------------------------------------------------------------- module Records.Generic.Subtype ( Subtype (..) ) where import Records.Generic.HasField import Records.Generic.Lens import Data.Kind (Type) import GHC.Generics -- |Structural subtype relationship -- -- @ -- -- module Test where -- -- import GHC.Generics -- import Record.Generic -- -- data Human = Human -- { name :: String -- , age :: Int -- , address :: String -- } deriving (Generic, Show) -- -- data Animal = Animal -- { name :: String -- , age :: Int -- } deriving (Generic, Show) -- -- human :: Human -- human = Human \"Tunyasz\" 50 \"London\" -- -- @ -- -- -- >>> human -- Human {name = "Tunyasz", age = 50, address = "London"} -- -- >>> upcast human :: Animal -- Animal {name = "Tunyasz", age = 50} -- class Subtype sub sup where -- | Cast the more specific subtype to the more general supertype upcast :: sub -> sup -- | Instances are created by the compiler instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where upcast = to . convert . from -- | Convert 'rep' into 'f' class Convert (rep :: Type -> Type) (f :: Type -> Type) where convert :: rep p -> f p instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where convert rep = convert rep :*: convert rep instance {-# OVERLAPPING #-} GHasField field rep t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where convert rep = M1 (K1 (rep ^. glabel @field)) instance Convert rep f => Convert rep (M1 i c f) where convert = M1 . convert