{- |
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)
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


-- | Meta information about function/type.
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)

-- | Pretty show 'NameMeta' in the following format: @package\/module\/name@.
prettyShowNameMeta :: NameMeta -> Text
prettyShowNameMeta :: NameMeta -> Text
prettyShowNameMeta NameMeta{..} = Text -> [Text] -> Text
T.intercalate "/"
    [ 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{..} 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
           -- 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
        '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
<> "_"

{- | 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 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
    -- check: not a module name
    Right name :: 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 Int -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails Int
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 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

{- | 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 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"
    }

{- | 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` "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` "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` "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 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"
    }

{- | 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 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"
    }

{- | 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 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"
    }

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