Playing with genetics-sop

SOPTest.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}


import Generics.SOP
import Data.List (intercalate)
import GHC.Stack (HasCallStack, prettyCallStack, callStack)
​
enumShow :: forall a. (IsEnumType a, HasDatatypeInfo a) => a -> String
enumShow a = gShow (constructorInfo (datatypeInfo (Proxy :: Proxy a))) (enumTypeFrom a)
  where
    gShow :: (SListI xss) => NP ConstructorInfo xss -> NS (K ()) xss -> String
    gShow (c :* _) (Z _)     = constructorName c
    gShow (_ :* cs) (S next) = gShow cs next
    gShow Nil _ = error "The (actually) impossible happened"
​
​
enumRead :: forall a. (IsEnumType a, HasDatatypeInfo a) => String -> Either String a
enumRead str = maybe (Left err) (Right . enumTypeTo) $ gRead $ constructorInfo typeInfo
  where
    typeInfo :: DatatypeInfo (Code a)
    typeInfo = datatypeInfo @a Proxy 
​
    gRead :: (SListI xss) => NP ConstructorInfo xss -> Maybe (NS (K ()) xss)
    gRead (c :* cs)
        | constructorName c == str = Just $ Z $ K ()
        | otherwise = S <$> gRead cs
    gRead Nil = Nothing
    err = concat 
            [ "enumRead: Could not read type '"
            , moduleName typeInfo, " ", datatypeName typeInfo
            , "' from string: "
            , show str 
            , " at:\n"
            , prettyCallStack callStack ]
​
enumRead' :: forall a. (IsEnumType a, HasDatatypeInfo a, HasCallStack)
         => (String -> String) ->  String -> Either String a
enumRead' f str = maybe (Left err) (Right . enumTypeTo) $ gRead $ constructors
  where
    typeInfo :: DatatypeInfo (Code a)
    typeInfo = datatypeInfo @a Proxy
    constructors :: NP ConstructorInfo (Code a)
    constructors = constructorInfo typeInfo
​
    gRead :: (SListI xss) => NP ConstructorInfo xss -> Maybe (NS (K ()) xss)
    gRead (c :* cs)
        | f (constructorName c) == str = Just $ Z $ K ()
        | otherwise = S <$> gRead cs
    gRead Nil = Nothing
    err =  concat 
            [ "enumRead': Could not read type '"
            , moduleName typeInfo, " ", datatypeName typeInfo
            ," (constructors: ", intercalate ", " (f <$> constructorNames constructors), ")"
            , "' from string: "
            , show str 
            , " at:\n"
            , prettyCallStack callStack ]
    constructorNames :: (SListI xss) => NP ConstructorInfo xss -> [String]
    constructorNames Nil = []
    constructorNames (c :* cs) = constructorName c : constructorNames cs