implementation module graph_to_sapl_string
import StdEnv
import StdStrictLists
import graph_to_string_with_descriptors
import StdDebug
//import sapldebug
// Conversion of dynamic graph string to sapl code
// JMJ 2007
// Simplified sapl representation
:: DynamicSapl = IntS Int | BoolS Bool | CharS Char | RealS Real | StringS String | CstrS String String Int [DynamicSapl] |
FunctionS String String Int [DynamicSapl] | ArrayS Int [DynamicSapl] | ListS [DynamicSapl] |
TupleS Int [DynamicSapl] | RecS String String Int [DynamicSapl]
cb :: Int
cb =: fromChar '\b'
cv :: Int
cv =: fromChar '\v'
escapeString :: Char String -> String
escapeString qc str = toString [qc: flatten (escapeString` (fromString str))]
where
escapeString` :: [Char] -> [[Char]]
escapeString` [] = [[qc]]
escapeString` ['\'':chars] = [['\\\'']: escapeString` chars]
escapeString` ['\"':chars] = [['\\\"']: escapeString` chars]
escapeString` [c :chars]
| isPrint c
= [[c] : escapeString` chars]
= [toHex (fromChar c): escapeString` chars]
toHex i
| i == 0 = ['\\0']
| i == 7 = ['\\a']
| i == cb = ['\\b']
| i == cv = ['\\v']
toHex i = ['\\x'] ++ ['0' \\ a <- [1..2-length letters]] ++ reverse (toHex` i)
where
letters = reverse (toHex` i)
toHex` 0 = []
toHex` i = [hex.[i bitand 15]:toHex` (i >> 4)]
where
hex = "0123456789ABCDEF"
makeSaplExpression :: !DynamicSapl -> String
makeSaplExpression e = mkse e
where
mkse (IntS i) = toString i
mkse (BoolS b) = toString b
mkse (CharS c) = escapeString '\'' (toString c)
mkse (RealS r) = toString r
mkse (StringS s) = escapeString '"' s
mkse (CstrS mod name _ []) = makePrintableName (mod +++ "." +++ makeSaplName name)
mkse (CstrS mod name _ as) = "(" +++ makePrintableName (mod +++ "." +++ makeSaplName name) +++ args as +++ ")"
mkse (FunctionS mod name _ []) = makePrintableName (mod +++ "." +++ makeSaplName name)
mkse (FunctionS mod name _ as) = "(" +++ makePrintableName (mod +++ "." +++ makeSaplName name) +++ args as +++ ")"
mkse (RecS mod name _ []) = makePrintableName (makeRecName mod name)
mkse (RecS mod name _ as) = "(" +++ makePrintableName (makeRecName mod name) +++ args as +++ ")"
mkse (ArrayS _ as) = mkl as
mkse (ListS as) = mkl as
mkse (TupleS n as) = "(_Tuple" +++ toString n +++ args as +++ ")"
args [] = ""
args [a:as] = " " +++ mkse a +++ args as
mkl [] = "_predefined._Nil"
mkl [a:as] = "(_predefined._Cons " +++ mkse a +++ " " +++ mkl as +++ ")"
instance toString DynamicSapl
where toString (IntS i) = "IntS " +++ toString i
toString (BoolS i) = "BoolS " +++ toString i
toString (CharS i) = "CharS " +++ toString i
toString (RealS i) = "RealS " +++ toString i
toString (StringS i) = "StringS " +++ toString i
sapl_from_string :: !*{#Char} -> (.a,!Int)
sapl_from_string str = (undef,3)
graph_to_sapl_string :: !a -> String
graph_to_sapl_string a = makeSaplExpression (graph_to_sapl_dynamic a)
string_to_graph :: !String -> .a
string_to_graph thread = abort "Cannot create Sapl graph while you are in Clean.\n"
graph_to_sapl_dynamic :: !a -> DynamicSapl
graph_to_sapl_dynamic graph
# (g,d,m) = graph_to_string_with_descriptor_and_module_table graph
# (v,_) = convertfromdyn g d m
= v
// Testing function, also gives decoding
graph_to_sapl_dynamic_test :: !a -> (({#Int},Char,{#String},Char,{#String}),Char,DynamicSapl,Char,String)
graph_to_sapl_dynamic_test graph
# (g,d,m) = graph_to_string_with_descriptor_and_module_table graph
# (v,_) = convertfromdyn g d m
= (dyndesc graph,'\n',v,'\n',graph_to_sapl_string graph)
dyndesc gg # (g,d,m) = graph_to_string_with_descriptor_and_module_table gg
= (string_to_int_array g,'\n',d,'\n',m);
// Decoding functions
string_to_int_array :: !{#Char} -> {#Int}
string_to_int_array s
= {select_int_from_string i s\\i<-[0,IF_INT_64_OR_32 8 4..size s-IF_INT_64_OR_32 7 3]}
select_int_from_string i s
= IF_INT_64_OR_32
(toInt s.[i]+(toInt s.[i+1]<<8)+(toInt s.[i+2]<<16)+(toInt s.[i+3]<<24)
+(toInt s.[i+4]<<32)+(toInt s.[i+5]<<40)+(toInt s.[i+6]<<48)+(toInt s.[i+7]<<56))
(toInt s.[i]+(toInt s.[i+1]<<8)+(toInt s.[i+2]<<16)+(toInt s.[i+3]<<24));
sifs = select_int_from_string
sbfs i s = int2bool (sifs i s)
scfs i s = toChar(sifs i s)
srfs i s
= IF_INT_64_OR_32
(make_real_from_int (select_int_from_string i s))
(make_real_from_2_ints (select_int_from_string i s) (select_int_from_string (i+4) s))
where
make_real_from_int :: !Int -> Real
make_real_from_int r = code {
pop_b 0
}
make_real_from_2_ints :: !Int !Int -> Real
make_real_from_2_ints r0 r1 = code {
pop_b 0
}
int2bool 0 = False
int2bool 1 = True
arity c | '0' <= c && c <= '9' = toInt c - toInt '0'
= toInt c - toInt 'A' + 10
selectmodnr i s = toInt s.[i]+(toInt s.[i+1]<<8)
getName :: Int String -> String
getName i s = s % (i,poszero-1)
where poszero = hd [n\\ n <- [i+1..(size s)]| s.[n] == '\0']
convertfromdyn str ds md = decodeDyn 0
where
decodeDyn pos
# dnr = sifs pos str
| dnr < 0 = getEarlierElem (pos + dnr - 1) (pos+IF_INT_64_OR_32 8 4) // shared node
# desc = ds.[dnr-1]
# desc_type = desc.[0]
# next_pos = pos+IF_INT_64_OR_32 8 4
| desc_type == 'i' = (IntS (sifs next_pos str),pos+IF_INT_64_OR_32 16 8) // Int
| desc_type == 'c' = (CharS (scfs next_pos str),pos+IF_INT_64_OR_32 16 8) // Char
| desc_type == 'b' = (BoolS (sbfs next_pos str),pos+IF_INT_64_OR_32 16 8) // Bool
| desc_type == 's' = readString pos // String in array
| desc_type == 'r' = (RealS (srfs next_pos str),pos+IF_INT_64_OR_32 16 12) // Real
//| desc_type == 'C' && size str > pos + 4 && sifs (pos+4) str < 0 // shared node in array
//= getEarlierElem (pos + 4 + sifs (pos+4) str + 3) (pos+8)
| desc_type == 'C'
| desc.[1]=='0' // arity==0
= makeBoxedConstr desc pos
| size str > next_pos && sifs next_pos str < 0 // shared node in constructor
= makeBoxedConstr desc pos
| size str > next_pos && ds.[sifs next_pos str - 1].[0] == 's' // String
= readString next_pos
| size str > next_pos && ds.[sifs next_pos str - 1].[0] == 'a'
| sifs (pos+IF_INT_64_OR_32 24 12) str <> 0 // unboxed array
# typedes = ds.[sifs (pos+IF_INT_64_OR_32 24 12) str-1]
# ssize = sifs (pos+IF_INT_64_OR_32 16 8) str
= makeUnboxedArray typedes ssize (pos+IF_INT_64_OR_32 32 16)
//sifs (pos+IF_INT_64_OR_32 24 12) str == 0 // boxed array
# ssize = sifs (pos+IF_INT_64_OR_32 16 8) str
= makeBoxedArray ssize (pos+IF_INT_64_OR_32 32 16)
// boxed constructor or partial application
= makeBoxedConstr desc pos
| desc_type == ':' // boxed list
= makeBoxedList pos
| desc_type == 'R'
| ds.[dnr-1].[5] == 'l' && ds.[dnr-1].[6] == 'R'// unboxed list of records
= makeUnBoxedListOfRecords pos
| ds.[dnr-1].[5] == 'l'// unboxed list
= makeUnBoxedList ds.[dnr-1].[6] pos
// records constructor & unboxed constructors
= makeRecord pos
| desc_type == 'n' = (ListS [],next_pos)// empty list
| desc_type == 't' // tuple
= makeTuple (arity ds.[dnr-1].[1]) next_pos
getEarlierElem pos newpos // backward ref
# dnr = sifs (pos) str // descriptor is in word before
# desc_type = ds.[dnr-1].[0]
| desc_type == 's' = (fst (decodeDyn pos),newpos) // string case
= (fst (decodeDyn pos),newpos)
readString pos
# strsize = sifs (pos+IF_INT_64_OR_32 8 4) str
first_char_pos = pos + IF_INT_64_OR_32 16 8
newpos = first_char_pos + ((strsize + IF_INT_64_OR_32 7 3) bitand (IF_INT_64_OR_32 (-8) (-4)))
= (StringS (str % (first_char_pos,first_char_pos + strsize - 1)), newpos)
makeUnboxedArray typedes size pos
# t=typedes.[0];
| t=='i' || t=='b' || t=='c' || t=='r'
# (elems,rest) = readUMany typedes.[0] size pos []
= (ArrayS size elems,rest)
| t=='R'
= makeUnBoxedArrayOfRecords size (pos-IF_INT_64_OR_32 8 4)
readUDMany types 0 pos res = (res,pos)
readUDMany ['r':types] n pos res = readUDMany types (n-IF_INT_64_OR_32 1 2) (pos+8) (res ++ [makeRealType pos])
readUDMany [type:types] n pos res = readUDMany types (n-1) (pos+IF_INT_64_OR_32 8 4) (res ++ [makeType type pos])
readUMany type 0 pos res = (res,pos)
readUMany type=:'r' n pos res = readUMany type (n-IF_INT_64_OR_32 1 2) (pos+8) (res ++ [makeRealType pos])
readUMany type n pos res = readUMany type (n-1) (pos+IF_INT_64_OR_32 8 4) (res ++ [makeType type pos])
makeBoxedArray size pos
# (elems,pos) = (readMany size pos [])
= (ArrayS size elems,pos)
makeTuple size pos
# (elems,pos) = (readMany size pos [])
= (TupleS size elems,pos)
makeRecord pos
# dnr = sifs pos str
# desc = ds.[dnr-1]
#(name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc)
= makeRecordTypeDesc desc
# (ubels,pos) = readUDMany ubtypes nrub (pos+IF_INT_64_OR_32 8 4) []
# (bels,pos) = readMany nrpointer pos []
# mergedelems = merge_elems alltypes ubels bels
# typedelems = setTypes (makeRecordType typedesc) mergedelems
= if (desc.[5]== 'd') (CstrS modname name tsize typedelems,pos)(RecS modname name tsize typedelems,pos)
makeRecordTypeDesc desc
# tsize = arity desc.[1]
# nrpointer = arity desc.[2]
# nrub = tsize - nrpointer
# modnr = selectmodnr 3 desc
# start_types = if (desc.[5] == 'd') 6 (if (desc.[5] == 'l' && desc.[6] == 'R') 7 5)
# modname = md.[modnr-1]
# typedesc = takeWhile (\a -> a <> '\0') [c\\ c <-: desc%(start_types,size str-1)]
# alltypes = [t\\ t <- typedesc| (t <> '(') && (t <> ')') && (t <> ',')]
# ubtypes = [c\\ c <- alltypes| c <> 'a']
# name = getName (start_types+length typedesc+1) desc
| start_types <> 7 = (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) // normal record
= (name,modname,tsize-1,nrpointer-1,nrub,droplast alltypes,ubtypes,droplast typedesc) // list: drop last of pointer part (= pointer to tail)
merge_elems [] _ _ = []
merge_elems ['a':types] ubels bels = [hd bels : merge_elems types ubels (tl bels)]
merge_elems [_:types] ubels bels = [hd ubels : merge_elems types (tl ubels) bels]
readMany 0 pos res = (res,pos)
readMany n pos res
# (elem,newpos) = decodeDyn pos
= readMany (n-1) newpos (res ++ [elem])
makeBoxedConstr desc pos
# nrargs = arity desc.[1]
# modnr = selectmodnr 3 desc
# name = getName 5 desc
# modname = md.[modnr-1]
# (elems,newpos) = readMany nrargs (pos+IF_INT_64_OR_32 8 4) []
| name == "ARRAY" = (hd elems,newpos) // array or string
= (CstrS modname name nrargs elems,newpos)
makeBoxedList pos
# (elems,newpos) = readListElems pos []
= (ListS elems,newpos)
makeUnBoxedList type pos
# (elems,newpos) = readUBListElems type pos []
= (ListS elems,newpos)
readListElems pos elems
# dnr = sifs pos str
| dnr < 0 = (elems,pos+IF_INT_64_OR_32 8 4) // always nil
# desc_type = ds.[dnr-1].[0]
| desc_type == ':'
# (elem,newpos) = decodeDyn (pos+IF_INT_64_OR_32 8 4)
= readListElems newpos (elems++[elem])
= (elems,pos+IF_INT_64_OR_32 8 4)
readUBListElems type pos elems
# dnr = sifs pos str
| dnr < 0 = (elems,pos+IF_INT_64_OR_32 8 4) // always nil
# desc_type = ds.[dnr-1].[0]
| desc_type == 'R'
| type=='r'
# elem = makeRealType (pos+IF_INT_64_OR_32 8 4)
= readUBListElems type (pos+IF_INT_64_OR_32 16 12) (elems++[elem])
# elem = makeType type (pos+IF_INT_64_OR_32 8 4)
= readUBListElems type (pos+IF_INT_64_OR_32 16 8) (elems++[elem])
= (elems,pos+IF_INT_64_OR_32 8 4)
makeUnBoxedArrayOfRecords size pos
# dnr = sifs pos str
# desc = ds.[dnr-1]
# typedes = makeRecordTypeDesc desc
# (elems,pos) = readUBArrayRecordElems size (pos+IF_INT_64_OR_32 8 4) typedes []
= (ArrayS size elems,pos)
makeUnBoxedListOfRecords pos
# dnr = sifs pos str
# desc = ds.[dnr-1]
# typedes = makeRecordTypeDesc desc
# (elems,pos) = readUBListRecordElems pos typedes []
= (ListS elems,pos)
readUBListRecordElems pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) elems
# dnr = sifs pos str
| dnr < 0 = (elems,pos+IF_INT_64_OR_32 8 4) // always nil
# desc_type = ds.[dnr-1].[0]
| desc_type == 'R'
# (ubels,pos) = readUDMany ubtypes nrub (pos+IF_INT_64_OR_32 8 4) []
# (bels,pos) = readMany nrpointer pos []
# mergedelems = merge_elems alltypes ubels bels
# typedelems = setTypes (makeRecordType typedesc) mergedelems
# elem = RecS modname name tsize typedelems
= readUBListRecordElems pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) (elems++[elem])
= (elems,pos+IF_INT_64_OR_32 8 4)
readUBArrayRecordElems 0 pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) elems
= (elems,pos)
readUBArrayRecordElems size pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) elems
# (ubels,pos) = readUDMany ubtypes nrub pos []
# (bels,pos) = readMany nrpointer pos []
# mergedelems = merge_elems alltypes ubels bels
# typedelems = setTypes (makeRecordType typedesc) mergedelems
# elem = RecS modname name tsize typedelems
= readUBArrayRecordElems (size-1) pos (name,modname,tsize,nrpointer,nrub,alltypes,ubtypes,typedesc) (elems++[elem])
makeType 'i' pos = IntS (sifs pos str)
makeType 'c' pos = CharS (scfs pos str)
makeType 'b' pos = BoolS (sbfs pos str)
makeRealType pos = RealS (srfs pos str)
//Start = testmrt "(1(2))34"
//testmrt str
//# rt = [toString c\\ c <-: str]
//# elems = [S c\\ c <- rt| c <> "(" && c <> ")" && c <> ","]
//= setTypes rt elems
// Setting the tuples and records correct in a record is quit compilcated
// Records can have type descriptors of the form a(a,a)a
// makeRecordType transforms this into: [[0],[2],[0],[0]]
// The 2 at the second position indicated that a tuple of size 2 starts at this position
// ((a),a)a is transformed in: [[2,1],[0],[0]] (nested tuple or records)
// setTypes applies this to the sequential list of elements
setTypes rtypes elems = mt rtypes elems
where
mt [[ ]:ts] [elem:elems] = [elem : mt ts elems]
mt [[0]:ts] [elem:elems] = [elem : mt ts elems]
mt [[1]:ts] [elem:elems] = [TupleS 1 [elem] : mt ts elems]
mt [[a:as]:ts] elems = [TupleS (length rs) rs:mt (drop (a-1) ts) (drop a elems)]
where rs = mt [as:take (a-1) ts] (take a elems)
mt [] [] = []
makeRecordType ltypes = mrt [ltype\\ ltype <- ltypes| ltype <> ',']
where
mrt ['(':ltypes] = [first : mrt (tl rs)]
where (first,rs) = dostartpars ['(':ltypes]
mrt [')':ltypes] = mrt ltypes
mrt [_ :ltypes] = [[0] : mrt ltypes]
mrt [] = []
dostartpars ['(':ltypes]
# f = gettuplength 1 0 ltypes
# (fs,rs) = dostartpars ltypes
= ([f:fs],rs)
dostartpars rs = ([],rs)
gettuplength 1 length [')':rs] = length
gettuplength n length [')':rs] = gettuplength (n-1) length rs
gettuplength n length ['(':rs] = gettuplength (n+1) length rs
gettuplength n length [r:rs] = gettuplength n (length+1) rs
droplast [x] = []
droplast [x:xs] = [x:droplast xs]
makeSaplName :: String -> String
makeSaplName str
# lstr = [c\\ c <-: str]
# revl = reverse lstr
# (dgs,revrest) = span isDigit revl
# initname = reverse (remsc revrest)
// FIXME: heuristic for this case: _f703;703;703 -> _f703_703
# initname = if (dgs<>[]) (takeWhile (\r -> not (r == ';')) initname) initname
# initstr = {c\\ c <- initname}
# fname = makeName initstr
| dgs <> [] && hd revrest == ';'
= (fname +++ "_" +++ toString (reverse dgs))
| dgs <> []
= (fname +++ toString (reverse dgs))
= fname
remsc [';':rs] = rs
remsc rs = rs
makePrintableName f | ss f = "<{" +++ f +++ "}>"
= f
where ss f = or [is_ss c\\ c <-: f]
is_ss c = not (isAlphanum c || c == '_' || c == '.')
makeRecName :: String String -> String
makeRecName mod name
| last [c\\ c <-: ("" +++ name)] == ';' = mod +++ "." +++ name
= mod +++ "._" +++ makeSaplName {a\\ a<-: name| a <> '[' && a <> ']' && a <> '#'}
makeName name | name.[0] == '\\' = "anon"
| startsWith "<lambda" name = "anon"
| startsWith "c;" name = "_lc"
| startsWith "g_" name = "_lc"
= name
startsWith :: String String -> Bool
startsWith s1 s2 = s1 == s2%(0,size s1-1)
print_graph :: !a -> String
print_graph g = des2string (string_to_int_array a,"[" +++ printlist [b\\ b <-:bs],"[" +++ printlist [c\\ c <-:cs])
where (a,bs,cs) = (graph_to_string_with_descriptor_and_module_table g)
des2string (ia,des,mods) = printintarray ia +++ "\n" +++ des +++ "\n" +++ mods +++ "\n"
printintarray ia = "[" +++ printlist [toString a\\ a <-: ia]
printlist [] = "]"
printlist [a] = a +++ "]"
printlist [a:as] = a +++ ", " +++ printlist as