----------------------------------------------------------------------
-- |
-- Module      : Ident
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/15 11:43:33 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------

module GF.Infra.Ident (-- ** Identifiers
  ModuleName(..), moduleNameS,
  Ident, ident2utf8, showIdent, prefixIdent,
  -- *** Normal identifiers (returned by the parser)
  identS, identC, identW,
  -- *** Special identifiers for internal use
  identV, identA, identAV,
  argIdent, isArgIdent, getArgIndex,
  varStr, varX, isWildIdent, varIndex,
  -- *** Raw identifiers
  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
  isPrefixOf, showRawIdent
) where

import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
                 -- Limit use of BS functions to the ones that work correctly on
                 -- UTF-8-encoded bytestrings!
import Data.Char(isDigit)
import PGF.Internal(Binary(..))
import GF.Text.Pretty


-- | Module names
newtype ModuleName = MN Ident deriving (ModuleName -> ModuleName -> Bool
(ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool) -> Eq ModuleName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleName -> ModuleName -> Bool
$c/= :: ModuleName -> ModuleName -> Bool
== :: ModuleName -> ModuleName -> Bool
$c== :: ModuleName -> ModuleName -> Bool
Eq,Eq ModuleName
Eq ModuleName
-> (ModuleName -> ModuleName -> Ordering)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> ModuleName)
-> (ModuleName -> ModuleName -> ModuleName)
-> Ord ModuleName
ModuleName -> ModuleName -> Bool
ModuleName -> ModuleName -> Ordering
ModuleName -> ModuleName -> ModuleName
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 :: ModuleName -> ModuleName -> ModuleName
$cmin :: ModuleName -> ModuleName -> ModuleName
max :: ModuleName -> ModuleName -> ModuleName
$cmax :: ModuleName -> ModuleName -> ModuleName
>= :: ModuleName -> ModuleName -> Bool
$c>= :: ModuleName -> ModuleName -> Bool
> :: ModuleName -> ModuleName -> Bool
$c> :: ModuleName -> ModuleName -> Bool
<= :: ModuleName -> ModuleName -> Bool
$c<= :: ModuleName -> ModuleName -> Bool
< :: ModuleName -> ModuleName -> Bool
$c< :: ModuleName -> ModuleName -> Bool
compare :: ModuleName -> ModuleName -> Ordering
$ccompare :: ModuleName -> ModuleName -> Ordering
$cp1Ord :: Eq ModuleName
Ord)

moduleNameS :: String -> ModuleName
moduleNameS = Ident -> ModuleName
MN (Ident -> ModuleName) -> (String -> Ident) -> String -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
identS

instance Show ModuleName where showsPrec :: Int -> ModuleName -> ShowS
showsPrec Int
d (MN Ident
m) = Int -> Ident -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d Ident
m
instance Pretty ModuleName where pp :: ModuleName -> Doc
pp (MN Ident
m) = Ident -> Doc
forall a. Pretty a => a -> Doc
pp Ident
m


-- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser
data Ident =
   IC  {-# UNPACK #-} !RawIdent                                           -- ^ raw identifier after parsing, resolved in Rename
 | IW                                                                     -- ^ wildcard
--
-- below this constructor: internal representation never returned by the parser
 | IV  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ variable
 | IA  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ argument of cat at position
 | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int   -- ^ /INTERNAL/ argument of cat with bindings at position
--
  deriving (Ident -> Ident -> Bool
(Ident -> Ident -> Bool) -> (Ident -> Ident -> Bool) -> Eq Ident
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ident -> Ident -> Bool
$c/= :: Ident -> Ident -> Bool
== :: Ident -> Ident -> Bool
$c== :: Ident -> Ident -> Bool
Eq, Eq Ident
Eq Ident
-> (Ident -> Ident -> Ordering)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Ident)
-> (Ident -> Ident -> Ident)
-> Ord Ident
Ident -> Ident -> Bool
Ident -> Ident -> Ordering
Ident -> Ident -> Ident
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 :: Ident -> Ident -> Ident
$cmin :: Ident -> Ident -> Ident
max :: Ident -> Ident -> Ident
$cmax :: Ident -> Ident -> Ident
>= :: Ident -> Ident -> Bool
$c>= :: Ident -> Ident -> Bool
> :: Ident -> Ident -> Bool
$c> :: Ident -> Ident -> Bool
<= :: Ident -> Ident -> Bool
$c<= :: Ident -> Ident -> Bool
< :: Ident -> Ident -> Bool
$c< :: Ident -> Ident -> Bool
compare :: Ident -> Ident -> Ordering
$ccompare :: Ident -> Ident -> Ordering
$cp1Ord :: Eq Ident
Ord, Int -> Ident -> ShowS
[Ident] -> ShowS
Ident -> String
(Int -> Ident -> ShowS)
-> (Ident -> String) -> ([Ident] -> ShowS) -> Show Ident
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ident] -> ShowS
$cshowList :: [Ident] -> ShowS
show :: Ident -> String
$cshow :: Ident -> String
showsPrec :: Int -> Ident -> ShowS
$cshowsPrec :: Int -> Ident -> ShowS
Show, ReadPrec [Ident]
ReadPrec Ident
Int -> ReadS Ident
ReadS [Ident]
(Int -> ReadS Ident)
-> ReadS [Ident]
-> ReadPrec Ident
-> ReadPrec [Ident]
-> Read Ident
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Ident]
$creadListPrec :: ReadPrec [Ident]
readPrec :: ReadPrec Ident
$creadPrec :: ReadPrec Ident
readList :: ReadS [Ident]
$creadList :: ReadS [Ident]
readsPrec :: Int -> ReadS Ident
$creadsPrec :: Int -> ReadS Ident
Read)

-- | Identifiers are stored as UTF-8-encoded bytestrings.
-- (It is also possible to use regular Haskell 'String's, with somewhat
-- reduced performance and increased memory use.)
newtype RawIdent = Id { RawIdent -> ByteString
rawId2utf8 :: UTF8.ByteString }
  deriving (RawIdent -> RawIdent -> Bool
(RawIdent -> RawIdent -> Bool)
-> (RawIdent -> RawIdent -> Bool) -> Eq RawIdent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawIdent -> RawIdent -> Bool
$c/= :: RawIdent -> RawIdent -> Bool
== :: RawIdent -> RawIdent -> Bool
$c== :: RawIdent -> RawIdent -> Bool
Eq, Eq RawIdent
Eq RawIdent
-> (RawIdent -> RawIdent -> Ordering)
-> (RawIdent -> RawIdent -> Bool)
-> (RawIdent -> RawIdent -> Bool)
-> (RawIdent -> RawIdent -> Bool)
-> (RawIdent -> RawIdent -> Bool)
-> (RawIdent -> RawIdent -> RawIdent)
-> (RawIdent -> RawIdent -> RawIdent)
-> Ord RawIdent
RawIdent -> RawIdent -> Bool
RawIdent -> RawIdent -> Ordering
RawIdent -> RawIdent -> RawIdent
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 :: RawIdent -> RawIdent -> RawIdent
$cmin :: RawIdent -> RawIdent -> RawIdent
max :: RawIdent -> RawIdent -> RawIdent
$cmax :: RawIdent -> RawIdent -> RawIdent
>= :: RawIdent -> RawIdent -> Bool
$c>= :: RawIdent -> RawIdent -> Bool
> :: RawIdent -> RawIdent -> Bool
$c> :: RawIdent -> RawIdent -> Bool
<= :: RawIdent -> RawIdent -> Bool
$c<= :: RawIdent -> RawIdent -> Bool
< :: RawIdent -> RawIdent -> Bool
$c< :: RawIdent -> RawIdent -> Bool
compare :: RawIdent -> RawIdent -> Ordering
$ccompare :: RawIdent -> RawIdent -> Ordering
$cp1Ord :: Eq RawIdent
Ord, Int -> RawIdent -> ShowS
[RawIdent] -> ShowS
RawIdent -> String
(Int -> RawIdent -> ShowS)
-> (RawIdent -> String) -> ([RawIdent] -> ShowS) -> Show RawIdent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawIdent] -> ShowS
$cshowList :: [RawIdent] -> ShowS
show :: RawIdent -> String
$cshow :: RawIdent -> String
showsPrec :: Int -> RawIdent -> ShowS
$cshowsPrec :: Int -> RawIdent -> ShowS
Show, ReadPrec [RawIdent]
ReadPrec RawIdent
Int -> ReadS RawIdent
ReadS [RawIdent]
(Int -> ReadS RawIdent)
-> ReadS [RawIdent]
-> ReadPrec RawIdent
-> ReadPrec [RawIdent]
-> Read RawIdent
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RawIdent]
$creadListPrec :: ReadPrec [RawIdent]
readPrec :: ReadPrec RawIdent
$creadPrec :: ReadPrec RawIdent
readList :: ReadS [RawIdent]
$creadList :: ReadS [RawIdent]
readsPrec :: Int -> ReadS RawIdent
$creadsPrec :: Int -> ReadS RawIdent
Read)

