module Data.Simtreelo(loadString, loadFile, write, toString, merge) where
import Data.Tree
merge [] tree = [ tree ]
merge (fh:fr) tree
| rootLabel fh == rootLabel tree = Node{rootLabel = rootLabel tree, subForest = mergeForest (subForest fh) (subForest tree)} : fr
| otherwise = fh : merge fr tree
mergeForest fa fb = foldl merge fa fb
write forest comment indent file =
let contents = comment ++ "\n" ++ toString forest indent in
writeFile file contents
toString forest indent = concat $ map ( toString' indent 0) forest
toString' indent depth tree =
indentation ++ (rootLabel tree) ++ "\n" ++ children
where
indentation = concat $ take depth $ repeat indent
children = concat $ map (toString' indent (depth + 1) ) $ subForest tree
loadString str = do
let (first:s:r) = lines str
(_,spaces) = separate' s
(tree,_,_) <- if spaces /= [] then
parse (s:r) 2 1 (Just spaces) first
else
parse (s:r) 2 0 Nothing first
return tree
loadFile fname = do
str <- readFile fname
return $ loadString str
parse [] ln _ _ _ = Right ([],[],ln)
parse (h:r) ln d Nothing comment = do
let (name,spaces) = separate' h
if (strip name comment) == "" then parse r (ln+1) d Nothing comment
else do
let (indentor,depth) = if spaces == "" then (Nothing,0) else (Just spaces,1)
(children,rest,ln') <- parse r (ln + 1) (d + 1) indentor comment
if depth == d then do
(siblings,rest',ln'') <- parse rest ln' d indentor comment
return (Node{rootLabel = (strip name comment), subForest = children}:siblings, rest',ln'')
else return ([],(h:r),ln)
parse (h:r) ln d (Just indentor) comment = do
(name,depth) <- separate h indentor ln
if (strip name comment) == "" then parse r (ln+1) d (Just indentor) comment
else do
(children,rest,ln') <- parse r (ln + 1) (d + 1) (Just indentor) comment
if depth == d then do
(siblings,rest',ln'') <- parse rest ln' d (Just indentor) comment
return (Node{rootLabel = (strip name comment), subForest = children}:siblings, rest',ln'')
else
return ([],(h:r),ln)
isPrefix [] r = (True,r)
isPrefix i [] = (False,[])
isPrefix (hi:ri) (h:r)
| h == hi =
let (prefix,rest) = isPrefix ri r in
(prefix,if prefix then rest else h:r)
| otherwise = (False,h:r)
separate' [] = ([],[])
separate' (h:r)
| h == ' ' || h == '\t' = let (name,spaces) = separate' r in
(name,h:spaces)
| otherwise = (h:r,"")
strip [] _ = []
strip (h:r) [] =
let rest = strip r [] in
if rest /= "" then h:rest
else
if h == ' ' || h == '\t' then "" else [h]
strip (h:r) comment =
let (prefix,_) = isPrefix comment (h:r) in
if prefix then ""
else
let rest = strip r comment in
if rest /= "" then h:rest
else
if h == ' ' || h == '\t' then "" else [h]
separate a [] _ = Right (a,0)
separate [] _ _ = Right ([],0)
separate line indentor lineNumber = do
let (prefix,rest) = isPrefix indentor line
if prefix then do
(name,depth) <- separate rest indentor lineNumber
return (name,depth + 1)
else
if head rest == ' ' || head rest == '\t' then
Left $ "Invalid indentation at line " ++ show lineNumber
else
Right (line,0)