{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Options.TH
( deriveParseRecord,
module Options.Generic,
)
where
import Data.Foldable (asum)
import Control.Applicative
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as T
import Data.Traversable
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Options.Applicative qualified as Options
import Options.Generic
deriveParseRecord :: Modifiers -> Name -> Q [Dec]
deriveParseRecord :: Modifiers -> Name -> Q [Dec]
deriveParseRecord Modifiers
modifiers Name
tyName = do
Info
tyInfo <- Name -> Q Info
reify Name
tyName
Datatype
datatype <-
Name -> Info -> Q Datatype
getDatatypeForInfo Name
tyName Info
tyInfo
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>) (Modifiers -> Datatype -> Q [Dec]
datatypeToInstanceDec Modifiers
modifiers Datatype
datatype) (Name -> Datatype -> Q [Dec]
datatypeToUnwrapRecordDec Name
tyName Datatype
datatype)
datatypeToUnwrapRecordDec :: Name -> Datatype -> Q [Dec]
datatypeToUnwrapRecordDec :: Name -> Datatype -> Q [Dec]
datatypeToUnwrapRecordDec Name
typeName Datatype
datatype = do
if Datatype -> Bool
datatypeIsWrapped Datatype
datatype
then do
let fnName :: Name
fnName =
String -> Name
mkName (String
"unwrapRecord" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
typeName)
fnType :: Q Type
fnType =
[t|$(conT typeName) Wrapped -> $(conT typeName) Unwrapped|]
fnExpr :: Q Exp
fnExpr = Datatype -> Q Exp
mkUnwrapRecordExpr Datatype
datatype
fnSig :: Q Dec
fnSig = Name -> Type -> Dec
SigD Name
fnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
fnType
(:)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
fnSig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
$(varP fnName) = $(fnExpr)
|]
else do
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkUnwrapRecordExpr :: Datatype -> Q Exp
mkUnwrapRecordExpr :: Datatype -> Q Exp
mkUnwrapRecordExpr Datatype
datatype = do
let mkMatch :: Con -> Q Match
mkMatch Con
con =
case Con
con of
NormalC Name
name [BangType]
bangTyps -> do
(Pat
pat, [(Name, Type)]
namesAndTypes) <- do
[(Name, Type)]
namesAndTypes <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [BangType]
bangTyps \(Bang
_bang, Type
typ) -> do
Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Type
typ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Name -> [Pat] -> Pat
mkConP Name
name (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
varName, Type
_fieldType) -> Name -> Pat
VarP Name
varName) [(Name, Type)]
namesAndTypes)
, [(Name, Type)]
namesAndTypes
)
Body
body <- do
let constr :: Exp
constr = Name -> Exp
ConE Name
name
[Exp]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name, Type) -> Q Exp
unwrapFields [(Name, Type)]
namesAndTypes
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE Exp
constr [Exp]
fields
let decs :: [a]
decs =
[]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body forall a. [a]
decs
RecC Name
name [VarBangType]
varBangTypes -> do
(Pat
pat, [(Name, Type)]
varNames) <- do
[(Name, Type)]
varNames <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [VarBangType]
varBangTypes \(Name
_fieldName, Bang
_bang, Type
typ) -> do
Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Type
typ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Name -> [Pat] -> Pat
mkConP Name
name (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
varName, Type
_fieldType) -> Name -> Pat
VarP Name
varName) [(Name, Type)]
varNames)
, [(Name, Type)]
varNames
)
Body
body <- do
let constr :: Exp
constr = Name -> Exp
ConE Name
name
[Exp]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name, Type) -> Q Exp
unwrapFields [(Name, Type)]
varNames
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE Exp
constr [Exp]
fields
let decs :: [a]
decs =
[]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body forall a. [a]
decs
Con
_ ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Unexpected constructor in mkUnwrapRecordExpr: "
, String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con
]
NonEmpty Match
matches <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Con -> Q Match
mkMatch (Datatype -> NonEmpty Con
datatypeConstructors Datatype
datatype)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Match] -> Exp
LamCaseE (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Match
matches)
unwrapFields :: (Name, Type) -> Q Exp
unwrapFields :: (Name, Type) -> Q Exp
unwrapFields (Name
varName, Type
varTyp) =
case Type
varTyp of
AppT
( AppT
(ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.:::)) -> Bool
True))
(VarT Name
_)
)
Type
rest -> do
Name -> Type -> Q Exp
tryUnwrapping Name
varName Type
rest
Type
_ ->
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varName
tryUnwrapping :: Name -> Type -> Q Exp
tryUnwrapping :: Name -> Type -> Q Exp
tryUnwrapping Name
varName = [Exp] -> Type -> Q Exp
go []
where
go :: [Exp] -> Type -> Q Exp
go [Exp]
fns Type
varTyp = do
case Type
varTyp of
( AppT
(ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.<?>)) -> Bool
True))
Type
rest
)
`AppT` Type
_helpText ->
do
[Exp] -> Type -> Q Exp
go (Name -> Exp
VarE 'unHelpful forall a. a -> [a] -> [a]
: [Exp]
fns) Type
rest
AppT
( AppT
(ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.<!>)) -> Bool
True))
Type
rest
)
Type
_defVal ->
do
[Exp] -> Type -> Q Exp
go (Name -> Exp
VarE 'unDefValue forall a. a -> [a] -> [a]
: [Exp]
fns) Type
rest
AppT
( AppT
(ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.<#>)) -> Bool
True))
Type
rest
)
Type
_shortLabel ->
[Exp] -> Type -> Q Exp
go (Name -> Exp
VarE 'unShortName forall a. a -> [a] -> [a]
: [Exp]
fns) Type
rest
Type
_ -> do
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Exp
fn Q Exp
acc -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
fn forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
acc) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varName) [Exp]
fns
getDatatypeForInfo :: Name -> Info -> Q Datatype
getDatatypeForInfo :: Name -> Info -> Q Datatype
getDatatypeForInfo Name
tyName Info
tyInfo =
case Info
tyInfo of
TyConI Dec
dec ->
case Dec
dec of
DataD Cxt
_xct Name
name [TyVarBndr ()]
bndrs Maybe Type
_mkind [Con]
constructors [DerivClause]
_derivs -> do
case [Con]
constructors of
[] ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"A `ParseRecord` instance can't be generated for the following type:"
, String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Name
tyName
, String
"... because it has no constructors."
]
(Con
c : [Con]
cs) -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Datatype
{ datatypeName :: Name
datatypeName =
Name
name
, datatypeConstructors :: NonEmpty Con
datatypeConstructors =
Con
c forall a. a -> [a] -> NonEmpty a
:| [Con]
cs
, datatypeIsWrapped :: Bool
datatypeIsWrapped =
Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr ()]
bndrs)
}
NewtypeD Cxt
_cxt Name
name [TyVarBndr ()]
bndrs Maybe Type
_mkind Con
constructor [DerivClause]
_derivs -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Datatype
{ datatypeName :: Name
datatypeName =
Name
name
, datatypeConstructors :: NonEmpty Con
datatypeConstructors =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
constructor
, datatypeIsWrapped :: Bool
datatypeIsWrapped =
Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr ()]
bndrs)
}
Dec
_ ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Internal error: Options.TH.getDatatypeForInfo."
, String
""
, String
"This is not your fault. Open a bug report and include the following error for the context in the report: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Dec
dec
, String
"The GHC API provided a `TyConI` wrapping a declaration that was not a `data` or `newtype` declaration, which should never happen."
]
Info
_ -> do
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat
[ String
"Expected a type constructor in 'deriveParseRecord', got: "
, String
"\n\t"
, forall a. Show a => a -> String
show Info
tyInfo
]
data Datatype = Datatype
{ Datatype -> Name
datatypeName :: Name
, Datatype -> Bool
datatypeIsWrapped :: Bool
, Datatype -> NonEmpty Con
datatypeConstructors :: NonEmpty Con
}
datatypeToInstanceDec :: Modifiers -> Datatype -> Q [Dec]
datatypeToInstanceDec :: Modifiers -> Datatype -> Q [Dec]
datatypeToInstanceDec Modifiers
mods Datatype {Bool
NonEmpty Con
Name
datatypeConstructors :: NonEmpty Con
datatypeIsWrapped :: Bool
datatypeName :: Name
datatypeName :: Datatype -> Name
datatypeConstructors :: Datatype -> NonEmpty Con
datatypeIsWrapped :: Datatype -> Bool
..} = do
let saturatedType :: Type
saturatedType =
if Bool
datatypeIsWrapped
then Name -> Type
ConT Name
datatypeName Type -> Type -> Type
`AppT` Name -> Type
ConT ''Wrapped
else Name -> Type
ConT Name
datatypeName
Exp
parseRecordExpr <-
case NonEmpty Con
datatypeConstructors of
Con
singleConstructor :| [] -> do
Modifiers -> Con -> Q Exp
makeSingleCommand Modifiers
mods Con
singleConstructor
NonEmpty Con
subcommands -> do
[|asum|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (forall a. NonEmpty a -> [a]
NonEmpty.toList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Modifiers -> Con -> Q Exp
makeSubcommand Modifiers
mods) NonEmpty Con
subcommands))
[d|
instance ParseRecord $(pure saturatedType) where
parseRecord =
Options.helper <*> $(pure parseRecordExpr)
|]
makeSingleCommand :: Modifiers -> Con -> Q Exp
makeSingleCommand :: Modifiers -> Con -> Q Exp
makeSingleCommand Modifiers {String -> String
String -> Maybe Char
fieldNameModifier :: Modifiers -> String -> String
constructorNameModifier :: Modifiers -> String -> String
shortNameModifier :: Modifiers -> String -> Maybe Char
shortNameModifier :: String -> Maybe Char
constructorNameModifier :: String -> String
fieldNameModifier :: String -> String
..} Con
con = do
case Con
con of
NormalC Name
conName [BangType]
bangTypes -> do
Exp
baseCase <- [e|pure $(conE conName)|]
let apps :: m Exp -> (a, b) -> m Exp
apps m Exp
expr (a
_bang, b
_type) = do
let label :: Maybe Text
label = forall a. Maybe a
Nothing @Text
shortName :: Maybe Char
shortName = forall a. Maybe a
Nothing @Char
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just m Exp
expr) (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>)) (forall a. a -> Maybe a
Just [e|parseFields Nothing $(lift label) $(lift shortName) Nothing|])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {m :: * -> *} {a} {b}. Quote m => m Exp -> (a, b) -> m Exp
apps (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
baseCase) [BangType]
bangTypes
RecC Name
conName [VarBangType]
varBangTypes -> do
Exp
baseCase <- [e|pure $(conE conName)|]
let apps :: Q Exp -> VarBangType -> Q Exp
apps Q Exp
expr (Name
fieldName, Bang
_bang, Type
_type) = do
let fieldNameString :: String
fieldNameString =
Name -> String
nameBase Name
fieldName
label :: Maybe Text
label =
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
fieldNameModifier forall a b. (a -> b) -> a -> b
$ String
fieldNameString
shortName :: Maybe Char
shortName =
String -> Maybe Char
shortNameModifier String
fieldNameString
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
expr) (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>)) (forall a. a -> Maybe a
Just [e|parseFields Nothing $(lift label) $(lift shortName) Nothing|])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> VarBangType -> Q Exp
apps (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
baseCase) [VarBangType]
varBangTypes
Con
_ ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Expected either a normal or record constructor, got: "
, String
"\t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con
, String
"Other constructors are not supported yet."
]
getConName :: Con -> Q Name
getConName :: Con -> Q Name
getConName = \case
NormalC Name
n [BangType]
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
RecC Name
n [VarBangType]
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
Con
other ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Expected a normal or record constructor, got unsupported constructor: "
, String
"\t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
other
]
makeSubcommand :: Modifiers -> Con -> Q Exp
makeSubcommand :: Modifiers -> Con -> Q Exp
makeSubcommand modifiers :: Modifiers
modifiers@Modifiers {String -> String
String -> Maybe Char
shortNameModifier :: String -> Maybe Char
constructorNameModifier :: String -> String
fieldNameModifier :: String -> String
fieldNameModifier :: Modifiers -> String -> String
constructorNameModifier :: Modifiers -> String -> String
shortNameModifier :: Modifiers -> String -> Maybe Char
..} Con
con = do
Name
conName <- Con -> Q Name
getConName Con
con
Exp
singleCommandParserExpr <- Modifiers -> Con -> Q Exp
makeSingleCommand Modifiers
modifiers Con
con
let conNameString :: String
conNameString =
Name -> String
nameBase Name
conName
name :: String
name =
String -> String
constructorNameModifier String
conNameString
Exp
subparserFieldsExpr <-
[e|
Options.command
$(lift name)
( Options.info (Options.helper <*> $(pure singleCommandParserExpr)) mempty
)
<> Options.metavar $(lift name)
|]
[e|Options.subparser $(pure subparserFieldsExpr)|]
#if MIN_VERSION_template_haskell(2,18,0)
mkConP :: Name -> [Pat] -> Pat
mkConP :: Name -> [Pat] -> Pat
mkConP Name
name [Pat]
pats = Name -> Cxt -> [Pat] -> Pat
ConP Name
name [] [Pat]
pats
#else
mkConP :: Name -> [Pat] -> Pat
mkConP name pats = ConP name pats
#endif