{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}

-- | Quasi-quoter support for large records
--
-- NOTE: The only reason for the existence of this module is that record pattern
-- syonyms in @ghc@ are currently not useable: when we declare a record pattern
-- synonym, @ghc@ automatically derives field accessors for every field in the
-- record. We don't want those accessors: they result in name clashes
-- (DuplicateRecordFields does not apply to record pattern synonyms) and, more
-- importantly, they result in quadratic code size again. Once the
-- @NoFieldSelectors@ language extension is merged (probably @ghc@ 9.2), we
-- can reconsider whether this module is still required.
--
-- See also:
--
-- * <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0160-no-toplevel-field-selectors.rst>
-- * <https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4743>
module Data.Record.QQ.CodeGen (
    lr

    -- * Exported for the benefit of tests
  , lrExp
  , lrPat
  ) where

import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax

import qualified Data.Generics         as SYB
import qualified Language.Haskell.Exts as HSE
import qualified Language.Haskell.Meta as HSE.Meta

import Data.Record.Internal.CodeGen
import Data.Record.Internal.Naming
import Data.Record.Internal.Record
import Data.Record.Internal.TH.Util
import Data.Record.QQ.CodeGen.HSE
import Data.Record.QQ.CodeGen.Parser
import Data.Record.QQ.Runtime.MatchHasField
import Data.Record.TH.CodeGen.Tree

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

{-------------------------------------------------------------------------------
  Top-level quasi-quoter
-------------------------------------------------------------------------------}

-- | Construct or match on @large-records@-style records
--
-- Example construction usage:
--
-- > inOrder :: R Bool
-- > inOrder = [lr| MkR { x = 1234, y = [True] } |]
--
-- or:
--
-- > constructorApp :: R Bool
-- > constructorApp = [lr| MkR |] 1234 [True]
--
-- Example matching usage:
--
-- > projectOne :: T Bool -> Int
-- > projectOne [lr| MkT { x = a } |] = a
lr :: QuasiQuoter
lr :: QuasiQuoter
lr = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter {
      quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
forall (m :: Type -> Type). Quasi m => String -> m Exp
lrExp
    , quotePat :: String -> Q Pat
quotePat  = String -> Q Pat
forall (m :: Type -> Type). Quasi m => String -> m Pat
lrPat
    , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. String -> Q a
unsupported
    , quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
forall a. String -> Q a
unsupported
    }
  where
    unsupported :: String -> Q a
    unsupported :: String -> Q a
unsupported String
_ = String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"lr can only be used for expressions or patterns"

{-------------------------------------------------------------------------------
  Individual quasi-quoters
-------------------------------------------------------------------------------}

lrExp :: forall m. Quasi m => String -> m Exp
lrExp :: String -> m Exp
lrExp = \String
str -> do
    [Extension]
exts <- Q [Extension] -> m [Extension]
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ Q [Extension]
extsEnabled
    case [Extension] -> String -> Either String Exp
parseExp [Extension]
exts String
str of
      Left  String
err  -> String -> m Exp
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String -> String
parseErr String
err
      Right Exp
expr -> Exp -> m Exp
forall (m :: Type -> Type). Quasi m => Exp -> m Exp
construct Exp
expr
  where
    parseExp :: [Extension] -> String -> Either String Exp
    parseExp :: [Extension] -> String -> Either String Exp
parseExp [Extension]
exts String
str =
        case ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
HSE.parseExpWithMode ([Extension] -> ParseMode
parseMode [Extension]
exts) String
str of
          HSE.ParseFailed SrcLoc
_loc String
err -> String -> Either String Exp
forall a b. a -> Either a b
Left String
err
          HSE.ParseOk Exp SrcSpanInfo
e -> Exp -> Either String Exp
forall a b. b -> Either a b
Right (Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
HSE.Meta.toExp Exp SrcSpanInfo
e)

    parseErr :: String -> String
    parseErr :: String -> String
parseErr String
err = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [
          String
"Could not parse expression: "
        , (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then Char
' ' else Char
c) String
err
        ]

lrPat :: forall m. Quasi m => String -> m Pat
lrPat :: String -> m Pat
lrPat = \String
str -> do
    [Extension]
exts <- Q [Extension] -> m [Extension]
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ Q [Extension]
extsEnabled
    case [Extension] -> String -> Either String Pat
parsePat [Extension]
exts String
str of
      Left  String
err  -> String -> m Pat
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m Pat) -> String -> m Pat
forall a b. (a -> b) -> a -> b
$ String -> String
parseErr String
err
      Right Pat
expr -> Pat -> m Pat
forall (m :: Type -> Type). Quasi m => Pat -> m Pat
deconstruct Pat
expr
  where
    parsePat :: [Extension] -> String -> Either String Pat
    parsePat :: [Extension] -> String -> Either String Pat
parsePat [Extension]
exts String
str =
        case ParseMode -> String -> ParseResult (Pat SrcSpanInfo)
HSE.parsePatWithMode ([Extension] -> ParseMode
parseMode [Extension]
exts) String
str of
          HSE.ParseFailed SrcLoc
