https://stackoverflow.com/questions/64154105/how-to-autogenerate-such-instances-with-generic-usage

FlexibleId.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}

module FlexibleId where

import Data.Char
import Data.List.Split
import Data.List
import Control.Applicative (Alternative((<|>)))
import GHC.Generics

newtype Name = Name String deriving newtype (Eq, Ord, Show)
newtype PK = PK Integer deriving newtype (Eq, Ord, Show)
newtype XXX = XXX String deriving newtype (Eq, Ord, Show)

class FlexibleId a where
    typeSuffix :: String
    readId :: String -> Maybe a

instance FlexibleId Name where
    typeSuffix = "name"
    readId s | all isAccepted s = Just $ Name s where isAccepted c = isAlphaNum c || c == '_'
    readId _ = Nothing

instance FlexibleId PK where
    typeSuffix = "pk"
    readId s | all isDigit s = Just $ PK $ read s
    readId _ = Nothing

instance FlexibleId XXX where
    typeSuffix = "xxx"
    readId s | all isDigit s = Just $ XXX s
    readId _ = Nothing

-- order matters!!!
data FlexibleUserId = UserPK PK | UserName Name | UserXXX XXX deriving (Show, Generic)
instance FlexibleId FlexibleUserId where
    typeSuffix = "User-key"
    readId = greadId "User"

--

greadId :: (Generic a, GFlexibleId (Rep a)) => String -> String -> Maybe a
greadId prefix s =
  case splitOn ":" s of
    [s1, suffix] -> to <$> greadId_ prefix s1 (Just suffix)
    [s1] -> to <$> greadId_ prefix s1 Nothing
    _ -> Nothing

class GFlexibleId f where
  greadId_ ::
    String {- type prefix to strip ("User") -} ->
    String {- input string (before ":") -} ->
    Maybe String {- optional input suffix (after ":") -} ->
    Maybe (f p)

instance GFlexibleId f => GFlexibleId (D1 c f) where
  greadId_ pre s suf = M1 <$> greadId_ pre s suf

instance (GFlexibleId f, GFlexibleId g) => GFlexibleId (f :+: g) where
  greadId_ pre s suf = (L1 <$> greadId_ pre s suf) <|> (R1 <$> greadId_ pre s suf)

instance (GFlexibleId f, Constructor c) => GFlexibleId (C1 c f) where
  greadId_ pre s suf | isMatch = M1 <$> greadId_ pre s suf
                    | otherwise = Nothing
    where
      isMatch = case (suf, stripPrefix pre cname) of
        (Just z, Just z') -> z == map toLower z'
        (Nothing, _) -> True
        (_, _) -> False
      cname = conName @c undefined  -- conName doesn't use its argument

instance (GFlexibleId f) => GFlexibleId (S1 c f) where
  greadId_ pre s suf = M1 <$> greadId_ pre s suf

instance FlexibleId a => GFlexibleId (K1 i a) where
  greadId_ _ s _ = K1 <$> readId s