7
\$\begingroup\$

I am writing a very simple Prolog intepreter in Haskell. It's a class assignment and I really want to do it right.

I was able to (quite quickly) write a parser for the language. Today I borrowed a copy of Programming in Haskell by Graham Hutton and I decided I would rewrite my code to a more function-oriented style, using fancy Haskell features.

I spent my whole day reading about Monads and how they can simplify the code. Then I tried coding the book's examples, but they seem a bit outdated and incomplete.

Now, I have a working Prolog parser I am not happy with (because I am sure I can do shorter and terser).

I would like if anyone could review my code and give advice as how to move towards a more "Haskellish" approach. I don't want to use Parsec or any other ready-made parser in my code. I am looking for a minimalist working solution.

import Data.Char


data Category = Atom | Variable | Number | Operator | Complex deriving (Show, Eq)

data Token = Token {
    category :: Category,
    token :: String
}

instance Show Token where
    show (Token {token = token}) = show token


data Term = Term {
    tokenType :: Category,
    name :: String,
    args :: [Term]
}

instance Show Term where
    show (Term {tokenType = tokenType, name = name, args = args}) =
        name ++ if tokenType == Complex then
                    "(" ++ showTermList args ++ ")"
                else []


showTermList [] = []
showTermList (t : []) = show t
showTermList (t : ts) = show t ++ ", " ++ showTermList ts


data Rule = Rule {
    lhs :: Maybe Term,
    rhs :: [Term]
}

instance Show Rule where
    show (Rule { lhs = lhs, rhs = rhs }) =
        show lhs ++ " :- " ++ showTermList rhs


operators = "()[];"
smileyOperator = ":-"
openParen = "("
closeParen = ")"
comma = ","
dot = "."



