Formatter.hs

{-# LANGUAGE OverloadedStrings #-}
module Formatter where

import Foreign.C.String
import Foreign.C.Types
import qualified Data.Text as T

foreign export ccall
  format :: CString -> IO CString

data Block = Instruction Bool String | Block [Block]

toBlock :: String -> Block
toBlock str = fst $ getBlocks [] "" (T.unpack . T.strip . T.pack $ str)
  where
    getBlocks acc currentStr [] = (Block $ reverse acc, [])
    getBlocks acc currentStr ( '}' : restStr) = (Block $ reverse acc, restStr)
    getBlocks acc currentStr ( '{' : restStr) =
      let b = getBlocks [] "" restStr in (fst $ getBlocks (fst b: (Instruction False $ reverse currentStr) : acc) [] (snd b), [])
    getBlocks acc currentStr ( ';' : restStr) =
      (fst $ getBlocks ((Instruction True $ reverse currentStr) : acc) [] restStr, [])
    getBlocks acc currentStr ('\r' : '\n' : restStr) = (fst $ getBlocks acc currentStr restStr, [])
    getBlocks acc currentStr (c : restStr) = (fst $ getBlocks acc (c:currentStr) restStr, [])

printBlock :: Int -> Block -> String
printBlock (-1) (Block xs) = concat $ map (printBlock $ 0) xs
printBlock indent (Block xs) = replicate (indent * 4) ' ' ++ "{" ++ "\r\n" ++
  (concat $ map (printBlock $ indent + 1) xs) ++ "\r\n" ++ replicate (indent * 4) ' ' ++ "}" ++ "\r\n"
printBlock indent (Instruction semicolon line) = replicate (indent * 4) ' ' ++
  (T.unpack . T.strip . T.pack $ line) ++ if semicolon then ";" else "" ++ "\r\n"

format :: CString -> IO CString
format cstr = do
  str <- peekCString cstr
  newCString . (printBlock (-1)). toBlock $ str