hobbits-1.0: Data/Binding/Hobbits/PatternParser.hs

{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Data.Binding.Hobbits.PatternParser
-- Copyright   : (c) 2011 Edwin Westbrook, Nicolas Frisby, and Paul Brauner
--
-- License     : BSD3
--
-- Maintainer  : emw4@rice.edu
-- Stability   : experimental
-- Portability : GHC
--
-- A simple parser for Haskell patterns. Currently does not handle:
--
-- - Record patterns @Pt { pointx = x }@
--
-- - Signature patterns @p :: t@
--
-- - View patterns @e -> p@

module Data.Binding.Hobbits.PatternParser (parsePattern, parseVar) where

import Text.ParserCombinators.Parsec
import Language.Haskell.TH
import Data.Char


varStartChars = ['a'..'z']
ctorStartChars = ['A'..'Z']

identChars = varStartChars ++ ctorStartChars ++ ['0'..'9'] ++ "'_"
infixChars = "!#$%&*+./<=>?@"

varParser :: GenParser Char st String
varParser =
    do char1 <- oneOf varStartChars
       char_rest <- many (oneOf identChars)
       return (char1 : char_rest)

ctorParser :: GenParser Char st String
ctorParser =
    do char1 <- oneOf ctorStartChars
       char_rest <- many (oneOf identChars)
       return (char1 : char_rest)

infixParser :: GenParser Char st String
infixParser =
    do char1 <- char ':'
       char_rest <- many (oneOf infixChars)
       return (char1 : char_rest)

stringParser :: GenParser Char st String
stringParser =
    do char '"'
       res <- stringContentsParser
       return res

stringContentsParser =
    many (noneOf "\\\"") >>= \prefix ->
        (char '"' >> return prefix)
        <|>
        (char '\\' >> do c <- anyChar
                         rest <- stringContentsParser
                         return $ prefix ++ [c] ++ rest)

charParser :: GenParser Char st Char
charParser =
    do char '\''
       c <- ((char '\\' >> anyChar) <|> anyChar)
       char '\''
       return c

digitsToInt digits = helper digits 0
    where helper [] accum = accum
          helper (digit:digits) accum =
              helper digits (accum * 10 + (digitToInt digit))

intToRational :: Int -> Rational
intToRational = fromIntegral

digitsToFrac digits = helper digits
    where helper [] = 0.0
          helper (digit:digits) = ((helper digits) + (intToRational $ digitToInt digit)) / 10

numParser :: GenParser Char st Lit
numParser =
    do base_digits <- many1 (oneOf ['0'..'9'])
       ((do char '.'
            frac_digits <- many1 (oneOf ['0'..'9'])
            return (RationalL $ (intToRational $ digitsToInt base_digits) + digitsToFrac frac_digits))
        <|> return (IntegerL $ fromIntegral $ digitsToInt base_digits))

litParser :: GenParser Char st Lit
litParser = (charParser >>= return . CharL) <|>
            (stringParser >>= return . StringL) <|>
            numParser

commaSepParser :: GenParser Char st [Pat]
commaSepParser =
    (do first <- pattParser 0
        rest <- (char ',' >> commaSepParser) <|> (return [])
        return (first:rest)) <|> (return [])


-- the int gives the "level":
--   0 = parse anything
--   1 = parse ctor args but not infix ops
--   2 = do not parse ctor args or infix ops
tokenParser :: Int -> GenParser Char st Pat
tokenParser i =
    -- literals
    (litParser >>= return . LitP) <|>

    -- wildcards
    (char '_' >> return WildP) <|>

    -- bangs
    (do char '!'
        patt <- pattParser i
        return $ BangP patt) <|>

    -- tildes
    (do char '~'
        patt <- pattParser i
        return $ TildeP patt) <|>

    -- as-patterns
    (try (do var <- varParser
             wsParser
             char '@'
             patt <- pattParser i
             return $ AsP (mkName var) patt)) <|>

    -- vars
    (varParser >>= return . VarP . mkName) <|>

    -- tuples; NOTE: we parse any parenthesized expression as a tuple,
    -- and remove the TupP constructor when there are no commas
    (do char '('
        tup <- commaSepParser
        char ')'
        return (case tup of
                  [] -> ConP '() []
                  [patt] -> patt
                  _ -> TupP tup)) <|>

    -- constructor applications
    (do ctor <- ctorParser
        args <- if i < 2 then many (try $ pattParser 2) else return []
        return $ ConP (mkName ctor) args) <|>

    -- lists
    (do char '['
        elems <- commaSepParser
        char ']'
        return $ ListP elems)



wsParser :: GenParser Char st ()
wsParser = many (oneOf " \t\n\r") >> return ()

pattParser :: Int -> GenParser Char st Pat
pattParser i =
    do wsParser
       res <- if i == 0 then
                  -- infix constructor applications
                  try (do lhs <- pattParser 1
                          op <- infixParser
                          rhs <- pattParser 0
                          return $ ConP (mkName op) [lhs, rhs]) <|>
                  tokenParser i
              else
                  tokenParser i
       wsParser
       return res

varOnlyParser :: GenParser Char st String
varOnlyParser = do wsParser
                   res <- varParser
                   wsParser
                   eof
                   return res


----------------------------------------
-- Finally, the external interface... --
----------------------------------------

-- | Parse a string into a Template Haskell pattern.
parsePattern str = case parse (pattParser 0) "" str of
                  Left err -> error $ show err
                  Right patt -> patt

{-|
  Parse a string for a Haskell variable; return the string on success
  (if the string is a valid Haskell variable) and signal an error
  otherwise.
-}
parseVar str = case parse varOnlyParser "" str of
                 Left err -> error $ show err
                 Right str -> str