1
\$\begingroup\$

I am working on some application which involves regular expressions with counting. Also, these regular expressions are not necessarily over some fixed alphabet, but over some class of predicates over bit-vectors.

I would like to be able parse/unparse these objects. I have come up with something that works, but I am concerned that the way this stands, this requires too many parens, and usually humans would not want to use parens in the places where I strictly require it. Suggestions on how I can make this entire thing closer to human syntax is welcome.

Also, general comments on haskell programming styles are welcome as well.

Here is the file Types.hs where the types are defined and also the unparsing

module Regex.Types where

import Data.List (intercalate)

data Regex a = -- this is required elsewhere
    Empty
  | Epsilon
  | Char a
  | Union [Regex a]
  | Concat [Regex a]
  | Star (Regex a)
  deriving Show

data CntRegex a =
  CEmpty
  | CEpsilon
  | CChar a
  | CUnion [CntRegex a]
  | CConcat [CntRegex a]
  | CStar (CntRegex a)
  | CCount Int Int (CntRegex a)
  | CCountUnbounded Int (CntRegex a)

data BoolExp a =
  BTrue
  | BFalse
  | BSelect a
  | BNot (BoolExp a)
  | BAnd [BoolExp a]
  | BOr [(BoolExp a)]

instance Show a => Show (BoolExp a) where
  show BTrue = "true"
  show BFalse = "false"
  show (BSelect a) = show a
  show (BNot a) = "! " ++ parenwrap (show a)
  show (BAnd as) = intercalate " & " ( (parenwrap . show) <$> as)
  show (BOr as) =  intercalate " | " ( (parenwrap . show) <$> as)

instance Show a => Show (CntRegex a) where
  show (CEmpty) = "empty"
  show (CEpsilon) = "epsilon"
  show (CChar a) = bracketwrap $ show a
  show (CUnion as) = intercalate " | " ( (parenwrap . show) <$> as)
  show (CConcat as) = intercalate " " ( (parenwrap . show) <$> as)
  show (CStar a) =  parenwrap (show a) ++ " *"
  show (CCount i j a) = parenwrap (show a) ++ "{ "  ++ show i ++ ", " ++ show j ++ " }"
  show (CCountUnbounded i a) = parenwrap (show a) ++ "{ "  ++ show i ++ ", }"

parenwrap p = "(" ++ p ++ ")"
bracketwrap p = "[" ++ p ++ "]"

This is the Parser.hs file:

module Regex.Parser where

import Text.Parsec
import Text.Parsec.String
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (emptyDef)

import Regex.Types

lexer       = P.makeTokenParser emptyDef

parens      = P.parens lexer
braces      = P.braces lexer
brackets    = P.brackets lexer
symbol      = P.symbol lexer
natural     = P.natural lexer
whiteSpace  = P.whiteSpace lexer

pSelect :: Integral a => Parser (BoolExp a)
pSelect = BSelect <$> fromIntegral <$> natural

pAnd :: Parser (BoolExp a) -> Parser (BoolExp a)
pAnd prsr = BAnd <$> prsr `sepBy1` (symbol "&")

pOr :: Parser (BoolExp a) -> Parser (BoolExp a)
pOr prsr = BOr <$> prsr `sepBy1` (symbol "|")

pNot :: Parser (BoolExp a) -> Parser (BoolExp a)
pNot prsr = BNot <$> ((symbol "!") *> prsr)

parseBool :: Integral a => Parser (BoolExp a)
parseBool = try (parens $ pNot parseBool)
        <|> try (parens $ pOr parseBool)
        <|> try (parens $ pAnd parseBool)
        <|> try (parens parseBool)
        <|> try (symbol "true" *> pure BTrue)
        <|> try (symbol "false" *> pure BFalse)
        <|> pSelect

parseRegex :: Integral a => Parser (CntRegex (BoolExp a))
parseRegex = whiteSpace *> pRegex <* eof

