blog-static/code/cs325-langs/src/CommonParsing.hs

module CommonParsing where
import Data.Char
import Data.Functor
import Text.Parsec
import Text.Parsec.Char
import Text.Parsec.Combinator

type Parser a b = Parsec String a b

kw :: String -> Parser a ()
kw s = try $ string s <* spaces $> ()

kwIf :: Parser a ()
kwIf = kw "if"

kwThen :: Parser a ()
kwThen = kw "then"

kwElse :: Parser a ()
kwElse = kw "else"

kwElsif :: Parser a ()
kwElsif = kw "elsif"

kwWhile :: Parser a ()
kwWhile = kw "while"

kwState :: Parser a ()
kwState = kw "state"

kwEffect :: Parser a ()
kwEffect = kw "effect"

kwCombine :: Parser a ()
kwCombine = kw "combine"

kwRand :: Parser a ()
kwRand = kw "rand"

kwFunction :: Parser a ()
kwFunction = kw "function"

kwSorted :: Parser a ()
kwSorted = kw "sorted"

kwLet :: Parser a ()
kwLet = kw "let"

kwTraverser :: Parser a ()
kwTraverser = kw "traverser"

kwReturn :: Parser a ()
kwReturn = kw "return"

op :: String -> op -> Parser a op
op s o = string s $> o

int :: Parser a Int
int = read <$> (many1 digit <* spaces)

var :: [String] -> Parser a String
var reserved =
    do
        c <- satisfy $ \c -> isLetter c || c == '_'
        cs <- many (satisfy isLetter <|> digit) <* spaces
        let name = c:cs
        if name `elem` reserved
        then fail "Can't use reserved keyword as identifier"
        else return name

list :: Char -> Char -> Char -> Parser a b -> Parser a [b]
list co cc cd pe = surround co cc $ sepBy pe (char cd >> spaces)

surround :: Char -> Char -> Parser a b -> Parser a b
surround c1 c2 pe =
    do
        char c1 >> spaces
        e <- pe
        spaces >> char c2 >> spaces
        return e

level :: (o -> e -> e -> e) -> Parser a o -> Parser a e -> Parser a e
level c po pe =
    do
        e <- pe <* spaces
        ops <- many $ try $ (flip . c <$> (po <* spaces) <*> pe) <* spaces
        return $ foldl (flip ($)) e ops

precedence :: (o -> e -> e -> e) -> Parser a e -> [ Parser a o ] -> Parser a e
precedence = foldl . flip . level