Parse.hs

module Language.Lojban.Camxes.Parse 
    (parse
    ,LojbanTree
    ,Expr
    ,Type
    ,Value) where

import Data.Char
import Data.List
import Data.Tree
import Text.ParserCombinators.Parsec hiding (parse)
import qualified Text.ParserCombinators.Parsec as P
import Control.Monad.Reader

sample = " text=(  text1=(  paragraphs=(  paragraph=(  statement=(  statement1=(  statement2=(  statement3=(  sentence=(  terms=(  terms1=(  terms2=(  term=(  term1=(  sumti=(  sumti1=(  sumti2=(  sumti3=(  sumti4=(  sumti5=(  sumti6=(  KOhAClause=(  KOhAPre=(  KOhA=(  CMAVO=(  KOhA=( mi )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  bridiTail=(  bridiTail1=(  bridiTail2=(  bridiTail3=(  selbri=(  selbri1=(  selbri2=(  selbri3=(  selbri4=(  selbri5=(  selbri6=(  tanruUnit=(  tanruUnit1=(  tanruUnit2=(  BRIVLAClause=(  BRIVLAPre=(  BRIVLA=(  BRIVLA=(  gismu=( dansu )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  )  ) "

parse :: String -> Either ParseError LojbanTree
parse = P.parse expr ""

expr = do skipMany space
          sym <- symbol
          char '='
          char '('
          inner <- try innerExprs <|> fmap return lojbanic
          char ')'
          skipMany space
          return $ Node (Left sym) inner

innerExprs :: Parser [LojbanTree]
innerExprs = many1 (do e <- expr; skipMany space; return e)

lojbanic :: Parser LojbanTree
lojbanic = do skipMany space
              string <- many1 (letter <|> digit <|> oneOf "'")
              skipMany space
              return $ Node (Right (map toLower string)) []

symbol :: Parser Type
symbol = fmap (map toLower) $ many1 (letter <|> digit)

type LojbanTree = Tree Expr
type Expr = Either Type Value
type Type = String
type Value = String

prettyPrint :: LojbanTree -> String
prettyPrint tree = runReader (go tree) "" where
    go (Node (Right value) []) = out value
    go (Node (Left value) [])  = out value
    go (Node (Left label) (x:xs)) 
        | isTree x = do indent <- ask
                        inner <- local (' ':) $ mapM go (x:xs)
                        return $ "\n" ++ indent ++ "(" ++ label ++ "" ++ concat inner ++ ")"
        | otherwise = do indent <- ask
                         in' <- go x
                         return $ "\n" ++ indent ++ "(" ++ label ++ " " ++ in' ++ ")"

isTree (Node (Left _) (_:_)) = True
isTree _                     = False

out = return