src/Worksheets/Utils/Generics.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE StandaloneDeriving #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 {-# OPTIONS_GHC -Wno-orphans #-}
   5
   6 module Worksheets.Utils.Generics (
   7   module Worksheets.Utils.Generics,
   8   module GHC.Generics,
   9 ) where
  10
  11 import Data.Char qualified as Char
  12 import GHC.Generics
  13 import Prelude (Eq (..), Maybe (..), String, otherwise, (<>))
  14
  15 -- | Cut the first lowercases, and lowercase the first uppercase.
  16 dropLowercasesAndLowerNextChar :: String -> String
  17 dropLowercasesAndLowerNextChar "" = ""
  18 dropLowercasesAndLowerNextChar (c : cs)
  19   | Char.isUpper c = Char.toLower c : cs
  20   | otherwise = dropLowercasesAndLowerNextChar cs
  21
  22 -- | Cut the first lowercases, and lowercase the first uppercase.
  23 dropUntilUnderscore :: String -> String
  24 dropUntilUnderscore "" = ""
  25 dropUntilUnderscore (c : cs)
  26   | c == '_' = cs
  27   | otherwise = dropUntilUnderscore cs
  28
  29 class DataSelectorNames f where
  30   -- | List the names of the selectors of a data type.
  31   dataSelectorNames :: [String]
  32 instance DataSelectorNames (Rep a ()) => DataSelectorNames (Generically a) where
  33   dataSelectorNames = dataSelectorNames @(Rep a ())
  34
  35 {-
  36 instance (DataSelectorNames f) => DataSelectorNames (M1 D t f) where
  37   dataSelectorNames = dataSelectorNames @f
  38 instance (DataSelectorNames f, DataSelectorNames g) => DataSelectorNames (f :+: g) where
  39   dataSelectorNames = dataSelectorNames @f <> dataSelectorNames @g
  40 instance DataSelectorNames (C1 c f) where
  41   dataSelectorNames = [conName (undefined :: C1 c f g)]
  42 -}
  43
  44 deriving instance DataSelectorNames c => DataSelectorNames (K1 i c p)
  45 deriving instance DataSelectorNames p => DataSelectorNames (Par1 p)
  46 deriving instance DataSelectorNames (f p) => DataSelectorNames (Rec1 f p)
  47
  48 -- instance DataSelectorNames (f p) => DataSelectorNames (M1 i c f p) where dataSelectorNames = dataSelectorNames @(f p)
  49 instance (DataSelectorNames (f p), DataSelectorNames (g p)) => DataSelectorNames ((f :*: g) p) where
  50   dataSelectorNames = dataSelectorNames @(f p) <> dataSelectorNames @(g p)
  51 deriving instance DataSelectorNames (f (g p)) => DataSelectorNames ((f :.: g) p)
  52 instance
  53   DataSelectorNames (f p) =>
  54   DataSelectorNames (M1 D (MetaData typeName moduleName packageName isNewtype) f p)
  55   where
  56   dataSelectorNames = dataSelectorNames @(f p)
  57 instance
  58   DataSelectorNames (f p) =>
  59   DataSelectorNames (M1 C (MetaCons consName consFixity consHasRecordSelectors) f p)
  60   where
  61   dataSelectorNames = dataSelectorNames @(f p)
  62 instance
  63   Selector (MetaSel (Just selName) selUnpackedness selStrictness selStrictnessInferred) =>
  64   DataSelectorNames (M1 S (MetaSel (Just selName) selUnpackedness selStrictness selStrictnessInferred) f p)
  65   where
  66   dataSelectorNames = [selName n]
  67     where
  68       n :: M1 S (MetaSel (Just selName) selUnpackedness selStrictness selStrictnessInferred) f p
  69       n = n