{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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 GHC.Records.Compat
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
LargeRecordOptions -> DataType
LargeRecordOptions -> Constr
(forall b. Data b => b -> b)
-> LargeRecordOptions -> 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)
gmapMo :: forall (m :: Type -> Type).
MonadPlus m =>
(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 (m :: Type -> Type).
MonadPlus m =>
(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 (m :: Type -> Type).
Monad m =>
(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 :: forall u.
Int -> (forall d. Data d => d -> u) -> LargeRecordOptions -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> LargeRecordOptions -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> LargeRecordOptions -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> LargeRecordOptions -> [u]
gmapQr :: forall r r'.
(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 :: forall r r'.
(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 (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(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 (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(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 (c :: Type -> Type).
(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 (c :: Type -> Type).
(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
Data)
largeRecord :: LargeRecordOptions
largeRecord :: LargeRecordOptions
largeRecord = LargeRecordOptions {
debugLargeRecords :: Bool
debugLargeRecords = Bool
False
}
instance HasField "debugLargeRecords" LargeRecordOptions Bool where
hasField :: LargeRecordOptions -> (Bool -> LargeRecordOptions, Bool)
hasField LargeRecordOptions
r = (\Bool
x -> LargeRecordOptions
r{debugLargeRecords :: Bool
debugLargeRecords = Bool
x}, LargeRecordOptions -> Bool
debugLargeRecords LargeRecordOptions
r)
getLargeRecordOptions :: HsModule -> Map String [(SrcSpan, LargeRecordOptions)]
getLargeRecordOptions :: HsModule -> Map String [(SrcSpan, LargeRecordOptions)]
getLargeRecordOptions =
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. a -> [a] -> [a]
:[]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AnnDecl GhcPs -> Maybe (String, (SrcSpan, LargeRecordOptions))
viewAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything forall a. [a] -> [a] -> [a]
(++) (forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
SYB.mkQ [] (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) ->
forall a. a -> Maybe a
Just (LRdrName -> String
nameBase LRdrName
tyName, (forall l e. GenLocated l e -> l
getLoc LRdrName
tyName, LargeRecordOptions
options))
AnnDecl GhcPs
_otherwise ->
forall a. Maybe a
Nothing
intOptions :: LHsExpr GhcPs -> Maybe LargeRecordOptions
intOptions :: LHsExpr GhcPs -> Maybe LargeRecordOptions
intOptions (VarE (LRdrName -> String
nameBase -> String
"largeRecord")) =
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 <- 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
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [LargeRecordOptions -> LargeRecordOptions]
updates LargeRecordOptions
opts
intOptions LHsExpr GhcPs
_ =
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) =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \LargeRecordOptions
opts -> LargeRecordOptions
opts { debugLargeRecords :: Bool
debugLargeRecords = Bool
b }
intUpdate (LRdrName, LHsExpr GhcPs)
_otherwise =
forall a. Maybe a
Nothing
intBool :: LHsExpr GhcPs -> Maybe Bool
intBool :: LHsExpr GhcPs -> Maybe Bool
intBool (ConE (LRdrName -> String
nameBase -> String
"True")) = forall a. a -> Maybe a
Just Bool
True
intBool (ConE (LRdrName -> String
nameBase -> String
"False")) = forall a. a -> Maybe a
Just Bool
False
intBool LHsExpr GhcPs
_otherwise = forall a. Maybe a
Nothing