{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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 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

{-------------------------------------------------------------------------------
  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
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
    }

{-------------------------------------------------------------------------------
  HasField instances

  These instances are required in modules that enable 'OverloadedRecordUpdate'
-------------------------------------------------------------------------------}

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)

{-------------------------------------------------------------------------------
  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 =
      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

{-------------------------------------------------------------------------------
  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")) =
    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