{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE RecordWildCards #-}

module Data.Record.Anon.Internal.Plugin.TC.Constraints.KnownHash (
    CKnownHash(..)
  , parseKnownHash
  , solveKnownHash
  ) where

import Data.Hashable (hash)
import Data.Void

import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI
import Data.Record.Anon.Internal.Plugin.TC.NameResolution
import Data.Record.Anon.Internal.Plugin.TC.Parsing
import Data.Record.Anon.Internal.Plugin.TC.TyConSubst

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

-- | Parsed form of an @KnownFieldLabel f@ constraint
data CKnownHash = CKnownHash {
      -- | The underlying @FastString@ when the label is a literal.
      CKnownHash -> FastString
knownHashLabel :: FastString

      -- | The raw type argument to the @KnownFieldLabel@ constraint.
    , CKnownHash -> Type
knownHashType :: Type
    }

{-------------------------------------------------------------------------------
  Outputable
-------------------------------------------------------------------------------}

instance Outputable CKnownHash where
  ppr :: CKnownHash -> SDoc
ppr (CKnownHash FastString
hashLabel Type
hashType) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CKnownHash" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"knownHashLabel" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
hashLabel
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"knownHashType"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
hashType
        ])

{-------------------------------------------------------------------------------
  Parser
-------------------------------------------------------------------------------}

parseKnownHash ::
     TyConSubst
  -> ResolvedNames
  -> Ct
  -> ParseResult Void (GenLocated CtLoc CKnownHash)
parseKnownHash :: TyConSubst
-> ResolvedNames
-> Ct
-> ParseResult Void (GenLocated CtLoc CKnownHash)
parseKnownHash TyConSubst
_ ResolvedNames{Id
TyCon
DataCon
Class
clsAllFields :: Class
clsKnownFields :: Class
clsKnownHash :: Class
clsRowHasField :: Class
clsSubRow :: Class
dataConDictAny :: DataCon
idEvidenceAllFields :: Id
idEvidenceKnownFields :: Id
idEvidenceKnownHash :: Id
idEvidenceRowHasField :: Id
idEvidenceSubRow :: Id
idMkDictAny :: Id
tyConDictAny :: TyCon
tyConMerge :: TyCon
tyConFieldTypes :: TyCon
tyConPair :: TyCon
tyConSimpleFieldTypes :: TyCon
clsAllFields :: ResolvedNames -> Class
clsKnownFields :: ResolvedNames -> Class
clsKnownHash :: ResolvedNames -> Class
clsRowHasField :: ResolvedNames -> Class
clsSubRow :: ResolvedNames -> Class
dataConDictAny :: ResolvedNames -> DataCon
idEvidenceAllFields :: ResolvedNames -> Id
idEvidenceKnownFields :: ResolvedNames -> Id
idEvidenceKnownHash :: ResolvedNames -> Id
idEvidenceRowHasField :: ResolvedNames -> Id
idEvidenceSubRow :: ResolvedNames -> Id
idMkDictAny :: ResolvedNames -> Id
tyConDictAny :: ResolvedNames -> TyCon
tyConMerge :: ResolvedNames -> TyCon
tyConFieldTypes :: ResolvedNames -> TyCon
tyConPair :: ResolvedNames -> TyCon
tyConSimpleFieldTypes :: ResolvedNames -> TyCon
..} =
    (Class -> [Type] -> Maybe (Type, FastString))
-> ((Type, FastString) -> Maybe CKnownHash)
-> Ct
-> ParseResult Void (GenLocated CtLoc CKnownHash)
forall a b e.
HasCallStack =>
(Class -> [Type] -> Maybe a)
-> (a -> Maybe b) -> Ct -> ParseResult e (GenLocated CtLoc b)
parseConstraint Class -> [Type] -> Maybe (Type, FastString)
isRelevant (((Type, FastString) -> Maybe CKnownHash)
 -> Ct -> ParseResult Void (GenLocated CtLoc CKnownHash))
-> ((Type, FastString) -> Maybe CKnownHash)
-> Ct
-> ParseResult Void (GenLocated CtLoc CKnownHash)
forall a b. (a -> b) -> a -> b
$ \(Type
ty, FastString
label) -> do
      CKnownHash -> Maybe CKnownHash
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CKnownHash -> Maybe CKnownHash) -> CKnownHash -> Maybe CKnownHash
forall a b. (a -> b) -> a -> b
$ CKnownHash {
          knownHashLabel :: FastString
knownHashLabel = FastString
label
        , knownHashType :: Type
knownHashType  = Type
ty
        }
  where
    isRelevant :: Class -> [Type] -> Maybe (Type, FastString)
    isRelevant :: Class -> [Type] -> Maybe (Type, FastString)
isRelevant Class
cls [Type]
args
      | [Type
ty] <- [Type]
args
      , Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
clsKnownHash
      , Just FastString
label <- Type -> Maybe FastString
isStrLitTy Type
ty
      = (Type, FastString) -> Maybe (Type, FastString)