pack :: String -> ByteString
pack = String -> ByteString
UTF8.fromString
unpack :: ByteString -> String
unpack = ByteString -> String
UTF8.toString

rawIdentS :: String -> RawIdent
rawIdentS = ByteString -> RawIdent
Id (ByteString -> RawIdent)
-> (String -> ByteString) -> String -> RawIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack
rawIdentC :: ByteString -> RawIdent
rawIdentC = ByteString -> RawIdent
Id
showRawIdent :: RawIdent -> String
showRawIdent = ByteString -> String
unpack (ByteString -> String)
-> (RawIdent -> ByteString) -> RawIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawIdent -> ByteString
rawId2utf8

prefixRawIdent :: RawIdent -> RawIdent -> RawIdent
prefixRawIdent (Id ByteString
x) (Id ByteString
y) = ByteString -> RawIdent
Id (ByteString -> ByteString -> ByteString
BS.append ByteString
x ByteString
y)
isPrefixOf :: RawIdent -> RawIdent -> Bool
isPrefixOf (Id ByteString
x) (Id ByteString
y) = ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
x ByteString
y

instance Binary RawIdent where
  put :: RawIdent -> Put
put = ByteString -> Put
forall t. Binary t => t -> Put
put (ByteString -> Put) -> (RawIdent -> ByteString) -> RawIdent -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawIdent -> ByteString
rawId2utf8
  get :: Get RawIdent
get = (ByteString -> RawIdent) -> Get ByteString -> Get RawIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> RawIdent
rawIdentC Get ByteString
forall t. Binary t => Get t
get

-- | This function should be used with care, since the returned ByteString is
-- UTF-8-encoded.
ident2utf8 :: Ident -> UTF8.ByteString
ident2utf8 :: Ident -> ByteString
ident2utf8 Ident
i = case Ident
i of
  IC (Id ByteString
s) -> ByteString
s
  IV (Id ByteString
s) Int
n -> ByteString -> ByteString -> ByteString
BS.append ByteString
s (String -> ByteString
pack (Char
'_'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
n))
  IA (Id ByteString
s) Int
j -> ByteString -> ByteString -> ByteString
BS.append ByteString
s (String -> ByteString
pack (Char
'_'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
j))
  IAV (Id ByteString
s) Int
b Int
j -> ByteString -> ByteString -> ByteString
BS.append ByteString
s (String -> ByteString
pack (Char
'_'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'_'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
j))
  Ident
IW -> String -> ByteString
pack String
"_"

ident2raw :: Ident -> RawIdent
ident2raw :: Ident -> RawIdent
ident2raw = ByteString -> RawIdent
Id (ByteString -> RawIdent)
-> (Ident -> ByteString) -> Ident -> RawIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ByteString
ident2utf8

showIdent :: Ident -> String
showIdent :: Ident -> String
showIdent Ident
i = ByteString -> String
unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$! Ident -> ByteString
ident2utf8 Ident
i

instance Pretty Ident where pp :: Ident -> Doc
pp = String -> Doc
forall a. Pretty a => a -> Doc
pp (String -> Doc) -> (Ident -> String) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
showIdent

