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 forall a. Eq a => a -> a -> Bool
== Int
k')
Bool -> Bool -> Bool
&& (Int
id forall a. Eq a => a -> a -> Bool
== Int
id')
Bool -> Bool -> Bool
&& (String
s 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 forall a. Ord a => a -> a -> Bool
< Int
k')
Bool -> Bool -> Bool
|| ((Int
k forall a. Eq a => a -> a -> Bool
== Int
k') Bool -> Bool -> Bool
&& (Int
id forall a. Ord a => a -> a -> Bool
< Int
id'))
Bool -> Bool -> Bool
|| ((Int
k forall a. Eq a => a -> a -> Bool
== Int
k') Bool -> Bool -> Bool
&& (Int
id forall a. Eq a => a -> a -> Bool
== Int
id')
Bool -> Bool -> Bool
&& (String
s forall a. Ord a => a -> a -> Bool
< String
s'))
Ident
id1 <= :: Ident -> Ident -> Bool
<= Ident
id2 = (Ident
id1 forall a. Ord a => a -> a -> Bool
< Ident
id2) Bool -> Bool -> Bool
|| (Ident
id1 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
"`" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide 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 = 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 forall a. Num a => a -> a -> a
* Int
bits21
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c3 forall a. Num a => a -> a -> a
* Int
bits14
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c2 forall a. Num a => a -> a -> a
* Int
bits7
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c1)
forall a. Integral a => a -> a -> a
`mod` Int
bits28)
forall a. Num a => a -> a -> a
+ (String -> Int
quad String
s forall a. Integral a => a -> a -> a
`mod` Int
bits28)
quad (Char
c1:Char
c2:Char
c3:[] ) = Char -> Int
ord Char
c3 forall a. Num a => a -> a -> a
* Int
bits14 forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c2 forall a. Num a => a -> a -> a
* Int
bits7 forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c1
quad (Char
c1:Char
c2:[] ) = Char -> Int
ord Char
c2 forall a. Num a => a -> a -> a
* Int
bits7 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
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
7
bits14 :: Int
bits14 = Int
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
14
bits21 :: Int
bits21 = Int
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
21
bits28 :: Int
bits28 = Int
2forall 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 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 forall a. Eq a => a -> a -> Bool
== Char
'_') Bool -> Bool -> Bool
&& String -> Bool
isIdent (Char
cforall a. a -> [a] -> [a]
:String
cs)
where
isIdent :: String -> Bool
isIdent = String -> Bool
checkTail forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isAlphaNumOrUS)
checkTail :: String -> Bool
checkTail [] = Bool
True
checkTail (String
"##") = Bool
True
checkTail (Char
'#':String
cs') = 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 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z']
isNum :: Char -> Bool
isNum Char
c = Char
c 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) String
cs'
Bool -> Bool -> Bool
&& (String -> Bool
checkTail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail) String
cs'
skip :: ShowS
skip [] = []
skip (Char
'\'':String
cs) = Char
'\''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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l)
then
forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"Idents: lexemeToIdent: Empty lexeme! " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
pos
else
if (forall a. [a] -> a
head String
l forall a. Eq a => a -> a -> Bool
== Char
'\'')
then
String -> (String, Int)
parseQuoted (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) = ([], ((forall a. Read a => String -> a
read 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
cforall a. a -> [a] -> [a]
:String
cs', Int
k)
check :: ShowS
check [] = forall a. String -> a
interr String
"Idents: lexemeToIdent: Missing\
\ number!"
check (Char
'-':String
cs) = forall a. String -> a
interr String
"Idents: lexemeToIdent: Illegal\
\ negative number!"
check String
s = String
s
parseQuoted :: String -> (String, Int)
parseQuoted [] = 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rmd) then ([], Int
k)
else 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
cforall 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 [] = 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 forall a. Num a => a -> a -> a
- Int
ord0
d2 :: Int
d2 = Char -> Int
ord Char
c2 forall a. Num a => a -> a -> a
- Int
ord0
d3 :: Int
d3 = Char -> Int
ord Char
c3 forall a. Num a => a -> a -> a
- Int
ord0
in
(Int -> Char
chr (Int
100forall a. Num a => a -> a -> a
*Int
d1 forall a. Num a => a -> a -> a
+ Int
10forall a. Num a => a -> a -> a
*Int
d2 forall a. Num a => a -> a -> a
+ Int
d3)
forall a. a -> [a] -> [a]
:String
cs', Int
k)
parseSpecial (Char
c:String
cs)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\' = (Char
'\\'forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\"' = (Char
'\"'forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' = (Char
'\''forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
'n' = (Char
'\n'forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
't' = (Char
'\t'forall a. a -> [a] -> [a]
:String
cs', Int
k)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
'r' = (Char
'\r'forall a. a -> [a] -> [a]
:String
cs', Int
k)
where
(String
cs', Int
k) = String -> (String, Int)
parseQuoted String
cs
parseSpecial String
_ = 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 (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 forall a. [a] -> [a] -> [a]
++ String
suffix
where
suffix :: String
suffix = if (Int
k forall a. Eq a => a -> a -> Bool
== Int
noARNum)
then String
""
else if (Int
k forall a. Eq a => a -> a -> Bool
== Int
primARNum)
then String
"##"
else if (Int
k forall a. Eq a => a -> a -> Bool
== Int
internARNum)
then String
"<internal>"
else String
"#" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k
isIdentSimple :: Ident -> Bool
isIdentSimple :: Ident -> Bool
isIdentSimple (Ident String
_ Int
k Int
_ Attrs
_) = Int
k forall a. Eq a => a -> a -> Bool
== Int
noARNum
isIdentPrim :: Ident -> Bool
isIdentPrim :: Ident -> Bool
isIdentPrim (Ident String
_ Int
k Int
_ Attrs
_) = Int
k 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 forall a. Eq a => a -> a -> Bool
== Int
primARNum Bool -> Bool -> Bool
|| Int
k forall a. Eq a => a -> a -> Bool
== Int
internARNum = 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 forall a. Eq a => a -> a -> Bool
== Int
primARNum Bool -> Bool -> Bool
|| Int
k forall a. Eq a => a -> a -> Bool
== Int
internARNum = 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' forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. String -> a
interr String
"Idents: newIdentARNum: \
\Negative number!"
| Int
k forall a. Eq a => a -> a -> Bool
== Int
primARNum Bool -> Bool -> Bool
|| Int
k forall a. Eq a => a -> a -> Bool
== Int
internARNum = 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 forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (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
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
ab
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
ac
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 <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Int
ac <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Attrs
ad <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int -> Int -> Attrs -> Ident
Ident String
aa Int
ab Int
ac Attrs
ad)