-- Copyright 2019 Google LLC
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd

{-# LANGUAGE CPP #-}
module GHC.SourceGen.Name.Internal where

import Data.Char (isAlphaNum, isUpper)
import Data.Function (on)
import Data.List (intercalate)
import Data.String (IsString(..))
#if MIN_VERSION_ghc(9,0,0)
import GHC.Data.FastString (FastString, fsLit)
import GHC.Unit.Module (mkModuleNameFS, ModuleName, moduleNameString)
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
#else
import FastString (FastString, fsLit)
import Module (mkModuleNameFS, ModuleName, moduleNameString)
import OccName
import RdrName
#endif

#if MIN_VERSION_ghc(9,2,0)
import GHC.Data.FastString (LexicalFastString(..))
#endif

#if MIN_VERSION_ghc(9,2,0)
import GHC.Parser.Annotation (LocatedN)
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Types.SrcLoc (Located)
#else
import SrcLoc (Located)
#endif

import GHC.SourceGen.Syntax.Internal (mkLocated)

-- | A string identifier referring to a name.
--
-- 'OccNameStr' keeps track of whether it is a "constructor" or "variable"
-- (e.g.: @\"Foo\"@ vs @\"foo\"@, respectively).
--
-- 'OccNameStr' is simililar in purpose to GHC's 'OccName'.  However, unlike
-- 'OccName', 'OccNameStr' does not differentiate between the namespace
-- of types and of values.
-- Functions in this package that take an 'OccNameStr' as input
-- will internally convert it to the proper namespace.  (This approach
-- makes it easier to implement an 'IsString' instance without the context
-- where a name would be used.)
data OccNameStr = OccNameStr !RawNameSpace !FastString
    deriving (Int -> OccNameStr -> ShowS
[OccNameStr] -> ShowS
OccNameStr -> String
(Int -> OccNameStr -> ShowS)
-> (OccNameStr -> String)
-> ([OccNameStr] -> ShowS)
-> Show OccNameStr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OccNameStr] -> ShowS
$cshowList :: [OccNameStr] -> ShowS
show :: OccNameStr -> String
$cshow :: OccNameStr -> String
showsPrec :: Int -> OccNameStr -> ShowS
$cshowsPrec :: Int -> OccNameStr -> ShowS
Show, OccNameStr -> OccNameStr -> Bool
(OccNameStr -> OccNameStr -> Bool)
-> (OccNameStr -> OccNameStr -> Bool) -> Eq OccNameStr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OccNameStr -> OccNameStr -> Bool
$c/= :: OccNameStr -> OccNameStr -> Bool
== :: OccNameStr -> OccNameStr -> Bool
$c== :: OccNameStr -> OccNameStr -> Bool
Eq)

instance Ord OccNameStr where
    compare :: OccNameStr -> OccNameStr -> Ordering
compare = (RawNameSpace, FastString)
-> (RawNameSpace, FastString) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((RawNameSpace, FastString)
 -> (RawNameSpace, FastString) -> Ordering)
-> (OccNameStr -> (RawNameSpace, FastString))
-> OccNameStr
-> OccNameStr
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(OccNameStr RawNameSpace
n FastString
s) -> (RawNameSpace
n, FastString -> FastString
forall a. a -> a
fromFastString FastString
s))
      where
#if MIN_VERSION_ghc(9,2,0)
        fromFastString = LexicalFastString
#else
        fromFastString :: a -> a
fromFastString = a -> a
forall a. a -> a
id
#endif

