Compiler Explorer

Source code

{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Arrows #-}

import Control.Monad(when)
import Control.Applicative(Alternative(..))

newtype Parser2 t m a = Parser2 ([t] -> [(m a, [t])])

instance Functor m => Functor (Parser2 t m) where
    fmap f (Parser2 x) = Parser2 $ \s -> [(f <$> m, s2) | (m, s2) <- x s]

instance Applicative m => Applicative (Parser2 t m) where
    pure c = Parser2 $ \s -> [(pure c, s)]
    Parser2 x <*> Parser2 y = Parser2 $ \s -> [(do { -- Applicative do
        xx <- m1;
        yy <- m2;
        pure $ xx yy;
    }, s3) | (m1, s2) <- x s, (m2, s3) <- y s2]

instance Applicative m => Alternative (Parser2 t m) where
    empty = Parser2 $ \_ -> []
    Parser2 x <|> Parser2 y = Parser2 $ \s -> x s ++ y s

-- Similar to https://hackage.haskell.org/package/Earley-0.13.0.1/docs/Text-Earley.html#v:terminal
-- and https://hackage.haskell.org/package/regex-applicative-0.3.4/docs/Text-Regex-Applicative.html#v:msym
msym :: Applicative m => (t -> Maybe c) -> Parser2 t m c
msym f = Parser2 $ \case {
    x:xs -> case f x of {
        Just c -> [(pure c, xs)];
        Nothing -> [];
    };
    [] -> [];
}

-- Similar to https://hackage.haskell.org/package/Earley-0.13.0.1/docs/Text-Earley.html#v:token
-- and https://hackage.haskell.org/package/regex-applicative-0.3.4/docs/Text-Regex-Applicative.html#v:sym
-- and https://hackage.haskell.org/package/parsec-3.1.14.0/docs/Text-Parsec-Char.html#v:char
sym :: (Applicative m, Eq t) => t -> Parser2 t m t
sym tok = msym (\input -> if input == tok then Just input else Nothing)

antiArrowLift :: Monad m => Parser2 t m (m c) -> Parser2 t m c
antiArrowLift (Parser2 x) = Parser2 $ \s -> [(do { m2 <- m; m2; }, s2) | (m, s2) <- x s]

runParser :: Parser2 t m c -> [t] -> [m c]
runParser (Parser2 x) s = [m | (m, []) <- x s]

{-
Example. Let's parse (and calculate) expressions ( 1 * ( 2 / 3 ) ).
We will use "words" as tokenizer, so place spaces between all tokens
Parens () are mandatory around every subterm, i. e. ( 1 * 2 ) is ok, 1 * 2 is not
-}

num :: Parser2 String (Either String) Int
num = msym (\token -> if all (`elem` ['0'..'9']) token then Just $ read token else Nothing)

-- We will write "prod" in usual Applicative style
prod :: Parser2 String (Either String) Int
prod = (*) <$> (sym "(" *> expr) <*> (sym "*" *> expr <* sym ")")

-- In "division" we want to process semantic error (division by zero), so we will use antiArrowLift
division :: Parser2 String (Either String) Int
division = antiArrowLift $ do { -- Applicative do
    sym "(";
    x <- expr;
    sym "/";
    y <- expr;
    sym ")";
    pure $ do {
        when (y == 0) $ Left "Division by zero";
        pure $ div x y;
    };
}

expr :: Parser2 String (Either String) Int
expr = num <|> prod <|> division

main :: IO ()
main = do {
    let { input = "( ( 6 / 3 ) * 21 )"; };
    case runParser expr (words input) of {
        [] -> putStrLn "Parser error: no parse";
        [m] -> case m of {
            Left e -> putStrLn $ "Semantic error: " ++ e;
            Right x -> putStrLn $ "Result: " ++ show x;
        };
        _ -> putStrLn "Parser error: ambiguous parse";
    };
}

-- Should print "Result: 42"