module Stan.NameMeta
( NameMeta (..)
, prettyShowNameMeta
, compareNames
, hieMatchNameMeta
, hieFindIdentifier
, baseNameFrom
, mkBaseListMeta
, mkBaseOldListMeta
, mkBaseFoldableMeta
, unorderedNameFrom
, textNameFrom
, ghcPrimNameFrom
, primTypeMeta
) where
import Stan.Core.ModuleName (ModuleName (..), fromGhcModule)
import Stan.Ghc.Compat (Name, isExternalName, moduleUnitId, nameModule, nameOccName, occNameString)
import Stan.Hie.Compat (ContextInfo (IEThing), HieAST (..), IEType (Import), Identifier,
IdentifierDetails (..), NodeInfo (..), TypeIndex)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
data NameMeta = NameMeta
{ NameMeta -> Text
nameMetaPackage :: !Text
, NameMeta -> ModuleName
nameMetaModuleName :: !ModuleName
, NameMeta -> Text
nameMetaName :: !Text
} deriving stock (Int -> NameMeta -> ShowS
[NameMeta] -> ShowS
NameMeta -> String
(Int -> NameMeta -> ShowS)
-> (NameMeta -> String) -> ([NameMeta] -> ShowS) -> Show NameMeta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NameMeta] -> ShowS
$cshowList :: [NameMeta] -> ShowS
show :: NameMeta -> String
$cshow :: NameMeta -> String
showsPrec :: Int -> NameMeta -> ShowS
$cshowsPrec :: Int -> NameMeta -> ShowS
Show, NameMeta -> NameMeta -> Bool
(NameMeta -> NameMeta -> Bool)
-> (NameMeta -> NameMeta -> Bool) -> Eq NameMeta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NameMeta -> NameMeta -> Bool
$c/= :: NameMeta -> NameMeta -> Bool
== :: NameMeta -> NameMeta -> Bool
$c== :: NameMeta -> NameMeta -> Bool
Eq)
prettyShowNameMeta :: NameMeta -> Text
prettyShowNameMeta :: NameMeta -> Text
prettyShowNameMeta NameMeta{..} = Text -> [Text] -> Text
T.intercalate "/"
[ Text
nameMetaPackage
, ModuleName -> Text
unModuleName ModuleName
nameMetaModuleName
, Text
nameMetaName
]
compareNames :: NameMeta -> Name -> Bool
compareNames :: NameMeta -> Name -> Bool
compareNames NameMeta{..} name :: Name
name =
let occName :: Text
occName = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ Name -> OccName
nameOccName Name
name
moduleName :: ModuleName
moduleName = Module -> ModuleName
fromGhcModule (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
package :: Text
package = forall a. (Show a, IsString Text) => a -> Text
forall b a. (Show a, IsString b) => a -> b
show @Text (UnitId -> Text) -> UnitId -> Text
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId (Module -> UnitId) -> Module -> UnitId
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
in
Name -> Bool
isExternalName Name
name
Bool -> Bool -> Bool
&& Text
occName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nameMetaName
Bool -> Bool -> Bool
&& ModuleName
moduleName ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
nameMetaModuleName
Bool -> Bool -> Bool
&& ( Text
nameMetaPackage Text -> Text -> Bool
`T.isPrefixOf` Text
package
Bool -> Bool -> Bool
|| Text -> Text
withoutVowels Text
nameMetaPackage Text -> Text -> Bool
`T.isPrefixOf` Text
package
Bool -> Bool -> Bool
|| Text -> Text
truncatedWindows Text
nameMetaPackage Text -> Text -> Bool
`T.isPrefixOf` Text
package
)
where
withoutVowels :: Text -> Text
withoutVowels :: Text -> Text
withoutVowels = (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
isNotVowel
isNotVowel :: Char -> Bool
isNotVowel :: Char -> Bool
isNotVowel = \case
'a' -> Bool
False
'e' -> Bool
False
'i' -> Bool
False
'o' -> Bool
False
'u' -> Bool
False
_ -> Bool
True
truncatedWindows :: Text -> Text
truncatedWindows :: Text -> Text
truncatedWindows s :: Text
s = Int -> Text -> Text
T.take 13 Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_"
hieMatchNameMeta
:: NameMeta
-> (Identifier, IdentifierDetails TypeIndex)
-> Bool
hieMatchNameMeta :: NameMeta -> (Identifier, IdentifierDetails Int) -> Bool
hieMatchNameMeta nameMeta :: NameMeta
nameMeta (identifier :: Identifier
identifier, details :: IdentifierDetails Int
details) = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> Maybe () -> Bool
forall a b. (a -> b) -> a -> b
$ do
Right name :: Name
name <- Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
identifier
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
(Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ContextInfo -> Set ContextInfo -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (IEType -> ContextInfo
IEThing IEType
Import) (IdentifierDetails Int -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails Int
details)
Bool -> Bool -> Bool
&& NameMeta -> Name -> Bool
compareNames NameMeta
nameMeta Name
name
hieFindIdentifier :: NameMeta -> HieAST TypeIndex -> Maybe NameMeta
hieFindIdentifier :: NameMeta -> HieAST Int -> Maybe NameMeta
hieFindIdentifier nameMeta :: NameMeta
nameMeta =
(NameMeta
nameMeta NameMeta
-> Maybe (Identifier, IdentifierDetails Int) -> Maybe NameMeta
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
(Maybe (Identifier, IdentifierDetails Int) -> Maybe NameMeta)
-> (HieAST Int -> Maybe (Identifier, IdentifierDetails Int))
-> HieAST Int
-> Maybe NameMeta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, IdentifierDetails Int) -> Bool)
-> [(Identifier, IdentifierDetails Int)]
-> Maybe (Identifier, IdentifierDetails Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (NameMeta -> (Identifier, IdentifierDetails Int) -> Bool
hieMatchNameMeta NameMeta
nameMeta)
([(Identifier, IdentifierDetails Int)]
-> Maybe (Identifier, IdentifierDetails Int))
-> (HieAST Int -> [(Identifier, IdentifierDetails Int)])
-> HieAST Int
-> Maybe (Identifier, IdentifierDetails Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Identifier (IdentifierDetails Int)
-> [(Identifier, IdentifierDetails Int)]
forall k a. Map k a -> [(k, a)]
Map.assocs
(Map Identifier (IdentifierDetails Int)
-> [(Identifier, IdentifierDetails Int)])
-> (HieAST Int -> Map Identifier (IdentifierDetails Int))
-> HieAST Int
-> [(Identifier, IdentifierDetails Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo Int -> Map Identifier (IdentifierDetails Int)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers
(NodeInfo Int -> Map Identifier (IdentifierDetails Int))
-> (HieAST Int -> NodeInfo Int)
-> HieAST Int
-> Map Identifier (IdentifierDetails Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST Int -> NodeInfo Int
forall a. HieAST a -> NodeInfo a
nodeInfo
infix 8 `baseNameFrom`
baseNameFrom :: Text -> ModuleName -> NameMeta
baseNameFrom :: Text -> ModuleName -> NameMeta
baseNameFrom funName :: Text
funName moduleName :: ModuleName
moduleName = $WNameMeta :: Text -> ModuleName -> Text -> NameMeta
NameMeta
{ nameMetaName :: Text
nameMetaName = Text
funName
, nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
, nameMetaPackage :: Text
nameMetaPackage = "base"
}
mkBaseListMeta :: Text -> NameMeta
mkBaseListMeta :: Text -> NameMeta
mkBaseListMeta = (Text -> ModuleName -> NameMeta
`baseNameFrom` "GHC.List")
mkBaseOldListMeta :: Text -> NameMeta
mkBaseOldListMeta :: Text -> NameMeta
mkBaseOldListMeta = (Text -> ModuleName -> NameMeta
`baseNameFrom` "Data.OldList")
mkBaseFoldableMeta :: Text -> NameMeta
mkBaseFoldableMeta :: Text -> NameMeta
mkBaseFoldableMeta = (Text -> ModuleName -> NameMeta
`baseNameFrom` "Data.Foldable")
infix 8 `unorderedNameFrom`
unorderedNameFrom :: Text -> ModuleName -> NameMeta
unorderedNameFrom :: Text -> ModuleName -> NameMeta
unorderedNameFrom funName :: Text
funName moduleName :: ModuleName
moduleName = $WNameMeta :: Text -> ModuleName -> Text -> NameMeta
NameMeta
{ nameMetaName :: Text
nameMetaName = Text
funName
, nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
, nameMetaPackage :: Text
nameMetaPackage = "unordered-containers"
}
infix 8 `textNameFrom`
textNameFrom :: Text -> ModuleName -> NameMeta
textNameFrom :: Text -> ModuleName -> NameMeta
textNameFrom funName :: Text
funName moduleName :: ModuleName
moduleName = $WNameMeta :: Text -> ModuleName -> Text -> NameMeta
NameMeta
{ nameMetaName :: Text
nameMetaName = Text
funName
, nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
, nameMetaPackage :: Text
nameMetaPackage = "text"
}
infix 8 `ghcPrimNameFrom`
ghcPrimNameFrom :: Text -> ModuleName -> NameMeta
ghcPrimNameFrom :: Text -> ModuleName -> NameMeta
ghcPrimNameFrom funName :: Text
funName moduleName :: ModuleName
moduleName = $WNameMeta :: Text -> ModuleName -> Text -> NameMeta
NameMeta
{ nameMetaName :: Text
nameMetaName = Text
funName
, nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
, nameMetaPackage :: Text
nameMetaPackage = "ghc-prim"
}
primTypeMeta :: Text -> NameMeta
primTypeMeta :: Text -> NameMeta
primTypeMeta = (Text -> ModuleName -> NameMeta
`ghcPrimNameFrom` "GHC.Types")