instance Pretty RawIdent where pp :: RawIdent -> Doc
pp = String -> Doc
forall a. Pretty a => a -> Doc
pp (String -> Doc) -> (RawIdent -> String) -> RawIdent -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawIdent -> String
showRawIdent

identS :: String -> Ident
identS :: String -> Ident
identS = RawIdent -> Ident
identC (RawIdent -> Ident) -> (String -> RawIdent) -> String -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RawIdent
rawIdentS

identC :: RawIdent -> Ident
identW :: Ident

prefixIdent :: String -> Ident -> Ident
prefixIdent :: String -> Ident -> Ident
prefixIdent String
pref = RawIdent -> Ident
identC (RawIdent -> Ident) -> (Ident -> RawIdent) -> Ident -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RawIdent
Id (ByteString -> RawIdent)
-> (Ident -> ByteString) -> Ident -> RawIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
BS.append (String -> ByteString
pack String
pref) (ByteString -> ByteString)
-> (Ident -> ByteString) -> Ident -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ByteString
ident2utf8

-- normal identifier
-- ident s = IC s

identV :: RawIdent -> Int -> Ident
identA :: RawIdent -> Int -> Ident
identAV:: RawIdent -> Int -> Int -> Ident

(RawIdent -> Ident
identC, RawIdent -> Int -> Ident
identV, RawIdent -> Int -> Ident
identA, RawIdent -> Int -> Int -> Ident
identAV, Ident
identW) =
    (RawIdent -> Ident
IC,     RawIdent -> Int -> Ident
IV,     RawIdent -> Int -> Ident
IA,     RawIdent -> Int -> Int -> Ident
IAV,     Ident
IW)

-- | to mark argument variables
argIdent :: Int -> Ident -> Int -> Ident
argIdent :: Int -> Ident -> Int -> Ident
argIdent Int
0 (IC RawIdent
c) Int
i = RawIdent -> Int -> Ident
identA  RawIdent
c Int
i
argIdent Int
b (IC RawIdent
c) Int
i = RawIdent -> Int -> Int -> Ident
identAV RawIdent
c Int
b Int
i

isArgIdent :: Ident -> Bool
isArgIdent IA{}  = Bool
True
isArgIdent IAV{} = Bool
True
isArgIdent Ident
_     = Bool
False

getArgIndex :: Ident -> Maybe Int
getArgIndex (IA RawIdent
_ Int
i)    = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
getArgIndex (IAV RawIdent
_ Int
_ Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
getArgIndex (IC (Id ByteString
bs))
  | Char -> Bool
isDigit Char
c =
   -- (Just . read . unpack . snd . BS.spanEnd isDigit) bs -- not ok with UTF-8
      (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (String -> Int) -> String -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Int) -> ShowS -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit) String
s
  where s :: String
s@(Char
c:String
_) = ShowS
forall a. [a] -> [a]
reverse (ByteString -> String
unpack ByteString
bs)
getArgIndex Ident
x = Maybe Int
forall a. Maybe a
Nothing

-- | used in lin defaults
varStr :: Ident
varStr :: Ident
varStr = RawIdent -> Int -> Ident
identA (String -> RawIdent
rawIdentS String
"str") Int
0

-- | refreshing variables
varX :: Int -> Ident
varX :: Int -> Ident
varX = RawIdent -> Int -> Ident
identV (String -> RawIdent
rawIdentS String
"x")

isWildIdent :: Ident -> Bool
isWildIdent :: Ident -> Bool
isWildIdent Ident
x = case Ident
x of
  Ident
IW -> Bool
True
  IC RawIdent
s | RawIdent
s RawIdent -> RawIdent -> Bool
forall a. Eq a => a -> a -> Bool
== RawIdent
wild -> Bool
True
  Ident
_ -> Bool
False

wild :: RawIdent
wild = ByteString -> RawIdent
Id (String -> ByteString
pack String
"_")

varIndex :: Ident -> Int
varIndex :: Ident -> Int
varIndex (IV RawIdent
_ Int
n) = Int
n
varIndex Ident
_ = -Int
1 --- other than IV should not count