{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Record.QQ.CodeGen.Parser (
    ParsedRecordInfo(..)
  , parseRecordExp
  , parseRecordPat
  ) where

import Data.Bifunctor
import Language.Haskell.TH (Exp(RecConE), Pat(RecP))
import Language.Haskell.TH.Syntax (Quasi, NameSpace(..))

import qualified Language.Haskell.TH.Syntax as TH

import Data.Record.Internal.Naming
import Data.Record.Internal.Record
import Data.Record.Internal.Record.Resolution
import Data.Record.QQ.CodeGen.HSE

import qualified Data.Record.Internal.TH.Name as N

data ParsedRecordInfo a =
    -- | The pattern/value we matched against is not a (known) large record
    NotKnownLargeRecord

    -- | The pattern/value has fields not present in the record definition
  | UnknownFields [String]

    -- | Successfully matched against a known large records
    --
    -- Note that not all fields may have a corresponding value/pattern.
    --
    -- In addition to the record info, we also record the qualifier used in
    -- the original name.
  | ParsedRecordInfo N.Qualifier (Record (Maybe a))

parseRecordExp :: Quasi m => Exp -> m (Maybe (ParsedRecordInfo Exp))
parseRecordExp :: Exp -> m (Maybe (ParsedRecordInfo Exp))
parseRecordExp = ((Name 'DataName 'Dynamic, [(String, Exp)])
 -> m (ParsedRecordInfo Exp))
-> Maybe (Name 'DataName 'Dynamic, [(String, Exp)])
-> m (Maybe (ParsedRecordInfo Exp))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Name 'DataName 'Dynamic
 -> [(String, Exp)] -> m (ParsedRecordInfo Exp))
-> (Name 'DataName 'Dynamic, [(String, Exp)])
-> m (ParsedRecordInfo Exp)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name 'DataName 'Dynamic
-> [(String, Exp)] -> m (ParsedRecordInfo Exp)
forall (m :: Type -> Type) a.
Quasi m =>
Name 'DataName 'Dynamic -> [(String, a)] -> m (ParsedRecordInfo a)
parseRecordInfo) (Maybe (Name 'DataName 'Dynamic, [(String, Exp)])
 -> m (Maybe (ParsedRecordInfo Exp)))
-> (Exp -> Maybe (Name 'DataName 'Dynamic, [(String, Exp)]))
-> Exp
-> m (Maybe (ParsedRecordInfo Exp))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Maybe (Name 'DataName 'Dynamic, [(String, Exp)])
termExp

parseRecordPat :: Quasi m => Pat -> m (Maybe (ParsedRecordInfo Pat))
parseRecordPat :: Pat -> m (Maybe (ParsedRecordInfo Pat))
parseRecordPat = ((Name 'DataName 'Dynamic, [(String, Pat)])
 -> m (ParsedRecordInfo Pat))
-> Maybe (Name 'DataName 'Dynamic, [(String, Pat)])
-> m (Maybe (ParsedRecordInfo Pat))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Name 'DataName 'Dynamic
 -> [(String, Pat)] -> m (ParsedRecordInfo Pat))
-> (Name 'DataName 'Dynamic, [(String, Pat)])
-> m (ParsedRecordInfo Pat)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name 'DataName 'Dynamic
-> [(String, Pat)] -> m (ParsedRecordInfo Pat)
forall (m :: Type -> Type) a.
Quasi m =>
Name 'DataName 'Dynamic -> [(String, a)] -> m (ParsedRecordInfo a)
parseRecordInfo) (Maybe (Name 'DataName 'Dynamic, [(String, Pat)])
 -> m (Maybe (ParsedRecordInfo Pat)))
-> (Pat -> Maybe (Name 'DataName 'Dynamic, [(String, Pat)]))
-> Pat
-> m (Maybe (ParsedRecordInfo Pat))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> Maybe (Name 'DataName 'Dynamic, [(String, Pat)])
termPat

-- | Try to match a pattern or expression against a (large) record
parseRecordInfo ::
     forall m a. Quasi m
  => N.Name 'DataName 'N.Dynamic
  -> [(String, a)]
  -> m (ParsedRecordInfo a)
parseRecordInfo :: Name 'DataName 'Dynamic -> [(String, a)] -> m (ParsedRecordInfo a)
parseRecordInfo Name 'DataName 'Dynamic
userConstr [(String, a)]
fields = do
    Maybe (Name 'DataName 'Global)
