module Attributes (
Attrs, newAttrsOnlyPos, newAttrs,
Attributed(attrsOf), eqOfAttrsOf, posOfAttrsOf,
Attr(undef, isUndef, dontCare, isDontCare),
AttrTable, newAttrTable, getAttr, setAttr, updAttr,
copyAttr, freezeAttrTable, softenAttrTable,
StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr,
isUndefStdAttr, setStdAttr, updStdAttr,
getGenAttr, setGenAttr, updGenAttr)
where
import Data.Array
import Control.Exception (assert)
import Position (Position, Pos(posOf), nopos, isNopos, dontCarePos,
isDontCarePos)
import Errors (interr)
import UNames (NameSupply, Name,
rootSupply, splitSupply, names)
import Map (Map)
import qualified Map as Map (fromList, toList, insert,
findWithDefault, empty)
import Binary (Binary(..), putByte, getByte)
data Attrs = OnlyPos Position
| Attrs Position Name
instance Pos Attrs where
posOf :: Attrs -> Position
posOf (OnlyPos Position
pos ) = Position
pos
posOf (Attrs Position
pos Name
_) = Position
pos
instance Eq Attrs where
(Attrs Position
_ Name
id1) == :: Attrs -> Attrs -> Bool
== (Attrs Position
_ Name
id2) = Name
id1 forall a. Eq a => a -> a -> Bool
== Name
id2
Attrs
_ == Attrs
_ =
forall a. String -> a
interr String
"Attributes: Attempt to compare `OnlyPos' attributes!"
instance Ord Attrs where
(Attrs Position
_ Name
id1) <= :: Attrs -> Attrs -> Bool
<= (Attrs Position
_ Name
id2) = Name
id1 forall a. Ord a => a -> a -> Bool
<= Name
id2
Attrs
_ <= Attrs
_ =
forall a. String -> a
interr String
"Attributes: Attempt to compare `OnlyPos' attributes!"
class Attributed a where
attrsOf :: a -> Attrs
eqOfAttrsOf :: Attributed a => a -> a -> Bool
eqOfAttrsOf :: forall a. Attributed a => a -> a -> Bool
eqOfAttrsOf a
obj1 a
obj2 = (forall a. Attributed a => a -> Attrs
attrsOf a
obj1) forall a. Eq a => a -> a -> Bool
== (forall a. Attributed a => a -> Attrs
attrsOf a
obj2)
posOfAttrsOf :: Attributed a => a -> Position
posOfAttrsOf :: forall a. Attributed a => a -> Position
posOfAttrsOf = forall a. Pos a => a -> Position
posOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Attributed a => a -> Attrs
attrsOf
newAttrsOnlyPos :: Position -> Attrs
newAttrsOnlyPos :: Position -> Attrs
newAttrsOnlyPos Position
pos = Position -> Attrs
OnlyPos Position
pos
newAttrs :: Position -> Name -> Attrs
newAttrs :: Position -> Name -> Attrs
newAttrs Position
pos Name
name = Position -> Name -> Attrs
Attrs Position
pos Name
name
class Attr a where
undef :: a
isUndef :: a -> Bool
dontCare :: a
isDontCare :: a -> Bool
undef = forall a. String -> a
interr String
"Attributes: Undefined `undef' method in `Attr' class!"
isUndef = forall a. String -> a
interr String
"Attributes: Undefined `isUndef' method in `Attr' \
\class!"
dontCare = forall a. String -> a
interr String
"Attributes: Undefined `dontCare' method in `Attr' \
\class!"
isDontCare = forall a. String -> a
interr String
"Attributes: Undefined `isDontCare' method in `Attr' \
\class!"
data Attr a =>
AttrTable a =
SoftTable (Map Name a)
String
| FrozenTable (Array Name a)
String
newAttrTable :: Attr a => String -> AttrTable a
newAttrTable :: forall a. Attr a => String -> AttrTable a
newAttrTable String
desc = forall a. Map Name a -> String -> AttrTable a
SoftTable forall k a. Map k a
Map.empty String
desc
getAttr :: Attr a => AttrTable a -> Attrs -> a
getAttr :: forall a. Attr a => AttrTable a -> Attrs -> a
getAttr AttrTable a
at (OnlyPos Position
pos ) = forall a b. Attr a => String -> AttrTable a -> Position -> b
onlyPosErr String
"getAttr" AttrTable a
at Position
pos
getAttr AttrTable a
at (Attrs Position
_ Name
aid) =
case AttrTable a
at of
(SoftTable Map Name a
fm String
_) -> forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Attr a => a
undef Name
aid Map Name a
fm
(FrozenTable Array Name a
arr String
_) -> let (Name
lbd, Name
ubd) = forall i e. Array i e -> (i, i)
bounds Array Name a
arr
in
if (Name
aid forall a. Ord a => a -> a -> Bool
< Name
lbd Bool -> Bool -> Bool
|| Name
aid forall a. Ord a => a -> a -> Bool
> Name
ubd) then forall a. Attr a => a
undef else Array Name a
arrforall i e. Ix i => Array i e -> i -> e
!Name
aid
setAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a
setAttr :: forall a. Attr a => AttrTable a -> Attrs -> a -> AttrTable a
setAttr AttrTable a
at (OnlyPos Position
pos ) a
av = forall a b. Attr a => String -> AttrTable a -> Position -> b
onlyPosErr String
"setAttr" AttrTable a
at Position
pos
setAttr AttrTable a
at (Attrs Position
pos Name
aid) a
av =
case AttrTable a
at of
(SoftTable Map Name a
fm String
desc) -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Attr a => a -> Bool
isUndef (forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Attr a => a
undef Name
aid Map Name a
fm)) forall a b. (a -> b) -> a -> b
$
forall a. Map Name a -> String -> AttrTable a
SoftTable (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
aid a
av Map Name a
fm) String
desc
(FrozenTable Array Name a
arr String
_) -> forall a. String -> a
interr String
frozenErr
where
frozenErr :: String
frozenErr = String
"Attributes.setAttr: Tried to write frozen attribute in\n"
forall a. [a] -> [a] -> [a]
++ forall a. Attr a => AttrTable a -> Position -> String
errLoc AttrTable a
at Position
pos
updAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a
updAttr :: forall a. Attr a => AttrTable a -> Attrs -> a -> AttrTable a
updAttr AttrTable a
at (OnlyPos Position
pos ) a
av = forall a b. Attr a => String -> AttrTable a -> Position -> b
onlyPosErr String
"updAttr" AttrTable a
at Position
pos
updAttr AttrTable a
at (Attrs Position
pos Name
aid) a
av =
case AttrTable a
at of
(SoftTable Map Name a
fm String
desc) -> forall a. Map Name a -> String -> AttrTable a
SoftTable (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
aid a
av Map Name a
fm) String
desc
(FrozenTable Array Name a
arr String
_) -> forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"Attributes.updAttr: Tried to\
\ update frozen attribute in\n"
forall a. [a] -> [a] -> [a]
++ forall a. Attr a => AttrTable a -> Position -> String
errLoc AttrTable a
at Position
pos
copyAttr :: Attr a => AttrTable a -> Attrs -> Attrs -> AttrTable a
copyAttr :: forall a. Attr a => AttrTable a -> Attrs -> Attrs -> AttrTable a
copyAttr AttrTable a
at Attrs
ats Attrs
ats'
| forall a. Attr a => a -> Bool
isUndef a
av = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Attr a => a -> Bool
isUndef (forall a. Attr a => AttrTable a -> Attrs -> a
getAttr AttrTable a
at Attrs
ats'))
AttrTable a
at
| Bool
otherwise = forall a. Attr a => AttrTable a -> Attrs -> a -> AttrTable a
updAttr AttrTable a
at Attrs
ats' a
av
where
av :: a
av = forall a. Attr a => AttrTable a -> Attrs -> a
getAttr AttrTable a
at Attrs
ats
onlyPosErr :: Attr a => String -> AttrTable a -> Position -> b
onlyPosErr :: forall a b. Attr a => String -> AttrTable a -> Position -> b
onlyPosErr String
fctName AttrTable a
at Position
pos =
forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"Attributes." forall a. [a] -> [a] -> [a]
++ String
fctName forall a. [a] -> [a] -> [a]
++ String
": No attribute identifier in\n"
forall a. [a] -> [a] -> [a]
++ forall a. Attr a => AttrTable a -> Position -> String
errLoc AttrTable a
at Position
pos
errLoc :: Attr a => AttrTable a -> Position -> String
errLoc :: forall a. Attr a => AttrTable a -> Position -> String
errLoc AttrTable a
at Position
pos = String
" table `" forall a. [a] -> [a] -> [a]
++ forall {a}. Attr a => AttrTable a -> String
tableDesc AttrTable a
at forall a. [a] -> [a] -> [a]
++ String
"' for construct at\n\
\ position " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
pos forall a. [a] -> [a] -> [a]
++ String
"!"
where
tableDesc :: AttrTable a -> String
tableDesc (SoftTable Map Name a
_ String
desc) = String
desc
tableDesc (FrozenTable Array Name a
_ String
desc) = String
desc
freezeAttrTable :: Attr a => AttrTable a -> AttrTable a
freezeAttrTable :: forall a. Attr a => AttrTable a -> AttrTable a
freezeAttrTable (SoftTable Map Name a
fm String
desc) =
let contents :: [(Name, a)]
contents = forall k a. Map k a -> [(k, a)]
Map.toList Map Name a
fm
keys :: [Name]
keys = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, a)]
contents
lbd :: Name
lbd = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Name]
keys
ubd :: Name
ubd = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Name]
keys
in
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
keys forall a. Ord a => a -> a -> Bool
< Int
1000 Bool -> Bool -> Bool
|| (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ix a => (a, a) -> [a]
range) (Name
lbd, Name
ubd) forall a. Ord a => a -> a -> Bool
> Int
3 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
keys)
(forall a. Array Name a -> String -> AttrTable a
FrozenTable (forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Name
lbd, Name
ubd) [(Name, a)]
contents) String
desc)
freezeAttrTable (FrozenTable Array Name a
arr String
desc) =
forall a. String -> a
interr (String
"Attributes.freezeAttrTable: Attempt to freeze the already frozen\n\
\ table `" forall a. [a] -> [a] -> [a]
++ String
desc forall a. [a] -> [a] -> [a]
++ String
"'!")
softenAttrTable :: Attr a => AttrTable a -> AttrTable a
softenAttrTable :: forall a. Attr a => AttrTable a -> AttrTable a
softenAttrTable (SoftTable Map Name a
fm String
desc) =
forall a. String -> a
interr (String
"Attributes.softenAttrTable: Attempt to soften the already \
\softened\n table `" forall a. [a] -> [a] -> [a]
++ String
desc forall a. [a] -> [a] -> [a]
++ String
"'!")
softenAttrTable (FrozenTable Array Name a
arr String
desc) =
forall a. Map Name a -> String -> AttrTable a
SoftTable (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i e. Ix i => Array i e -> [(i, e)]
assocs forall a b. (a -> b) -> a -> b
$ Array Name a
arr) String
desc
data StdAttr a = UndefStdAttr
| DontCareStdAttr
| JustStdAttr a
instance Attr (StdAttr a) where
undef :: StdAttr a
undef = forall a. StdAttr a
UndefStdAttr
isUndef :: StdAttr a -> Bool
isUndef StdAttr a
UndefStdAttr = Bool
True
isUndef StdAttr a
_ = Bool
False
dontCare :: StdAttr a
dontCare = forall a. StdAttr a
DontCareStdAttr
isDontCare :: StdAttr a -> Bool
isDontCare StdAttr a
DontCareStdAttr = Bool
True
isDontCare StdAttr a
_ = Bool
False
getStdAttr :: AttrTable (StdAttr a) -> Attrs -> a
getStdAttr :: forall a. AttrTable (StdAttr a) -> Attrs -> a
getStdAttr AttrTable (StdAttr a)
atab Attrs
at = forall a. AttrTable (StdAttr a) -> Attrs -> a -> a
getStdAttrDft AttrTable (StdAttr a)
atab Attrs
at forall {a}. a
err
where
err :: a
err = forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"Attributes.getStdAttr: Don't care in\n"
forall a. [a] -> [a] -> [a]
++ forall a. Attr a => AttrTable a -> Position -> String
errLoc AttrTable (StdAttr a)
atab (forall a. Pos a => a -> Position
posOf Attrs
at)
getStdAttrDft :: AttrTable (StdAttr a) -> Attrs -> a -> a
getStdAttrDft :: forall a. AttrTable (StdAttr a) -> Attrs -> a -> a
getStdAttrDft AttrTable (StdAttr a)
atab Attrs
at a
dft =
case forall a. Attr a => AttrTable a -> Attrs -> a
getAttr AttrTable (StdAttr a)
atab Attrs
at of
StdAttr a
DontCareStdAttr -> a
dft
JustStdAttr a
av -> a
av
StdAttr a
UndefStdAttr -> forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"Attributes.getStdAttrDft: Undefined in\n"
forall a. [a] -> [a] -> [a]
++ forall a. Attr a => AttrTable a -> Position -> String
errLoc AttrTable (StdAttr a)
atab (forall a. Pos a => a -> Position
posOf Attrs
at)
isDontCareStdAttr :: AttrTable (StdAttr a) -> Attrs -> Bool
isDontCareStdAttr :: forall a. AttrTable (StdAttr a) -> Attrs -> Bool
isDontCareStdAttr AttrTable (StdAttr a)
atab Attrs
at = forall a. Attr a => a -> Bool
isDontCare (forall a. Attr a => AttrTable a -> Attrs -> a
getAttr AttrTable (StdAttr a)
atab Attrs
at)
isUndefStdAttr :: AttrTable (StdAttr a) -> Attrs -> Bool
isUndefStdAttr :: forall a. AttrTable (StdAttr a) -> Attrs -> Bool
isUndefStdAttr AttrTable (StdAttr a)
atab Attrs
at = forall a. Attr a => a -> Bool
isUndef (forall a. Attr a => AttrTable a -> Attrs -> a
getAttr AttrTable (StdAttr a)
atab Attrs
at)
setStdAttr :: AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a)
setStdAttr :: forall a.
AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a)
setStdAttr AttrTable (StdAttr a)
atab Attrs
at a
av = forall a. Attr a => AttrTable a -> Attrs -> a -> AttrTable a
setAttr AttrTable (StdAttr a)
atab Attrs
at (forall a. a -> StdAttr a
JustStdAttr a
av)
updStdAttr :: AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a)
updStdAttr :: forall a.
AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a)
updStdAttr AttrTable (StdAttr a)
atab Attrs
at a
av = forall a. Attr a => AttrTable a -> Attrs -> a -> AttrTable a
updAttr AttrTable (StdAttr a)
atab Attrs
at (forall a. a -> StdAttr a
JustStdAttr a
av)
getGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a
getGenAttr :: forall a obj. (Attr a, Attributed obj) => AttrTable a -> obj -> a
getGenAttr AttrTable a
atab obj
at = forall a. Attr a => AttrTable a -> Attrs -> a
getAttr AttrTable a
atab (forall a. Attributed a => a -> Attrs
attrsOf obj
at)
setGenAttr :: (Attr a, Attributed obj)
=> AttrTable a -> obj -> a -> AttrTable a
setGenAttr :: forall a obj.
(Attr a, Attributed obj) =>
AttrTable a -> obj -> a -> AttrTable a
setGenAttr AttrTable a
atab obj
at a
av = forall a. Attr a => AttrTable a -> Attrs -> a -> AttrTable a
setAttr AttrTable a
atab (forall a. Attributed a => a -> Attrs
attrsOf obj
at) a
av
updGenAttr :: (Attr a, Attributed obj)
=> AttrTable a -> obj -> a -> AttrTable a
updGenAttr :: forall a obj.
(Attr a, Attributed obj) =>
AttrTable a -> obj -> a -> AttrTable a
updGenAttr AttrTable a
atab obj
at a
av = forall a. Attr a => AttrTable a -> Attrs -> a -> AttrTable a
updAttr AttrTable a
atab (forall a. Attributed a => a -> Attrs
attrsOf obj
at) a
av
instance Binary Attrs where
put_ :: BinHandle -> Attrs -> IO ()
put_ BinHandle
bh (OnlyPos Position
aa) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Position
aa
put_ BinHandle
bh (Attrs Position
ab Name
ac) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Position
ab
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Name
ac
get :: BinHandle -> IO Attrs
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> do
Position
aa <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Attrs
OnlyPos Position
aa)
Word8
1 -> do
Position
ab <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Name
ac <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Name -> Attrs
Attrs Position
ab Name
ac)
instance (Binary a, Attr a) => Binary (AttrTable a) where
put_ :: BinHandle -> AttrTable a -> IO ()
put_ BinHandle
bh (SoftTable Map Name a
aa String
ab) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Map Name a
aa
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh String
ab
put_ BinHandle
bh (FrozenTable Array Name a
ac String
ad) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Array Name a
ac
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh String
ad
get :: BinHandle -> IO (AttrTable a)
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> do
Map Name a
aa <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
String
ab <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Map Name a -> String -> AttrTable a
SoftTable Map Name a
aa String
ab)
Word8
1 -> do
Array Name a
ac <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
String
ad <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Array Name a -> String -> AttrTable a
FrozenTable Array Name a
ac String
ad)