{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Record.Internal.Plugin.Options (
LargeRecordOptions(..)
, largeRecord
, getLargeRecordOptions
) where
import Data.Bifunctor
import Data.Data (Data)
import Data.Map (Map)
import Data.Maybe (mapMaybe)
import qualified Data.Generics as SYB
import qualified Data.Map.Strict as Map
import Data.Record.Internal.GHC.Shim
import Data.Record.Internal.GHC.TemplateHaskellStyle
data LargeRecordOptions = LargeRecordOptions {
LargeRecordOptions -> Bool
debugLargeRecords :: Bool
}
deriving stock (Typeable LargeRecordOptions
DataType
Constr
Typeable LargeRecordOptions
-> (forall (c :: Type -> Type).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> LargeRecordOptions
-> c LargeRecordOptions)
-> (forall (c :: Type -> Type).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LargeRecordOptions)
-> (LargeRecordOptions -> Constr)
-> (LargeRecordOptions -> DataType)
-> (forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LargeRecordOptions))
-> (forall (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LargeRecordOptions))
-> ((forall b. Data b => b -> b)
-> LargeRecordOptions -> LargeRecordOptions)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r)
-> (forall u.
(forall d. Data d => d -> u) -> LargeRecordOptions -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> LargeRecordOptions -> u)
-> (forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions)
-> (forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions)
-> (forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions)
-> Data LargeRecordOptions
LargeRecordOptions -> DataType
LargeRecordOptions -> Constr
(forall b. Data b => b -> b)
-> LargeRecordOptions -> LargeRecordOptions
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> LargeRecordOptions
-> c LargeRecordOptions
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LargeRecordOptions
forall a.
Typeable a
-> (forall (c :: Type -> Type).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: Type -> Type).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> LargeRecordOptions -> u
forall u. (forall d. Data d => d -> u) -> LargeRecordOptions -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r
forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
forall (c :: Type -> Type).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LargeRecordOptions
forall (c :: Type -> Type).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> LargeRecordOptions
-> c LargeRecordOptions
forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LargeRecordOptions)
forall (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LargeRecordOptions)
$cLargeRecordOptions :: Constr
$tLargeRecordOptions :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
$cgmapMo :: forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
gmapMp :: (forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
$cgmapMp :: forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
gmapM :: (forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
$cgmapM :: forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d)
-> LargeRecordOptions -> m LargeRecordOptions
gmapQi :: Int -> (forall d. Data d => d -> u) -> LargeRecordOptions -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> LargeRecordOptions -> u
gmapQ :: (forall d. Data d => d -> u) -> LargeRecordOptions -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> LargeRecordOptions -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LargeRecordOptions -> r
gmapT :: (forall b. Data b => b -> b)
-> LargeRecordOptions -> LargeRecordOptions
$cgmapT :: (forall b. Data b => b -> b)
-> LargeRecordOptions -> LargeRecordOptions
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LargeRecordOptions)
$cdataCast2 :: forall (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LargeRecordOptions)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c LargeRecordOptions)
$cdataCast1 :: forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LargeRecordOptions)
dataTypeOf :: LargeRecordOptions -> DataType
$cdataTypeOf :: LargeRecordOptions -> DataType
toConstr :: LargeRecordOptions -> Constr
$ctoConstr :: LargeRecordOptions -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LargeRecordOptions
$cgunfold :: forall (c :: Type -> Type).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LargeRecordOptions
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> LargeRecordOptions
-> c LargeRecordOptions
$cgfoldl :: forall (c :: Type -> Type).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> LargeRecordOptions
-> c LargeRecordOptions
$cp1Data :: Typeable LargeRecordOptions
Data)
largeRecord :: LargeRecordOptions
largeRecord :: LargeRecordOptions
largeRecord = LargeRecordOptions :: Bool -> LargeRecordOptions
LargeRecordOptions {
debugLargeRecords :: Bool
debugLargeRecords = Bool
False
}
getLargeRecordOptions :: HsModule -> Map String [(SrcSpan, LargeRecordOptions)]
getLargeRecordOptions :: HsModule -> Map String [(SrcSpan, LargeRecordOptions)]
getLargeRecordOptions =
([(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)])
-> [(String, [(SrcSpan, LargeRecordOptions)])]
-> Map String [(SrcSpan, LargeRecordOptions)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)]
forall a. [a] -> [a] -> [a]
(++)
([(String, [(SrcSpan, LargeRecordOptions)])]
-> Map String [(SrcSpan, LargeRecordOptions)])
-> (HsModule -> [(String, [(SrcSpan, LargeRecordOptions)])])
-> HsModule
-> Map String [(SrcSpan, LargeRecordOptions)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, (SrcSpan, LargeRecordOptions))
-> (String, [(SrcSpan, LargeRecordOptions)]))
-> [(String, (SrcSpan, LargeRecordOptions))]
-> [(String, [(SrcSpan, LargeRecordOptions)])]
forall a b. (a -> b) -> [a] -> [b]
map (((SrcSpan, LargeRecordOptions) -> [(SrcSpan, LargeRecordOptions)])
-> (String, (SrcSpan, LargeRecordOptions))
-> (String, [(SrcSpan, LargeRecordOptions)])
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((SrcSpan, LargeRecordOptions)
-> [(SrcSpan, LargeRecordOptions)]
-> [(SrcSpan, LargeRecordOptions)]
forall a. a -> [a] -> [a]
:[]))
([(String, (SrcSpan, LargeRecordOptions))]
-> [(String, [(SrcSpan, LargeRecordOptions)])])
-> (HsModule -> [(String, (SrcSpan, LargeRecordOptions))])
-> HsModule
-> [(String, [(SrcSpan, LargeRecordOptions)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnDecl GhcPs -> Maybe (String, (SrcSpan, LargeRecordOptions)))
-> [AnnDecl GhcPs] -> [(String, (SrcSpan, LargeRecordOptions))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AnnDecl GhcPs -> Maybe (String, (SrcSpan, LargeRecordOptions))
viewAnnotation
([AnnDecl GhcPs] -> [(String, (SrcSpan, LargeRecordOptions))])
-> (HsModule -> [AnnDecl GhcPs])
-> HsModule
-> [(String, (SrcSpan, LargeRecordOptions))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([AnnDecl GhcPs] -> [AnnDecl GhcPs] -> [AnnDecl GhcPs])
-> GenericQ [AnnDecl GhcPs] -> GenericQ [AnnDecl GhcPs]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything [AnnDecl GhcPs] -> [AnnDecl GhcPs] -> [AnnDecl GhcPs]
forall a. [a] -> [a] -> [a]
(++) ([AnnDecl GhcPs]
-> (AnnDecl GhcPs -> [AnnDecl GhcPs]) -> a -> [AnnDecl GhcPs]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
SYB.mkQ [] (AnnDecl GhcPs -> [AnnDecl GhcPs] -> [AnnDecl GhcPs]
forall a. a -> [a] -> [a]
:[]))
viewAnnotation :: AnnDecl GhcPs -> Maybe (String, (SrcSpan, LargeRecordOptions))
viewAnnotation :: AnnDecl GhcPs -> Maybe (String, (SrcSpan, LargeRecordOptions))
viewAnnotation = \case
PragAnnD (TypeAnnotation LRdrName
tyName) (LHsExpr GhcPs -> Maybe LargeRecordOptions
intOptions -> Just LargeRecordOptions
options) ->
(String, (SrcSpan, LargeRecordOptions))
-> Maybe (String, (SrcSpan, LargeRecordOptions))
forall a. a -> Maybe a
Just (LRdrName -> String
nameBase LRdrName
tyName, (LRdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LRdrName
tyName, LargeRecordOptions
options))
AnnDecl GhcPs
_otherwise ->
Maybe (String, (SrcSpan, LargeRecordOptions))
forall a. Maybe a
Nothing
intOptions :: LHsExpr GhcPs -> Maybe LargeRecordOptions
intOptions :: LHsExpr GhcPs -> Maybe LargeRecordOptions
intOptions (VarE (LRdrName -> String
nameBase -> String
"largeRecord")) =
LargeRecordOptions -> Maybe LargeRecordOptions
forall a. a -> Maybe a
Just LargeRecordOptions
largeRecord
intOptions (RecUpdE LHsExpr GhcPs
expr [(LRdrName, LHsExpr GhcPs)]
fields) = do
LargeRecordOptions
opts <- LHsExpr GhcPs -> Maybe LargeRecordOptions
intOptions LHsExpr GhcPs
expr
[LargeRecordOptions -> LargeRecordOptions]
updates <- ((LRdrName, LHsExpr GhcPs)
-> Maybe (LargeRecordOptions -> LargeRecordOptions))
-> [(LRdrName, LHsExpr GhcPs)]
-> Maybe [LargeRecordOptions -> LargeRecordOptions]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LRdrName, LHsExpr GhcPs)
-> Maybe (LargeRecordOptions -> LargeRecordOptions)
intUpdate [(LRdrName, LHsExpr GhcPs)]
fields
LargeRecordOptions -> Maybe LargeRecordOptions
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LargeRecordOptions -> Maybe LargeRecordOptions)
-> LargeRecordOptions -> Maybe LargeRecordOptions
forall a b. (a -> b) -> a -> b
$ ((LargeRecordOptions -> LargeRecordOptions)
-> (LargeRecordOptions -> LargeRecordOptions)
-> LargeRecordOptions
-> LargeRecordOptions)
-> (LargeRecordOptions -> LargeRecordOptions)
-> [LargeRecordOptions -> LargeRecordOptions]
-> LargeRecordOptions
-> LargeRecordOptions
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LargeRecordOptions -> LargeRecordOptions)
-> (LargeRecordOptions -> LargeRecordOptions)
-> LargeRecordOptions
-> LargeRecordOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) LargeRecordOptions -> LargeRecordOptions
forall a. a -> a
id [LargeRecordOptions -> LargeRecordOptions]
updates LargeRecordOptions
opts
intOptions LHsExpr GhcPs
_otherwise =
Maybe LargeRecordOptions
forall a. Maybe a
Nothing
intUpdate ::
(LRdrName, LHsExpr GhcPs)
-> Maybe (LargeRecordOptions -> LargeRecordOptions)
intUpdate :: (LRdrName, LHsExpr GhcPs)
-> Maybe (LargeRecordOptions -> LargeRecordOptions)
intUpdate (LRdrName -> String
nameBase -> String
"debugLargeRecords", LHsExpr GhcPs -> Maybe Bool
intBool -> Just Bool
b) =
(LargeRecordOptions -> LargeRecordOptions)
-> Maybe (LargeRecordOptions -> LargeRecordOptions)
forall a. a -> Maybe a
Just ((LargeRecordOptions -> LargeRecordOptions)
-> Maybe (LargeRecordOptions -> LargeRecordOptions))
-> (LargeRecordOptions -> LargeRecordOptions)
-> Maybe (LargeRecordOptions -> LargeRecordOptions)
forall a b. (a -> b) -> a -> b
$ \LargeRecordOptions
opts -> LargeRecordOptions
opts { debugLargeRecords :: Bool
debugLargeRecords = Bool
b }
intUpdate (LRdrName, LHsExpr GhcPs)
_otherwise =
Maybe (LargeRecordOptions -> LargeRecordOptions)
forall a. Maybe a
Nothing
intBool :: LHsExpr GhcPs -> Maybe Bool
intBool :: LHsExpr GhcPs -> Maybe Bool
intBool (ConE (LRdrName -> String
nameBase -> String
"True")) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
intBool (ConE (LRdrName -> String
nameBase -> String
"False")) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
intBool LHsExpr GhcPs
_otherwise = Maybe Bool
forall a. Maybe a
Nothing