{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns    #-}
{-# LANGUAGE NamedFieldPuns #-}

module Data.Record.Anon.Internal.Plugin.TC.Rewriter (rewrite) where

import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (KnownRow)
import Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (Fields)
import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI
import Data.Record.Anon.Internal.Plugin.TC.NameResolution
import Data.Record.Anon.Internal.Plugin.TC.TyConSubst

import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownField as KnownField
import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow   as KnownRow
import qualified Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow  as ParsedRow

rewrite :: ResolvedNames -> UniqFM TyCon TcPluginRewriter
rewrite :: ResolvedNames -> UniqFM TyCon TcPluginRewriter
rewrite rn :: ResolvedNames
rn@ResolvedNames{Class
DataCon
TyCon
Id
tyConSimpleFieldTypes :: ResolvedNames -> TyCon
tyConPair :: ResolvedNames -> TyCon
tyConFieldTypes :: ResolvedNames -> TyCon
tyConMerge :: ResolvedNames -> TyCon
tyConDictAny :: ResolvedNames -> TyCon
idUnsafeCoerce :: ResolvedNames -> Id
idEvidenceSubRow :: ResolvedNames -> Id
idEvidenceRowHasField :: ResolvedNames -> Id
idEvidenceKnownHash :: ResolvedNames -> Id
idEvidenceKnownFields :: ResolvedNames -> Id
idEvidenceAllFields :: ResolvedNames -> Id
dataConDictAny :: ResolvedNames -> DataCon
clsSubRow :: ResolvedNames -> Class
clsRowHasField :: ResolvedNames -> Class
clsKnownHash :: ResolvedNames -> Class
clsKnownFields :: ResolvedNames -> Class
clsAllFields :: ResolvedNames -> Class
tyConSimpleFieldTypes :: TyCon
tyConPair :: TyCon
tyConFieldTypes :: TyCon
tyConMerge :: TyCon
tyConDictAny :: TyCon
idUnsafeCoerce :: Id
idEvidenceSubRow :: Id
idEvidenceRowHasField :: Id
idEvidenceKnownHash :: Id
idEvidenceKnownFields :: Id
idEvidenceAllFields :: Id
dataConDictAny :: DataCon
clsSubRow :: Class
clsRowHasField :: Class
clsKnownHash :: Class
clsKnownFields :: Class
clsAllFields :: Class
..} = forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [
      (TyCon
tyConFieldTypes       , TyCon -> ResolvedNames -> TcPluginRewriter
rewriteRecordMetadataOf TyCon
tyConFieldTypes       ResolvedNames
rn)
    , (TyCon
tyConSimpleFieldTypes , TyCon -> ResolvedNames -> TcPluginRewriter
rewriteRecordMetadataOf TyCon
tyConSimpleFieldTypes ResolvedNames
rn)
    ]

data Args = Args {
      -- | Functor argument, if any
      Args -> Maybe Type
argsFunctor :: Maybe Type

      -- | Parsed fields
    , Args -> Maybe Fields
argsParsedFields :: Maybe Fields

      -- | Known record, if all fields are known
    , Args -> Maybe (KnownRow Type)
argsParsedKnown :: Maybe (KnownRow Type)
    }

mkArgs :: TyConSubst -> ResolvedNames -> Maybe Type -> Type -> Args
mkArgs :: TyConSubst -> ResolvedNames -> Maybe Type -> Type -> Args
mkArgs TyConSubst
tcs ResolvedNames
rn Maybe Type
argsFunctor Type
r = Args{Maybe Type
Maybe (KnownRow Type)
Maybe Fields
argsParsedKnown :: Maybe (KnownRow Type)
argsParsedFields :: Maybe Fields
argsFunctor :: Maybe Type
argsParsedKnown :: Maybe (KnownRow Type)
argsParsedFields :: Maybe Fields
argsFunctor :: Maybe Type
..}
  where
    argsParsedFields :: Maybe Fields
argsParsedFields = TyConSubst -> ResolvedNames -> Type -> Maybe Fields
ParsedRow.parseFields TyConSubst
tcs ResolvedNames
rn Type
r
    argsParsedKnown :: Maybe (KnownRow Type)
argsParsedKnown  = Fields -> Maybe (KnownRow Type)
ParsedRow.allKnown forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Fields
argsParsedFields

parseArgs :: [Ct] -> ResolvedNames -> [Type] -> Args
parseArgs :: [Ct] -> ResolvedNames -> [Type] -> Args
parseArgs [Ct]
given ResolvedNames
rn = \case
    [Type
_k, Type
f, Type
r] -> TyConSubst -> ResolvedNames -> Maybe Type -> Type -> Args
mkArgs TyConSubst
tcs ResolvedNames
rn (forall a. a -> Maybe a
Just Type
f) Type
r
    [       Type
r] -> TyConSubst -> ResolvedNames -> Maybe Type -> Type -> Args
mkArgs TyConSubst
tcs ResolvedNames
rn forall a. Maybe a
Nothing  Type
r
    [Type]
args       -> forall a. String -> a
panic forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        String
"Data.Record.Anon.Plugin.Rewriter.parseArgs: "
      , String
"unexpected arguments: "
      , SDoc -> String
showSDocUnsafe (forall a. Outputable a => a -> SDoc
ppr [Type]
args)
      ]
  where
    tcs :: TyConSubst
    tcs :: TyConSubst
tcs = [Ct] -> TyConSubst
mkTyConSubst [Ct]
given

rewriteRecordMetadataOf :: TyCon -> ResolvedNames -> TcPluginRewriter
rewriteRecordMetadataOf :: TyCon -> ResolvedNames -> TcPluginRewriter
rewriteRecordMetadataOf TyCon
fun ResolvedNames
rn [Ct]
given args :: [Type]
args@([Ct] -> ResolvedNames -> [Type] -> Args
parseArgs [Ct]
given ResolvedNames
rn -> Args{Maybe Type
Maybe (KnownRow Type)
Maybe Fields
argsParsedKnown :: Maybe (KnownRow Type)
argsParsedFields :: Maybe Fields
argsFunctor :: Maybe Type
argsParsedKnown :: Args -> Maybe (KnownRow Type)
argsParsedFields :: Args -> Maybe Fields
argsFunctor :: Args -> Maybe Type
..}) =
--  trace _debugInput  $
--  trace _debugParsed $
    case Maybe (KnownRow Type)
argsParsedKnown of
      Maybe (KnownRow Type)
Nothing ->
        forall (m :: * -> *) a. Monad m => a -> m a
return TcPluginRewriteResult
TcPluginNoRewrite
      Just KnownRow Type
knownFields ->
        forall (m :: * -> *) a. Monad m => a -> m a
return TcPluginRewriteTo {
            tcRewriterNewWanteds :: [Ct]
tcRewriterNewWanteds = []
          , tcPluginReduction :: Reduction
tcPluginReduction    =
               String -> Role -> TyCon -> [Type] -> Type -> Reduction
mkTyFamAppReduction
                 String
"large-anon"
                 Role
Nominal
                 TyCon
fun
                 [Type]
args
                 (Maybe Type -> KnownRow Type -> Type
computeMetadataOf Maybe Type
argsFunctor KnownRow Type
knownFields)
          }
  where
    _debugInput :: String
    _debugInput :: String
_debugInput = [String] -> String
unlines [
          String
"*** input"
        , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"given:"
            , SDoc -> String
showSDocUnsafe (forall a. Outputable a => a -> SDoc
ppr [Ct]
given)
            ]
        , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"args: "
            , SDoc -> String
showSDocUnsafe (forall a. Outputable a => a -> SDoc
ppr [Type]
args)
            ]
        ]

    _debugParsed :: String
    _debugParsed :: String
_debugParsed = [String] -> String
unlines [
          String
"*** parsed"
        , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"parsedFields: "
            , SDoc -> String
showSDocUnsafe (forall a. Outputable a => a -> SDoc
ppr Maybe Fields
argsParsedFields)
            ]
        , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"mKnownFields: "
            , SDoc -> String
showSDocUnsafe (forall a. Outputable a => a -> SDoc
ppr Maybe (KnownRow Type)
argsParsedKnown)
            ]
        ]

computeMetadataOf :: Maybe Type -> KnownRow Type -> TcType
computeMetadataOf :: Maybe Type -> KnownRow Type -> Type
computeMetadataOf Maybe Type
mf KnownRow Type
r =
    Type -> [Type] -> Type
mkPromotedListTy
      (Boxity -> [Type] -> Type
mkTupleTy Boxity
Boxed [TyCon -> Type
mkTyConTy TyCon
typeSymbolKindCon, Type
liftedTypeKind])
      (forall a b. (a -> b) -> [a] -> [b]
map (Maybe Type -> KnownField Type -> Type
KnownField.toType Maybe Type
mf) forall a b. (a -> b) -> a -> b
$ forall a. KnownRow a -> [KnownField a]
KnownRow.toList KnownRow Type
r)