Parsing.hs

-----------------------------------------------------------------------------
-- Copyright 2014, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Utility functions for parsing with Parsec library
--
-----------------------------------------------------------------------------
--  $Id: Parsing.hs 6535 2014-05-14 11:05:06Z bastiaan $

module Ideas.Text.Parsing
   ( module Export
   , (<*>), (*>), (<*), (<$>), (<$), (<**>)
   , parseSimple, complete, skip, (<..>), ranges, stopOn
   , naturalOrFloat, float
   , UnbalancedError(..), balanced
   ) where

import Control.Applicative hiding ((<|>))
import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Text.ParserCombinators.Parsec as Export
import Text.ParserCombinators.Parsec.Expr as Export
import Text.ParserCombinators.Parsec.Language as Export
import Text.ParserCombinators.Parsec.Pos

parseSimple :: Parser a -> String -> Either String a
parseSimple p = left show . runParser (complete p) () ""

complete :: Parser a -> Parser a
complete p = spaces *> (p <* eof)

skip :: Parser a -> Parser ()
skip = void

-- Like the combinator from parser, except that for doubles
-- the read instance is used. This is a more precies representation
-- of the double (e.g., 1.413 is not 1.413000000001).
naturalOrFloat :: Parser (Either Integer Double)
naturalOrFloat = do
   a <- num
   b <- option "" ((:) <$> char '.' <*> nat)
   c <- option "" ((:) <$> oneOf "eE" <*> num)
   spaces
   case reads (a++b++c) of
      _ | null b && null c ->
         case a of
            '-':xs -> return (Left (negate (readInt xs)))
            xs     -> return (Left (readInt xs))
      [(d, [])] -> return (Right d)
      _         -> fail "not a float"
 where
   nat = many1 digit
   num = maybe id (:) <$> optionMaybe (char '-') <*> nat
   readInt = foldl' op 0 -- '
   op a b  = a*10+fromIntegral (ord b)-48

float :: Parser Double
float = do
   a <- nat
   b <- option "" ((:) <$> char '.' <*> nat)
   c <- option "" ((:) <$> oneOf "eE" <*> num)
   case reads (a++b++c) of
      [(d, [])] -> return d
      _         -> fail "not a float"
 where
   nat = many1 digit
   num = (:) <$> char '-' <*> nat

infix  6 <..>

(<..>) :: Char -> Char -> Parser Char
x <..> y = satisfy (\c -> c >= x && c <= y)

ranges :: [(Char, Char)] -> Parser Char
ranges xs = choice [ a <..> b | (a, b) <- xs ]

-- return in local function f needed for backwards compatibility
stopOn :: [String] -> Parser String
stopOn ys = rec
 where
   stop = choice (map f ys)
   f x  = try (string x >> return ' ')
   rec  =  (:) <$ notFollowedBy stop <*> anyChar <*> rec
       <|> return []

-- simple function for finding unbalanced pairs (e.g. parentheses)
balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError
balanced table = run (initialPos "") []
 where
   run _ [] [] = Nothing
   run _ ((pos, c):_) [] = return (NotClosed pos c)
   run pos stack (x:xs)
      | x `elem` opens  =
           run next ((pos, x):stack) xs
      | x `elem` closes =
           case stack of
              (_, y):rest | Just x == lookup y table -> run next rest xs
              _ -> return (NotOpened pos x)
      | otherwise =
           run next stack xs
    where
      next = updatePosChar pos x

   (opens, closes) = unzip table

data UnbalancedError = NotClosed SourcePos Char
                     | NotOpened SourcePos Char

instance Show UnbalancedError where
   show (NotClosed pos c) =
      show pos ++ ": Opening symbol " ++ [c] ++ " is not closed"
   show (NotOpened pos c) =
      show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol"