module Idents (Ident, noARNum, isLegalIdent, lexemeToIdent, internalIdent,
onlyPosIdent, cloneIdent, identToLexeme, isIdentSimple,
isIdentPrim, stripIdentARNum, getIdentARNum, newIdentARNum,
getIdentAttrs, dumpIdent)
where
import Data.Char
import Position (Position, Pos(posOf), nopos)
import UNames (Name)
import Errors (interr)
import Attributes (Attrs, newAttrsOnlyPos, newAttrs,
Attributed(attrsOf), posOfAttrsOf)
import Binary (Binary(..), putSharedString, getSharedString)
data Ident = Ident String
!Int
!Int
!Attrs
instance Eq Ident where
(Ident String
s Int
k Int
id Attrs
_) == :: Ident -> Ident -> Bool
== (Ident String
s' Int
k' Int
id' Attrs
_) = (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k')
Bool -> Bool -> Bool
&& (Int
id Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
id')
Bool -> Bool -> Bool
&& (String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s')
instance Ord Ident where
(Ident String
s Int
k Int
id Attrs
_) < :: Ident -> Ident -> Bool
< (Ident String
s' Int
k' Int
id' Attrs
_) = (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k')
Bool -> Bool -> Bool
|| ((Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k') Bool -> Bool -> Bool
&& (Int
id Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
id'))
Bool -> Bool -> Bool
|| ((Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k') Bool -> Bool -> Bool
&& (Int
id Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
id')
Bool -> Bool -> Bool
&& (String
s String -> String -> Bool
forall a. Ord a => a -> a -> Bool
< String
s'))
Ident
id1 <= :: Ident -> Ident -> Bool
<= Ident
id2 = (Ident
id1 Ident -> Ident -> Bool
forall a. Ord a => a -> a -> Bool
< Ident
id2) Bool -> Bool -> Bool
|| (Ident
id1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
id2)
instance Show Ident where
showsPrec :: Int -> Ident -> ShowS
showsPrec Int
_ Ident
ide = String -> ShowS
showString (String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'")
instance Attributed Ident where
attrsOf :: Ident -> Attrs
attrsOf (Ident String
_ Int
_ Int
_ Attrs
at) = Attrs
at
instance Pos Ident where
posOf :: Ident -> Position
posOf = Ident -> Position
forall a. Attributed a => a -> Position
posOfAttrsOf
quad :: String -> Int
quad :: String -> Int
quad (Char
c1:Char
c2:Char
c3:Char
c4:String
s) = ((Char -> Int
ord Char
c4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bits21
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bits14
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bits7
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c1)
Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
bits28)
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (String -> Int
quad String
s Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
bits28)
quad (Char
c1:Char
c2:Char
c3:[] ) = Char -> Int
ord Char
c3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bits14 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bits7 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c1
quad (Char
c1:Char
c2:[] ) = Char -> Int
ord Char
c2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bits7 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c1
quad (Char
c1:[] ) = Char -> Int
ord Char
c1
quad ([] ) = Int
0
bits7 :: Int
bits7 = Int
2Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
7
bits14 :: Int
bits14 = Int
2Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
14
bits21 :: Int
bits21 = Int
2Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
21
bits28 :: Int
bits28 = Int
2Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
28
noARNum :: Int
noARNum :: Int
noARNum = -Int
1
primARNum :: Int
primARNum :: Int
primARNum = -Int
2
internARNum :: Int
internARNum :: Int
internARNum = -Int
3
isLegalIdent :: String -> Bool
isLegalIdent :: String -> Bool
isLegalIdent [] = Bool
False
isLegalIdent (Char
c:String
cs) = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`' then String -> Bool
isQualIdent String
cs
else (Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') Bool -> Bool -> Bool
&& String -> Bool
isIdent (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs)
where
isIdent :: String -> Bool
isIdent = String -> Bool
checkTail (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isAlphaNumOrUS)
checkTail :: String -> Bool
checkTail [] = Bool
True
checkTail (String
"##") = Bool
True
checkTail (Char
'#':String
cs') = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
cs'
checkTail String
_ = Bool
False
isAlphaNumOrUS :: Char -> Bool
isAlphaNumOrUS Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
isAlphaNum :: Char -> Bool
isAlphaNum Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isNum Char
c
isAlpha :: Char -> Bool
isAlpha Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z']
isNum :: Char -> Bool
isNum Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']
isQualIdent :: String -> Bool
isQualIdent String
cs = let
cs' :: String
cs' = ShowS
skip String
cs
in
(Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) String
cs'
Bool -> Bool -> Bool
&& (String -> Bool
checkTail (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
tail) String
cs'
skip :: ShowS
skip [] = []
skip (Char
'\'':String
cs) = Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs
skip (Char
'\\':String
cs) = case String
cs of
(Char
'\'':String
cs') -> ShowS
skip String
cs'
(Char
'\\':String
cs') -> ShowS
skip String
cs'
String
_ -> ShowS
skip String
cs
skip (Char
c :String
cs) = ShowS
skip String
cs
lexemeToIdent :: Position -> String -> Name -> Ident
lexemeToIdent :: Position -> String -> Name -> Ident
lexemeToIdent Position
pos String
l Name
name = String -> Int -> Int -> Attrs -> Ident
Ident String
s Int
k (String -> Int
quad String
s) (Position -> Name -> Attrs
newAttrs Position
pos Name
name)
where
(String
s, Int
k) = Position -> String -> (String, Int)
parseIdent Position
pos String
l
internalIdent :: String -> Ident
internalIdent :: String -> Ident
internalIdent String
s = String -> Int -> Int -> Attrs -> Ident
Ident String
s Int
internARNum (String -> Int
quad String
s) (Position -> Attrs
newAttrsOnlyPos Position
nopos)
onlyPosIdent :: Position -> String -> Ident
onlyPosIdent :: Position -> String -> Ident
onlyPosIdent Position
pos String
l = String -> Int -> Int -> Attrs -> Ident
Ident String
s Int
k (String -> Int
quad String
s) (Position -> Attrs
newAttrsOnlyPos Position
pos)
where
(String
s, Int
k) = Position -> String -> (String, Int)
parseIdent Position
pos String
l
parseIdent :: Position -> String -> (String, Int)
parseIdent :: Position -> String -> (String, Int)
parseIdent Position
pos String
l
= if (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l)
then
String -> (String, Int)
forall a. String -> a
interr (String -> (String, Int)) -> String -> (String, Int)
forall a b. (a -> b) -> a -> b
$ String
"Idents: lexemeToIdent: Empty lexeme! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show Position
pos
else
if (String -> Char
forall a. [a] -> a
head String
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'')
then
String -> (String, Int)
parseQuoted (ShowS
forall a. [a] -> [a]
tail String
l)
else
String -> (String, Int)
parseNorm String
l
where
parseNorm :: String -> (String, Int)
parseNorm [] = ([], Int
noARNum)
parseNorm (String
"##") = ([], Int
primARNum)
parseNorm (Char
'#':String
cs) = ([], ((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
check) String
cs)::Int)
parseNorm (Char
c :String
cs) = let
(String
cs', Int
k) = String -> (String, Int)
parseNorm String
cs
in
(Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
check :: ShowS
check [] = ShowS
forall a. String -> a
interr String
"Idents: lexemeToIdent: Missing\
\ number!"
check (Char
'-':String
cs) = ShowS
forall a. String -> a
interr String
"Idents: lexemeToIdent: Illegal\
\ negative number!"
check String
s = String
s
parseQuoted :: String -> (String, Int)
parseQuoted [] = String -> (String, Int)
forall a. String -> a
interr String
endInQuotes
parseQuoted (Char
'\\':String
cs) = String -> (String, Int)
parseSpecial String
cs
parseQuoted (Char
'\'':String
cs) = let
(String
rmd, Int
k) = String -> (String, Int)
parseNorm String
cs
in
if (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rmd) then ([], Int
k)
else String -> (String, Int)
forall a. String -> a
interr String
afterQuotes
parseQuoted (Char
c :String
cs) = let
(String
cs', Int
k) = String -> (String, Int)
parseQuoted String
cs
in
(Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
endInQuotes :: String
endInQuotes = String
"Idents: lexemeToIdent: Unexpected end of\
\ lexeme (in quotes)!"
afterQuotes :: String
afterQuotes = String
"Idents: lexemeToIdent: Superfluous\
\ characters after quotes!"
endInSpecial :: String
endInSpecial = String
"Idents: lexemeToIdent: Unexpected end of\
\ lexeme (in escape sequence)!"
illegalSpecial :: String
illegalSpecial = String
"Idents: lexemeToIdent: Illegal escape\
\ sequence!"
parseSpecial :: String -> (String, Int)
parseSpecial [] = String -> (String, Int)
forall a. String -> a
interr String
endInSpecial
parseSpecial (Char
c1:Char
c2:Char
c3:String
cs)
| Char -> Bool
isDigit Char
c1
Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
c2
Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
c3 = let
(String
cs', Int
k) = String -> (String, Int)
parseQuoted String
cs
ord0 :: Int
ord0 = Char -> Int
ord Char
'0'
d1 :: Int
d1 = Char -> Int
ord Char
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ord0
d2 :: Int
d2 = Char -> Int
ord Char
c2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ord0
d3 :: Int
d3 = Char -> Int
ord Char
c3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ord0
in
(Int -> Char
chr (Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
d1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
d2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d3)
Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
parseSpecial (Char
c:String
cs)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' = (Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"' = (Char
'\"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' = (Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'n' = (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
't' = (Char
'\t'Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'r' = (Char
'\r'Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs', Int
k)
where
(String
cs', Int
k) = String -> (String, Int)
parseQuoted String
cs
parseSpecial String
_ = String -> (String, Int)
forall a. String -> a
interr String
illegalSpecial
cloneIdent :: Ident -> Name -> Ident
cloneIdent :: Ident -> Name -> Ident
cloneIdent (Ident String
s Int
k Int
idnum Attrs
at) Name
name =
String -> Int -> Int -> Attrs -> Ident
Ident String
s Int
k Int
idnum (Position -> Name -> Attrs
newAttrs (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) Name
name)
identToLexeme :: Ident -> String
identToLexeme :: Ident -> String
identToLexeme (Ident String
s Int
k Int
_ Attrs
_) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix
where
suffix :: String
suffix = if (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
noARNum)
then String
""
else if (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
primARNum)
then String
"##"
else if (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
internARNum)
then String
"<internal>"
else String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k
isIdentSimple :: Ident -> Bool
isIdentSimple :: Ident -> Bool
isIdentSimple (Ident String
_ Int
k Int
_ Attrs
_) = Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
noARNum
isIdentPrim :: Ident -> Bool
isIdentPrim :: Ident -> Bool
isIdentPrim (Ident String
_ Int
k Int
_ Attrs
_) = Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
primARNum
stripIdentARNum :: Ident -> Ident
stripIdentARNum :: Ident -> Ident
stripIdentARNum (Ident String
s Int
k Int
id Attrs
at)
| Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
primARNum Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
internARNum = String -> Ident
forall a. String -> a
interr String
"Idents: stripIdentARNum: \
\Not allowed!"
| Bool
otherwise = String -> Int -> Int -> Attrs -> Ident
Ident String
s Int
noARNum Int
id Attrs
at
getIdentARNum :: Ident -> Int
getIdentARNum :: Ident -> Int
getIdentARNum (Ident String
s Int
k Int
id Attrs
at)
| Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
primARNum Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
internARNum = String -> Int
forall a. String -> a
interr String
"Idents: getIdentARNum: \
\Not allowed!"
| Bool
otherwise = Int
k
newIdentARNum :: Ident -> Int -> Ident
newIdentARNum :: Ident -> Int -> Ident
newIdentARNum (Ident String
s Int
k Int
id Attrs
at) Int
k'
| Int
k' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> Ident
forall a. String -> a
interr String
"Idents: newIdentARNum: \
\Negative number!"
| Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
primARNum Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
internARNum = String -> Ident
forall a. String -> a
interr String
"Idents: newIdentARNum: \
\Not allowed!"
| Bool
otherwise = String -> Int -> Int -> Attrs -> Ident
Ident String
s Int
k' Int
id Attrs
at
getIdentAttrs :: Ident -> Attrs
getIdentAttrs :: Ident -> Attrs
getIdentAttrs (Ident String
_ Int
_ Int
_ Attrs
as) = Attrs
as
dumpIdent :: Ident -> String
dumpIdent :: Ident -> String
dumpIdent Ident
ide = Ident -> String
identToLexeme Ident
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide)
instance Binary Ident where
put_ :: BinHandle -> Ident -> IO ()
put_ BinHandle
bh (Ident String
aa Int
ab Int
ac Attrs
ad) = do
BinHandle -> String -> IO ()
putSharedString BinHandle
bh String
aa
BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
ab
BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
ac
BinHandle -> Attrs -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Attrs
ad
get :: BinHandle -> IO Ident
get BinHandle
bh = do
String
aa <- BinHandle -> IO String
getSharedString BinHandle
bh
Int
ab <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Int
ac <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Attrs
ad <- BinHandle -> IO Attrs
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Ident -> IO Ident
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int -> Int -> Attrs -> Ident
Ident String
aa Int
ab Int
ac Attrs
ad)