CustomShowEnum.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module CustomShowEnum where

import Data.Aeson
import Data.Aeson.Types
import Data.Maybe
import Generics.SOP
import Generics.SOP.NS
import Generics.SOP.TH
import Text.Read

-- | Computes a product (a list with a statically known
-- number of elements) of all the constructor names.
--
-- Example:
--
-- >>> conNames (Proxy @OrderType)
-- K "Confirmed" :* K "AwaitingShipping" :* K "Shipped" :* Nil
--
conNames ::
  forall a proxy .
  (Generic a, HasDatatypeInfo a)
  => proxy a -> NP (K String) (Code a)
conNames _ =
  hmap
    (K . constructorName)
    (constructorInfo (datatypeInfo (Proxy @a)))

-- | Computes the name of the outermost constructor
-- of a given value.
--
-- Examples:
--
-- >>> conName Confirmed
-- "Confirmed"
-- >>> conName (Just 3)
-- "Just"
-- >>> conName [1,2,3]
-- ":"
--
conName ::
  forall a .
  (Generic a, HasDatatypeInfo a)
  => a -> String
conName x =
  hcollapse
    (hzipWith
      const
      (conNames (Proxy @a))
      (unSOP (from x))
    )

-- | Computes a product (a list with a statically known
-- number of elements) of all the values of an enumeration
-- type.
--
-- Examples:
--
-- >>> enum @Bool
-- K False :* K True :* Nil
-- >>> enum @Ordering
-- K LT :* K EQ :* K GT :* Nil
--
-- With the derived 'Show' instance for 'OrderType':
--
-- >>> enum @OrderType
-- K Confirmed :* K AwaitingShipping :* K Shipped :* Nil
--
-- With the custom 'Show' instance for 'OrderType':
--
-- >>> enum @OrderType
-- K confirmed :* K awaiting_shipping :* K shipped :* Nil
--
enum ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => NP (K a) (Code a)
enum =
  hmap
    (mapKK to)
    (apInjs'_POP (POP (hcpure (Proxy @((~) '[])) Nil)))

-- | Computes a lookup table mapping the string constructor
-- names to the actual values of an enum type.
--
-- Examples:
--
-- >>> conTable @Bool
-- [("False", False), ("True", True)]
-- >>> conTable @Ordering
-- [("LT", LT), ("EQ", EQ), ("GT", GT)]
--
-- With the derived 'Show' instance for 'OrderType':
--
-- >>> conTable @OrderType
-- [("Confirmed", Confirmed), ("AwaitingShipping", AwaitingShipping), ("Shipped", Shipped)]
--
-- With the custom 'Show' instance for 'OrderType':
--
-- >>> conTable @OrderType
-- [("Confirmed", confirmed), ("AwaitingShipping", awaiting_shipping), ("Shipped", shipped)]
--
conTable ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => [(String, a)]
conTable =
  hcollapse
    (hzipWith
      (mapKKK (,))
      (conNames (Proxy @a))
      enum
    )

-- | Custom show function for enum types. Takes a transformation
-- function that is applied to the constructor name.
--
-- Examples:
--
-- >>> customShowEnum id AwaitingShipping
-- "AwaitingShipping"
-- >>> customShowEnum reverse Confirmed
-- "demrifnoC"
-- >>> customShowEnum (camelTo2 '_') AwaitingShipping
-- "awaiting_shipping"
--
customShowEnum ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => (String -> String)
  -> a -> String
customShowEnum f = f . conName

-- | Custom read function for enum types. Takes a transformation
-- function that is applied to the constructor names.
--
-- Proceeds by first building an adjusted lookup table mapping
-- the transformed names to the values, and then trying to find
-- the given string in that lookup table.
--
-- Examples (with the derived 'Show' instance for 'OrderType'):
--
-- >>> readPrec_to_S (customReadEnum @OrderType id) 0 "AwaitingShipping"
-- [(AwaitingShipping, "")]
-- >>> readPrec_to_S (customReadEnum @OrderType (camelTo2 '_')) 0 "AwaitingShipping"
-- []
-- >>> readPrec_to_S (customReadEnum @OrderType (camelTo2 '_')) 0 "awaiting_shipping"
-- [(AwaitingShipping, "")]
-- >>> readPrec_to_S (customReadEnum @OrderType (camelTo2 '_')) 0 "   ( awaiting_shipping)  "
-- [(AwaitingShipping, "  ")]
--
customReadEnum ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => (String -> String)
  -> ReadPrec a
customReadEnum f =
  let
    adjustedTable :: [(Lexeme, a)]
    adjustedTable = map (\ (n, x) -> (Ident (f n), x)) conTable
  in
    parens $ do
      n <- lexP
      maybe pfail return (lookup n adjustedTable)

-- | Example datatype with derived instances of the generic-sop
-- 'Generic' and 'HasDatatypeInfo' classes.
data OrderType = Confirmed | AwaitingShipping | Shipped
deriveGeneric ''OrderType

-- | Default 'Show' instance for 'OrderType'.
deriving instance Show OrderType

-- | Custom instance for 'Show', applying transformation function.
-- instance Show OrderType where
--   show = customShowEnum (camelTo2 '_')

-- | Custom instance for 'Read', applying transformation function.
-- instance Read OrderType where
--   readPrec = customReadEnum (camelTo2 '_')

class ToString a where
  toString :: a -> String

class FromString a where
  fromString :: String -> Maybe a

instance ToString OrderType where
  toString = customShowEnum (camelTo2 '_')

customFromString ::
  forall a .
  (Generic a, HasDatatypeInfo a, All ((~) '[]) (Code a))
  => (String -> String)
  -> String -> Maybe a
customFromString f x =
  case readPrec_to_S (customReadEnum f) 0 x of
    [(r, "")] -> Just r
    _         -> Nothing

instance FromString OrderType where
  fromString = customFromString (camelTo2 '_')