{-# 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

{-------------------------------------------------------------------------------
  Record instances
-------------------------------------------------------------------------------}

data RecordInstances = RecordInstances {
      -- | Explicitly supported type class instances
      RecordInstances -> [Deriving]
recordInstancesDerived :: [Deriving]

      -- | Anyclass deriving
      --
      -- We list these separately, because we need to add these as anyclass
      -- deriving classes when defining the newtype, rather than as standalone
      -- deriving instances. (If we don't, we need to duplicate ghc's logic for
      -- figuring out how many parameters to provide to the datatype.)
    , 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)

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}

-- | Try to match a record declaration
--
-- We use 'Maybe' in these matching functions, along with 'reportError', so that
-- we can report multiple errors rather than stopping at the first.
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

-- | Support deriving clauses
--
-- We return the anyclass deriving clauses separately.
-- See 'recordAnyclass' for more details.
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

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

-- When @DuplicateRecordFields@ is enabled, it produces field names such as
-- @$sel:a:MkY@. We don't really care much about 'DuplicateRecordFields',
-- insofar as that we will not try to be compatible with DRF-style
-- overloading (all overloading must happen through 'HasField' instead).
-- We do however need to recover the original field name.
--
-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/records/overloaded-record-fields/duplicate-record-fields>
-- <https://gitlab.haskell.org/ghc/ghc/-/issues/14848>
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