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

module Data.Record.Anon.Internal.Plugin.TC.NameResolution (
    ResolvedNames(..)
  , nameResolution
  ) where

import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI

-- | Names we need to parse constraints or generate core
--
-- Listed alphabetically.
data ResolvedNames = ResolvedNames {
      ResolvedNames -> Class
clsAllFields          :: Class
    , ResolvedNames -> Class
clsKnownFields        :: Class
    , ResolvedNames -> Class
clsKnownHash          :: Class
    , ResolvedNames -> Class
clsRowHasField        :: Class
    , ResolvedNames -> Class
clsSubRow             :: Class
    , ResolvedNames -> DataCon
dataConDictAny        :: DataCon
    , ResolvedNames -> Id
idEvidenceAllFields   :: Id
    , ResolvedNames -> Id
idEvidenceKnownFields :: Id
    , ResolvedNames -> Id
idEvidenceKnownHash   :: Id
    , ResolvedNames -> Id
idEvidenceRowHasField :: Id
    , ResolvedNames -> Id
idEvidenceSubRow      :: Id
    , ResolvedNames -> Id
idUnsafeCoerce        :: Id
    , ResolvedNames -> TyCon
tyConDictAny          :: TyCon
    , ResolvedNames -> TyCon
tyConMerge            :: TyCon
    , ResolvedNames -> TyCon
tyConFieldTypes       :: TyCon
    , ResolvedNames -> TyCon
tyConPair             :: TyCon
    , ResolvedNames -> TyCon
tyConSimpleFieldTypes :: TyCon
    }

nameResolution :: TcPluginM 'Init ResolvedNames
nameResolution :: TcPluginM 'Init ResolvedNames
nameResolution = do
    Module
modl <- String -> String -> TcPluginM 'Init Module
forall (m :: * -> *).
MonadTcPlugin m =>
String -> String -> m Module
getModule String
"large-anon" String
"Data.Record.Anon.Plugin.Internal.Runtime"

    let getClass       :: MonadTcPlugin m => String -> m Class
        getTyCon       :: MonadTcPlugin m => String -> m TyCon
        getDataCon     :: MonadTcPlugin m => String -> m DataCon
        getVar         :: MonadTcPlugin m => String -> m Id
        getPromDataCon :: MonadTcPlugin m => String -> m TyCon

        getClass :: String -> m Class
getClass       String
cls = Module -> OccName -> m Name
forall (m :: * -> *).
MonadTcPlugin m =>
Module -> OccName -> m Name
lookupOrig Module
modl (String -> OccName
mkTcOcc String
cls)   m Name -> (Name -> m Class) -> m Class
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Class
forall (m :: * -> *). MonadTcPlugin m => Name -> m Class
tcLookupClass
        getTyCon :: String -> m TyCon
getTyCon       String
con = Module -> OccName -> m Name
forall (m :: * -> *).
MonadTcPlugin m =>
Module -> OccName -> m Name
lookupOrig Module
modl (String -> OccName
mkTcOcc String
con)   m Name -> (Name -> m TyCon) -> m TyCon
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m TyCon
forall (m :: * -> *). MonadTcPlugin m => Name -> m TyCon
tcLookupTyCon
        getDataCon :: String -> m DataCon
getDataCon     String
con = Module -> OccName -> m Name
forall (m :: * -> *).
MonadTcPlugin m =>
Module -> OccName -> m Name
lookupOrig Module
modl (String -> OccName
mkDataOcc String
con) m Name -> (Name -> m DataCon) -> m DataCon
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m DataCon
forall (m :: * -> *). MonadTcPlugin m => Name -> m DataCon
tcLookupDataCon
        getVar :: String -> m Id
getVar         String
var = Module -> OccName -> m Name
forall (m :: * -> *).
MonadTcPlugin m =>
Module -> OccName -> m Name
lookupOrig Module
modl (String -> OccName
mkVarOcc String
var)  m Name -> (Name -> m Id) -> m Id
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> m Id
forall (m :: * -> *). MonadTcPlugin m => Name -> m Id
tcLookupId
        getPromDataCon :: String -> m TyCon
getPromDataCon String
con = DataCon -> TyCon
promoteDataCon (DataCon -> TyCon) -> m DataCon -> m TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m DataCon
forall (m :: * -> *). MonadTcPlugin m => String -> m DataCon
getDataCon String
con

    Class
clsAllFields          <- String -> TcPluginM 'Init Class
forall (m :: * -> *). MonadTcPlugin m => String -> m Class
getClass String
"AllFields"
    Class