parse :: [Token] -> [Rule]
parse [] = []
parse ts =
    let (rule, ts') = parseRule ts
    in (rule : parse ts')


parseRule :: [Token] -> (Rule, [Token])
parseRule [] = error "No tokens to parse"
parseRule ts =
    if null ts' || token (head ts') /= dot then
        (rule, ts')
    else
        (rule, tail ts')
    where (rule, ts') = parseRule' ts


parseRule' :: [Token] -> (Rule, [Token])
parseRule' (t : ts)
    | token t == smileyOperator =
        let (terms, ts') = parseTermList ts
        in (Rule {lhs = Nothing, rhs = terms}, ts')
    | otherwise =
        let (term, ts') = parseTerm (t : ts)
            (terms, ts'') =
                if null ts' then
                     error "Syntax error: missing dot (.)"
                else
                    if token (head ts') == smileyOperator then
                        parseTermList $ tail ts'
                    else
                        ([], ts')
        in (Rule {lhs = Just term, rhs = terms}, ts'')


parseTerm :: [Token] -> (Term, [Token])
parseTerm [] = error "No tokens to parse"
parseTerm (t : ts) =
    case category t of
        Variable -> (Term {tokenType = Variable, name = token t, args = []}, ts)
        Number -> (Term{tokenType = Number, name = token t, args = []}, ts)
        Atom -> parseAtom (t : ts)
        Operator -> error "Operator was unexpected here"
    where
        parseAtom (t : ts)
            | null ts || token (head ts) /= openParen =
                (Term {tokenType = Atom, name = token t, args = []}, ts)
            | otherwise = 
                let (args, ts') = parseTermList (ts)
                in (Term {tokenType = Complex, name = token t, args = args}, ts')


parseTermList :: [Token] -> ([Term], [Token])
parseTermList [] = ([], [])
parseTermList (t : ts)
    | token t == openParen = parseTermList ts
    | token t == comma = parseTermList ts
    | token t `elem` [dot, closeParen] = ([], ts) -- TODO this allows . instead ), fix it
    | otherwise =
        let (term, ts') = parseTerm (t : ts)
            (terms, ts'') = parseTermList ts'
        in (term : terms, ts'')


tokens :: String -> [Token]
tokens [] = []
tokens (c : cs)
    | isSpace c = tokens cs -- eat all whitespace
    | otherwise =
        let (token, cs') = nextToken (c : cs)
        in token : tokens cs'


nextToken :: String -> (Token, String)
nextToken [] = error "There are no tokens in an empty string"
nextToken (c : cs)
    | c `elem` operators = (Token {category = Atom, token = [c]}, cs)
    | isUpper c || c == '_' = wrap Variable isValidIdentifierChar
    | isLower c = wrap Atom isValidIdentifierChar
    | isNumber c = wrap Number isNumber
    | otherwise = wrap Operator (\c -> not (isLetter c || isSpace c))
    where
        wrap category charFilter =
           let (acc, cs') = accumulate (c : cs) charFilter
           in (Token {category = category, token = acc}, cs')
        isValidIdentifierChar c = isAlphaNum c || c == '_'


accumulate :: String -> (Char -> Bool) -> (String, String)
accumulate [] _ = ([], [])
accumulate (c : cs) charFilter
    | charFilter c =
        let (acc, cs') = accumulate cs charFilter
        in (c : acc, cs')
    | otherwise = ([], c : cs)

PS: Why is a Monad called Monad?


Edit: My question doesn't fit this forum. See Question Author's Answer for a precise answer if you are interested in the use of Monad for recursive parsing.

\$\endgroup\$
  • 1
    \$\begingroup\$ The etymology of Monad is covered in a fantastic answer here: english.stackexchange.com/questions/30654/… \$\endgroup\$ – hao Mar 22 '16 at 23:39
  • \$\begingroup\$ @haoformayor Great post, thanks for the link. \$\endgroup\$ – David Mar 22 '16 at 23:46
  • \$\begingroup\$ Thanks for the editor's attention. Just out of curiosity, what was wrong about my edit? \$\endgroup\$ – David Mar 22 '16 at 23:52
  • \$\begingroup\$ It's better to modify the question text than to separate out your requests. Note that your edit was just moved, not removed. It was the chatty "thanks" text that was removed. Also the extraneous text right before the code block. \$\endgroup\$ – mdfst13 Mar 23 '16 at 0:32
  • \$\begingroup\$ What's up with the stray mgu :: ? C&P error? \$\endgroup\$ – Zeta Mar 23 '16 at 12:44
4
\$\begingroup\$

Built-ins

The function showTermList applies show to each item in the list (map show) and puts , [COMMA] between any two items of the list (intercalate ","). You can just use this predefined functions to write:

showTermList = intercalate ","  . map show

Also in tokens:

| isSpace c = tokens cs -- eat all whitespace

Eating all white-space is better expressed as filter (not . isSpace).

tokens :: String -> [Token]
tokens = tokens' . filter (not . isSpace)
  where
    tokens' [] = []
    tokens' (c:cs) = let (token, cs') = nextToken (c : cs)
        in token : tokens cs'

Repetition

You have the repetition of (rule, in your function:

parseRule :: [Token] -> (Rule, [Token])
parseRule [] = error "No tokens to parse"
parseRule ts =
    if null ts' || token (head ts') /= dot then
        (rule, ts')
    else
        (rule, tail ts')
    where (rule, ts') = parseRule' ts

You could avoid it by assigning a tail variable:

parseRule ts = (rule, tail)
    where
      (rule, ts') = parseRule' ts
      tail = if null ts' || token (head ts') /= dot then ts' else tail ts'

Guards are even more visually immediate then if else:

parseRule ts = (rule, decideTail ts')
    where
      (rule, ts') = parseRule' ts
      decideTail ts'
        | null ts' || token (head ts') /= dot = ts'
        | otherwise = tail ts'

Now we note that:

(rule, decideTail ts')
     where
       (rule, ts') = parseRule' ts

Is built-in under the name of mapSnd

parseRule ts = mapSnd decideTail $  parseRule' ts
    where
      decideTail ts'
        | null ts' || token (head ts') /= dot = ts'
        | otherwise = tail ts'

Or even pointfree:

parseRule = mapSnd decideTail .  parseRule'
  where
      decideTail ts'
        | null ts' || token (head ts') /= dot = ts'
        | otherwise = tail ts'

accumulate

accumulate is a particularly fortunate case because it can be written as flip span using Haskell built-ins (just search String -> (Char -> Bool) -> (String, String) in Hoogle and you will find it (span is more general hence the a in the signature, in your case a = Char))

\$\endgroup\$
3
\$\begingroup\$

Question Author's answer

I accepted Caridorc's answer as it shows the canonical CR answer style and my original question doesn't seem to fit this forum very much. His/her suggestions are spot-on when it comes to making the original code better.

Nonetheless, I figured it out and understood Monad and related concepts. I think it's really a clever idea to use them as a conceptual basis for Parser.

The new code:

import Data.Char
import Control.Monad
import Control.Applicative

{- data structures -}

data Term = Atom String
          | Number Int
          | Variable String
          | Complex String [Term]
          deriving Show

data Rule = Rule (Maybe Term) [Term]
            deriving Show

{- Parser algebra -}

data Parser a = Parser (String -> [(a, String)])

instance Functor Parser where
    fmap = liftM

instance Applicative Parser where
    pure v = Parser (\input -> [(v, input)])
    (<*>) = ap

instance Monad Parser where
    p >>= f = Parser (
        \cs -> concat [parse (f val) cs' | (val, cs') <- parse p cs])
    return = pure

instance MonadPlus Parser where
    mzero = Parser (\input -> [])
    mplus p q = Parser (\input -> parse p input ++ parse q input) 

instance Alternative Parser where
    empty = mzero
    (<|>) = mplus
    many p = some p `mplus` return []
    some p = do
        a <- p
        as <- many p
        return (a:as)

parse :: Parser a -> String -> [(a, String)]
parse (Parser p) input = p input

{- simple parsers: building blocks for other parsers -}

char :: Char -> Parser Char
char c = sat (c ==)

string :: String -> Parser String
string "" = return ""
string (c:cs) = do
    char c
    string cs
    return (c:cs)

item :: Parser Char
item = Parser (\input -> case input of
    [] -> []
    (c:cs) -> [(c, cs)])

sat :: (Char -> Bool) -> Parser Char
sat pred = do
    c <- item
    if pred c then return c else mzero

sat2 :: (Char -> Bool) -> (Char -> Bool) -> Parser String
sat2 initChar insideChar = do
    c <- sat initChar
    cs <- many (sat insideChar)
    return (c:cs)

sepBy :: Parser a -> Parser b -> Parser [a]
sepBy p sep = do
    a <- p
    as <- many (do {sep; p})
    return (a:as)

list1 :: Parser a -> Parser [a]
list1 p = p `sepBy` comma

list :: Parser a -> Parser [a]
list p = list1 p <|> return []

{- Prolog character classes and operator parsers -}

dot = char '.'
comma = char ','

isIdentChar :: Char -> Bool
isIdentChar c = isAlphaNum c || isSymbol c

smiley = string ":-"

{- Prolog language construct parsers -}

variable :: Parser Term
variable = fmap Variable $ sat2 isUpper isIdentChar

atom :: Parser Term
atom = fmap Atom $ sat2 (\c -> isLower c || c == '_') isIdentChar

number :: Parser Term
number = fmap (Number . read) (some (sat isNumber))

complex :: Parser Term
complex = fmap (uncurry Complex) $ do
    Atom f <- atom
    char '('
    args <- list1 term
    char ')'
    return (f, args)

term :: Parser Term
term = complex <|> atom <|> variable <|> number

rule :: Parser Rule
rule = fmap (uncurry Rule) $ do
    ruleHead <- (fmap Just term <|> return Nothing)
    body <- (do {smiley; list term} <|> return [])
    dot
    return (ruleHead, body) -- TODO `:-.` ~~~> Rule Nothing [], do I mind?

The line term = complex <|> atom <|> variable <|> number is where it really shines (cf. definition of term in the beginning).

The new code is much more sophisticated and easily extensible, but is not very straightforward, at least not in the part when it comes to Monadic behavior. Quite a lot of concepts and ideas are burried in the code. To write it and understand it completely, I needed to read:

The last resource is really good and much of the code is based on it. But it's slightly outdated (contains references to MonadZero which does not seem to exist and does not account for the fact that Alternative is superclass of MonadPlus for some time already).

The project is hosted at GitHub in dcepelik/prolog. If you're interested, check it out in the future for updates (parsing the rest of Prolog syntactic structures, whitespace processing etc.).

Of course, I welcome any suggestions regarding the new code, too.

\$\endgroup\$
  • \$\begingroup\$ I suggest asking this version as a new question to get new suggestions. \$\endgroup\$ – Caridorc Mar 26 '16 at 15:00
  • 2
    \$\begingroup\$ Maybe I could, but right now I am quite confident with the code the way it is, so I don't want to bother anyone without a point. The phrase is there just in case someone explicitly wanted to comment on some obvious deficiency I haven't noticed. \$\endgroup\$ – David Mar 26 '16 at 15:03
  • 2
    \$\begingroup\$ You can almost always improve something but (not being a Haskell programmer, so caveats apply) I think this new version is indeed quite good, well done! Also, you noted that you “think it's really a clever idea to use [monads] as a conceptual basis for Parser.” — Yes. In fact, it’s devastatingly clever. If you haven’t already, check out the concept of parser combinators, and the library that implements them in Haskell, Parsec. \$\endgroup\$ – Konrad Rudolph Mar 26 '16 at 17:28
  • \$\begingroup\$ @KonradRudolph Thanks for the link, it will certainly be useful as I proceed. And thanks for the praise. I was trying to avoid using Parsec as I wanted to see how the stuff really works, but you're right that after this it may be valuable source (literally). I was kind of surprised how nicely it all works in practice. What really got me was the notion that lists represent results of non-deterministic operations and that the parsers actually operate on these. I guess one can write much faster code, but hardly as elegant. It's basically a description of grammar, nothing else. \$\endgroup\$ – David Mar 26 '16 at 20:03
3
\$\begingroup\$

Have some refactoring of your latest version, mostly to move the code closer to my tastes, YMMV. Take what you will.

import Data.Char
import Control.Monad
import Control.Applicative
import Control.Monad.Trans.State

{- data structures -}

data Term = Atom String
          | Number Int
          | Variable String
          | Complex String [Term]
          deriving Show

data Rule = Rule (Maybe Term) [Term]
            deriving Show

{- Parser algebra -}

type Parser = StateT String []

parse :: Parser a -> String -> [(a, String)]
parse = runStateT

{- simple parsers: building blocks for other parsers -}

char :: Char -> Parser Char
char = sat . (==)

string :: String -> Parser String
string = traverse char

item :: Parser Char
item = mapStateT maybeToList $ StateT uncons

sat :: (Char -> Bool) -> Parser Char
sat pred = mfilter pred item

sat2 :: (Char -> Bool) -> (Char -> Bool) -> Parser String
sat2 initChar insideChar = (:) <$> sat initChar <*> many (sat insideChar)

sepBy :: Parser a -> Parser b -> Parser [a]
sepBy p sep = (:) <$> p <*> many (sep *> p)

list1 :: Parser a -> Parser [a]
list1 p = p `sepBy` comma

list :: Parser a -> Parser [a]
list p = list1 p <|> return []

{- Prolog character classes and operator parsers -}

dot = char '.'
comma = char ','

isIdentChar :: Char -> Bool
isIdentChar = liftA2 (||) isAlphaNum isSymbol

smiley = string ":-"

{- Prolog language construct parsers -}

variable :: Parser Term
variable = Variable <$> sat2 isUpper isIdentChar

atom :: Parser Term
atom = Atom <$> sat2 (liftA2 (||) isLower (== '_')) isIdentChar

number :: Parser Term
number = Number . read <$> some (sat isNumber)

complex :: Parser Term
complex = do
    Atom f <- atom
    char '('
    args <- list1 term
    char ')'
    return $ Complex f args

term :: Parser Term
term = complex <|> atom <|> variable <|> number

rule :: Parser Rule
rule = do
    ruleHead <- fmap Just term <|> return Nothing
    body <- (smiley *> list term) <|> return []
    dot
    return $ Rule ruleHead body -- TODO `:-.` ~~~> Rule Nothing [], do I mind?
\$\endgroup\$
  • \$\begingroup\$ Well, I'll really have to take a closer look at this :). \$\endgroup\$ – David Mar 28 '16 at 11:34
  • \$\begingroup\$ Gurkenglas, would you mind elaborating on how did you manage to get rid of basically all the typeclasses I use, replacing them with StateT? \$\endgroup\$ – David Mar 29 '16 at 15:31
  • 1
    \$\begingroup\$ Well, you were doing precisely what StateT is doing, so I got rid of basically all the typeclasses you used, replacing them with StateT, because they already implemented it and with more features to boot. How? I "saw a pattern" and "applied a cached thought" etc. I don't know what you're asking me to explain here :( By the way, you might want to take a look at hackage.haskell.org/package/base-4.8.2.0/docs/… , it's in base and looks close to what you're doing. \$\endgroup\$ – Gurkenglas Mar 30 '16 at 20:22

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.