module Data.ATerm.ReadWrite (
readATerm,
writeATerm,
writeSharedATerm
) where
import Data.ATerm.AbstractSyntax
import Data.Map as FM
import Data.Char
readATerm :: String -> ATerm
readATerm ('!':str) = let (t,_,_,_) = readTAF str emptyRT 0 in t
readATerm str = let (t,_) = readAT str in t
readAT ('[':str) = let (kids, str') = readATs (dropSpaces str)
in (AList kids, str')
readAT str@(c:cs)
| isIntHead c = let (i,str') = span isDigit cs
in (AInt (read (c:i)),str')
| otherwise = let (c,str') = readAFun str
(kids, str'') = readParenATs (dropSpaces str')
in (AAppl c kids, str'')
readAFun ('"':str) = let (c,('"':str')) = spanNotQuote' str
in (quote c,str')
readAFun str = spanAFunChar str
readParenATs ('(':str) = readATs (dropSpaces str)
readParenATs str = ([],str)
readATs (')':str) = ([],str)
readATs (']':str) = ([],str)
readATs str = readATs1 str
readATs1 str = let (t,str') = readAT (dropSpaces str)
(ts,str'') = readATs' (dropSpaces str')
in (t:ts,str'')
readATs' (',':str) = readATs1 (dropSpaces str)
readATs' (')':str) = ([],str)
readATs' (']':str) = ([],str)
readTAF :: String -> ReadTable -> Int
-> (ATerm,String,ReadTable,Int)
readTAF ('#':str) tbl l = let (i,str') = spanAbbrevChar str
in (getElementRT (deAbbrev i) tbl,
str',tbl,l+(length i)+1)
readTAF ('[':str) tbl l = let (kids, str',tbl',l')
= readTAFs (dropSpaces str) tbl 1
t = AList kids
in (t, str',condAddElementRT t l' tbl',l+l')
readTAF str@(c:cs) tbl l
| isIntHead c = let (i,str') = span isDigit cs
ci = (c:i)
l' = length ci
t = AInt (read ci)
tbl' = condAddElementRT t l' tbl
in (t,str',tbl',l+l')
| otherwise = let (c,str') = readAFun str
(kids, str'',tbl',l')
= readParenTAFs (dropSpaces str') tbl 0
t = AAppl c kids
lks = if Prelude.null kids then 0 else l'
l'' = (length c) + lks
in (t, str'',condAddElementRT t l'' tbl',l'')
readParenTAFs ('(':str) tbl l = readTAFs (dropSpaces str) tbl l
readParenTAFs str tbl l = ([],str,tbl,l)
readTAFs (')':str) tbl l = ([],str,tbl,l+1)
readTAFs (']':str) tbl l = ([],str,tbl,l+1)
readTAFs str tbl l = readTAFs1 str tbl l
readTAFs1 str tbl l = let (t,str',tbl',l')
= readTAF (dropSpaces str) tbl l
(ts,str'',tbl'',l'')
= readTAFs' (dropSpaces str') tbl' l'
in (t:ts,str'',tbl'',l'')
readTAFs' (',':str) tbl l = readTAFs1 (dropSpaces str) tbl (l+1)
readTAFs' (')':str) tbl l = ([],str,tbl,l+1)
readTAFs' (']':str) tbl l = ([],str,tbl,l+1)
dropSpaces = dropWhile isSpace
spanAFunChar = span isAFunChar
isAFunChar c = (isAlphaNum c) || (c `elem` "-_*+")
spanNotQuote = span (/='"')
spanAbbrevChar = span (`elem` toBase64)
isIntHead c = (isDigit c) || (c=='-')
quote str = ('"':str)++"\""
spanNotQuote' [] = ([],[])
spanNotQuote' xs@('"':xs') = ([],xs)
spanNotQuote' xs@('\\':'"':xs') = ('\\':'"':ys,zs)
where (ys,zs) = spanNotQuote' xs'
spanNotQuote' xs@('\\':'\\':xs')= ('\\':'\\':ys,zs)
where (ys,zs) = spanNotQuote' xs'
spanNotQuote' xs@(x:xs') = (x:ys,zs)
where (ys,zs) = spanNotQuote' xs'
writeATerm :: ATerm -> String
writeATerm t = writeAT t
writeSharedATerm :: ATerm -> String
writeSharedATerm t = let (s,_) = writeTAF t emptyWT in ('!':s)
writeAT :: ATerm -> String
writeAT (AAppl c ts) = writeATermAux c (Prelude.map writeAT ts)
writeAT (AList ts) = bracket (commaSep (Prelude.map writeAT ts))
writeAT (AInt i) = show i
writeTAF :: ATerm -> WriteTable -> (String,WriteTable)
writeTAF t tbl = case getIndexWT t tbl of
(Just i) -> (makeAbbrev i,tbl)
Nothing -> (str, condAddElementWT t str tbl')
where (str,tbl') = writeTAF' t tbl
writeTAF' (AAppl c ts) tbl = let (kids,tbl') = writeTAFs ts tbl
in (writeATermAux c kids,tbl')
writeTAF' (AList ts) tbl = let (kids,tbl') = writeTAFs ts tbl
in (bracket (commaSep kids),tbl')
writeTAF' (AInt i) tbl = (show i,tbl)
writeTAFs [] tbl = ([],tbl)
writeTAFs (t:ts) tbl = let (str,tbl') = writeTAF t tbl
(strs,tbl'') = writeTAFs ts tbl'
in ((str:strs),tbl'')
writeATermAux c [] = c
writeATermAux c ts = c++(parenthesise (commaSep ts))
sepBy sep (x:y:ys) = x:sep:sepBy sep (y:ys)
sepBy sep ys = ys
commaSep strs = concat (sepBy "," strs)
bracket str = "["++str++"]"
parenthesise str = "("++str++")"
type ReadTable = (Integer,[ATerm])
emptyRT = (0,[])
getElementRT' i tbl = case getElementRT i tbl of
(AAppl "prod" _) -> AAppl "#prod" []
t -> t
getElementRT i tbl = (snd tbl)!!!((fst tbl)i1)
addElementRT a tbl = ((fst tbl)+1,a:(snd tbl))
sizeOfRT tbl = fst tbl
condAddElementRT t l tbl
= if (length next_abbrev) < l then
addElementRT t tbl
else
tbl
where next_abbrev = makeAbbrev (toInteger (sizeOfRT tbl))
condAddElementRT' t str tbl
= if (length next_abbrev) < (length str) then
addElementRT t tbl
else
tbl
where next_abbrev = makeAbbrev (toInteger (sizeOfRT tbl)+1)
type WriteTable = FM.Map ATerm Integer
emptyWT = FM.empty
getIndexWT a tbl = FM.lookup a tbl
addElementWT a tbl = FM.insert a (sizeOfWT tbl) tbl
sizeOfWT tbl = toInteger (FM.size tbl)
condAddElementWT t str tbl
= if (length next_abbrev) < (length str) then
addElementWT t tbl
else
tbl
where next_abbrev = makeAbbrev (toInteger (sizeOfWT tbl))
mkAbbrev x
| x == 0 = [toBase64!!0]
| otherwise = reverse (mkAbbrevAux x)
mkAbbrevAux x
| x == 0 = []
| x > 0 = (toBase64!!!m:mkAbbrevAux d) where (d,m) = divMod x 64
deAbbrev x = deAbbrevAux (reverse x)
deAbbrevAux [] = 0
deAbbrevAux (c:cs) = let (Just i) = indexOf c toBase64
r = deAbbrevAux cs
in (i + 64*r)
toBase64 =
[ 'A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P',
'Q','R','S','T','U','V','W','X','Y','Z','a','b','c','d','e','f',
'g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v',
'w','x','y','z','0','1','2','3','4','5','6','7','8','9','+','/'
]
makeAbbrev i = '#':mkAbbrev i
indexOf t [] = Nothing
indexOf t (x:xs) = if t==x
then (Just (0::Integer))
else case indexOf t xs of
(Just i) -> Just (i+1)
Nothing -> Nothing
(!!!) :: [b] -> Integer -> b
(x:_) !!! 0 = x
(_:xs) !!! n | n>0 = xs !!! (n1)
(_:_) !!! _ = error "!!!: negative index"
[] !!! _ = error "!!!: index too large"
testAbbrevBoundaries :: Bool
testAbbrevBoundaries
= writeSharedATerm term == shared && readATerm shared == term
where
term = AList $ Prelude.map AInt ([100..164]++[100..164])
shared = "![100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,#A,#B,#C,#D,#E,#F,#G,#H,#I,#J,#K,#L,#M,#N,#O,#P,#Q,#R,#S,#T,#U,#V,#W,#X,#Y,#Z,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z,#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#+,#/,164]"