{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE ViewPatterns       #-}

-- | Generation options for large-records.
module Data.Record.Internal.Plugin.Options (
    -- * Definition
    LargeRecordOptions(..)
  , largeRecord
    -- * Extract options from source module
  , 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

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | A type specifying how a record should be treated by large-records.
--
-- The default for Haskell code should probably be:
--
-- > {-# ANN type T largeRecord #-}
-- > data T = ..
--
-- To see the definitions generated by @large-records@:
--
-- > {-# ANN type T largeRecord {debugLargeRecords = True} #-}
-- > data T = ..
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
    }

{-------------------------------------------------------------------------------
  Extract options from module
-------------------------------------------------------------------------------}

-- | Extract all 'LargeRecordOptions' in a module
--
-- Additionally returns the location of the ANN pragma.
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

{-------------------------------------------------------------------------------
  Very limited interpreter for 'LargeRecordOptions'

  TODO: Instead of doing this, we might be able to use runAnnotation. This lives
  in the TcM monad, but the Hsc monad gives us a HscEnv which is sufficient to
  run things in the TcM monad. For that however we would need to use the
  /renamed/ module, rather than the parsed one. I think this might be possible
  now that quasi-quotation is no longer necessary, but I am not 100% sure.
-------------------------------------------------------------------------------}

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