Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# 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 '_')
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement