{-# 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
Id
TyCon
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
..} = [(TyCon, TcPluginRewriter)] -> UniqFM TyCon TcPluginRewriter
forall key elt. Uniquable key => [(key, elt)] -> UniqFM 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 Fields -> Maybe (KnownRow Type) -> Args
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 (Fields -> Maybe (KnownRow Type))
-> Maybe Fields -> Maybe (KnownRow Type)
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 (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
f) Type
r
    [       Type
r] -> TyConSubst -> ResolvedNames -> Maybe Type -> Type -> Args
mkArgs TyConSubst
tcs ResolvedNames
rn Maybe Type
forall a. Maybe a
Nothing  Type
r
    [Type]
args       -> String -> Args
forall a. String -> a
panic (String -> Args) -> String -> Args
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        String
"Data.Record.Anon.Plugin.Rewriter.parseArgs: "
      , String
"unexpected arguments: "
      , SDoc -> String
showSDocUnsafe ([Type] -> SDoc
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 ->
        TcPluginRewriteResult -> TcPluginM 'Rewrite TcPluginRewriteResult
forall (m :: * -> *) a. Monad m => a -> m a
return TcPluginRewriteResult
TcPluginNoRewrite
      Just KnownRow Type
knownFields ->
        TcPluginRewriteResult -> TcPluginM 'Rewrite TcPluginRewriteResult
forall (m :: * -> *) a. Monad m => a -> m a
return TcPluginRewriteTo :: Reduction -> [Ct] -> TcPluginRewriteResult
TcPluginRewriteTo {
            tcRewriterWanteds :: [Ct]
tcRewriterWanteds = []
          , 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"
        , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"given:"
            , SDoc -> String
showSDocUnsafe ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
given)
            ]
        , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"args: "
            , SDoc -> String
showSDocUnsafe ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
args)
            ]
        ]

    _debugParsed :: String
    _debugParsed :: String
_debugParsed = [String] -> String
unlines [
          String
"*** parsed"
        , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"parsedFields: "
            , SDoc -> String
showSDocUnsafe (Maybe Fields -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fields
argsParsedFields)
            ]
        , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"mKnownFields: "
            , SDoc -> String
showSDocUnsafe (Maybe (KnownRow Type) -> SDoc
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])
      ((KnownField Type -> Type) -> [KnownField Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Type -> KnownField Type -> Type
KnownField.toType Maybe Type
mf) ([KnownField Type] -> [Type]) -> [KnownField Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ KnownRow Type -> [KnownField Type]
forall a. KnownRow a -> [KnownField a]
KnownRow.toList KnownRow Type
r)