conversion.hs

import GHC.Generics
import Data.Kind
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HMS
import qualified Data.Map.Strict as Map
import Data.Hashable (Hashable)

type family WebApiType a :: *

class ToWebApi a where
  toWebApi :: a -> WebApiType a
  default toWebApi :: (Generic a, Generic (WebApiType a), GToWebApi (Rep a) (Rep (WebApiType a))) => a -> WebApiType a
  toWebApi x = to (gtoWebApi (from x))

class GToWebApi f g where
  gtoWebApi :: f p -> g p

instance GToWebApi V1 V1 where
  gtoWebApi = \case {}

instance GToWebApi U1 U1 where
  gtoWebApi U1 = U1

instance (GToWebApi f f', GToWebApi g g') => GToWebApi (f :+: g) (f' :+: g') where
  gtoWebApi = \case
    L1 x -> L1 (gtoWebApi x)
    R1 x -> R1 (gtoWebApi x)

instance (GToWebApi f f', GToWebApi g g') => GToWebApi (f :*: g) (f' :*: g') where
  gtoWebApi (x :*: y) = gtoWebApi x :*: gtoWebApi y

instance (ToWebApi a, WebApiType a ~ b) => GToWebApi (K1 i a) (K1 i b) where
  gtoWebApi (K1 x) = K1 (toWebApi x)

type family ToWebApiMeta (m :: Meta) (m' :: Meta) :: Constraint where
  -- we do not care about the datatype name, just about its structure. for example
  -- we want to match ScanBody7 with ScanBody
  ToWebApiMeta ('MetaData n m p nt) ('MetaData n' m' p' nt') = (nt ~ nt')
  ToWebApiMeta ('MetaCons n f s) ('MetaCons n' f' s') = (n ~ n, f ~ f', s ~ s')
  ToWebApiMeta ('MetaSel mn su ss ds) ('MetaSel mn' su' ss' ds') = (mn ~ mn')

instance (i ~ i', ToWebApiMeta m m', GToWebApi f f') => GToWebApi (M1 i m f) (M1 i' m' f') where
  gtoWebApi (M1 x) = M1 (gtoWebApi x)

class FromWebApi a where
  fromWebApi :: WebApiType a -> Either String a
  default fromWebApi :: (Generic a, Generic (WebApiType a), GFromWebApi (Rep a) (Rep (WebApiType a))) => WebApiType a -> Either String a
  fromWebApi x = to <$> gfromWebApi (from x)

class GFromWebApi f g where
  gfromWebApi :: g p -> Either String (f p)

instance GFromWebApi V1 V1 where
  gfromWebApi = \case {}

instance GFromWebApi U1 U1 where
  gfromWebApi U1 = return U1

instance (GFromWebApi f f', GFromWebApi g g') => GFromWebApi (f :+: g) (f' :+: g') where
  gfromWebApi = \case
    L1 x -> L1 <$> gfromWebApi x
    R1 x -> R1 <$> gfromWebApi x

instance (GFromWebApi f f', GFromWebApi g g') => GFromWebApi (f :*: g) (f' :*: g') where
  gfromWebApi (x :*: y) = (:*:) <$> gfromWebApi x <*> gfromWebApi y

instance (FromWebApi a, WebApiType a ~ b) => GFromWebApi (K1 i a) (K1 i b) where
  gfromWebApi (K1 x) = K1 <$> fromWebApi x

instance (i ~ i', ToWebApiMeta m m', GFromWebApi f f') => GFromWebApi (M1 i m f) (M1 i' m' f') where
  gfromWebApi (M1 x) = M1 <$> gfromWebApi x

-- a few instances
-- --------------------------------------------------------------------

type instance WebApiType [a] = [WebApiType a]
instance ToWebApi a => ToWebApi [a] where
  toWebApi = map toWebApi
instance FromWebApi a => FromWebApi [a] where
  fromWebApi = traverse fromWebApi

type instance WebApiType (V.Vector a) = V.Vector (WebApiType a)
instance ToWebApi a => ToWebApi (V.Vector a) where
  toWebApi = fmap toWebApi
instance FromWebApi a => FromWebApi (V.Vector a) where
  fromWebApi = traverse fromWebApi

type instance WebApiType (HMS.HashMap k v) = HMS.HashMap (WebApiType k) (WebApiType v)
instance (Eq k, Hashable k, Eq (WebApiType k), Hashable (WebApiType k), ToWebApi k, ToWebApi v) => ToWebApi (HMS.HashMap k v) where
  toWebApi = HMS.fromList . map (\(k, v) -> (toWebApi k, toWebApi v)) . HMS.toList
instance (Eq k, Hashable k, Eq (WebApiType k), Hashable (WebApiType k), FromWebApi k, FromWebApi v) => FromWebApi (HMS.HashMap k v) where
  fromWebApi = fmap HMS.fromList . traverse (\(k, v) -> (,) <$> fromWebApi k <*> fromWebApi v) . HMS.toList

type instance WebApiType (Map.Map k v) = Map.Map (WebApiType k) (WebApiType v)
instance (Ord k, Ord (WebApiType k), ToWebApi k, ToWebApi v) => ToWebApi (Map.Map k v) where
  toWebApi = Map.fromList . map (\(k, v) -> (toWebApi k, toWebApi v)) . Map.toList
instance (Ord k, Ord (WebApiType k), FromWebApi k, FromWebApi v) => FromWebApi (Map.Map k v) where
  fromWebApi = fmap Map.fromList . traverse (\(k, v) -> (,) <$> fromWebApi k <*> fromWebApi v) . Map.toList

type instance WebApiType (Maybe a) = Maybe (WebApiType a)
instance ToWebApi a => ToWebApi (Maybe a) where
  toWebApi = fmap toWebApi
instance FromWebApi a => FromWebApi (Maybe a) where
fromWebApi = traverse fromWebApi