#if __GLASGOW_HASKELL__ <= 706
#endif
module HERMIT.Name
( HermitName
, fromRdrName
, toRdrName
, toRdrNames
, hnModuleName
, hnUnqualified
, parseName
, Named(..)
, varToNamed
, allNameSpaces
, dataConNS
, tyConClassNS
, tyVarNS
, varNS
, findId
#if __GLASGOW_HASKELL__ > 706
, findVar
, findTyCon
, findType
, findInNameSpace
, findInNameSpaces
#endif
) where
import Control.Monad
import Control.Monad.IO.Class
#if __GLASGOW_HASKELL__ <= 706
import Data.List (intercalate)
#endif
import HERMIT.Context
import HERMIT.GHC
import HERMIT.Kure
import HERMIT.Monad
data HermitName = HermitName { hnModuleName :: Maybe ModuleName
, hnUnqualified :: String
}
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]
mkQualified :: String -> String -> HermitName
mkQualified mnm nm = HermitName (Just $ mkModuleName mnm) nm
mkUnqualified :: String -> HermitName
mkUnqualified = HermitName Nothing
fromRdrName :: RdrName -> HermitName
fromRdrName nm = case isQual_maybe nm of
Nothing -> HermitName Nothing (occNameString $ rdrNameOcc nm)
Just (mnm, onm) -> HermitName (Just mnm) (occNameString onm)
toRdrName :: NameSpace -> HermitName -> RdrName
toRdrName ns (HermitName mnm nm) = maybe (mkRdrUnqual onm) (flip mkRdrQual onm) mnm
where onm = mkOccName ns nm
toRdrNames :: [NameSpace] -> HermitName -> [RdrName]
toRdrNames nss hnm = [ toRdrName ns hnm | ns <- nss ]
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)
parseName :: String -> HermitName
parseName s | isQualified s = parseQualified s
| otherwise = mkUnqualified s
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
#if __GLASGOW_HASKELL__ > 706
findId :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m)
=> String -> 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, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m)
=> String -> 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, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m)
=> String -> 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, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m)
=> String -> 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, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m)
=> [NameSpace] -> String -> c -> m Named
findInNameSpaces nss nm c = setFailMsg "Variable not in scope."
$ catchesM [ findInNameSpace ns nm c | ns <- nss ]
findInNameSpace :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadIO m, MonadThings m)
=> NameSpace -> String -> c -> m Named
findInNameSpace ns nm c =
case filter ((== ns) . occNameSpace . getOccName) $ varSetElems (findBoundVars nm c) of
_ : _ : _ -> fail "multiple matching variables in scope."
[v] -> return $ varToNamed v
[] -> findInNSModGuts ns (parseName nm)
findInNSModGuts :: (HasHscEnv m, HasModGuts 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, HasModGuts m, MonadIO m, MonadThings m)
=> NameSpace -> HermitName -> m Named
findInNSPackageDB ns nm = do
mnm <- lookupName ns nm
case mnm of
Nothing -> findNamedBuiltIn ns (hnUnqualified nm)
Just n -> nameToNamed n
lookupName :: (HasModGuts 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 $ lookupRdrNameInModuleForPlugins hscEnv guts m rdrName
where rdrName = toRdrName ns nm
findNamedBuiltIn :: Monad m => NameSpace -> String -> m Named
findNamedBuiltIn ns str
| isValNameSpace ns =
case [ dc | tc <- wiredInTyCons, dc <- tyConDataCons tc, str == getOccString dc ] of
[] -> fail "name not in scope."
[dc] -> return $ NamedDataCon dc
dcs -> fail $ "multiple DataCons match: " ++ show (map getOccString dcs)
| isTcClsNameSpace ns =
case [ tc | tc <- wiredInTyCons, str == getOccString tc ] of
[] -> fail "type name not in scope."
[tc] -> return $ NamedTyCon tc
tcs -> fail $ "multiple TyCons match: " ++ show (map getOccString 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"
#else
findId :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> c -> m Id
findId nm c = case varSetElems (findBoundVars nm c) of
[] -> findIdMG (parseName nm)
[v] -> return v
_ : _ : _ -> fail "multiple matching variables in scope."
findIdMG :: (HasModGuts m, MonadThings m) => HermitName -> m Id
findIdMG hnm = do
let nm = hnUnqualified hnm
rdrEnv <- liftM mg_rdr_env getModGuts
case filter isValName $ findNamesFromString rdrEnv nm of
[] -> findIdBuiltIn nm
[n] -> nameToId n
ns -> fail $ "multiple matches found:\n" ++ intercalate ", " (map getOccString ns)
nameToId :: MonadThings m => Name -> m Id
nameToId n | isVarName n = lookupId n
| isDataConName n = liftM dataConWrapId $ lookupDataCon n
| otherwise = fail "nameToId: unknown name type"
findIdBuiltIn :: forall m. Monad m => String -> m Id
findIdBuiltIn = go
where go ":" = dataConId consDataCon
go "[]" = dataConId nilDataCon
go "True" = return trueDataConId
go "False" = return falseDataConId
go "<" = return ltDataConId
go "==" = return eqDataConId
go ">" = return gtDataConId
go "I#" = dataConId intDataCon
go "()" = return unitDataConId
go _ = fail "variable not in scope."
dataConId :: DataCon -> m Id
dataConId = return . dataConWorkId
#endif