pRegex :: Integral a => Parser (CntRegex (BoolExp a))
pRegex =    try (parens $ pStar pRegex)
        <|> try (parens $ pUnion pRegex)
        <|> try (parens $ pConcat pRegex)
        <|> try (parens $ pCount pRegex)
        <|> try (parens $ pSingleCount pRegex)
        <|> try (parens $ pCountUnbounded pRegex)
        <|> try (parens $ pRegex)
        <|> try (brackets $ CChar <$> parseBool)
        <|> try pEmpty
        <|> pEpsilon

pEmpty :: Parser (CntRegex a)
pEmpty = symbol "empty" *> pure CEmpty

pEpsilon :: Parser (CntRegex a)
pEpsilon = symbol "epsilon" *> pure CEpsilon

pUnion :: Parser (CntRegex a) -> Parser (CntRegex a)
pUnion subparser = CUnion <$> subparser `sepBy1` (symbol "|")

pConcat :: Parser (CntRegex a) -> Parser (CntRegex a)
pConcat subparser = CConcat <$> many1 subparser

pStar :: Parser (CntRegex a) -> Parser (CntRegex a)
pStar subparser = CStar <$> subparser <* symbol "*"

pSingleCount :: Parser (CntRegex a) -> Parser (CntRegex a)
pSingleCount subparser = do
    exp <- subparser
    int <- fromIntegral <$> braces natural
    pure $ CCount int int exp

pCount :: Parser (CntRegex a) -> Parser (CntRegex a)
pCount subparser = do
    exp <- subparser
    symbol "{"
    lo <- fromIntegral <$> natural
    symbol ","
    hi <- fromIntegral <$> natural
    symbol "}"
    pure $ CCount lo hi exp

pCountUnbounded :: Parser (CntRegex a) -> Parser (CntRegex a)
pCountUnbounded subparser = do
    exp <- subparser
    symbol "{"
    lo <- fromIntegral <$> natural
    symbol ","
    symbol "}"
    pure $ CCountUnbounded lo exp
