{-# LANGUAGE LambdaCase, RecordWildCards, ViewPatterns, CPP #-} module Data.MakeEnum( makeEnum, makeEnumWith, ) where import Control.Monad import Data.Functor.Identity import Data.Maybe import Data.Monoid import Language.Haskell.TH import Language.Haskell.TH.Syntax import Lens.Micro hiding(filtered) import Data.MakeEnum.Options makeEnum :: Name -> [Name] -> Q [Dec] makeEnum :: Name -> [Name] -> Q [Dec] makeEnum Name tyName [Name] omit = Name -> [Name] -> Options -> Q [Dec] makeEnumWith Name tyName [Name] omit Options defaultOptions makeEnumWith :: Name -> [Name] -> Options -> Q [Dec] makeEnumWith :: Name -> [Name] -> Options -> Q [Dec] makeEnumWith Name tyName [Name] omit Options options = Name -> Q Info reify Name tyName Q Info -> (Info -> Q [Dec]) -> Q [Dec] forall a b. Q a -> (a -> Q b) -> Q b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case TyConI (Dec -> Maybe DataDef unwrapDec -> Just DataDef dec) -> do let deducedOpts :: DeducedOptions deducedOpts = DataDef -> Options -> DeducedOptions deduceOptions DataDef dec Options options let (Dec dec', [Con] origCons, Name name) = DeducedOptions -> [Maybe Name] -> DataDef -> (Dec, [Con], Name) buildReducedEnum DeducedOptions deducedOpts [Maybe Name] omit' DataDef dec (Dec fromSig, Dec fromFun) <- DeducedOptions -> Name -> [Con] -> Q (Dec, Dec) buildFromFun DeducedOptions deducedOpts Name name [Con] origCons (Dec toSig, Dec toFun) <- DeducedOptions -> Name -> [Con] -> Q (Dec, Dec) buildToFun DeducedOptions deducedOpts Name name [Con] origCons [Dec] -> Q [Dec] forall a. a -> Q a forall (f :: * -> *) a. Applicative f => a -> f a pure [Dec dec', Dec fromSig, Dec fromFun, Dec toSig, Dec toFun] Info _ -> String -> Q [Dec] forall a. String -> Q a forall (m :: * -> *) a. MonadFail m => String -> m a fail String "unsupported type" where omit' :: [Maybe Name] omit' = Name -> Maybe Name forall a. a -> Maybe a Just (Name -> Maybe Name) -> [Name] -> [Maybe Name] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] omit #if MIN_VERSION_template_haskell(2, 21, 0) type BndrParam = BndrVis #else type BndrParam = () #endif data DataDef = DataDef Cxt Name [TyVarBndr BndrParam] (Maybe Kind) [Con] [DerivClause] deriving (DataDef -> DataDef -> Bool (DataDef -> DataDef -> Bool) -> (DataDef -> DataDef -> Bool) -> Eq DataDef forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: DataDef -> DataDef -> Bool == :: DataDef -> DataDef -> Bool $c/= :: DataDef -> DataDef -> Bool /= :: DataDef -> DataDef -> Bool Eq, Eq DataDef Eq DataDef => (DataDef -> DataDef -> Ordering) -> (DataDef -> DataDef -> Bool) -> (DataDef -> DataDef -> Bool) -> (DataDef -> DataDef -> Bool) -> (DataDef -> DataDef -> Bool) -> (DataDef -> DataDef -> DataDef) -> (DataDef -> DataDef -> DataDef) -> Ord DataDef DataDef -> DataDef -> Bool DataDef -> DataDef -> Ordering DataDef -> DataDef -> DataDef forall a. Eq a => (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a $ccompare :: DataDef -> DataDef -> Ordering compare :: DataDef -> DataDef -> Ordering $c< :: DataDef -> DataDef -> Bool < :: DataDef -> DataDef -> Bool $c<= :: DataDef -> DataDef -> Bool <= :: DataDef -> DataDef -> Bool $c> :: DataDef -> DataDef -> Bool > :: DataDef -> DataDef -> Bool $c>= :: DataDef -> DataDef -> Bool >= :: DataDef -> DataDef -> Bool $cmax :: DataDef -> DataDef -> DataDef max :: DataDef -> DataDef -> DataDef $cmin :: DataDef -> DataDef -> DataDef min :: DataDef -> DataDef -> DataDef Ord, Int -> DataDef -> ShowS [DataDef] -> ShowS DataDef -> String (Int -> DataDef -> ShowS) -> (DataDef -> String) -> ([DataDef] -> ShowS) -> Show DataDef forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> DataDef -> ShowS showsPrec :: Int -> DataDef -> ShowS $cshow :: DataDef -> String show :: DataDef -> String $cshowList :: [DataDef] -> ShowS showList :: [DataDef] -> ShowS Show) unwrapDec :: Dec -> Maybe DataDef unwrapDec :: Dec -> Maybe DataDef unwrapDec (DataD Cxt cx Name name [TyVarBndr BndrParam] bndrs Maybe Kind kind [Con] cons [DerivClause] derivs) = DataDef -> Maybe DataDef forall a. a -> Maybe a Just (DataDef -> Maybe DataDef) -> DataDef -> Maybe DataDef forall a b. (a -> b) -> a -> b $ Cxt -> Name -> [TyVarBndr BndrParam] -> Maybe Kind -> [Con] -> [DerivClause] -> DataDef DataDef Cxt cx Name name [TyVarBndr BndrParam] bndrs Maybe Kind kind [Con] cons [DerivClause] derivs unwrapDec Dec _ = Maybe DataDef forall a. Maybe a Nothing type DeducedOptions = OptionsT Identity deduceOptions :: DataDef -> Options -> DeducedOptions deduceOptions :: DataDef -> Options -> DeducedOptions deduceOptions (DataDef Cxt _ Name name [TyVarBndr BndrParam] _ Maybe Kind _ [Con] _ [DerivClause] _) Options { [Name] Maybe String ShowS newEnumName :: Maybe String fromFunctionName :: Maybe String toFunctionName :: Maybe String ctorNameModifier :: ShowS deriveClasses :: [Name] newEnumName :: forall (f :: * -> *). OptionsT f -> f String fromFunctionName :: forall (f :: * -> *). OptionsT f -> f String toFunctionName :: forall (f :: * -> *). OptionsT f -> f String ctorNameModifier :: forall (f :: * -> *). OptionsT f -> ShowS deriveClasses :: forall (f :: * -> *). OptionsT f -> [Name] .. } = Options { newEnumName :: Identity String newEnumName = String -> Identity String forall a. a -> Identity a Identity (String -> Identity String) -> String -> Identity String forall a b. (a -> b) -> a -> b $ String -> Maybe String -> String forall a. a -> Maybe a -> a fromMaybe (Name -> String nameBase Name name) Maybe String newEnumName , fromFunctionName :: Identity String fromFunctionName = String -> Identity String forall a. a -> Identity a Identity (String -> Identity String) -> String -> Identity String forall a b. (a -> b) -> a -> b $ String -> Maybe String -> String forall a. a -> Maybe a -> a fromMaybe (String "from" String -> ShowS forall a. Semigroup a => a -> a -> a <> Name -> String nameBase Name name) Maybe String fromFunctionName , toFunctionName :: Identity String toFunctionName = String -> Identity String forall a. a -> Identity a Identity (String -> Identity String) -> String -> Identity String forall a b. (a -> b) -> a -> b $ String -> Maybe String -> String forall a. a -> Maybe a -> a fromMaybe (String "to" String -> ShowS forall a. Semigroup a => a -> a -> a <> Name -> String nameBase Name name) Maybe String toFunctionName , [Name] ShowS ctorNameModifier :: ShowS deriveClasses :: [Name] ctorNameModifier :: ShowS deriveClasses :: [Name] .. } buildReducedEnum :: DeducedOptions -> [Maybe Name] -> DataDef -> (Dec, [Con], Name) buildReducedEnum :: DeducedOptions -> [Maybe Name] -> DataDef -> (Dec, [Con], Name) buildReducedEnum Options { [Name] Identity String ShowS newEnumName :: forall (f :: * -> *). OptionsT f -> f String fromFunctionName :: forall (f :: * -> *). OptionsT f -> f String toFunctionName :: forall (f :: * -> *). OptionsT f -> f String ctorNameModifier :: forall (f :: * -> *). OptionsT f -> ShowS deriveClasses :: forall (f :: * -> *). OptionsT f -> [Name] newEnumName :: Identity String fromFunctionName :: Identity String toFunctionName :: Identity String ctorNameModifier :: ShowS deriveClasses :: [Name] .. } [Maybe Name] omit (DataDef Cxt cx Name name [TyVarBndr BndrParam] bndrs Maybe Kind kind [Con] cons [DerivClause] _) = (Cxt -> Name -> [TyVarBndr BndrParam] -> Maybe Kind -> [Con] -> [DerivClause] -> Dec DataD Cxt cx Name name' [TyVarBndr BndrParam] bndrs Maybe Kind kind [Con] cons' [DerivClause] derivs, [Con] filtered, Name name) where filtered :: [Con] filtered = (Con -> Bool) -> [Con] -> [Con] forall a. (a -> Bool) -> [a] -> [a] filter ((Maybe Name -> [Maybe Name] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `notElem` [Maybe Name] omit) (Maybe Name -> Bool) -> (Con -> Maybe Name) -> Con -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . (Con -> Getting (First Name) Con Name -> Maybe Name forall s a. s -> Getting (First a) s a -> Maybe a ^? Getting (First Name) Con Name Traversal' Con Name nameT)) [Con] cons cons' :: [Con] cons' = (Name -> Identity Name) -> Con -> Identity Con Traversal' Con Name nameT ((Name -> Identity Name) -> Con -> Identity Con) -> (Name -> Name) -> Con -> Con forall s t a b. ASetter s t a b -> (a -> b) -> s -> t `over` (String -> Name mkName (String -> Name) -> (Name -> String) -> Name -> Name forall b c a. (b -> c) -> (a -> b) -> a -> c . ShowS ctorNameModifier ShowS -> (Name -> String) -> Name -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Name -> String nameBase) (Con -> Con) -> [Con] -> [Con] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Con] filtered name' :: Name name' = String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ Identity String -> String forall a. Identity a -> a runIdentity Identity String newEnumName derivs :: [DerivClause] derivs = [Maybe DerivStrategy -> Cxt -> DerivClause DerivClause Maybe DerivStrategy forall a. Maybe a Nothing (Cxt -> DerivClause) -> Cxt -> DerivClause forall a b. (a -> b) -> a -> b $ Name -> Kind ConT (Name -> Kind) -> [Name] -> Cxt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] deriveClasses] buildFromFun :: DeducedOptions -> Name -> [Con] -> Q (Dec, Dec) buildFromFun :: DeducedOptions -> Name -> [Con] -> Q (Dec, Dec) buildFromFun Options { [Name] Identity String ShowS newEnumName :: forall (f :: * -> *). OptionsT f -> f String fromFunctionName :: forall (f :: * -> *). OptionsT f -> f String toFunctionName :: forall (f :: * -> *). OptionsT f -> f String ctorNameModifier :: forall (f :: * -> *). OptionsT f -> ShowS deriveClasses :: forall (f :: * -> *). OptionsT f -> [Name] newEnumName :: Identity String fromFunctionName :: Identity String toFunctionName :: Identity String ctorNameModifier :: ShowS deriveClasses :: [Name] .. } Name name [Con] cons = do Module PkgName _ (ModName String thisModName) <- Q Module thisModule let funName :: Name funName = String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ Identity String -> String forall a. Identity a -> a runIdentity Identity String fromFunctionName let funSig :: Dec funSig = Name -> Kind -> Dec SigD Name funName (Kind -> Dec) -> Kind -> Dec forall a b. (a -> b) -> a -> b $ Kind ArrowT Kind -> Kind -> Kind `AppT` Name -> Kind ConT Name name Kind -> Kind -> Kind `AppT` (Name -> Kind ConT (String -> Name mkName String "Maybe") Kind -> Kind -> Kind `AppT` Name -> Kind ConT (String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ Identity String -> String forall a. Identity a -> a runIdentity Identity String newEnumName)) [Clause] clauses <- (Con -> Q Clause) -> [Con] -> Q [Clause] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM (String -> Con -> Q Clause forall {m :: * -> *}. (Quote m, MonadFail m) => String -> Con -> m Clause mkClause String thisModName) [Con] cons let fallback :: Clause fallback = [Pat] -> Body -> [Dec] -> Clause Clause [Pat WildP] (Exp -> Body NormalB (Exp -> Body) -> Exp -> Body forall a b. (a -> b) -> a -> b $ Name -> Exp ConE (Name -> Exp) -> Name -> Exp forall a b. (a -> b) -> a -> b $ String -> Name mkName String "Nothing") [] let funDef :: Dec funDef = Name -> [Clause] -> Dec FunD Name funName ([Clause] -> Dec) -> [Clause] -> Dec forall a b. (a -> b) -> a -> b $ [Clause] clauses [Clause] -> [Clause] -> [Clause] forall a. [a] -> [a] -> [a] ++ [Clause fallback] (Dec, Dec) -> Q (Dec, Dec) forall a. a -> Q a forall (f :: * -> *) a. Applicative f => a -> f a pure (Dec funSig, Dec funDef) where mkClause :: String -> Con -> m Clause mkClause String thisModName (NormalC Name n [BangType] ts) = do let thisName :: Name thisName = String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ String thisModName String -> ShowS forall a. Semigroup a => a -> a -> a <> String "." String -> ShowS forall a. Semigroup a => a -> a -> a <> ShowS ctorNameModifier (Name -> String nameBase Name n) [Name] binders <- Int -> m Name -> m [Name] forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a] replicateM ([BangType] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [BangType] ts) (m Name -> m [Name]) -> m Name -> m [Name] forall a b. (a -> b) -> a -> b $ String -> m Name forall (m :: * -> *). Quote m => String -> m Name newName String "p" let body :: Body body = Exp -> Body NormalB (Exp -> Body) -> Exp -> Body forall a b. (a -> b) -> a -> b $ Name -> Exp ConE (String -> Name mkName String "Just") Exp -> Exp -> Exp `AppE` (Name -> Exp ConE Name thisName Exp -> [Name] -> Exp `foldBinders` [Name] binders) Clause -> m Clause forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (Clause -> m Clause) -> Clause -> m Clause forall a b. (a -> b) -> a -> b $ [Pat] -> Body -> [Dec] -> Clause Clause [Name -> Cxt -> [Pat] -> Pat ConP Name n [] ([Pat] -> Pat) -> [Pat] -> Pat forall a b. (a -> b) -> a -> b $ Name -> Pat VarP (Name -> Pat) -> [Name] -> [Pat] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] binders] Body body [] mkClause String _ Con p = String -> m Clause forall a. String -> m a forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> m Clause) -> String -> m Clause forall a b. (a -> b) -> a -> b $ String "this type of constructor is not supported yet:\n" String -> ShowS forall a. Semigroup a => a -> a -> a <> Con -> String forall a. Ppr a => a -> String pprint Con p buildToFun :: DeducedOptions -> Name -> [Con] -> Q (Dec, Dec) buildToFun :: DeducedOptions -> Name -> [Con] -> Q (Dec, Dec) buildToFun Options { [Name] Identity String ShowS newEnumName :: forall (f :: * -> *). OptionsT f -> f String fromFunctionName :: forall (f :: * -> *). OptionsT f -> f String toFunctionName :: forall (f :: * -> *). OptionsT f -> f String ctorNameModifier :: forall (f :: * -> *). OptionsT f -> ShowS deriveClasses :: forall (f :: * -> *). OptionsT f -> [Name] newEnumName :: Identity String fromFunctionName :: Identity String toFunctionName :: Identity String ctorNameModifier :: ShowS deriveClasses :: [Name] .. } Name name [Con] cons = do Module PkgName _ (ModName String thisModName) <- Q Module thisModule let funName :: Name funName = String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ Identity String -> String forall a. Identity a -> a runIdentity Identity String toFunctionName let funSig :: Dec funSig = Name -> Kind -> Dec SigD Name funName (Kind -> Dec) -> Kind -> Dec forall a b. (a -> b) -> a -> b $ Kind ArrowT Kind -> Kind -> Kind `AppT` Name -> Kind ConT (String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ Identity String -> String forall a. Identity a -> a runIdentity Identity String newEnumName) Kind -> Kind -> Kind `AppT` Name -> Kind ConT Name name [Clause] clauses <- (Con -> Q Clause) -> [Con] -> Q [Clause] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b] mapM (String -> Con -> Q Clause forall {m :: * -> *}. (Quote m, MonadFail m) => String -> Con -> m Clause mkClause String thisModName) [Con] cons let funDef :: Dec funDef = Name -> [Clause] -> Dec FunD Name funName [Clause] clauses (Dec, Dec) -> Q (Dec, Dec) forall a. a -> Q a forall (f :: * -> *) a. Applicative f => a -> f a pure (Dec funSig, Dec funDef) where mkClause :: String -> Con -> m Clause mkClause String thisModName (NormalC Name n [BangType] ts) = do let thisName :: Name thisName = String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ String thisModName String -> ShowS forall a. Semigroup a => a -> a -> a <> String "." String -> ShowS forall a. Semigroup a => a -> a -> a <> ShowS ctorNameModifier (Name -> String nameBase Name n) [Name] binders <- Int -> m Name -> m [Name] forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a] replicateM ([BangType] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [BangType] ts) (m Name -> m [Name]) -> m Name -> m [Name] forall a b. (a -> b) -> a -> b $ String -> m Name forall (m :: * -> *). Quote m => String -> m Name newName String "p" let body :: Body body = Exp -> Body NormalB (Exp -> Body) -> Exp -> Body forall a b. (a -> b) -> a -> b $ Name -> Exp ConE Name n Exp -> [Name] -> Exp `foldBinders` [Name] binders Clause -> m Clause forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (Clause -> m Clause) -> Clause -> m Clause forall a b. (a -> b) -> a -> b $ [Pat] -> Body -> [Dec] -> Clause Clause [Name -> Cxt -> [Pat] -> Pat ConP Name thisName [] ([Pat] -> Pat) -> [Pat] -> Pat forall a b. (a -> b) -> a -> b $ Name -> Pat VarP (Name -> Pat) -> [Name] -> [Pat] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] binders] Body body [] mkClause String _ Con p = String -> m Clause forall a. String -> m a forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> m Clause) -> String -> m Clause forall a b. (a -> b) -> a -> b $ String "this type of constructor is not supported yet:\n" String -> ShowS forall a. Semigroup a => a -> a -> a <> Con -> String forall a. Ppr a => a -> String pprint Con p foldBinders :: Exp -> [Name] -> Exp foldBinders :: Exp -> [Name] -> Exp foldBinders Exp name = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp forall b a. (b -> a -> b) -> b -> [a] -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl Exp -> Exp -> Exp AppE Exp name ([Exp] -> Exp) -> ([Name] -> [Exp]) -> [Name] -> Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . (Name -> Exp) -> [Name] -> [Exp] forall a b. (a -> b) -> [a] -> [b] map Name -> Exp VarE nameT :: Traversal' Con Name nameT :: Traversal' Con Name nameT Name -> f Name f (NormalC Name n [BangType] bts) = (Name -> [BangType] -> Con `NormalC` [BangType] bts) (Name -> Con) -> f Name -> f Con forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Name -> f Name f Name n nameT Name -> f Name f (RecC Name n [VarBangType] vbts) = (Name -> [VarBangType] -> Con `RecC` [VarBangType] vbts) (Name -> Con) -> f Name -> f Con forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Name -> f Name f Name n nameT Name -> f Name f (InfixC BangType bt1 Name n BangType bt2) = (\Name n' -> BangType -> Name -> BangType -> Con InfixC BangType bt1 Name n' BangType bt2) (Name -> Con) -> f Name -> f Con forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Name -> f Name f Name n nameT Name -> f Name f (ForallC [TyVarBndr Specificity] tvbs Cxt cx Con n) = [TyVarBndr Specificity] -> Cxt -> Con -> Con ForallC [TyVarBndr Specificity] tvbs Cxt cx (Con -> Con) -> f Con -> f Con forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Name -> f Name) -> Con -> f Con Traversal' Con Name nameT Name -> f Name f Con n nameT Name -> f Name _ c :: Con c@GadtC {} = Con -> f Con forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure Con c nameT Name -> f Name _ c :: Con c@RecGadtC {} = Con -> f Con forall a. a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure Con c