Parser.hs

{-# 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 = traverse (uncurry parseRecordInfo) . termExp

parseRecordPat :: Quasi m => Pat -> m (Maybe (ParsedRecordInfo Pat))
parseRecordPat = traverse (uncurry parseRecordInfo) . 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 userConstr fields = do
    mInternalConstr <- resolveHseName nameRecordInternalConstr userConstr
    case mInternalConstr of
      Nothing ->
        return NotKnownLargeRecord
      Just internalConstr ->
        aux <$> resolveRecord (N.nameBase userConstr) internalConstr
  where
    aux :: Either String (Record ()) -> ParsedRecordInfo a
    aux (Left _err) = NotKnownLargeRecord
    aux (Right r)   =
        case matchRecordFields fields r of
          (r', []) -> ParsedRecordInfo  (N.nameQualifier userConstr) (snd <$> r')
          (_ , un) -> UnknownFields 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 (RecConE constr fields) = Just (
      fromHseName constr
    , map (first TH.nameBase) fields
    )
termExp _otherwise = Nothing

termPat :: Pat -> Maybe (N.Name 'DataName 'N.Dynamic, [(String, TH.Pat)])
termPat (RecP constr fields) = Just (
      fromHseName constr
    , map (first TH.nameBase) fields
    )
termPat _otherwise = Nothing