{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Data.Record.QQ.CodeGen (
lr
, 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
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"
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
]
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 ->
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 ->
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) |]
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 ->
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)
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 [
(Extension -> Extension) -> [Extension] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> Extension
extensionFromTH [Extension]
exts
, ParseMode -> [Extension]
HSE.extensions ParseMode
HSE.defaultParseMode
]
}