{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Record.Internal.Record.Parser (
RecordInstances(..)
, Deriving(..)
, parseRecordDef
) where
import Data.Either (partitionEithers)
import Data.Maybe (catMaybes)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Record.Internal.Record
import Data.Record.Internal.TH.Util
import Data.Record.Internal.Util
data RecordInstances = RecordInstances {
RecordInstances -> [Deriving]
recordInstancesDerived :: [Deriving]
, RecordInstances -> [Type]
recordInstancesAnyclass :: [Type]
}
data Deriving =
DeriveEq
| DeriveOrd
| DeriveShow
deriving (Int -> Deriving -> ShowS
[Deriving] -> ShowS
Deriving -> String
(Int -> Deriving -> ShowS)
-> (Deriving -> String) -> ([Deriving] -> ShowS) -> Show Deriving
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Deriving] -> ShowS
$cshowList :: [Deriving] -> ShowS
show :: Deriving -> String
$cshow :: Deriving -> String
showsPrec :: Int -> Deriving -> ShowS
$cshowsPrec :: Int -> Deriving -> ShowS
Show)
parseRecordDef :: Dec -> Q (Maybe (Record (), RecordInstances))
parseRecordDef :: Dec -> Q (Maybe (Record (), RecordInstances))
parseRecordDef (DataD
_cxt :: [Type]
_cxt@[]
Name
typeName
[TyVarBndr]
tyVarBndrs
_kind :: Maybe Type
_kind@Maybe Type
Nothing
[RecC Name
constrName [VarBangType]
fieldTypes]
[DerivClause]
derivClauses
) = do
[Field ()]
fields <- [Maybe (Field ())] -> [Field ()]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Field ())] -> [Field ()])
-> Q [Maybe (Field ())] -> Q [Field ()]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
((Int, VarBangType) -> Q (Maybe (Field ())))
-> [(Int, VarBangType)] -> Q [Maybe (Field ())]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, VarBangType) -> Q (Maybe (Field ()))
parseFieldDef ([Int] -> [VarBangType] -> [(Int, VarBangType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [VarBangType]
fieldTypes)
([Deriving]
deriv, [Type]
anyclass) <- [Either Deriving Type] -> ([Deriving], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Deriving Type] -> ([Deriving], [Type]))
-> Q [Either Deriving Type] -> Q ([Deriving], [Type])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
(DerivClause -> Q [Either Deriving Type])
-> [DerivClause] -> Q [Either Deriving Type]
forall (m :: Type -> Type) a b.
Applicative m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM DerivClause -> Q [Either Deriving Type]
parseDeriv [DerivClause]
derivClauses
Maybe (Record (), RecordInstances)
-> Q (Maybe (Record (), RecordInstances))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (Record (), RecordInstances)
-> Q (Maybe (Record (), RecordInstances)))
-> Maybe (Record (), RecordInstances)
-> Q (Maybe (Record (), RecordInstances))
forall a b. (a -> b) -> a -> b
$ (Record (), RecordInstances) -> Maybe (Record (), RecordInstances)
forall a. a -> Maybe a
Just (
Record :: forall a. String -> String -> [TyVarBndr] -> [Field a] -> Record a
Record {
recordType :: String
recordType = Name -> String
nameBase Name
typeName
, recordConstr :: String
recordConstr = Name -> String
nameBase Name
constrName
, recordTVars :: [TyVarBndr]
recordTVars = [TyVarBndr]
tyVarBndrs
, recordFields :: [Field ()]
recordFields = [Field ()]
fields
}
, RecordInstances :: [Deriving] -> [Type] -> RecordInstances
RecordInstances {
recordInstancesDerived :: [Deriving]
recordInstancesDerived = [Deriving]
deriv
, recordInstancesAnyclass :: [Type]
recordInstancesAnyclass = [Type]
anyclass
}
)
parseRecordDef Dec
d = do
String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported declaration: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show Dec
d
Maybe (Record (), RecordInstances)
-> Q (Maybe (Record (), RecordInstances))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Record (), RecordInstances)
forall a. Maybe a
Nothing
parseDeriv :: DerivClause -> Q [Either Deriving Type]
parseDeriv :: DerivClause -> Q [Either Deriving Type]
parseDeriv = \case
DerivClause Maybe DerivStrategy
Nothing [Type]
cs ->
(Deriving -> Either Deriving Type)
-> [Deriving] -> [Either Deriving Type]
forall a b. (a -> b) -> [a] -> [b]
map Deriving -> Either Deriving Type
forall a b. a -> Either a b
Left ([Deriving] -> [Either Deriving Type])
-> Q [Deriving] -> Q [Either Deriving Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> Q [Deriving]
derivStock [Type]
cs
DerivClause (Just DerivStrategy
StockStrategy) [Type]
cs ->
(Deriving -> Either Deriving Type)
-> [Deriving] -> [Either Deriving Type]
forall a b. (a -> b) -> [a] -> [b]
map Deriving -> Either Deriving Type
forall a b. a -> Either a b
Left ([Deriving] -> [Either Deriving Type])
-> Q [Deriving] -> Q [Either Deriving Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> Q [Deriving]
derivStock [Type]
cs
DerivClause (Just DerivStrategy
AnyclassStrategy) [Type]
cs ->
[Either Deriving Type] -> Q [Either Deriving Type]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Either Deriving Type] -> Q [Either Deriving Type])
-> [Either Deriving Type] -> Q [Either Deriving Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Either Deriving Type) -> [Type] -> [Either Deriving Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Either Deriving Type
forall a b. b -> Either a b
Right [Type]
cs
DerivClause Maybe DerivStrategy
strategy [Type]
_ -> do
String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported deriving strategy " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe DerivStrategy -> String
forall a. Show a => a -> String
show Maybe DerivStrategy
strategy
[Either Deriving Type] -> Q [Either Deriving Type]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
where
derivStock :: [Type] -> Q [Deriving]
derivStock [Type]
cs = [Maybe Deriving] -> [Deriving]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Deriving] -> [Deriving])
-> Q [Maybe Deriving] -> Q [Deriving]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q (Maybe Deriving)) -> [Type] -> Q [Maybe Deriving]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Maybe Deriving)
go [Type]
cs
go :: Pred -> Q (Maybe Deriving)
go :: Type -> Q (Maybe Deriving)
go Type
p | Type
p Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Eq = Maybe Deriving -> Q (Maybe Deriving)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Deriving -> Q (Maybe Deriving))
-> Maybe Deriving -> Q (Maybe Deriving)
forall a b. (a -> b) -> a -> b
$ Deriving -> Maybe Deriving
forall a. a -> Maybe a
Just Deriving
DeriveEq
| Type
p Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Ord = Maybe Deriving -> Q (Maybe Deriving)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Deriving -> Q (Maybe Deriving))
-> Maybe Deriving -> Q (Maybe Deriving)
forall a b. (a -> b) -> a -> b
$ Deriving -> Maybe Deriving
forall a. a -> Maybe a
Just Deriving
DeriveOrd
| Type
p Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Show = Maybe Deriving -> Q (Maybe Deriving)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Deriving -> Q (Maybe Deriving))
-> Maybe Deriving -> Q (Maybe Deriving)
forall a b. (a -> b) -> a -> b
$ Deriving -> Maybe Deriving
forall a. a -> Maybe a
Just Deriving
DeriveShow
| Bool
otherwise = do
String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot derive instance for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
p
Maybe Deriving -> Q (Maybe Deriving)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Deriving
forall a. Maybe a
Nothing
parseFieldDef :: (Int, VarBangType) -> Q (Maybe (Field ()))
parseFieldDef :: (Int, VarBangType) -> Q (Maybe (Field ()))
parseFieldDef (Int
i, (Name
nm, Bang
bng, Type
typ)) =
case Bang
bng of
Bang
DefaultBang ->
Maybe (Field ()) -> Q (Maybe (Field ()))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (Field ()) -> Q (Maybe (Field ())))
-> (Field () -> Maybe (Field ()))
-> Field ()
-> Q (Maybe (Field ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field () -> Maybe (Field ())
forall a. a -> Maybe a
Just (Field () -> Q (Maybe (Field ())))
-> Field () -> Q (Maybe (Field ()))
forall a b. (a -> b) -> a -> b
$ Field :: forall a. String -> Type -> Int -> a -> Field a
Field {
fieldName :: String
fieldName = Name -> String
unqualify Name
nm
, fieldType :: Type
fieldType = Type
typ
, fieldIndex :: Int
fieldIndex = Int
i
, fieldVal :: ()
fieldVal = ()
}
Bang
_otherwise -> do
String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported bang type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bang -> String
forall a. Show a => a -> String
show Bang
bng
Maybe (Field ()) -> Q (Maybe (Field ()))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Field ())
forall a. Maybe a
Nothing
where
unqualify :: Name -> String
unqualify :: Name -> String
unqualify = ShowS
undoDRF ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
undoDRF :: String -> String
undoDRF :: ShowS
undoDRF String
nm =
case String
nm of
Char
'$' : String
drf -> (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
drf
String
_otherwise -> String
nm