-- <ghc2021+->
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE EmptyCase, PostfixOperators, TupleSections, NamedFieldPuns, BangPatterns, BinaryLiterals, HexFloatLiterals, NumericUnderscores, GADTSyntax, RankNTypes, TypeApplications, PolyKinds, ExistentialQuantification, TypeOperators, ConstraintKinds, ExplicitForAll, KindSignatures, NamedWildCards, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ConstrainedClassMethods, InstanceSigs, TypeSynonymInstances, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveTraversable, StandaloneDeriving, EmptyDataDeriving, DeriveLift, DeriveGeneric #-}
-- Deleted GeneralisedNewtypeDeriving, because it is not compatible with Safe
-- Deleted ImportQualifiedPost, StandaloneKindSignatures, because they are not supported in ghc 8.8.1
{-# LANGUAGE MonoLocalBinds #-}
-- </ghc2021+->
{-# LANGUAGE ApplicativeDo #-}
module ParserUnbiasedChoiceMonadEmbedding ({- $Example -} ArrowProd(..), msym, sym, lift, loc, arrowRule, arrowParser, showLoc, positionToLoc) where
import Prelude hiding (id, (.))
import Control.Category(Category(..))
import Control.Arrow(Arrow(..))
import Control.Applicative(Alternative(..))
import Text.Earley(Prod, Grammar, Parser, terminal, rule, parser)
import Data.Loc(L(..), Loc(..), (<-->), Pos(..))
import Data.Traversable(for)
newtype ArrowProd r e t m b c = ArrowProd (Prod r e (L t) (L (b -> m c)))
instance Monad m => Category (ArrowProd r e t m) where
id = ArrowProd $ pure $ L NoLoc pure
ArrowProd x . ArrowProd y = ArrowProd $ do {
~(L yl ya) <- y;
~(L xl xa) <- x;
pure $ L (yl <--> xl) $ \v1 -> do {
v2 <- ya v1;
xa v2;
};
}
instance Monad m => Arrow (ArrowProd r e t m) where
arr f = ArrowProd $ pure $ L NoLoc (\b -> pure $ f b)
first (ArrowProd x) = ArrowProd $ do {
~(L l arr1) <- x;
pure $ L l $ \(b, d) -> do {
c <- arr1 b;
pure (c, d);
};
}
instance Functor m => Functor (ArrowProd r e t m b) where
fmap f (ArrowProd x) = ArrowProd $ do {
~(L l arr1) <- x;
pure $ L l $ \b -> f <$> arr1 b;
}
instance Applicative m => Applicative (ArrowProd r e t m b) where
pure c = ArrowProd $ pure $ L NoLoc $ \_ -> pure c
ArrowProd x <*> ArrowProd y = ArrowProd $ do {
~(L xl xa) <- x;
~(L yl ya) <- y;
pure $ L (xl <--> yl) $ \b -> do {
xv <- xa b;
yv <- ya b;
pure $ xv yv;
};
}
instance Applicative m => Alternative (ArrowProd r e t m b) where
empty = ArrowProd empty
ArrowProd x <|> ArrowProd y = ArrowProd $ x <|> y
-- We really need to define "many" and "some" here. Because they are special-cased in "Earley", see https://github.com/ollef/Earley/issues/55
many (ArrowProd x) = ArrowProd $ do {
list <- many x;
pure $ L (foldl (<-->) NoLoc $ map (\(L l _) -> l) list) $ \b -> for list $ \(L _ arr1) -> arr1 b;
}
some x = (:) <$> x <*> many x
msym :: Applicative m => (t -> Maybe c) -> ArrowProd r e t m () c
msym f = ArrowProd $ terminal $ \(L l input) -> case f input of {
Just result -> Just $ L l (\() -> pure result);
Nothing -> Nothing;
}
sym :: (Applicative m, Eq t) => t -> ArrowProd r e t m () t
sym tok = msym (\input -> if input == tok then Just input else Nothing)
lift :: ArrowProd r e t m (m c) c
lift = ArrowProd $ pure $ L NoLoc id
loc :: Applicative m => ArrowProd r e t m b c -> ArrowProd r e t m b (L c)
loc (ArrowProd x) = ArrowProd $ do {
~(L l a) <- x;
pure $ L l $ \b -> (L l) <$> a b;
}
arrowRule :: ArrowProd r e t m b c -> Grammar r (ArrowProd r e t m b c)
arrowRule (ArrowProd x) = ArrowProd <$> rule x
arrowParser :: (forall r. Grammar r (ArrowProd r e t m () c)) -> Parser e [L t] (m c)
arrowParser g = parser $ do {
ArrowProd x <- g;
pure $ do {
~(L _ a) <- x;
pure $ a ();
};
}
showLoc :: Loc -> String
showLoc NoLoc = "-:1:1-1:1"
showLoc (Loc (Pos file line1 col1 _) (Pos _ line2 col2 _)) = file ++ ":" ++ show line1 ++ ":" ++ show col1 ++ "-" ++ show line2 ++ ":" ++ show col2
-- | This function is buggy: if a file contains no tokens, the file name will not be returned
positionToLoc :: [L a] -> Int -> Loc
positionToLoc list position = if position < length list then let L l _ = list !! position in l else if position == 0 then NoLoc else let L l _ = list !! (position - 1) in l
{- $Example
Example. Let's parse (and calculate) such expressions: "( 1 * 2 / 3 )". We will use tokenizer similar to "words", so we place spaces between all tokens. Parens () are not mandatory around every subterm, i. e. ( 1 * 2 ) is ok and 1 * 2 is ok, too.
>>> :set -XHaskell2010
>>> :set -XRecursiveDo
>>> :set -XArrows
>>> import Control.Arrow(returnA)
>>> import Text.Earley(fullParses, Report(..))
>>> import Control.Monad(when)
>>> import Language.Lexer.Applicative(Lexer, token, longest, whitespace, streamToEitherList, runLexer, LexicalError(..))
>>> import Text.Regex.Applicative(psym, string)
>>> import ParserUnbiasedChoiceMonadEmbedding
>>> :{
grammar :: Grammar r (ArrowProd r () String (Either String) () Int)
grammar = mdo {
num <- arrowRule $ msym $ \tok -> if all (`elem` ['0'..'9']) tok then Just $ read tok else Nothing;
term <- arrowRule $ num <|> (sym "(" *> expr <* sym ")");
expr <- arrowRule $ term <|> ((*) <$> (expr <* sym "*") <*> term) <|> (proc () -> do {
L xl x <- loc expr -< ();
sym "/" -< ();
L yl y <- loc term -< ();
lift -< when (y == 0) $ Left $ "Division by zero. Attempting to divide this expression: " ++ showLoc xl ++ " by this expression: " ++ showLoc yl;
returnA -< div x y;
});
return expr;
}
lexer :: Lexer String
lexer = mconcat [
token $ longest $ many $ psym (/= ' '),
whitespace $ longest $ string " "
]
:}
>>> :{
case streamToEitherList $ runLexer lexer "-" "6 / 3 * 21" of {
Left (LexicalError (Pos _ line col _)) -> putStrLn $ "Lexer error at " ++ show line ++ " " ++ show col;
Right tokens -> case fullParses (arrowParser grammar) tokens of {
([], Report pos _ _) -> putStrLn $ "Parser error: " ++ showLoc (positionToLoc tokens pos) ++ ": no parse";
([m], _) -> case m of {
Left e -> putStrLn $ "Semantic error: " ++ e;
Right x -> putStrLn $ "Result: " ++ show x;
};
(_, _) -> putStrLn "Ambiguity";
};
}
:}
Result: 42
-}