module HERMIT.Name
( HermitName
, cmpHN2Name
, cmpHN2Var
, fromRdrName
, toRdrName
, toRdrNames
, hnModuleName
, hnUnqualified
, parseName
, showName
, OccurrenceName(..)
, OccurrenceNameListBox(..)
, mkOccPred
, BindingName(..)
, mkBindingPred
, RhsOfName(..)
, mkRhsOfPred
, Named(..)
, varToNamed
, allNameSpaces
, dataConNS
, tyConClassNS
, tyVarNS
, varNS
, newGlobalIdH
, newIdH
, newTyVarH
, newCoVarH
, newVarH
, cloneVarH
, cloneVarFSH
, findId
, findVar
, findTyCon
, findType
, findInNameSpace
, findInNameSpaces
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.List (intercalate)
import Data.Dynamic (Typeable)
import Data.String (IsString(..))
import HERMIT.Context
import HERMIT.External
import HERMIT.GHC
import HERMIT.Kure
import HERMIT.Monad
data Named = NamedId Id
| NamedDataCon DataCon
| NamedTyCon TyCon
| NamedTyVar Var
instance Show Named where
show (NamedId _) = "NamedId"
show (NamedDataCon _) = "NamedDataCon"
show (NamedTyCon _) = "NamedTyCon"
show (NamedTyVar _) = "NamedTyVar"
varToNamed :: Var -> Named
varToNamed v | isVarOcc onm = NamedId v
| isTvOcc onm = NamedTyVar v
| otherwise = error "varToNamed: impossible Var namespace"
where onm = getOccName v
tyConClassNS :: NameSpace
tyConClassNS = tcClsName
dataConNS :: NameSpace
dataConNS = dataName
tyVarNS :: NameSpace
tyVarNS = tvName
varNS :: NameSpace
varNS = varNameNS
allNameSpaces :: [NameSpace]
allNameSpaces = [varNS, dataConNS, tyConClassNS, tyVarNS]
data HermitName = HermitName { hnModuleName :: Maybe ModuleName
, hnUnqualified :: FastString
}
deriving (Eq, Typeable)
instance Extern HermitName where
type Box HermitName = HermitName
box = id
unbox = id
instance IsString HermitName where fromString = parseName
instance Show HermitName where show = showName
cmpHN2Var :: HermitName -> Var -> Bool
cmpHN2Var hn = cmpHN2Name hn . varName
cmpHN2Name :: HermitName -> Name -> Bool
cmpHN2Name (HermitName hm nm) n
| Just mn <- hm
, Just m <- nameModule_maybe n = (mn == moduleName m) && sameOccName
| otherwise = sameOccName
where sameOccName = nm == occNameFS (getOccName n)
mkQualified :: String -> String -> HermitName
mkQualified mnm = HermitName (Just $ mkModuleName mnm) . mkFastString
mkUnqualified :: String -> HermitName
mkUnqualified = HermitName Nothing . mkFastString
parseName :: String -> HermitName
parseName s | isQualified s = parseQualified s
| otherwise = mkUnqualified s
parseQualified :: String -> HermitName
parseQualified [] = error "parseQualified: empty string"
parseQualified s = mkQualified mnm nm
where (c:cs) = reverse s
(rNm, _dot:rMod) = break (=='.') cs
(nm, mnm) = (reverse (c:rNm), reverse rMod)
showName :: HermitName -> String
showName (HermitName mnm nm) = maybe id (\ m n -> moduleNameString m ++ ('.' : n)) mnm $ unpackFS nm
fromRdrName :: RdrName -> HermitName
fromRdrName nm = case isQual_maybe nm of
Nothing -> HermitName Nothing (occNameFS $ rdrNameOcc nm)
Just (mnm, onm) -> HermitName (Just mnm) (occNameFS onm)
toRdrName :: NameSpace -> HermitName -> RdrName
toRdrName ns (HermitName mnm nm) = maybe (mkRdrUnqual onm) (flip mkRdrQual onm) mnm
where onm = mkOccNameFS ns nm
toRdrNames :: [NameSpace] -> HermitName -> [RdrName]
toRdrNames nss hnm = [ toRdrName ns hnm | ns <- nss ]
newtype BindingName = BindingName { unBindingName :: HermitName } deriving Typeable
instance Extern BindingName where
type Box BindingName = BindingName
box = id
unbox = id
mkBindingPred :: BindingName -> Var -> Bool
mkBindingPred (BindingName hnm) = cmpHN2Var hnm
newtype OccurrenceName = OccurrenceName { unOccurrenceName :: HermitName } deriving Typeable
instance Extern OccurrenceName where
type Box OccurrenceName = OccurrenceName
box = id
unbox = id
mkOccPred :: OccurrenceName -> Var -> Bool
mkOccPred (OccurrenceName hnm) = cmpHN2Var hnm
newtype OccurrenceNameListBox = OccurrenceNameListBox [OccurrenceName] deriving Typeable
instance Extern [OccurrenceName] where
type Box [OccurrenceName] = OccurrenceNameListBox
box = OccurrenceNameListBox
unbox (OccurrenceNameListBox l) = l
newtype RhsOfName = RhsOfName { unRhsOfName :: HermitName } deriving Typeable
instance Extern RhsOfName where
type Box RhsOfName = RhsOfName
box = id
unbox = id
mkRhsOfPred :: RhsOfName -> Var -> Bool
mkRhsOfPred (RhsOfName hnm) = cmpHN2Var hnm
instance (MonadThings m, BoundVars c) => MonadThings (Transform c m a) where
lookupThing nm = contextonlyT $ \ c ->
case varSetElems $ filterVarSet ((== nm) . varName) (boundVars c) of
(i:_) | isVarName nm -> return $ AnId i
| isTyVarName nm -> fail "lookupThing cannot be used with TyVars."
| otherwise -> fail "MonadThings instance for Transform: impossible namespace."
[] -> lookupThing nm
findId :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)
=> HermitName -> c -> m Id
findId nm c = do
nmd <- findInNameSpaces [varNS, dataConNS] nm c
case nmd of
NamedId i -> return i
NamedDataCon dc -> return $ dataConWrapId dc
other -> fail $ "findId: impossible Named returned: " ++ show other
findVar :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)
=> HermitName -> c -> m Var
findVar nm c = do
nmd <- findInNameSpaces [varNS, tyVarNS, dataConNS] nm c
case nmd of
NamedId i -> return i
NamedTyVar v -> return v
NamedDataCon dc -> return $ dataConWrapId dc
other -> fail $ "findVar: impossible Named returned: " ++ show other
findTyCon :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)
=> HermitName -> c -> m TyCon
findTyCon nm c = do
nmd <- findInNameSpace tyConClassNS nm c
case nmd of
NamedTyCon tc -> return tc
other -> fail $ "findTyCon: impossible Named returned: " ++ show other
findType :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)
=> HermitName -> c -> m Type
findType nm c = do
nmd <- findInNameSpaces [tyVarNS, tyConClassNS] nm c
case nmd of
NamedTyVar v -> return $ mkTyVarTy v
NamedTyCon tc -> return $ mkTyConTy tc
other -> fail $ "findType: impossible Named returned: " ++ show other
findInNameSpaces :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)
=> [NameSpace] -> HermitName -> c -> m Named
findInNameSpaces nss nm c = setFailMsg "Variable not in scope."
$ catchesM [ findInNameSpace ns nm c | ns <- nss ]
findInNameSpace :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m)
=> NameSpace -> HermitName -> c -> m Named
findInNameSpace ns nm c =
case varSetElems $ filterVarSet ((== ns) . occNameSpace . getOccName) $ findBoundVars (cmpHN2Var nm) c of
_ : _ : _ -> fail "multiple matching variables in scope."
[v] -> return $ varToNamed v
[] -> findInNSModGuts ns nm
findInNSModGuts :: (HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m)
=> NameSpace -> HermitName -> m Named
findInNSModGuts ns nm = do
rdrEnv <- liftM mg_rdr_env getModGuts
case lookupGRE_RdrName (toRdrName ns nm) rdrEnv of
[gre] -> nameToNamed $ gre_name gre
[] -> findInNSPackageDB ns nm
_ -> fail "findInNSModGuts: multiple names returned"
findInNSPackageDB :: (HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m)
=> NameSpace -> HermitName -> m Named
findInNSPackageDB ns nm = do
mnm <- lookupName ns nm
case mnm of
Nothing -> findNamedBuiltIn ns nm
Just n -> nameToNamed n
lookupName :: (HasHermitMEnv m, HasHscEnv m, MonadIO m) => NameSpace -> HermitName -> m (Maybe Name)
lookupName ns nm = case isQual_maybe rdrName of
Nothing -> return Nothing
Just (m,_) -> do
hscEnv <- getHscEnv
guts <- getModGuts
liftIO $ lookupRdrNameInModule hscEnv guts m rdrName
where rdrName = toRdrName ns nm
findNamedBuiltIn :: Monad m => NameSpace -> HermitName -> m Named
findNamedBuiltIn ns hnm
| isValNameSpace ns =
case [ dc | tc <- wiredInTyCons, dc <- tyConDataCons tc, cmpHN2Name hnm (getName dc) ] of
[] -> fail "name not in scope."
[dc] -> return $ NamedDataCon dc
dcs -> fail $ "multiple DataCons match: " ++ intercalate ", " (map unqualifiedName dcs)
| isTcClsNameSpace ns =
case [ tc | tc <- wiredInTyCons, cmpHN2Name hnm (getName tc) ] of
[] -> fail "type name not in scope."
[tc] -> return $ NamedTyCon tc
tcs -> fail $ "multiple TyCons match: " ++ intercalate ", " (map unqualifiedName tcs)
| otherwise = fail "findNameBuiltIn: unusable NameSpace"
nameToNamed :: MonadThings m => Name -> m Named
nameToNamed n | isVarName n = liftM NamedId $ lookupId n
| isDataConName n = liftM NamedDataCon $ lookupDataCon n
| isTyConName n = liftM NamedTyCon $ lookupTyCon n
| isTyVarName n = fail "nameToNamed: impossible, TyVars are not exported and cannot be looked up."
| otherwise = fail "nameToNamed: unknown name type"
newName :: MonadUnique m => String -> m Name
newName nm = mkSystemVarName <$> getUniqueM <*> return (mkFastString nm)
newGlobalIdH :: MonadUnique m => String -> Type -> m Id
newGlobalIdH nm ty = mkVanillaGlobal <$> newName nm <*> return ty
newIdH :: MonadUnique m => String -> Type -> m Id
newIdH nm ty = mkLocalId <$> newName nm <*> return ty
newTyVarH :: MonadUnique m => String -> Kind -> m TyVar
newTyVarH nm k = mkTyVar <$> newName nm <*> return k
newCoVarH :: MonadUnique m => String -> Type -> m TyVar
newCoVarH nm ty = mkCoVar <$> newName nm <*> return ty
newVarH :: MonadUnique m => String -> KindOrType -> m Var
newVarH name tk | isCoVarType tk = newCoVarH name tk
| isKind tk = newTyVarH name tk
| otherwise = newIdH name tk
cloneVarH :: MonadUnique m => (String -> String) -> Var -> m Var
cloneVarH nameMod v | isTyVar v = newTyVarH name ty
| isCoVar v = newCoVarH name ty
| isId v = newIdH name ty
| otherwise = fail "If this variable isn't a type, coercion or identifier, then what is it?"
where
name = nameMod (unqualifiedName v)
ty = varType v
cloneVarFSH :: MonadUnique m => (FastString -> FastString) -> Var -> m Var
cloneVarFSH nameMod v | isTyVar v = newTyVarH name ty
| isCoVar v = newCoVarH name ty
| isId v = newIdH name ty
| otherwise = fail "If this variable isn't a type, coercion or identifier, then what is it?"
where
name = unpackFS $ nameMod $ occNameFS $ getOccName v
ty = varType v