{-# language TemplateHaskell #-}
module Data.Csv.TH
( deriveToNamedRecord,
deriveToRecord,
deriveDefaultOrdered,
deriveNamedRecord,
deriveFromNamedRecord,
deriveFromRecord,
deriveToAndFromRecord,
deriveToNamedRecordAndDefaultOrdered,
deriveToAndFromNamedRecordAndDefaultOrdered,
CsvOptions,
csvDefaultOptions,
)
where
import Data.Traversable
import Control.Monad
import Control.Monad.Fail
import Data.Csv qualified as Csv
import Data.Vector qualified as V
import Language.Haskell.TH
type CsvOptions = Csv.Options
csvDefaultOptions :: Csv.Options
csvDefaultOptions :: Options
csvDefaultOptions = Options
Csv.defaultOptions
deriveToNamedRecordAndDefaultOrdered :: Csv.Options -> Name -> DecsQ
deriveToNamedRecordAndDefaultOrdered :: Options -> Name -> DecsQ
deriveToNamedRecordAndDefaultOrdered Options
opts Name
name =
Options -> Name -> DecsQ
deriveToNamedRecord Options
opts Name
name forall a. Semigroup a => a -> a -> a
<> Options -> Name -> DecsQ
deriveDefaultOrdered Options
opts Name
name
deriveToAndFromNamedRecordAndDefaultOrdered :: Csv.Options -> Name -> DecsQ
deriveToAndFromNamedRecordAndDefaultOrdered :: Options -> Name -> DecsQ
deriveToAndFromNamedRecordAndDefaultOrdered Options
opts Name
name =
Options -> Name -> DecsQ
deriveToNamedRecord Options
opts Name
name
forall a. Semigroup a => a -> a -> a
<> Options -> Name -> DecsQ
deriveDefaultOrdered Options
opts Name
name
forall a. Semigroup a => a -> a -> a
<> Options -> Name -> DecsQ
deriveFromNamedRecord Options
opts Name
name
deriveToNamedRecord :: Csv.Options -> Name -> DecsQ
deriveToNamedRecord :: Options -> Name -> DecsQ
deriveToNamedRecord Options
opts Name
typName = do
Info
info <- Name -> Q Info
reify Name
typName
Con
con <-
case Info
info of
TyConI Dec
dec ->
case Dec
dec of
NewtypeD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind Con
con [DerivClause]
_derivs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
DataD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind [Con]
cons [DerivClause]
_derivs ->
case [Con]
cons of
[Con
con] ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
[Con]
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Dec
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Info
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected"
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a type name of a single record constructor."
]
(Pat
constrPatternMatch, [FieldName]
matchedVariables) <-
case Con
con of
RecC Name
constrName [VarBangType]
fields -> do
[FieldName]
namesWithPatterns <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [VarBangType]
fields \(Name
fieldName, Bang
_, Kind
_) -> do
Name -> Name -> FieldName
FieldName Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => [Char] -> m Name
newName (Name -> [Char]
nameBase Name
fieldName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Cxt -> [Pat] -> Pat
ConP Name
constrName [] (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Pat
VarP forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Name
fieldPatternVariable) [FieldName]
namesWithPatterns), [FieldName]
namesWithPatterns)
Con
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
"to be a record with a single constructor."
]
let fieldExpr :: FieldName -> Q Exp
fieldExpr FieldName
fieldName = do
let modifiedFieldName :: [Char]
modifiedFieldName =
Options -> [Char] -> [Char]
Csv.fieldLabelModifier Options
opts (Name -> [Char]
nameBase forall a b. (a -> b) -> a -> b
$ FieldName -> Name
fieldOriginalName FieldName
fieldName)
[e|
( $(litE $ StringL modifiedFieldName)
, Csv.toField $(varE (fieldPatternVariable fieldName))
)
|]
Exp
listExpr <-
[Exp] -> Exp
ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FieldName]
matchedVariables \FieldName
fieldName ->
FieldName -> Q Exp
fieldExpr FieldName
fieldName
[d|
instance Csv.ToNamedRecord $(conT typName) where
toNamedRecord val =
case val of
$(pure constrPatternMatch) ->
Csv.namedRecord $(pure listExpr)
|]
data FieldName = FieldName
{ FieldName -> Name
fieldOriginalName :: Name
, FieldName -> Name
fieldPatternVariable :: Name
}
deriveToRecord :: Name -> DecsQ
deriveToRecord :: Name -> DecsQ
deriveToRecord Name
typName = do
Info
info <- Name -> Q Info
reify Name
typName
[Con]
cons <-
case Info
info of
TyConI Dec
dec ->
case Dec
dec of
NewtypeD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind Con
con [DerivClause]
_derivs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con
con]
DataD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind [Con]
cons [DerivClause]
_derivs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cons
Dec
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a datatype."
]
Info
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected"
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a type name of a datatype."
]
[Match]
cases <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cons \case
NormalC Name
constrName [BangType]
bangTypes -> do
[Name]
names <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [BangType]
bangTypes \BangType
_ -> forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"p"
Exp
exprBody <-
Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'V.fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Name]
names \Name
name ->
[e|Csv.toField $(varE name)|]
let constrPattern :: Pat
constrPattern =
Name -> Cxt -> [Pat] -> Pat
ConP Name
constrName [] (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
constrPattern (Exp -> Body
NormalB Exp
exprBody) []
RecC Name
constrName [VarBangType]
varBangTypes -> do
[Name]
names <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [VarBangType]
varBangTypes \(Name
name, Bang
_, Kind
_) -> forall (m :: * -> *). Quote m => [Char] -> m Name
newName (Name -> [Char]
nameBase Name
name)
Exp
exprBody <-
Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'V.fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Name]
names \Name
name ->
[e|Csv.toField $(varE name)|]
let constrPattern :: Pat
constrPattern =
Name -> Cxt -> [Pat] -> Pat
ConP Name
constrName [] (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
constrPattern (Exp -> Body
NormalB Exp
exprBody) []
Con
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to have regular constructors"
]
[d|
instance Csv.ToRecord $(conT typName) where
toRecord =
$(pure $ LamCaseE cases)
|]
deriveDefaultOrdered :: CsvOptions -> Name -> DecsQ
deriveDefaultOrdered :: Options -> Name -> DecsQ
deriveDefaultOrdered Options
opts Name
typName = do
Info
info <- Name -> Q Info
reify Name
typName
Con
con <-
case Info
info of
TyConI Dec
dec ->
case Dec
dec of
NewtypeD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind Con
con [DerivClause]
_derivs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
DataD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind [Con]
cons [DerivClause]
_derivs ->
case [Con]
cons of
[Con
con] ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
[Con]
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Dec
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Info
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected"
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a type name of a single record constructor."
]
Exp
body <-
case Con
con of
RecC Name
_constrName [VarBangType]
varBangTypes -> do
[Exp] -> Exp
ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [VarBangType]
varBangTypes \(Name
fieldName, Bang
_, Kind
_) -> do
let modifiedFieldName :: [Char]
modifiedFieldName =
Options -> [Char] -> [Char]
Csv.fieldLabelModifier Options
opts (Name -> [Char]
nameBase Name
fieldName)
[e|$(litE $ StringL modifiedFieldName)|]
Con
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
"to be a record with a single constructor."
]
[d|
instance Csv.DefaultOrdered $(conT typName) where
headerOrder _ = V.fromList $(pure body)
|]
deriveNamedRecord :: CsvOptions -> Name -> DecsQ
deriveNamedRecord :: Options -> Name -> DecsQ
deriveNamedRecord Options
opts Name
typName =
Options -> Name -> DecsQ
deriveToNamedRecord Options
opts Name
typName forall a. Semigroup a => a -> a -> a
<> Options -> Name -> DecsQ
deriveFromNamedRecord Options
opts Name
typName
deriveFromNamedRecord :: CsvOptions -> Name -> DecsQ
deriveFromNamedRecord :: Options -> Name -> DecsQ
deriveFromNamedRecord Options
opts Name
typName = do
Info
info <- Name -> Q Info
reify Name
typName
Con
con <-
case Info
info of
TyConI Dec
dec ->
case Dec
dec of
NewtypeD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind Con
con [DerivClause]
_derivs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
DataD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind [Con]
cons [DerivClause]
_derivs ->
case [Con]
cons of
[Con
con] ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
[Con]
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Dec
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Info
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected"
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a type name of a single record constructor."
]
(Name
constrName, [Name]
fieldNames) <-
case Con
con of
RecC Name
constrName [VarBangType]
fields -> do
[Name]
namesWithPatterns <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [VarBangType]
fields \(Name
fieldName, Bang
_, Kind
_) -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
fieldName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
constrName, [Name]
namesWithPatterns)
Con
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
"to be a record with a single constructor."
]
Exp
lamExpr <- do
Name
arg <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"namedRecord"
let getFieldExpr :: Name -> Q Exp
getFieldExpr Name
fieldName = do
let modifiedFieldName :: [Char]
modifiedFieldName =
Options -> [Char] -> [Char]
Csv.fieldLabelModifier Options
opts (Name -> [Char]
nameBase Name
fieldName)
[e|$(varE arg) Csv..: $(litE $ StringL modifiedFieldName)|]
Exp
body <- do
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(\Exp
acc Name
fieldName -> [e|$(pure acc) <*> $(getFieldExpr fieldName)|])
(Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
constrName)
[Name]
fieldNames
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
arg] Exp
body
[d|
instance Csv.FromNamedRecord $(conT typName) where
parseNamedRecord = $(pure lamExpr)
|]
deriveFromRecord :: Name -> DecsQ
deriveFromRecord :: Name -> DecsQ
deriveFromRecord Name
typName = do
Info
info <- Name -> Q Info
reify Name
typName
Con
con <-
case Info
info of
TyConI Dec
dec ->
case Dec
dec of
NewtypeD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind Con
con [DerivClause]
_derivs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
DataD Cxt
_cxt Name
_name [TyVarBndr ()]
_tyvars Maybe Kind
_mkind [Con]
cons [DerivClause]
_derivs ->
case [Con]
cons of
[Con
con] ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
[Con]
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Dec
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a record with a single constructor."
]
Info
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected"
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
" to be a type name of a single record constructor."
]
(Name
constrName, Int
fieldCount) <-
case Con
con of
RecC Name
constrName [VarBangType]
fields -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
constrName, forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
fields)
NormalC Name
constrName [BangType]
fields ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
constrName, forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fields)
Con
_ ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Expected "
, forall a. Show a => a -> [Char]
show Name
typName
, [Char]
"to be a record with a single constructor."
]
Exp
lamExpr <- do
Name
arg <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"record"
let getFieldExpr :: Int -> Q Exp
getFieldExpr Int
idx = do
[e|$(varE arg) Csv..! idx|]
Exp
body <- do
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(\Exp
acc Int
fieldIndex -> [e|$(pure acc) <*> $(getFieldExpr fieldIndex)|])
(Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
constrName)
[Int
0 .. Int
fieldCount forall a. Num a => a -> a -> a
- Int
1]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
arg] Exp
body
[d|
instance Csv.FromRecord $(conT typName) where
parseRecord = $(pure lamExpr)
|]
deriveToAndFromRecord :: Name -> DecsQ
deriveToAndFromRecord :: Name -> DecsQ
deriveToAndFromRecord Name
name =
Name -> DecsQ
deriveToRecord Name
name forall a. Semigroup a => a -> a -> a
<> Name -> DecsQ
deriveFromRecord Name
name