data RawNameSpace = Constructor | Value
    deriving (Int -> RawNameSpace -> ShowS
[RawNameSpace] -> ShowS
RawNameSpace -> String
(Int -> RawNameSpace -> ShowS)
-> (RawNameSpace -> String)
-> ([RawNameSpace] -> ShowS)
-> Show RawNameSpace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawNameSpace] -> ShowS
$cshowList :: [RawNameSpace] -> ShowS
show :: RawNameSpace -> String
$cshow :: RawNameSpace -> String
showsPrec :: Int -> RawNameSpace -> ShowS
$cshowsPrec :: Int -> RawNameSpace -> ShowS
Show, RawNameSpace -> RawNameSpace -> Bool
(RawNameSpace -> RawNameSpace -> Bool)
-> (RawNameSpace -> RawNameSpace -> Bool) -> Eq RawNameSpace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawNameSpace -> RawNameSpace -> Bool
$c/= :: RawNameSpace -> RawNameSpace -> Bool
== :: RawNameSpace -> RawNameSpace -> Bool
$c== :: RawNameSpace -> RawNameSpace -> Bool
Eq, Eq RawNameSpace
Eq RawNameSpace
-> (RawNameSpace -> RawNameSpace -> Ordering)
-> (RawNameSpace -> RawNameSpace -> Bool)
-> (RawNameSpace -> RawNameSpace -> Bool)
-> (RawNameSpace -> RawNameSpace -> Bool)
-> (RawNameSpace -> RawNameSpace -> Bool)
-> (RawNameSpace -> RawNameSpace -> RawNameSpace)
-> (RawNameSpace -> RawNameSpace -> RawNameSpace)
-> Ord RawNameSpace
RawNameSpace -> RawNameSpace -> Bool
RawNameSpace -> RawNameSpace -> Ordering
RawNameSpace -> RawNameSpace -> RawNameSpace
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawNameSpace -> RawNameSpace -> RawNameSpace
$cmin :: RawNameSpace -> RawNameSpace -> RawNameSpace
max :: RawNameSpace -> RawNameSpace -> RawNameSpace
$cmax :: RawNameSpace -> RawNameSpace -> RawNameSpace
>= :: RawNameSpace -> RawNameSpace -> Bool
$c>= :: RawNameSpace -> RawNameSpace -> Bool
> :: RawNameSpace -> RawNameSpace -> Bool
$c> :: RawNameSpace -> RawNameSpace -> Bool
<= :: RawNameSpace -> RawNameSpace -> Bool
$c<= :: RawNameSpace -> RawNameSpace -> Bool
< :: RawNameSpace -> RawNameSpace -> Bool
$c< :: RawNameSpace -> RawNameSpace -> Bool
compare :: RawNameSpace -> RawNameSpace -> Ordering
$ccompare :: RawNameSpace -> RawNameSpace -> Ordering
$cp1Ord :: Eq RawNameSpace
Ord)

-- TODO: symbols
rawNameSpace :: String -> RawNameSpace
rawNameSpace :: String -> RawNameSpace
rawNameSpace (Char
c:String
_)
    | Char -> Bool
isUpper Char
c = RawNameSpace
Constructor
rawNameSpace String
_ = RawNameSpace
Value

instance IsString OccNameStr where
    fromString :: String -> OccNameStr
fromString String
s = RawNameSpace -> FastString -> OccNameStr
OccNameStr (String -> RawNameSpace
rawNameSpace String
s) (String -> FastString
fsLit String
s)

valueOccName, typeOccName :: OccNameStr -> OccName
valueOccName :: OccNameStr -> OccName
valueOccName (OccNameStr RawNameSpace
Constructor FastString
s) = FastString -> OccName
mkDataOccFS FastString
s
valueOccName (OccNameStr RawNameSpace
Value FastString
s) = FastString -> OccName
mkVarOccFS FastString
s
typeOccName :: OccNameStr -> OccName
typeOccName (OccNameStr RawNameSpace
Constructor FastString
s) = FastString -> OccName
mkTcOccFS FastString
s
typeOccName (OccNameStr RawNameSpace
Value FastString
s) = FastString -> OccName
mkTyVarOccFS FastString
s

-- | A newtype wrapper around 'ModuleName' which is an instance of 'IsString'.
newtype ModuleNameStr = ModuleNameStr { ModuleNameStr -> ModuleName
unModuleNameStr :: ModuleName }
    deriving (ModuleNameStr -> ModuleNameStr -> Bool
(ModuleNameStr -> ModuleNameStr -> Bool)
-> (ModuleNameStr -> ModuleNameStr -> Bool) -> Eq ModuleNameStr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleNameStr -> ModuleNameStr -> Bool
$c/= :: ModuleNameStr -> ModuleNameStr -> Bool
== :: ModuleNameStr -> ModuleNameStr -> Bool
$c== :: ModuleNameStr -> ModuleNameStr -> Bool
Eq, Eq ModuleNameStr
Eq ModuleNameStr
-> (ModuleNameStr -> ModuleNameStr -> Ordering)
-> (ModuleNameStr -> ModuleNameStr -> Bool)
-> (ModuleNameStr -> ModuleNameStr -> Bool)
-> (ModuleNameStr -> ModuleNameStr -> Bool)
-> (ModuleNameStr -> ModuleNameStr -> Bool)
-> (ModuleNameStr -> ModuleNameStr -> ModuleNameStr)
-> (ModuleNameStr -> ModuleNameStr -> ModuleNameStr)
-> Ord ModuleNameStr
ModuleNameStr -> ModuleNameStr -> Bool
ModuleNameStr -> ModuleNameStr -> Ordering
ModuleNameStr -> ModuleNameStr -> ModuleNameStr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ModuleNameStr -> ModuleNameStr -> ModuleNameStr
$cmin :: ModuleNameStr -> ModuleNameStr -> ModuleNameStr
max :: ModuleNameStr -> ModuleNameStr -> ModuleNameStr
$cmax :: ModuleNameStr -> ModuleNameStr -> ModuleNameStr
>= :: ModuleNameStr -> ModuleNameStr -> Bool
$c>= :: ModuleNameStr -> ModuleNameStr -> Bool
> :: ModuleNameStr -> ModuleNameStr -> Bool
$c> :: ModuleNameStr -> ModuleNameStr -> Bool
<= :: ModuleNameStr -> ModuleNameStr -> Bool
$c<= :: ModuleNameStr -> ModuleNameStr -> Bool
< :: ModuleNameStr -> ModuleNameStr -> Bool
$c< :: ModuleNameStr -> ModuleNameStr -> Bool
compare :: ModuleNameStr -> ModuleNameStr -> Ordering
$ccompare :: ModuleNameStr -> ModuleNameStr -> Ordering
$cp1Ord :: Eq ModuleNameStr
Ord)

