layout_parser.hs

{-
sample

*Main> interactiveParser
a b c
    d
  e
  f g
    h
  i j
    k l
      m
      n
    o
    p
  q

(a (b c d) e (f g h) (i j (k l m n) o p) q)
-}

import Text.ParserCombinators.Parsec
import Data.Char

-- Data Types

data Position = Position Int Int

data LayoutInfo = LayoutInfo Bool Int

data SyntaxTree = SyntaxTree String [SyntaxTree]

-- Output Format

instance Show SyntaxTree where
    show (SyntaxTree str []) = str
    show (SyntaxTree str stree) = "("++str++concatMap ((' ':).show) stree++")"

-- Layout

arbitraryLayout :: LayoutInfo
arbitraryLayout = LayoutInfo False 0

checkLayout :: LayoutInfo -> Position -> Bool
checkLayout (LayoutInfo False n) (Position line column) = n <= column
checkLayout (LayoutInfo True n) (Position line column) = n == column

arbitraryElemLayout :: LayoutInfo -> LayoutInfo
arbitraryElemLayout (LayoutInfo t n) = LayoutInfo False n

tailElemLayout :: LayoutInfo -> LayoutInfo
tailElemLayout (LayoutInfo True n) = LayoutInfo False (n+1)
tailElemLayout layout = layout

-- Parser

getPos :: GenParser token st Position
getPos = do pos <- getPosition
            return $ Position (sourceLine pos) (sourceColumn pos)

testPos :: (Show tok) => LayoutInfo -> GenParser tok st ()
testPos layout
    = do pos <- getPos
         if checkLayout layout pos
             then return ()
             else do eof >>= const (unexpected "end of file")
                     unexpected "token position"

tokenizer :: CharParser st String
tokenizer = do str <- many1 alphaNum
               spaces
               return str

parser :: LayoutInfo -> CharParser st SyntaxTree
parser layout
    = do testPos layout
         t <- tokenizer
         pos@(Position line column) <- getPos
         body <- if checkLayout (tailElemLayout layout) pos
                     then many $ parser (LayoutInfo True column)
                     else return []
         return $ SyntaxTree t body

globalParser :: CharParser st SyntaxTree
globalParser = spaces >>= const (parser arbitraryLayout)

-- Parser Tester

strParser :: String -> IO ()
strParser input
    = case runParser globalParser () "<string>" input of
        Left err -> print err
        Right result -> print result

interactiveParser :: IO ()
interactiveParser
    = do input <- getInput
         case runParser globalParser () "<interactive>" input of
             Left err -> print err
             Right result -> print result
    where
        getInput = do h <- getLine
                      t <- if h == "" then return "" else getInput
                      return (h++"\n"++t)