```
\$\endgroup\$
1
\$\begingroup\$

Parsing with Precedence

I gather you want to add precedence to your operators, so you can write:

15 | !6 & 12

in place of:

(15 | (!6) & 12)

with the understanding that ! binds more tightly than & which binds more tightly than |. Fortunately, Parsec has built in support for this in the Text.Parsec.Expr module. The way you use it is to write a table-based parser for "expressions" that consist of operators applied to "terms". Terms include both atoms (like your pSelect) and parenthesized expressions.

(If you also want to see a manual alternative to the table-based approach, you may find this Stack Overflow answer of mine helpful. See the section "Operator Precedence" in particular.)

So, first, we define a parser for boolean terms:

reserved = P.reserved lexer

boolTerm :: Integral a => Parser (BoolExp a)
boolTerm = BTrue  <$ reserved "true"
       <|> BFalse <$ reserved "false"
       <|> BSelect . fromIntegral <$> natural
       <|> parens boolExpr
       <?> "boolean term"

A few notes:

  • Note the alternative way of writing the parsers for true and false using the (<$) operator. This is pretty common.
  • Also, reserved is correct here, not symbol, though it doesn't make a difference for your particular parser. The problem is that symbol "false" would match the first five characters of "falsehood" and then leave "hood" for a subsequent parser to parse, which is rarely what you want. The alternative reserved "false" avoids this, only parsing "false" if it isn't the prefix of a valid alphanumeric identifier.
  • Also note the use of f . g <$> natural in place of f <$> g <$> natural, though this is a minor stylistic choice.
  • Finally, note that try is unnecessary here. You only need try if a parser might fail after consuming input and you want to try subsequent alternatives. Here, none of these parsers can fail after consuming input, expect parens, which might fail if there's an open parenthesis followed by something other than a valid bool expression and a close parenthesis, but if that happens, there's nothing left to try (i.e., there are no valid parses starting with an open parenthesis, other than this one), so try is still unnecessary.

Then, we write the table based parser for expressions. The table is a list of lists of operator specifications: each inner list contains operator specfications at the same precedence, and in the outer list, the highest precedence (tightest binding) operators come first. In this parser, ! binds more tightly than & which binds more tightly than |.

boolExpr :: Integral a => Parser (BoolExp a)
boolExpr = buildExpressionParser table boolTerm <?> "boolean expression"
  where table =
          [ [prefix BNot "!"]
          , [binary band' "&"]
          , [binary bor' "|"]
          ]
        prefix op str = Prefix (op <$ symbol str)
        binary op str = Infix (op <$ symbol str) AssocRight
        band' x (BAnd ys) = BAnd (x:ys)
        band' (BAnd xs) y = BAnd (xs ++ [y])
        band' x y = BAnd [x,y]
        bor' x (BOr ys) = BOr (x:ys)
        bor' (BOr xs) y = BOr (xs ++ [y])
        bor' x y = BOr [x,y]

Your choice of data type has made this slightly more complicated than usual. If BAnd and BOr were binary constructors instead (which is the more usual representation for binary operators in ADTs), like so:

data BoolExp a =
  ...
  | BAnd (BoolExp a)
  | BOr (BoolExp a)
  ...

then boolExpr would look something like this:

boolExpr :: Integral a => Parser (BoolExp a)
boolExpr = buildExpressionParser table boolTerm <?> "boolean expression"
  where table =
          [ [prefix BNot "!"]
          , [binary BAnd "&"]
          , [binary BOr "|"]
          ]
        prefix op str = Prefix (op <$ symbol str)
        binary op str = Infix (op <$ symbol str) AssocLeft

We can rewrite the parser for CntRegex similarly. The countTerm parser parses atoms, as well as bracketed boolean expressions and parenthesized count expressions:

countTerm :: Integral a => Parser (CntRegex (BoolExp a))
countTerm = CEmpty <$ reserved "empty"
        <|> CEpsilon <$ reserved "epsilon"
        <|> brackets (CChar <$> boolExpr)
        <|> parens countExpr
        <?> "count term"

Again, no trys are needed here. If any of these parsers fails after consuming input, no subsequent parser is going to work, so trying is pointless.

The corresponding countExpr parser is table based, though it uses several tricks:

countExpr :: Integral a => Parser (CntRegex (BoolExp a))
countExpr = buildExpressionParser table countTerm <?> "count expression"
  where table =
          [ [ Postfix postfix ]
          , [ Infix (pure cconcat') AssocRight ]
          , [ Infix (cunion' <$ symbol "|") AssocRight]
          ]
        postfix = foldr1 (flip (.)) <$> many1 (CStar <$ symbol "*" <|> braces countSpec)
        cconcat' x (CConcat ys) = CConcat (x:ys)
        cconcat' (CConcat xs) y = CConcat (xs ++ [y])
        cconcat' x y = CConcat [x,y]
        cunion' x (CUnion ys) = CUnion (x:ys)
        cunion' (CUnion xs) y = CUnion (xs ++ [y])
        cunion' x y = CUnion [x,y]
        countSpec = do
          -- there's always a lower bound
          lo <- fromIntegral <$> natural
          -- there might be an upper bound, possibly empty/unbounded
          hi <- optionMaybe (symbol "," *> optionMaybe (fromIntegral <$> natural))
          case hi of
            -- no comma/bound
            Nothing -> pure $ CCount lo lo
            -- comma but no bound
            Just Nothing -> pure $ CCountUnbounded lo
            -- comma and upper bound
            Just (Just hi') -> pure $ CCount lo hi'

Notes:

  • The precedence here is any number of postfix operators bind most tightly, followed by juxtaposition (CConcat) and finally unions.
  • An intentional limitation of Parsec's table-based expression parsers is that they won't parse multiple postfix operators at the same precedence, so you need to combine them into a single parser (the postfix helper here) that parses them all and turns them into the right composition of functions to apply to the postfixed term.
  • Juxtaposition is implemented by an entry in the table that parses nothing (pure concat').
  • Note how I combined your multiple count specification parsers into a single do-block. If you kept them as distinct alternatives instead, this would be the one place in your parser where it would be legitimate to use try.

All that's enough to parse pretty complicated expressions with no parentheses required:

> parseTest parseRegex "empty{15} empty{3,4}* | [true & !15]{8,}"
(((empty){ 15, 15 }) (((empty){ 3, 4 }) *)) | (([(true) & (! (15))]){ 8, })

I haven't done exhaustive tests though, so there may be a few lingering bugs

Pretty Printing with Precedence

On the Show side, you can make use of showsPrec to simplify the printed representation by avoiding unnecessary parentheses. The precedence values here are mostly arbitrary. I've tried to match them up to the precedence of similar Haskell operators, where possible. Again, I haven't done exhaustive testing, so there may be some bugs.

showAtom d = showParen (d > 10) . showString
showPolyOp d d' op xs = showParen (d > d') $ foldr1 (.) $ intersperse (showString op) $ map (showsPrec (d'+1)) xs

instance Show a => Show (BoolExp a) where
  showsPrec d BTrue = showAtom d "true"
  showsPrec d BFalse = showAtom d "false"
  showsPrec d (BSelect a) = showsPrec d a
  showsPrec d (BNot a) = showParen (d > 9) $ showString "!" . showsPrec 10 a
  showsPrec d (BAnd as) = showPolyOp d 3 " & " as
  showsPrec d (BOr as) = showPolyOp d 2 " | " as

instance Show a => Show (CntRegex a) where
  showsPrec d CEmpty = showAtom d "empty"
  showsPrec d CEpsilon = showAtom d "epsilon"
  showsPrec d (CChar a) = showString "[" . showsPrec 0 a . showString "]"
  showsPrec d (CUnion as) = showPolyOp d 2 " | " as
  showsPrec d (CConcat as) = showPolyOp d 3 " " as
  showsPrec d (CStar a) =  showParen (d > 9) $ showsPrec 9 a . showString "*"
  showsPrec d (CCount i j a) = showParen (d > 9) $ showsPrec 9 a
    . showString "{" . showsPrec 0 i . showString "," . showsPrec 0 j . showString "}"
  showsPrec d (CCountUnbounded i a) = showParen (d > 9) $ showsPrec 9 a
    . showString "{" . showsPrec 0 i . showString ",}"

Be warned that many people consider this sort of thing an abuse of the Show type class. The idea is that Show is supposed to produce a Haskell-readable representation of your data, not necessarily a human-readable one. It might be better practice to define a separate pretty-printing type class, as I've done below.

Full Program

Here's my full version of the program:

import Data.List (intersperse)
import Text.Parsec
import Text.Parsec.String
import Text.Parsec.Expr
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (emptyDef)

data Regex a
  = Empty
  | Epsilon
  | Char a
  | Union [Regex a]
  | Concat [Regex a]
  | Star (Regex a)
  deriving Show

data CntRegex a
  = CEmpty
  | CEpsilon
  | CChar a
  | CUnion [CntRegex a]
  | CConcat [CntRegex a]
  | CStar (CntRegex a)
  | CCount Int Int (CntRegex a)
  | CCountUnbounded Int (CntRegex a)
  deriving (Show)

data BoolExp a
  = BTrue
  | BFalse
  | BSelect a
  | BNot (BoolExp a)
  | BAnd [BoolExp a]
  | BOr [BoolExp a]
  deriving (Show, Eq)

pprintAtom d = showParen (d > 10) . showString
pprintPolyOp d d' op xs = showParen (d > d') $ foldr1 (.) $ intersperse (showString op) $ map (pprintPrec (d'+1)) xs

class PPrint a where
  pprint :: a -> String
  pprint = ($ "") . pprintPrec 0
  pprintPrec :: Int -> a -> ShowS

instance Show a => PPrint (BoolExp a) where
  pprintPrec d BTrue = pprintAtom d "true"
  pprintPrec d BFalse = pprintAtom d "false"
  pprintPrec d (BSelect a) = showsPrec d a
  pprintPrec d (BNot a) = showParen (d > 9) $ showString "!" . pprintPrec 10 a
  pprintPrec d (BAnd as) = pprintPolyOp d 3 " & " as
  pprintPrec d (BOr as) = pprintPolyOp d 2 " | " as

instance PPrint a => PPrint (CntRegex a) where
  pprintPrec d CEmpty = pprintAtom d "empty"
  pprintPrec d CEpsilon = pprintAtom d "epsilon"
  pprintPrec d (CChar a) = showString "[" . pprintPrec 0 a . showString "]"
  pprintPrec d (CUnion as) = pprintPolyOp d 2 " | " as
  pprintPrec d (CConcat as) = pprintPolyOp d 3 " " as
  pprintPrec d (CStar a) =  showParen (d > 9) $ pprintPrec 9 a . showString "*"
  pprintPrec d (CCount i j a) = showParen (d > 9) $ pprintPrec 9 a
    . showString "{" . showsPrec 0 i . showString "," . showsPrec 0 j . showString "}"
  pprintPrec d (CCountUnbounded i a) = showParen (d > 9) $ pprintPrec 9 a
    . showString "{" . showsPrec 0 i . showString ",}"

lexer       = P.makeTokenParser emptyDef

parens      = P.parens lexer
braces      = P.braces lexer
brackets    = P.brackets lexer
symbol      = P.symbol lexer
natural     = P.natural lexer
whiteSpace  = P.whiteSpace lexer
reserved    = P.reserved lexer

boolTerm :: Integral a => Parser (BoolExp a)
boolTerm = BTrue  <$ reserved "true"
       <|> BFalse <$ reserved "false"
       <|> BSelect . fromIntegral <$> natural
       <|> parens boolExpr
       <?> "boolean term"

boolExpr :: Integral a => Parser (BoolExp a)
boolExpr = buildExpressionParser table boolTerm <?> "boolean expression"
  where table =
          [ [prefix BNot "!"]
          , [binary band' "&"]
          , [binary bor' "|"]
          ]
        prefix op str = Prefix (op <$ symbol str)
        binary op str = Infix (op <$ symbol str) AssocRight
        band' x (BAnd ys) = BAnd (x:ys)
        band' (BAnd xs) y = BAnd (xs ++ [y])
        band' x y = BAnd [x,y]
        bor' x (BOr ys) = BOr (x:ys)
        bor' (BOr xs) y = BOr (xs ++ [y])
        bor' x y = BOr [x,y]

countTerm :: Integral a => Parser (CntRegex (BoolExp a))
countTerm = CEmpty <$ reserved "empty"
        <|> CEpsilon <$ reserved "epsilon"
        <|> brackets (CChar <$> boolExpr)
        <|> parens countExpr
        <?> "count term"

countExpr :: Integral a => Parser (CntRegex (BoolExp a))
countExpr = buildExpressionParser table countTerm <?> "count expression"
  where table =
          [ [ Postfix postfix ]
          , [ Infix (pure cconcat') AssocRight ]
          , [ Infix (cunion' <$ symbol "|") AssocRight]
          ]
        postfix = foldr1 (flip (.)) <$> many1 (CStar <$ symbol "*" <|> braces countSpec)
        cconcat' x (CConcat ys) = CConcat (x:ys)
        cconcat' (CConcat xs) y = CConcat (xs ++ [y])
        cconcat' x y = CConcat [x,y]
        cunion' x (CUnion ys) = CUnion (x:ys)
        cunion' (CUnion xs) y = CUnion (xs ++ [y])
        cunion' x y = CUnion [x,y]
        countSpec = do
          -- there's always a lower bound
          lo <- fromIntegral <$> natural
          -- there might be an upper bound, possibly empty/unbounded
          hi <- optionMaybe (symbol "," *> optionMaybe (fromIntegral <$> natural))
          case hi of
            -- no comma/bound
            Nothing -> pure $ CCount lo lo
            -- comma but no bound
            Just Nothing -> pure $ CCountUnbounded lo
            -- comma and upper bound
            Just (Just hi') -> pure $ CCount lo hi'

parseRegex :: Integral a => Parser (CntRegex (BoolExp a))
parseRegex = whiteSpace *> countExpr <* eof

main = do
  -- I think this tests all the constructors
  let ex1 = "empty{1}** | epsilon*{2,3} [true|!false&15]{4,}*"
  let Right val1 = parse parseRegex "<string>" ex1
  print (val1 :: CntRegex (BoolExp Int))
  putStrLn . pprint $ val1
  -- A test for uniform handling of associativity
  print $ Right (BOr (replicate 3 (BAnd (map BSelect [5::Int,6,7]))))
    == parse boolExpr "" "5 & 6 & 7 | (5 & 6) & 7 | 5 & (6 & 7)"
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.