module Lambdabot.Parser (parseExpr, parseDecl, withParsed, prettyPrintInLine) where
import Control.Monad.Error ()
import Data.Char
import Data.Generics
import Language.Haskell.Parser
import Language.Haskell.Pretty
import Language.Haskell.Syntax
import Lambdabot.FixPrecedence
parseExpr :: String -> Either String HsExp
parseExpr s
| not (balanced 0 ' ' s) = Left "Unbalanced parentheses"
| otherwise = case parseModule wrapped of
ParseOk (HsModule _ _ _ _ [HsPatBind _ _ (HsUnGuardedRhs e) _])
-> Right $ fixPrecedence $ unparen e
ParseFailed (SrcLoc _ _ col) msg
-> Left $ showParseError msg (col length prefix) s
where
prefix = "module Main where { main = ("
wrapped = prefix ++ s ++ "\n)}"
unparen (HsParen e) = e
unparen e = e
balanced :: Int -> Char -> String -> Bool
balanced n _ "" = n == 0
balanced n _ ('(':cs) = balanced (n+1) '(' cs
balanced n _ (')':cs) = n > 0 && balanced (n1) ')' cs
balanced n p (c :cs)
| c `elem` "\"'" && (not (isAlphaNum p) || c /= '\'')
= balancedString c n cs
balanced n p ('-':'-':_)
| not (isSymbol p) = n == 0
balanced n _ ('{':'-':cs) = balancedComment 1 n cs
balanced n _ (c :cs) = balanced n c cs
balancedString :: Char -> Int -> String -> Bool
balancedString _ n "" = n == 0
balancedString delim n ('\\':c:cs)
| isSpace c = case dropWhile isSpace cs of
'\\':cs' -> balancedString delim n cs'
cs' -> balancedString delim n cs'
| otherwise = balancedString delim n cs
balancedString delim n (c :cs)
| delim == c = balanced n c cs
| otherwise = balancedString delim n cs
balancedComment :: Int -> Int -> String -> Bool
balancedComment 0 n cs = balanced n ' ' cs
balancedComment _ _ "" = True
balancedComment m n ('{':'-':cs) = balancedComment (m+1) n cs
balancedComment m n ('-':'}':cs) = balancedComment (m1) n cs
balancedComment m n (_ :cs) = balancedComment m n cs
parseDecl :: String -> Either String HsDecl
parseDecl s = case parseModule s of
ParseOk (HsModule _ _ _ _ [d]) -> Right $ fixPrecedence d
ParseFailed (SrcLoc _ _ col) msg -> Left $ showParseError msg col s
showParseError :: String -> Int -> String -> String
showParseError msg col s = " " ++ msg
++ case (col < 0, drop (col 1) s) of
(True, _) -> " at end of input"
(_,[] ) -> " at end of input"
(_,ctx ) -> let ctx' = takeWhile (/= ' ') ctx
in " at \"" ++ (take 5 ctx')
++ (if length ctx' > 5 then "..." else "")
++ "\" (column " ++ show col ++ ")"
withParsed :: (forall a. (Data a, Eq a) => a -> a) -> String -> String
withParsed f s = case (parseExpr s, parseDecl s) of
(Right a, _) -> prettyPrintInLine $ f a
(_, Right a) -> prettyPrintInLine $ f a
(Left e, _) -> e
prettyPrintInLine :: Pretty a => a -> String
prettyPrintInLine = prettyPrintWithMode (defaultMode { layout = PPInLine })