clsKnownFields        <- String -> TcPluginM 'Init Class
forall (m :: * -> *). MonadTcPlugin m => String -> m Class
getClass String
"KnownFields"
    Class
clsKnownHash          <- String -> TcPluginM 'Init Class
forall (m :: * -> *). MonadTcPlugin m => String -> m Class
getClass String
"KnownHash"
    Class
clsRowHasField        <- String -> TcPluginM 'Init Class
forall (m :: * -> *). MonadTcPlugin m => String -> m Class
getClass String
"RowHasField"
    Class
clsSubRow             <- String -> TcPluginM 'Init Class
forall (m :: * -> *). MonadTcPlugin m => String -> m Class
getClass String
"SubRow"

    DataCon
dataConDictAny        <- String -> TcPluginM 'Init DataCon
forall (m :: * -> *). MonadTcPlugin m => String -> m DataCon
getDataCon String
"DictAny"

    Id
idEvidenceAllFields   <- String -> TcPluginM 'Init Id
forall (m :: * -> *). MonadTcPlugin m => String -> m Id
getVar String
"evidenceAllFields"
    Id
idEvidenceKnownFields <- String -> TcPluginM 'Init Id
forall (m :: * -> *). MonadTcPlugin m => String -> m Id
getVar String
"evidenceKnownFields"
    Id
idEvidenceKnownHash   <- String -> TcPluginM 'Init Id
forall (m :: * -> *). MonadTcPlugin m => String -> m Id
getVar String
"evidenceKnownHash"
    Id
idEvidenceRowHasField <- String -> TcPluginM 'Init Id
forall (m :: * -> *). MonadTcPlugin m => String -> m Id
getVar String
"evidenceRowHasField"
    Id
idEvidenceSubRow      <- String -> TcPluginM 'Init Id
forall (m :: * -> *). MonadTcPlugin m => String -> m Id
getVar String
"evidenceSubRow"
    Id
idUnsafeCoerce        <- String -> TcPluginM 'Init Id
forall (m :: * -> *). MonadTcPlugin m => String -> m Id
getVar String
"noInlineUnsafeCo"

    TyCon
tyConDictAny          <- String -> TcPluginM 'Init TyCon
forall (m :: * -> *). MonadTcPlugin m => String -> m TyCon
getTyCon       String
"DictAny"
    TyCon
tyConFieldTypes       <- String -> TcPluginM 'Init TyCon
forall (m :: * -> *). MonadTcPlugin m => String -> m TyCon
getTyCon       String
"FieldTypes"
    TyCon
tyConMerge            <- String -> TcPluginM 'Init TyCon
forall (m :: * -> *). MonadTcPlugin m => String -> m TyCon
getTyCon       String
"Merge"
    TyCon
tyConPair             <- String -> TcPluginM 'Init TyCon
forall (m :: * -> *). MonadTcPlugin m => String -> m TyCon
getPromDataCon String
":="
    TyCon
tyConSimpleFieldTypes <- String -> TcPluginM 'Init TyCon
forall (m :: * -> *). MonadTcPlugin m => String -> m TyCon
getTyCon       String
"SimpleFieldTypes"

    ResolvedNames -> TcPluginM 'Init ResolvedNames
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedNames -> TcPluginM 'Init ResolvedNames)
-> ResolvedNames -> TcPluginM 'Init ResolvedNames
forall a b. (a -> b) -> a -> b
$ ResolvedNames :: Class
-> Class
-> Class
-> Class
-> Class
-> DataCon
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> ResolvedNames
ResolvedNames {Class
DataCon
Id
TyCon
tyConSimpleFieldTypes :: TyCon
tyConPair :: TyCon
tyConMerge :: TyCon
tyConFieldTypes :: 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
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
..}

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

getModule :: MonadTcPlugin m => String -> String -> m Module
getModule :: String -> String -> m Module
getModule String
pkg String
modl = do
    FindResult
r <- ModuleName -> PkgQual -> m FindResult
forall (m :: * -> *).
MonadTcPlugin m =>
ModuleName -> PkgQual -> m FindResult
findImportedModule (String -> ModuleName
mkModuleName String
modl) (UnitId -> PkgQual
OtherPkg (UnitId -> PkgQual) -> UnitId -> PkgQual
forall a b. (a -> b) -> a -> b
$ String -> UnitId
stringToUnitId String
pkg)
    case FindResult
r of
      Found ModLocation
_ Module
m  -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
      FindResult
_otherwise -> String -> m Module
forall a. String -> a
panic (String -> m Module) -> String -> m Module
forall a b. (a -> b) -> a -> b
$ String
"Could not find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkg