module Data.Generics.Record.Subtype (
(:<:),
genSubtype,
isSubtype,
upcast) where
import Data.Data
import Data.List
import Data.Function
import Control.Monad
import Data.Map ((!))
import qualified Data.Map as M
import Data.Maybe
import Data.Generics.Record.Reify
import Data.Generics.Record
newtype a :<: b = SubWit {unSubWit :: [(String, String)]}
genSubtype :: forall a b. (Data a, Data b) => RecordT a -> RecordT b -> Maybe (a :<: b)
genSubtype ra rb = (SubWit . fst) `fmap` foldM findMatch ([], recordStructure ra) (recordStructure rb)
where findMatch (matches, remaining) (t, n) = do
n' <- lookup t remaining
return ((n', n) : matches, deleteBy ((==) `on` fst) (t, "") remaining)
isSubtype :: forall a b. (Data a, Data b) => RecordT a -> RecordT b -> Bool
isSubtype ra rb = isJust $ genSubtype ra rb
upcast :: forall a b. (Data a, Data b) => a :<: b -> a -> b
upcast (SubWit fs) = fromJust
. reflect
. flip (foldl' updater) fs
. M.filterWithKey (\ k a -> isJust . flip lookup fs $ k)
. fromJust
. reifyMay
where updater m (na, nb) = M.insert nb (m ! na) $ M.delete na m