forall a. a -> Maybe a
Just (Type
ty, FastString
label)

      | Bool
otherwise
      = Maybe (Type, FastString)
forall a. Maybe a
Nothing

evidenceKnownFieldLabel ::
     ResolvedNames
  -> CKnownHash
  -> TcPluginM 'Solve EvTerm
evidenceKnownFieldLabel :: ResolvedNames -> CKnownHash -> TcPluginM 'Solve EvTerm
evidenceKnownFieldLabel ResolvedNames{Id
TyCon
DataCon
Class
clsAllFields :: ResolvedNames -> Class
clsKnownFields :: ResolvedNames -> Class
clsKnownHash :: ResolvedNames -> Class
clsRowHasField :: ResolvedNames -> Class
clsSubRow :: ResolvedNames -> Class
dataConDictAny :: ResolvedNames -> DataCon
idEvidenceAllFields :: ResolvedNames -> Id
idEvidenceKnownFields :: ResolvedNames -> Id
idEvidenceKnownHash :: ResolvedNames -> Id
idEvidenceRowHasField :: ResolvedNames -> Id
idEvidenceSubRow :: ResolvedNames -> Id
idMkDictAny :: ResolvedNames -> Id
tyConDictAny :: ResolvedNames -> TyCon
tyConMerge :: ResolvedNames -> TyCon
tyConFieldTypes :: ResolvedNames -> TyCon
tyConPair :: ResolvedNames -> TyCon
tyConSimpleFieldTypes :: ResolvedNames -> TyCon
clsAllFields :: Class
clsKnownFields :: Class
clsKnownHash :: Class
clsRowHasField :: Class
clsSubRow :: Class
dataConDictAny :: DataCon
idEvidenceAllFields :: Id
idEvidenceKnownFields :: Id
idEvidenceKnownHash :: Id
idEvidenceRowHasField :: Id
idEvidenceSubRow :: Id
idMkDictAny :: Id
tyConDictAny :: TyCon
tyConMerge :: TyCon
tyConFieldTypes :: TyCon
tyConPair :: TyCon
tyConSimpleFieldTypes :: TyCon
..} CKnownHash{FastString
Type
knownHashLabel :: CKnownHash -> FastString
knownHashType :: CKnownHash -> Type
knownHashLabel :: FastString
knownHashType :: Type
..} =
    EvTerm -> TcPluginM 'Solve EvTerm
forall a. a -> TcPluginM 'Solve a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvTerm -> TcPluginM 'Solve EvTerm)
-> EvTerm -> TcPluginM 'Solve EvTerm
forall a b. (a -> b) -> a -> b
$
      DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp
        (Class -> DataCon
classDataCon Class
clsKnownHash)
        [Type]
typeArgsEvidence
        [ EvExpr -> [EvExpr] -> EvExpr
mkCoreApps (Id -> EvExpr
forall b. Id -> Expr b
Var Id
idEvidenceKnownHash) ([EvExpr] -> EvExpr) -> [EvExpr] -> EvExpr
forall a b. (a -> b) -> a -> b
$ [[EvExpr]] -> [EvExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              (Type -> EvExpr) -> [Type] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> EvExpr
forall b. Type -> Expr b
Type [Type]
typeArgsEvidence
            , [ Integer -> EvExpr
mkUncheckedIntExpr (Integer -> EvExpr) -> (Int -> Integer) -> Int -> EvExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> EvExpr) -> Int -> EvExpr
forall a b. (a -> b) -> a -> b
$
                  String -> Int
forall a. Hashable a => a -> Int
hash (FastString -> String
unpackFS FastString
knownHashLabel)
              ]
            ]
        ]
  where
    typeArgsEvidence :: [Type]
    typeArgsEvidence :: [Type]
typeArgsEvidence = [
          Type
knownHashType
        ]

{-------------------------------------------------------------------------------
  Solver
-------------------------------------------------------------------------------}

solveKnownHash ::
     ResolvedNames
  -> Ct
  -> GenLocated CtLoc CKnownHash
  -> TcPluginM 'Solve (Maybe (EvTerm, Ct), [Ct])
solveKnownHash :: ResolvedNames
-> Ct
-> GenLocated CtLoc CKnownHash
-> TcPluginM 'Solve (Maybe (EvTerm, Ct), [Ct])
solveKnownHash ResolvedNames
rn Ct
orig (L CtLoc
_ CKnownHash
lbl) = do
    EvTerm
ev <- ResolvedNames -> CKnownHash -> TcPluginM 'Solve EvTerm
evidenceKnownFieldLabel ResolvedNames
rn CKnownHash
lbl
    (Maybe (EvTerm, Ct), [Ct])
-> TcPluginM 'Solve (Maybe (EvTerm, Ct), [Ct])
forall a. a -> TcPluginM 'Solve a
forall (m :: * -> *) a. Monad m => a -> m a
return ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvTerm
ev, Ct
orig), [])