{- |
Copyright: (c) 2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Data types and functions for working with meta information.
-}

module Stan.NameMeta
    ( NameMeta (..)

      -- * Pretty show
    , prettyShowNameMeta

      -- * Comparison with 'Name'
    , compareNames
    , hieMatchNameMeta
    , hieFindIdentifier

      -- * Smart constructors
    , 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, showTUnitId)
import Stan.Hie.Compat (ContextInfo (IEThing), HieAST (..), IEType (Import), Identifier,
                        IdentifierDetails (..), NodeInfo (..), TypeIndex, nodeInfo)

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T


-- | Meta information about function/type.
data NameMeta = NameMeta
    { NameMeta -> Text
nameMetaPackage    :: !Text
    , NameMeta -> ModuleName
nameMetaModuleName :: !ModuleName
    , NameMeta -> Text
nameMetaName       :: !Text
    } deriving stock (TypeIndex -> NameMeta -> ShowS
[NameMeta] -> ShowS
NameMeta -> String
(TypeIndex -> NameMeta -> ShowS)
-> (NameMeta -> String) -> ([NameMeta] -> ShowS) -> Show NameMeta
forall a.
(TypeIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: TypeIndex -> NameMeta -> ShowS
showsPrec :: TypeIndex -> NameMeta -> ShowS
$cshow :: NameMeta -> String
show :: NameMeta -> String
$cshowList :: [NameMeta] -> ShowS
showList :: [NameMeta] -> ShowS
Show, NameMeta -> NameMeta -> Bool
(NameMeta -> NameMeta -> Bool)
-> (NameMeta -> NameMeta -> Bool) -> Eq NameMeta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameMeta -> NameMeta -> Bool
== :: NameMeta -> NameMeta -> Bool
$c/= :: NameMeta -> NameMeta -> Bool
/= :: NameMeta -> NameMeta -> Bool
Eq)

-- | Pretty show 'NameMeta' in the following format: @package\/module\/name@.
prettyShowNameMeta :: NameMeta -> Text
prettyShowNameMeta :: NameMeta -> Text
prettyShowNameMeta NameMeta{Text
ModuleName
nameMetaPackage :: NameMeta -> Text
nameMetaModuleName :: NameMeta -> ModuleName
nameMetaName :: NameMeta -> Text
nameMetaPackage :: Text
nameMetaModuleName :: ModuleName
nameMetaName :: Text
..} = Text -> [Text] -> Text
T.intercalate Text
"/"
    [ Text
nameMetaPackage
    , ModuleName -> Text
unModuleName ModuleName
nameMetaModuleName
    , Text
nameMetaName
    ]

-- | Check if 'NameMeta' is identical to 'Name'.
compareNames :: NameMeta -> Name -> Bool
compareNames :: NameMeta -> Name -> Bool
compareNames NameMeta{Text
ModuleName
nameMetaPackage :: NameMeta -> Text
nameMetaModuleName :: NameMeta -> ModuleName
nameMetaName :: NameMeta -> Text
nameMetaPackage :: Text
nameMetaModuleName :: ModuleName
nameMetaName :: Text
..} 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
$ (() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
name
        package :: Text
package = UnitId -> Text
showTUnitId (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
$ (() :: Constraint) => 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
           -- Cabal hack they made for MacOS. For now, we check for all platforms.
           -- See this issue for more info: https://github.com/kowainik/stan/issues/240
           Bool -> Bool -> Bool
|| Text -> Text
withoutVowels Text
nameMetaPackage Text -> Text -> Bool
`T.isPrefixOf` Text
package
           -- Cabal hack they made for Windows. For now, we check for all platforms
           -- See this issue for more info: https://github.com/kowainik/stan/issues/274
           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
        Char
'a' -> Bool
False
        Char
'e' -> Bool
False
        Char
'i' -> Bool
False
        Char
'o' -> Bool
False
        Char
'u' -> Bool
False
        Char
_ -> Bool
True

    truncatedWindows :: Text -> Text
    truncatedWindows :: Text -> Text
truncatedWindows Text
s = TypeIndex -> Text -> Text
T.take TypeIndex
13 Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"

{- | Check whether HIE 'Identifier' with details is a given 'NameMeta'.
-}
hieMatchNameMeta
    :: NameMeta  -- ^ Name meta info
    -> (Identifier, IdentifierDetails TypeIndex)  -- ^ HIE identifier
    -> Bool
hieMatchNameMeta :: NameMeta -> (Identifier, IdentifierDetails TypeIndex) -> Bool
hieMatchNameMeta NameMeta
nameMeta (Identifier
identifier, IdentifierDetails TypeIndex
details) = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> Maybe () -> Bool
forall a b. (a -> b) -> a -> b
$ do
    -- check: not a module name
    Right Name
name <- Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
identifier
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
        -- not in the imports
        (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 TypeIndex -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails TypeIndex
details)
        -- exact name/module/package
        Bool -> Bool -> Bool
&& NameMeta -> Name -> Bool
compareNames NameMeta
nameMeta Name
name

{- | Check if the given 'HieAST' node is identifier equal to the given
'NameMeta'.
-}
hieFindIdentifier :: NameMeta -> HieAST TypeIndex -> Maybe NameMeta
hieFindIdentifier :: NameMeta -> HieAST TypeIndex -> Maybe NameMeta
hieFindIdentifier NameMeta
nameMeta =
    (NameMeta
nameMeta NameMeta
-> Maybe (Identifier, IdentifierDetails TypeIndex)
-> Maybe NameMeta
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
    (Maybe (Identifier, IdentifierDetails TypeIndex) -> Maybe NameMeta)
-> (HieAST TypeIndex
    -> Maybe (Identifier, IdentifierDetails TypeIndex))
-> HieAST TypeIndex
-> Maybe NameMeta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, IdentifierDetails TypeIndex) -> Bool)
-> [(Identifier, IdentifierDetails TypeIndex)]
-> Maybe (Identifier, IdentifierDetails TypeIndex)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (NameMeta -> (Identifier, IdentifierDetails TypeIndex) -> Bool
hieMatchNameMeta NameMeta
nameMeta)
    ([(Identifier, IdentifierDetails TypeIndex)]
 -> Maybe (Identifier, IdentifierDetails TypeIndex))
-> (HieAST TypeIndex
    -> [(Identifier, IdentifierDetails TypeIndex)])
-> HieAST TypeIndex
-> Maybe (Identifier, IdentifierDetails TypeIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Identifier (IdentifierDetails TypeIndex)
-> [(Identifier, IdentifierDetails TypeIndex)]
forall k a. Map k a -> [(k, a)]
Map.assocs
    (Map Identifier (IdentifierDetails TypeIndex)
 -> [(Identifier, IdentifierDetails TypeIndex)])
-> (HieAST TypeIndex
    -> Map Identifier (IdentifierDetails TypeIndex))
-> HieAST TypeIndex
-> [(Identifier, IdentifierDetails TypeIndex)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo TypeIndex -> Map Identifier (IdentifierDetails TypeIndex)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers
    (NodeInfo TypeIndex
 -> Map Identifier (IdentifierDetails TypeIndex))
-> (HieAST TypeIndex -> NodeInfo TypeIndex)
-> HieAST TypeIndex
-> Map Identifier (IdentifierDetails TypeIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST TypeIndex -> NodeInfo TypeIndex
forall a. Ord a => HieAST a -> NodeInfo a
nodeInfo

{- | Create 'NameMeta' for a function from the @base@ package and
a given 'ModuleName'. module.
-}
infix 8 `baseNameFrom`
baseNameFrom :: Text -> ModuleName -> NameMeta
baseNameFrom :: Text -> ModuleName -> NameMeta
baseNameFrom Text
funName ModuleName
moduleName = NameMeta
    { nameMetaName :: Text
nameMetaName       = Text
funName
    , nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
    , nameMetaPackage :: Text
nameMetaPackage    = Text
"base"
    }

{- | Create 'NameMeta' for a function from the @base@ package and
the "GHC.List" module.
-}
mkBaseListMeta :: Text -> NameMeta
mkBaseListMeta :: Text -> NameMeta
mkBaseListMeta = (Text -> ModuleName -> NameMeta
`baseNameFrom` ModuleName
"GHC.List")

{- | Create 'NameMeta' for a function from the @base@ package and
the "Data.OldList" module.
-}
mkBaseOldListMeta :: Text -> NameMeta
mkBaseOldListMeta :: Text -> NameMeta
mkBaseOldListMeta = (Text -> ModuleName -> NameMeta
`baseNameFrom` ModuleName
"Data.OldList")

{- | Create 'NameMeta' for a function from the @base@ package and
the "Data.Foldable" module.
-}
mkBaseFoldableMeta :: Text -> NameMeta
mkBaseFoldableMeta :: Text -> NameMeta
mkBaseFoldableMeta = (Text -> ModuleName -> NameMeta
`baseNameFrom` ModuleName
"Data.Foldable")

{- | Create 'NameMeta' for a function from the @unordered-containers@ package
and a given 'ModuleName' module.
-}
infix 8 `unorderedNameFrom`
unorderedNameFrom :: Text -> ModuleName -> NameMeta
unorderedNameFrom :: Text -> ModuleName -> NameMeta
unorderedNameFrom Text
funName ModuleName
moduleName = NameMeta
    { nameMetaName :: Text
nameMetaName       = Text
funName
    , nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
    , nameMetaPackage :: Text
nameMetaPackage    = Text
"unordered-containers"
    }

{- | Create 'NameMeta' for a function from the @text@ package
and a given 'ModuleName' module.
-}
infix 8 `textNameFrom`
textNameFrom :: Text -> ModuleName -> NameMeta
textNameFrom :: Text -> ModuleName -> NameMeta
textNameFrom Text
funName ModuleName
moduleName = NameMeta
    { nameMetaName :: Text
nameMetaName       = Text
funName
    , nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
    , nameMetaPackage :: Text
nameMetaPackage    = Text
"text"
    }

{- | Create 'NameMeta' for a function from the @ghc-prim@ package
and a given 'ModuleName' module.
-}
infix 8 `ghcPrimNameFrom`
ghcPrimNameFrom :: Text -> ModuleName -> NameMeta
ghcPrimNameFrom :: Text -> ModuleName -> NameMeta
ghcPrimNameFrom Text
funName ModuleName
moduleName = NameMeta
    { nameMetaName :: Text
nameMetaName       = Text
funName
    , nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
moduleName
    , nameMetaPackage :: Text
nameMetaPackage    = Text
"ghc-prim"
    }

-- | 'NameMeta' for primitive types.
primTypeMeta :: Text -> NameMeta
primTypeMeta :: Text -> NameMeta
primTypeMeta = (Text -> ModuleName -> NameMeta
`ghcPrimNameFrom` ModuleName
"GHC.Types")