Compiler Explorer

Source code

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

import Prelude hiding (id, (.))
import Control.Category(Category(..))
import Control.Monad((>=>), when)
import Control.Arrow(Arrow(..), returnA)
import Control.Applicative(Alternative(..))

newtype Parser1 t m b c = Parser1 ([t] -> [(b -> m c, [t])])

instance Monad m => Category (Parser1 t m) where
    id = Parser1 $ \s -> [(pure, s)]
    Parser1 x . Parser1 y = Parser1 $ \s1 -> [(arr1 >=> arr2, s3) | (arr1, s2) <- y s1, (arr2, s3) <- x s2]

instance Monad m => Arrow (Parser1 t m) where
    arr f = Parser1 $ \s -> [(pure . f, s)]
    first (Parser1 x) = Parser1 $ \s -> [(\(b, d) -> do {
        c <- arr1 b;
        pure (c, d);
    }, s2) | (arr1, s2) <- x s]

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

instance Applicative m => Applicative (Parser1 t m b) where
    pure c = Parser1 $ \s -> [(\_ -> pure c, s)]
    Parser1 x <*> Parser1 y = Parser1 $ \s -> [(\b -> do { -- Applicative do
        xx <- arr1 b;
        yy <- arr2 b;
        pure $ xx yy;
    }, s3) | (arr1, s2) <- x s, (arr2, s3) <- y s2]

instance Applicative m => Alternative (Parser1 t m b) where
    empty = Parser1 $ \_ -> []
    Parser1 x <|> Parser1 y = Parser1 $ \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) -> Parser1 t m () c
msym f = Parser1 $ \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 -> Parser1 t m () t
sym tok = msym (\input -> if input == tok then Just input else Nothing)

-- Lift into embedded monad
lift :: Parser1 t m (m c) c
lift = Parser1 $ \s -> [(id, s)]

runParser :: Parser1 t m () c -> [t] -> [m c]
runParser (Parser1 x) s = [arr1 () | (arr1, []) <- 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 :: Parser1 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 :: Parser1 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 Arrow style
division :: Parser1 String (Either String) () Int
division = proc () -> do {
    sym "(" -< ();
    x <- expr -< ();
    sym "/" -< ();
    y <- expr -< ();
    sym ")" -< ();
    lift -< when (y == 0) $ Left "Division by zero";
    returnA -< div x y;
}

expr :: Parser1 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"