instance Show ModuleNameStr where
    show :: ModuleNameStr -> String
show = ShowS
forall a. Show a => a -> String
show ShowS -> (ModuleNameStr -> String) -> ModuleNameStr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString (ModuleName -> String)
-> (ModuleNameStr -> ModuleName) -> ModuleNameStr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameStr -> ModuleName
unModuleNameStr

instance IsString ModuleNameStr where
    fromString :: String -> ModuleNameStr
fromString = ModuleName -> ModuleNameStr
ModuleNameStr (ModuleName -> ModuleNameStr)
-> (String -> ModuleName) -> String -> ModuleNameStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ModuleName
mkModuleNameFS (FastString -> ModuleName)
-> (String -> FastString) -> String -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
fsLit

-- | A string identifier which may be qualified to a particular module.
--
-- 'RdrNameStr' wraps an 'OccNameStr' and thus keeps track of whether it is a
-- "constructor" or "variable" (e.g.: @\"Foo.Bar\"@ vs @\"Foo.bar\"@,
-- respectively).
--
-- 'RdrNameStr' is simililar in purpose to GHC's 'RdrName'.  However, unlike
-- 'RdrName', 'RdrNameStr' does not differentiate between the namespace of types
-- and of values.
-- Functions in this package that take a 'RdrNameStr' as input
-- will internally convert it to the proper namespace.  (This approach
-- makes it easier to implement an 'IsString' instance without the context
-- where a name would be used.)
--
-- For example:
--
-- > fromString "A.B.c" == QualStr (fromString "A.B") (fromString "c")
-- > fromString "c" == UnqualStr (fromString "c")
data RdrNameStr = UnqualStr OccNameStr | QualStr ModuleNameStr OccNameStr
    deriving (Int -> RdrNameStr -> ShowS
[RdrNameStr] -> ShowS
RdrNameStr -> String
(Int -> RdrNameStr -> ShowS)
-> (RdrNameStr -> String)
-> ([RdrNameStr] -> ShowS)
-> Show RdrNameStr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RdrNameStr] -> ShowS
$cshowList :: [RdrNameStr] -> ShowS
show :: RdrNameStr -> String
$cshow :: RdrNameStr -> String
showsPrec :: Int -> RdrNameStr -> ShowS
$cshowsPrec :: Int -> RdrNameStr -> ShowS
Show, RdrNameStr -> RdrNameStr -> Bool
(RdrNameStr -> RdrNameStr -> Bool)
-> (RdrNameStr -> RdrNameStr -> Bool) -> Eq RdrNameStr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RdrNameStr -> RdrNameStr -> Bool
$c/= :: RdrNameStr -> RdrNameStr -> Bool
== :: RdrNameStr -> RdrNameStr -> Bool
$c== :: RdrNameStr -> RdrNameStr -> Bool
Eq, Eq RdrNameStr
Eq RdrNameStr
-> (RdrNameStr -> RdrNameStr -> Ordering)
-> (RdrNameStr -> RdrNameStr -> Bool)
-> (RdrNameStr -> RdrNameStr -> Bool)
-> (RdrNameStr -> RdrNameStr -> Bool)
-> (RdrNameStr -> RdrNameStr -> Bool)
-> (RdrNameStr -> RdrNameStr -> RdrNameStr)
-> (RdrNameStr -> RdrNameStr -> RdrNameStr)
-> Ord RdrNameStr
RdrNameStr -> RdrNameStr -> Bool
RdrNameStr -> RdrNameStr -> Ordering
RdrNameStr -> RdrNameStr -> RdrNameStr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RdrNameStr -> RdrNameStr -> RdrNameStr
$cmin :: RdrNameStr -> RdrNameStr -> RdrNameStr
max :: RdrNameStr -> RdrNameStr -> RdrNameStr
$cmax :: RdrNameStr -> RdrNameStr -> RdrNameStr
>= :: RdrNameStr -> RdrNameStr -> Bool
$c>= :: RdrNameStr -> RdrNameStr -> Bool
> :: RdrNameStr -> RdrNameStr -> Bool
$c> :: RdrNameStr -> RdrNameStr -> Bool
<= :: RdrNameStr -> RdrNameStr -> Bool
$c<= :: RdrNameStr -> RdrNameStr -> Bool
< :: RdrNameStr -> RdrNameStr -> Bool
$c< :: RdrNameStr -> RdrNameStr -> Bool
compare :: RdrNameStr -> RdrNameStr -> Ordering
$ccompare :: RdrNameStr -> RdrNameStr -> Ordering
$cp1Ord :: Eq RdrNameStr
Ord)