mInternalConstr <- (String -> String)
-> Name 'DataName 'Dynamic -> m (Maybe (Name 'DataName 'Global))
forall (m :: Type -> Type) (ns' :: NameSpace) (ns :: NameSpace).
(Quasi m, LookupName ns') =>
(String -> String)
-> Name ns 'Dynamic -> m (Maybe (Name ns' 'Global))
resolveHseName String -> String
nameRecordInternalConstr Name 'DataName 'Dynamic
userConstr
    case Maybe (Name 'DataName 'Global)
mInternalConstr of
      Maybe (Name 'DataName 'Global)
Nothing ->
        ParsedRecordInfo a -> m (ParsedRecordInfo a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ParsedRecordInfo a
forall a. ParsedRecordInfo a
NotKnownLargeRecord
      Just Name 'DataName 'Global
internalConstr ->
        Either String (Record ()) -> ParsedRecordInfo a
aux (Either String (Record ()) -> ParsedRecordInfo a)
-> m (Either String (Record ())) -> m (ParsedRecordInfo a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Name 'DataName 'Global -> m (Either String (Record ()))
forall (m :: Type -> Type).
Quasi m =>
String -> Name 'DataName 'Global -> m (Either String (Record ()))
resolveRecord (Name 'DataName 'Dynamic -> String
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> String
N.nameBase Name 'DataName 'Dynamic
userConstr) Name 'DataName 'Global
internalConstr
  where
    aux :: Either String (Record ()) -> ParsedRecordInfo a
    aux :: Either String (Record ()) -> ParsedRecordInfo a
aux (Left String
_err) = ParsedRecordInfo a
forall a. ParsedRecordInfo a
NotKnownLargeRecord
    aux (Right Record ()
r)   =
        case [(String, a)] -> Record () -> (Record ((), Maybe a), [String])
forall a b.
[(String, b)] -> Record a -> (Record (a, Maybe b), [String])
matchRecordFields [(String, a)]
fields Record ()
r of
          (Record ((), Maybe a)
r', []) -> Qualifier -> Record (Maybe a) -> ParsedRecordInfo a
forall a. Qualifier -> Record (Maybe a) -> ParsedRecordInfo a
ParsedRecordInfo  (Name 'DataName 'Dynamic -> Qualifier
forall (ns :: NameSpace). Name ns 'Dynamic -> Qualifier
N.nameQualifier Name 'DataName 'Dynamic
userConstr) (((), Maybe a) -> Maybe a
forall a b. (a, b) -> b
snd (((), Maybe a) -> Maybe a)
-> Record ((), Maybe a) -> Record (Maybe a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Record ((), Maybe a)
r')
          (Record ((), Maybe a)
_ , [String]
un) -> [String] -> ParsedRecordInfo a
forall a. [String] -> ParsedRecordInfo a
UnknownFields [String]
un

{-------------------------------------------------------------------------------
  Match against the syntax tree generated by @haskell-src-exts@

  We ignore any qualifiers for field names.
-------------------------------------------------------------------------------}

termExp :: Exp -> Maybe (N.Name 'DataName 'N.Dynamic, [(String, TH.Exp)])
termExp :: Exp -> Maybe (Name 'DataName 'Dynamic, [(String, Exp)])
termExp (RecConE Name
constr [FieldExp]
fields) = (Name 'DataName 'Dynamic, [(String, Exp)])
-> Maybe (Name 'DataName 'Dynamic, [(String, Exp)])
forall a. a -> Maybe a
Just (
      Name -> Name 'DataName 'Dynamic
forall (flavour :: NameSpace). Name -> Name flavour 'Dynamic
fromHseName Name
constr
    , (FieldExp -> (String, Exp)) -> [FieldExp] -> [(String, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> String) -> FieldExp -> (String, Exp)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Name -> String
TH.nameBase) [FieldExp]
fields
    )
termExp Exp
_otherwise = Maybe (Name 'DataName 'Dynamic, [(String, Exp)])
forall a. Maybe a
Nothing

termPat :: Pat -> Maybe (N.Name 'DataName 'N.Dynamic, [(String, TH.Pat)])
termPat :: Pat -> Maybe (Name 'DataName 'Dynamic, [(String, Pat)])
termPat (RecP Name
constr [FieldPat]
fields) = (Name 'DataName 'Dynamic, [(String, Pat)])
-> Maybe (Name 'DataName 'Dynamic, [(String, Pat)])
forall a. a -> Maybe a
Just (
      Name -> Name 'DataName 'Dynamic
forall (flavour :: NameSpace). Name -> Name flavour 'Dynamic
fromHseName Name
constr
    , (FieldPat -> (String, Pat)) -> [FieldPat] -> [(String, Pat)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> String) -> FieldPat -> (String, Pat)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Name -> String
TH.nameBase) [FieldPat]
fields
    )
termPat Pat
_otherwise = Maybe (Name 'DataName 'Dynamic, [(String, Pat)])
forall a. Maybe a
Nothing