guarantee: Map k v -> Maybe (k -> v)

guaranteed.hs

-- | Generic transformation for map to a total function 'key' -> 'value.
--
-- It fails if the given 'Data.Map.Strict' does not contains all the options
-- for the given 'key'.
--
-- The 'key' is expected to be a unary coproduct with an Ord instance.
class GGuaranteed gEnum where
  gguarantee :: Map (gEnum key) value
             -> Either (gEnum key) (gEnum key -> value)

type GGuaranteedNoInstance =
    'Text "guarantee only works for unary coproducts keys e.g. data A = A | B | C"
    ':$$: 'Text "Maybe you are missing the Generic Ord instance for your key."

instance GGuaranteed U1 where
  gguarantee m
    | null m  = Left U1
    | otherwise = Right (const (m Map.! U1))
  {-# INLINE gguarantee #-}

-- Constants, additional parameters and recursion of kind
instance (GHC.TypeLits.TypeError GGuaranteedNoInstance) => GGuaranteed (K1 _t _c) where
  gguarantee = P.error "K1"
  {-# INLINE gguarantee #-}
-- Void: used for datatypes without constructors
instance (GHC.TypeLits.TypeError GGuaranteedNoInstance) => GGuaranteed V1 where
  gguarantee = P.error "V1"
  {-# INLINE gguarantee #-}

type GOrd k = forall x. (Ord (k x))

instance ( GOrd a
         , GOrd b
         , GGuaranteed a
         , GGuaranteed b
         ) => GGuaranteed (a :+: b)
  where
    gguarantee mapAB = do
      let (mapA, mapB) = discriminateByKey splitCase mapAB
      fA <- first L1 $ gguarantee mapA
      fB <- first R1 $ gguarantee mapB
      let f (L1 x) = fA x
          f (R1 x) = fB x
      return f
        where
          splitCase (L1 a) = Left a
          splitCase (R1 b) = Right b
    {-# INLINE gguarantee #-}

instance ( GHC.TypeLits.TypeError GGuaranteedNoInstance ) => GGuaranteed (a :*: b) where
  gguarantee = P.error ":*:"
  {-# INLINE gguarantee #-}

instance ( GHC.TypeLits.TypeError GGuaranteedNoInstance
         )
         => GGuaranteed (M1 S _meta a)
  where
    gguarantee = P.error "S1"
    {-# INLINE gguarantee #-}

instance {-# INCOHERENT #-}
         ( GOrd a
         , GGuaranteed a
         )
         => GGuaranteed (M1 _type _meta a)
  where
    gguarantee mapM1 = do
      let unwrapped = Map.fromList
                        $ over (traversed . _1) unM1
                        $ Map.toList mapM1
      f <- first M1 $ gguarantee unwrapped
      return (\(M1 a) -> f a)
    {-# INLINE gguarantee #-}

-------------------------------

-- | Feel free to use this generic on other functions
type Guaranteed enum = ( Generic enum
                       , Ord ((Rep enum) ())
                       , GGuaranteed (Rep enum)
                       )

-- | Transform a 'Data.Map k v' to a function 'Either [k] (k -> v)'.
-- Returns 'Right' if the map contains all the values of the given 'k'.
-- Otherwise 'Left' with the missing keys.
--
-- nb. 'k' must be a coproduct of unitary data constructors.
--
-- >>> data TranslationKey = EN | ES deriving (Show, Eq, Ord, Generic)
-- >>> let translation = Map.fromList [(EN, "hello"), (ES, "hola")]
-- >>> let Right translate = guarantee translation
-- >>> translate EN
-- "hello"
-- >>> translate ES
-- "hola"
--
-- >>> let oops = Map.fromList [(EN, "hello")]
-- >>> guarantee oops
-- Left [ES]
guarantee
  :: forall enum v. Guaranteed enum
  => Map enum v
  -> Either enum (enum -> v)
guarantee m = case gguarantee (Map.mapKeys toGeneric' m) of
  Left  e -> Left (fromGeneric e)
  Right f -> Right (f . toGeneric)
{-# INLINE guarantee #-}

guaranteedSpec.hs

data Enum = A | B | C
  deriving ( Eq, Ord
           , Generic
           )

data AProduct = AProduct Int Int
  deriving ( Eq, Ord
           , Generic
           )

data ARecord = ARecord
  { field :: Int }
  deriving ( Eq, Ord
           , Generic
           )

data AARecord = AARecord
  { field1 :: Int
  , field2 :: Int
  } deriving ( Eq, Ord
             , Generic
             )

spec :: Spec
spec = describe "XCO Prelude Library" $ do
  it "should success when all keys are present" $ do
    let Right f = X.guarantee $ Map.fromList [(A, 1), (B, 2), (C, 3)]
    f A `shouldBe` 1
    f B `shouldBe` 2
    f C `shouldBe` 3
  it "should fail if a coproduct choice is missing" $ do
    let oops = Map.fromList [(A, 1::Int), (B, 2)]
    case X.guarantee oops of
      Left _ -> return ()
      Right _ -> expectationFailure "guarantee on missing keys should have failed."

  -- TODO test that the resolving an instance for those types fails.
  -- For now, do it manually.
  it "should not resolve an instance for anything that is not a unary coproduct" $ do
    --let Right f = X.guarantee $ Map.fromList [(AProduct 0 0, 1), (AProduct 0 1, 2)]
    --let Right f = X.guarantee $ Map.fromList [(ARecord 0, 1), (ARecord 1, 2)]
    --let Right f = X.guarantee $ Map.fromList [(AARecord 0 0, 1), (AARecord 0 1, 2)]
    True