Generic.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

#if __GLASGOW_HASKELL__ < 709
{-# LANGUAGE OverlappingInstances       #-}
#define OVERLAP
#else
#define OVERLAP {-# OVERLAPPABLE #-}
#endif
-- |
-- Module      :  Pinch.Internal.Generic
-- Copyright   :  (c) Abhinav Gupta 2015
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- Implements support for automatically deriving Pinchable instances for types
-- that implement @Generic@ and follow a specific pattern.
--
module Pinch.Internal.Generic
    ( Field(..)
    , getField
    , putField
    , field

    , Enumeration(..)
    , enum

    , Void(..)
    ) where


#if __GLASGOW_HASKELL__ < 709
import Data.Foldable    (Foldable)
import Data.Monoid      (Monoid)
import Data.Traversable (Traversable)
#endif

import Control.Applicative
import Control.DeepSeq     (NFData)
import Data.Proxy          (Proxy (..))
import Data.Typeable       (Typeable)
import GHC.Generics
import GHC.TypeLits

import qualified Data.HashMap.Strict as HM

import Pinch.Internal.Pinchable
import Pinch.Internal.TType
import Pinch.Internal.Value     (Value (..))


-- | Implemented by TType tags whose values know how to combine.
class Combinable t where
    combine :: Value t -> Value t -> Value t

instance Combinable TStruct where
    combine (VStruct as) (VStruct bs) = VStruct $ as `HM.union` bs


instance OVERLAP GPinchable a => GPinchable (M1 i c a) where
    type GTag (M1 i c a) = GTag a
    gPinch = gPinch . unM1
    gUnpinch = fmap M1 . gUnpinch


-- Adds the name of the data type to the error message.
instance (Datatype d, GPinchable a) => GPinchable (D1 d a) where
    type GTag (D1 d a) = GTag a
    gPinch = gPinch . unM1
    gUnpinch v = case gUnpinch v of
        Left msg -> Left $ "Failed to read '" ++ name ++ "': " ++ msg
        Right a -> Right $ M1 a
      where
        name = datatypeName (undefined :: D1 d a b)

instance
  ( GPinchable a
  , GPinchable b
  , GTag a ~ GTag b
  , Combinable (GTag a)
  ) => GPinchable (a :*: b) where
    type GTag (a :*: b) = GTag a
    gPinch (a :*: b) = gPinch a `combine` gPinch b
    gUnpinch m = (:*:) <$> gUnpinch m <*> gUnpinch m

instance
  ( GPinchable a
  , GPinchable b
  , GTag a ~ GTag b
  ) => GPinchable (a :+: b) where
    type GTag (a :+: b) = GTag a
    gPinch (L1 a) = gPinch a
    gPinch (R1 b) = gPinch b
    gUnpinch m = L1 <$> gUnpinch m <|> R1 <$> gUnpinch m

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

-- | Fields of data types that represent structs, unions, and exceptions
-- should be wrapped inside 'Field' and tagged with the field identifier.
--
-- > data Foo = Foo (Field 1 Text) (Field 2 (Maybe Int32)) deriving Generic
-- > instance Pinchable Foo
--
-- > data A = A (Field 1 Int32) | B (Field 2 Text) deriving Generic
-- > instance Pinchable Foo
--
-- Fields which hold @Maybe@ values are treated as optional. All fields values
-- must be 'Pinchable' to automatically derive a @Pinchable@ instance for the
-- new data type.
newtype Field (n :: Nat) a = Field a
  deriving
    (Bounded, Eq, Enum, Foldable, Functor, Generic, Monoid, NFData, Ord, Show,
     Traversable, Typeable)

-- | Gets the current value of a field.
--
-- > let Foo a' _ = {- ... -}
-- >     a = getField a'
getField :: Field n a -> a
getField (Field a) = a

-- | Puts a value inside a field.
--
-- > Foo (putField "Hello") (putField (Just 42))
putField :: a -> Field n a
putField = Field

-- | A lens on @Field@ wrappers for use with the lens library.
--
-- > person & name . field .~ "new value"
--
field :: Functor f => (a -> f b) -> Field n a -> f (Field n b)
field f (Field a) = Field <$> f a

instance OVERLAP (Pinchable a, KnownNat n)
  => GPinchable (K1 i (Field n a)) where
    type GTag (K1 i (Field n a)) = TStruct
    gPinch (K1 (Field a)) = struct [n .= a]
      where
        n = fromIntegral $ natVal (Proxy :: Proxy n)

    gUnpinch m = K1 . Field <$> m .: n
      where
        n = fromIntegral $ natVal (Proxy :: Proxy n)

instance
  (Pinchable a, KnownNat n)
  => GPinchable (K1 i (Field n (Maybe a))) where
    type GTag (K1 i (Field n (Maybe a))) = TStruct
    gPinch (K1 (Field a)) = struct [n ?= a]
      where
        n = fromIntegral $ natVal (Proxy :: Proxy n)

    gUnpinch m = K1 . Field <$> m .:? n
      where
        n = fromIntegral $ natVal (Proxy :: Proxy n)

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

-- | Data types that represent Thrift enums must have one constructor for each
-- enum item accepting an 'Enumeration' object tagged with the corresponding
-- enum value.
--
-- > data Role = RoleUser (Enumeration 1) | RoleAdmin (Enumeration 2)
-- >   deriving Generic
-- > instance Pinchable Role
data Enumeration (n :: Nat) = Enumeration
  deriving
    (Eq, Generic, Ord, Show, Typeable)

instance NFData (Enumeration n)

-- | Convenience function to construct 'Enumeration' objects.
--
-- > let role = RoleUser enum
enum :: Enumeration n
enum = Enumeration

instance KnownNat n => GPinchable (K1 i (Enumeration n)) where
    type GTag (K1 i (Enumeration n)) = TEnum
    gPinch (K1 Enumeration) = VInt32 . fromIntegral $ natVal (Proxy :: Proxy n)
    gUnpinch (VInt32 i)
        | i == val  = return (K1 Enumeration)
        | otherwise = Left $ "Couldn't match enum value " ++ show i
      where
        val = fromIntegral $ natVal (Proxy :: Proxy n)
    gUnpinch x = Left $ "Failed to read enum. Got " ++ show x

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

-- | Represents a @void@ result for methods.
--
-- This should be used as an element in a response union along with 'Field'
-- tags.
--
-- For a method,
--
-- > void setValue(..) throws
-- >   (1: ValueAlreadyExists alreadyExists,
-- >    2: InternalError internalError)
--
-- Something similar to the following can be used.
--
-- > data SetValueResponse
-- >   = SetValueAlreadyExists (Field 1 ValueAlreadyExists)
-- >   | SetValueInternalError (Field 2 InternalError)
-- >   | SetValueSuccess Void
-- >   deriving (Generic)
-- >
-- > instance Pinchable SetValueResponse
data Void = Void
  deriving
    (Eq, Generic, Ord, Show, Typeable)

instance GPinchable (K1 i Void) where
    type GTag (K1 i Void) = TStruct

    gPinch (K1 Void) = struct []

    -- If the map isn't empty, there's probably an exception in there.
    gUnpinch (VStruct m) | HM.null m = Right $ K1 Void
    gUnpinch x = Left $
        "Failed to read response. Expected void, got: " ++ show x