#if !MIN_VERSION_ghc(9,2,0)
type LocatedN e = Located e
#endif

-- GHC always wraps RdrName in a Located.  (Usually: 'Located (IdP pass)')
-- So for convenience, these functions return a Located-wrapped value.
valueRdrName, typeRdrName :: RdrNameStr -> LocatedN RdrName
valueRdrName :: RdrNameStr -> LocatedN RdrName
valueRdrName (UnqualStr OccNameStr
r) = RdrName -> LocatedN RdrName
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
Unqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ OccNameStr -> OccName
valueOccName OccNameStr
r
valueRdrName (QualStr (ModuleNameStr ModuleName
m) OccNameStr
r) = RdrName -> LocatedN RdrName
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
Qual ModuleName
m (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ OccNameStr -> OccName
valueOccName OccNameStr
r
typeRdrName :: RdrNameStr -> LocatedN RdrName
typeRdrName (UnqualStr OccNameStr
r) = RdrName -> LocatedN RdrName
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
Unqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ OccNameStr -> OccName
typeOccName OccNameStr
r
typeRdrName (QualStr (ModuleNameStr ModuleName
m) OccNameStr
r) = RdrName -> LocatedN RdrName
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
Qual ModuleName
m (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ OccNameStr -> OccName
typeOccName OccNameStr
r

-- TODO: operators
instance IsString RdrNameStr where
    -- Split "Foo.Bar.baz" into ("Foo.Bar", "baz")
    fromString :: String -> RdrNameStr
fromString String
s = case String -> ([String], String)
collectModuleName String
s of
        ([String]
m, String
n)
            | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
m -> OccNameStr -> RdrNameStr
UnqualStr (String -> OccNameStr
forall a. IsString a => String -> a
fromString String
n)
            | Bool
otherwise -> ModuleNameStr -> OccNameStr -> RdrNameStr
QualStr (String -> ModuleNameStr
forall a. IsString a => String -> a
fromString (String -> ModuleNameStr) -> String -> ModuleNameStr
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
m) (String -> OccNameStr
forall a. IsString a => String -> a
fromString String
n)

collectModuleName :: String -> ([String],String)
collectModuleName :: String -> ([String], String)
collectModuleName String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isVarChar String
s of
    (String
"", String
n) -> ([], String
n)  -- Symbol
    (String
n, String
"") -> ([], String
n)  -- Identifier
    (String
m, Char
'.' : String
s') -> case String -> ([String], String)
collectModuleName String
s' of
                            ([String]
m', String
s'') -> (String
m String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
m', String
s'')
    (String, String)
_ -> String -> ([String], String)
forall a. HasCallStack => String -> a
error (String -> ([String], String)) -> String -> ([String], String)
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse RdrNameStr: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
  where
    isVarChar :: Char -> Bool
isVarChar Char
'\'' = Bool
True
    isVarChar Char
'_' = Bool
True
    isVarChar Char
c = Char -> Bool
isAlphaNum Char
c

-- | A RdrName suitable for an import or export list.
-- E.g.: `import F(a, B)`
-- The 'a' should be a value, but the 'B' should be a type/class.
-- (Currently, GHC doesn't distinguish the class and type namespaces.)
exportRdrName :: RdrNameStr -> LocatedN RdrName
exportRdrName :: RdrNameStr -> LocatedN RdrName
exportRdrName (UnqualStr OccNameStr
r) = RdrName -> LocatedN RdrName
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
Unqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ OccNameStr -> OccName
exportOccName OccNameStr
r
exportRdrName (QualStr (ModuleNameStr ModuleName
m) OccNameStr
r) = RdrName -> LocatedN RdrName
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ ModuleName -> OccName -> RdrName
Qual ModuleName
m (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ OccNameStr -> OccName
exportOccName OccNameStr
r

exportOccName :: OccNameStr -> OccName
exportOccName :: OccNameStr -> OccName
exportOccName (OccNameStr RawNameSpace
Value FastString
s) = FastString -> OccName
mkVarOccFS FastString
s
exportOccName (OccNameStr RawNameSpace
Constructor FastString
s) = FastString -> OccName
mkTcOccFS FastString
s