_loc String
err -> String -> Either String Pat
forall a b. a -> Either a b
Left String
err
          HSE.ParseOk Pat SrcSpanInfo
p -> Pat -> Either String Pat
forall a b. b -> Either a b
Right (Pat SrcSpanInfo -> Pat
forall a. ToPat a => a -> Pat
HSE.Meta.toPat (Pat SrcSpanInfo -> Pat SrcSpanInfo
forall l. Data l => Pat l -> Pat l
processRecordPuns Pat SrcSpanInfo
p))

    parseErr :: String -> String
    parseErr :: String -> String
parseErr String
err = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [
          String
"Could not parse pattern: "
        , (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then Char
' ' else Char
c) String
err
        ]

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

construct :: forall m. Quasi m => Exp -> m Exp
construct :: Exp -> m Exp
construct = \case
    ConE Name
constr -> do
      Name 'VarName 'Global
constrFn <- (String -> String)
-> Name Any 'Dynamic -> m (Name 'VarName 'Global)
forall (m :: Type -> Type) (ns' :: NameSpace) (ns :: NameSpace).
(Quasi m, LookupName ns') =>
(String -> String) -> Name ns 'Dynamic -> m (Name ns' 'Global)
resolveKnownHseName String -> String
nameRecordTypedConstructorFn (Name -> Name Any 'Dynamic
forall (flavour :: NameSpace). Name -> Name flavour 'Dynamic
fromHseName Name
constr)
      Q Exp -> m Exp
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (Q Exp -> m Exp) -> Q Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Name 'VarName 'Global -> Q Exp
forall (flavour :: Flavour). Name 'VarName flavour -> Q Exp
N.varE Name 'VarName 'Global
constrFn
    Exp
expr ->
      -- Assume this is a record construction expression
      GenericM m -> Exp -> m Exp
forall (m :: Type -> Type). Monad m => GenericM m -> GenericM m
SYB.everywhereM ((Exp -> m Exp) -> a -> m a
forall (m :: Type -> Type) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
SYB.mkM Exp -> m Exp
go) Exp
expr
  where
    go :: Exp -> m Exp
    go :: Exp -> m Exp
go Exp
e = do
        Maybe (ParsedRecordInfo Exp)
mTerm <- Exp -> m (Maybe (ParsedRecordInfo Exp))
forall (m :: Type -> Type).
Quasi m =>
Exp -> m (Maybe (ParsedRecordInfo Exp))
parseRecordExp Exp
e
        case Maybe (ParsedRecordInfo Exp)
mTerm of
          Maybe (ParsedRecordInfo Exp)
Nothing ->
            -- Leave non-record expressions alone
            Exp -> m Exp
forall (m :: Type -> Type) a. Monad m => a -> m a
return Exp
e
          Just ParsedRecordInfo Exp
NotKnownLargeRecord ->
            Exp -> m Exp
forall (m :: Type -> Type) a. Monad m => a -> m a
return Exp
e
          Just (UnknownFields [String]
unknown) -> Q Exp -> m Exp
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (Q Exp -> m Exp) -> Q Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ do
            String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown fields: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
unknown
            [| undefined |]
          Just (ParsedRecordInfo Qualifier
qual Record{String
[TyVarBndr]
[Field (Maybe Exp)]
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
recordFields :: [Field (Maybe Exp)]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
..}) -> Q Exp -> m Exp
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (Q Exp -> m Exp) -> Q Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ do
            [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name 'VarName 'Dynamic -> Q Exp
forall (flavour :: Flavour). Name 'VarName flavour -> Q Exp
N.varE (Qualifier -> String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). Qualifier -> String -> Name ns 'Dynamic
N.qualify Qualifier
qual (String -> String
nameRecordTypedConstructorFn String
recordConstr))
                  Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Field (Maybe Exp) -> Q Exp) -> [Field (Maybe Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Field (Maybe Exp) -> Q Exp
mkArg [Field (Maybe Exp)]
recordFields

    mkArg :: Field (Maybe Exp) -> Q Exp
    mkArg :: Field (Maybe Exp) -> Q Exp
mkArg Field{Int
String
Maybe Exp
Type
fieldVal :: forall a. Field a -> a
fieldIndex :: forall a. Field a -> Int
fieldType :: forall a. Field a -> Type
fieldName :: forall a. Field a -> String
fieldVal :: Maybe Exp
fieldIndex :: Int
fieldType :: Type
fieldName :: String
..}
      | Just Exp
e <- Maybe Exp
fieldVal = Exp -> Q Exp
forall (m :: Type -> Type) a. Monad m => a -> m a
return Exp
e
      | Bool
otherwise = do
          String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"No value for field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldName
          [| error $ "No value given for field " ++ $(lift fieldName) |]

{-------------------------------------------------------------------------------
  Deconstruction
-------------------------------------------------------------------------------}

deconstruct :: forall m. Quasi m => Pat -> m Pat
deconstruct :: Pat -> m Pat
deconstruct = \Pat
pat -> do
    [Extension] -> m ()
forall (m :: Type -> Type). Quasi m => [Extension] -> m ()
requiresExtensions [Extension
TypeApplications, Extension
ViewPatterns, Extension
DataKinds]
    GenericM m -> Pat -> m Pat
forall (m :: Type -> Type). Monad m => GenericM m -> GenericM m
SYB.everywhereM ((Pat -> m Pat) -> a -> m a
forall (m :: Type -> Type) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
SYB.mkM Pat -> m Pat
go) Pat
pat
  where
    go :: Pat -> m Pat
    go :: Pat -> m Pat
go Pat
p = do
         Maybe (ParsedRecordInfo Pat)
mTerm <- Pat -> m (Maybe (ParsedRecordInfo Pat))
forall (m :: Type -> Type).
Quasi m =>
Pat -> m (Maybe (ParsedRecordInfo Pat))
parseRecordPat Pat
p
         case Maybe (ParsedRecordInfo Pat)
mTerm of
           Maybe (ParsedRecordInfo Pat)
Nothing -> -- Not a record pattern
             Pat -> m Pat
forall (m :: Type -> Type) a. Monad m => a -> m a
return Pat
p
           Just ParsedRecordInfo Pat
NotKnownLargeRecord ->
             Pat -> m Pat
forall (m :: Type -> Type) a. Monad m => a -> m a
return Pat
p
           Just (UnknownFields [String]
unknown) -> Q Pat -> m Pat
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (Q Pat -> m Pat) -> Q Pat -> m Pat
forall a b. (a -> b) -> a -> b
$ do
             String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown fields: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
unknown
             Pat -> Q Pat
forall (m :: Type -> Type) a. Monad m => a -> m a
return Pat
p
           Just (ParsedRecordInfo Qualifier
qual Record (Maybe Pat)
r) -> Q Pat -> m Pat
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (Q Pat -> m Pat) -> Q Pat -> m Pat
forall a b. (a -> b) -> a -> b
$
             Q Exp -> Q Pat -> Q Pat
viewP (Name -> Q Exp
varE 'viewAtType Q Exp -> Q Exp -> Q Exp
`appE` Qualifier -> Record (Maybe Pat) -> Q Exp
forall a. Qualifier -> Record a -> Q Exp
recordUndefinedValueE Qualifier
qual Record (Maybe Pat)
r) (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$
               case Record Pat -> [Field Pat]
forall a. Record a -> [Field a]
recordFields (Record (Maybe Pat) -> Record Pat
forall a. Record (Maybe a) -> Record a
dropMissingRecordFields Record (Maybe Pat)
r) of
                 [] -> Q Pat
wildP
                 [Field Pat]
fs -> [Field Pat] -> Q Pat
outerViewPat [Field Pat]
fs

    outerViewPat :: [Field Pat] -> Q Pat
    outerViewPat :: [Field Pat] -> Q Pat
outerViewPat [Field Pat]
fs =
        Q Exp -> Q Pat -> Q Pat
viewP (Name -> Q Exp
varE 'matchHasField) (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$
          (Field Pat -> Q Pat) -> Forest (Field Pat) -> Q Pat
forall a. (a -> Q Pat) -> Forest a -> Q Pat
mkTupleP Field Pat -> Q Pat
innerViewPat (Forest (Field Pat) -> Q Pat) -> Forest (Field Pat) -> Q Pat
forall a b. (a -> b) -> a -> b
$ TupleLimit -> [Field Pat] -> Forest (Field Pat)
forall a. TupleLimit -> [a] -> Forest a
nest (Int -> TupleLimit
MaxTupleElems Int
2) [Field Pat]
fs

    innerViewPat :: Field Pat -> Q Pat
    innerViewPat :: Field Pat -> Q Pat
innerViewPat f :: Field Pat
f@Field{Int
String
Pat
Type
fieldVal :: Pat
fieldIndex :: Int
fieldType :: Type
fieldName :: String
fieldVal :: forall a. Field a -> a
fieldIndex :: forall a. Field a -> Int
fieldType :: forall a. Field a -> Type
fieldName :: forall a. Field a -> String
..} =
        Q Exp -> Q Pat -> Q Pat
viewP
          (Name -> Q Exp
varE 'fieldNamed Q Exp -> Q Type -> Q Exp
`appTypeE` Field Pat -> Q Type
forall a. Field a -> Q Type
fieldNameT Field Pat
f)
          (Pat -> Q Pat
forall (m :: Type -> Type) a. Monad m => a -> m a
return Pat
fieldVal)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

parseMode :: [Extension] -> HSE.ParseMode
parseMode :: [Extension] -> ParseMode
parseMode [Extension]
exts = ParseMode
HSE.defaultParseMode {
      extensions :: [Extension]
HSE.extensions = [[Extension]] -> [Extension]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [
          -- Include extensions enabled in the module
          (Extension -> Extension) -> [Extension] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> Extension
extensionFromTH [Extension]
exts

          -- But also include the default
          --
          -- We do this primarily because 'fromTH' doesn't actually parse
          -- all extensions
        , ParseMode -> [Extension]
HSE.extensions ParseMode
HSE.defaultParseMode
        ]
    }