-- <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 :: forall a. ArrowProd r e t m a a
id = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Loc -> a -> L a
L Loc
NoLoc forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ArrowProd Prod r e (L t) (L (b -> m c))
x . :: forall b c a.
ArrowProd r e t m b c
-> ArrowProd r e t m a b -> ArrowProd r e t m a c
. ArrowProd Prod r e (L t) (L (a -> m b))
y = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ do {
    ~(L Loc
yl a -> m b
ya) <- Prod r e (L t) (L (a -> m b))
y;
    ~(L Loc
xl b -> m c
xa) <- Prod r e (L t) (L (b -> m c))
x;
    pure $ forall a. Loc -> a -> L a
L (Loc
yl forall a b. (Located a, Located b) => a -> b -> Loc
<--> Loc
xl) forall a b. (a -> b) -> a -> b
$ \a
v1 -> do {
      b
v2 <- a -> m b
ya a
v1;
      b -> m c
xa b
v2;
    };
  }

instance Monad m => Arrow (ArrowProd r e t m) where
  arr :: forall b c. (b -> c) -> ArrowProd r e t m b c
arr b -> c
f = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Loc -> a -> L a
L Loc
NoLoc (\b
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ b -> c
f b
b)
  first :: forall b c d.
ArrowProd r e t m b c -> ArrowProd r e t m (b, d) (c, d)
first (ArrowProd Prod r e (L t) (L (b -> m c))
x) = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ do {
    ~(L Loc
l b -> m c
arr1) <- Prod r e (L t) (L (b -> m c))
x;
    pure $ forall a. Loc -> a -> L a
L Loc
l forall a b. (a -> b) -> a -> b
$ \(b
b, d
d) -> do {
      c
c <- b -> m c
arr1 b
b;
      pure (c
c, d
d);
    };
  }

instance Functor m => Functor (ArrowProd r e t m b) where
  fmap :: forall a b.
(a -> b) -> ArrowProd r e t m b a -> ArrowProd r e t m b b
fmap a -> b
f (ArrowProd Prod r e (L t) (L (b -> m a))
x) = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ do {
    ~(L Loc
l b -> m a
arr1) <- Prod r e (L t) (L (b -> m a))
x;
    pure $ forall a. Loc -> a -> L a
L Loc
l forall a b. (a -> b) -> a -> b
$ \b
b -> a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> m a
arr1 b
b;
  }

instance Applicative m => Applicative (ArrowProd r e t m b) where
  pure :: forall a. a -> ArrowProd r e t m b a
pure a
c = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Loc -> a -> L a
L Loc
NoLoc forall a b. (a -> b) -> a -> b
$ \b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
c
  ArrowProd Prod r e (L t) (L (b -> m (a -> b)))
x <*> :: forall a b.
ArrowProd r e t m b (a -> b)
-> ArrowProd r e t m b a -> ArrowProd r e t m b b
<*> ArrowProd Prod r e (L t) (L (b -> m a))
y = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ do {
    ~(L Loc
xl b -> m (a -> b)
xa) <- Prod r e (L t) (L (b -> m (a -> b)))
x;
    ~(L Loc
yl b -> m a
ya) <- Prod r e (L t) (L (b -> m a))
y;
    pure $ forall a. Loc -> a -> L a
L (Loc
xl forall a b. (Located a, Located b) => a -> b -> Loc
<--> Loc
yl) forall a b. (a -> b) -> a -> b
$ \b
b -> do {
      a -> b
xv <- b -> m (a -> b)
xa b
b;
      a
yv <- b -> m a
ya b
b;
      pure $ a -> b
xv a
yv;
    };
  }

instance Applicative m => Alternative (ArrowProd r e t m b) where
  empty :: forall a. ArrowProd r e t m b a
empty = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall (f :: * -> *) a. Alternative f => f a
empty
  ArrowProd Prod r e (L t) (L (b -> m a))
x <|> :: forall a.
ArrowProd r e t m b a
-> ArrowProd r e t m b a -> ArrowProd r e t m b a
<|> ArrowProd Prod r e (L t) (L (b -> m a))
y = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ Prod r e (L t) (L (b -> m a))
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Prod r e (L t) (L (b -> m a))
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 :: forall a. ArrowProd r e t m b a -> ArrowProd r e t m b [a]
many (ArrowProd Prod r e (L t) (L (b -> m a))
x) = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ do {
    [L (b -> m a)]
list <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Prod r e (L t) (L (b -> m a))
x;
    pure $ forall a. Loc -> a -> L a
L (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a b. (Located a, Located b) => a -> b -> Loc
(<-->) Loc
NoLoc forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(L Loc
l b -> m a
_) -> Loc
l) [L (b -> m a)]
list) forall a b. (a -> b) -> a -> b
$ \b
b -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [L (b -> m a)]
list forall a b. (a -> b) -> a -> b
$ \(L Loc
_ b -> m a
arr1) -> b -> m a
arr1 b
b;
  }
  some :: forall a. ArrowProd r e t m b a -> ArrowProd r e t m b [a]
some ArrowProd r e t m b a
x = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArrowProd r e t m b a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ArrowProd r e t m b a
x

msym :: Applicative m => (t -> Maybe c) -> ArrowProd r e t m () c
msym :: forall (m :: * -> *) t c (r :: * -> * -> * -> *) e.
Applicative m =>
(t -> Maybe c) -> ArrowProd r e t m () c
msym t -> Maybe c
f = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ forall t a (r :: * -> * -> * -> *) e.
(t -> Maybe a) -> Prod r e t a
terminal forall a b. (a -> b) -> a -> b
$ \(L Loc
l t
input) -> case t -> Maybe c
f t
input of {
  Just c
result -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Loc -> a -> L a
L Loc
l (\() -> forall (f :: * -> *) a. Applicative f => a -> f a
pure c
result);
  Maybe c
Nothing -> forall a. Maybe a
Nothing;
}

sym :: (Applicative m, Eq t) => t -> ArrowProd r e t m () t
sym :: forall (m :: * -> *) t (r :: * -> * -> * -> *) e.
(Applicative m, Eq t) =>
t -> ArrowProd r e t m () t
sym t
tok = forall (m :: * -> *) t c (r :: * -> * -> * -> *) e.
Applicative m =>
(t -> Maybe c) -> ArrowProd r e t m () c
msym (\t
input -> if t
input forall a. Eq a => a -> a -> Bool
== t
tok then forall a. a -> Maybe a
Just t
input else forall a. Maybe a
Nothing)

lift :: ArrowProd r e t m (m c) c
lift :: forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) (c :: k).
ArrowProd r e t m (m c) c
lift = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Loc -> a -> L a
L Loc
NoLoc forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

loc :: Applicative m => ArrowProd r e t m b c -> ArrowProd r e t m b (L c)
loc :: forall (m :: * -> *) (r :: * -> * -> * -> *) e t b c.
Applicative m =>
ArrowProd r e t m b c -> ArrowProd r e t m b (L c)
loc (ArrowProd Prod r e (L t) (L (b -> m c))
x) = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall a b. (a -> b) -> a -> b
$ do {
  ~(L Loc
l b -> m c
a) <- Prod r e (L t) (L (b -> m c))
x;
  pure $ forall a. Loc -> a -> L a
L Loc
l forall a b. (a -> b) -> a -> b
$ \b
b -> (forall a. Loc -> a -> L a
L Loc
l) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> m c
a b
b;
}

arrowRule :: ArrowProd r e t m b c -> Grammar r (ArrowProd r e t m b c)
arrowRule :: forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
ArrowProd r e t m b c -> Grammar r (ArrowProd r e t m b c)
arrowRule (ArrowProd Prod r e (L t) (L (b -> m c))
x) = forall {k} (r :: * -> * -> * -> *) e t (m :: k -> *) b (c :: k).
Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
ArrowProd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: * -> * -> * -> *) e t a.
Prod r e t a -> Grammar r (Prod r e t a)
rule Prod r e (L t) (L (b -> m c))
x

arrowParser :: (forall r. Grammar r (ArrowProd r e t m () c)) -> Parser e [L t] (m c)
arrowParser :: forall {k} e t (m :: k -> *) (c :: k).
(forall (r :: * -> * -> * -> *).
 Grammar r (ArrowProd r e t m () c))
-> Parser e [L t] (m c)
arrowParser forall (r :: * -> * -> * -> *). Grammar r (ArrowProd r e t m () c)
g = forall i t e a.
ListLike i t =>
(forall (r :: * -> * -> * -> *). Grammar r (Prod r e t a))
-> Parser e i a
parser forall a b. (a -> b) -> a -> b
$ do {
  ArrowProd Prod r e (L t) (L (() -> m c))
x <- forall (r :: * -> * -> * -> *). Grammar r (ArrowProd r e t m () c)
g;
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do {
    ~(L Loc
_ () -> m c
a) <- Prod r e (L t) (L (() -> m c))
x;
    pure $ () -> m c
a ();
  };
}

showLoc :: Loc -> String
showLoc :: Loc -> String
showLoc Loc
NoLoc = String
"-:1:1-1:1"
showLoc (Loc (Pos String
file Int
line1 Int
col1 Int
_) (Pos String
_ Int
line2 Int
col2 Int
_)) = String
file forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
line1 forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
col1 forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
line2 forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
col2

-- | This function is buggy: if a file contains no tokens, the file name will not be returned
positionToLoc :: [L a] -> Int -> Loc
positionToLoc :: forall a. [L a] -> Int -> Loc
positionToLoc [L a]
list Int
position = if Int
position forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [L a]
list then let L Loc
l a
_ = [L a]
list forall a. [a] -> Int -> a
!! Int
position in Loc
l else if Int
position forall a. Eq a => a -> a -> Bool
== Int
0 then Loc
NoLoc else let L Loc
l a
_ = [L a]
list forall a. [a] -> Int -> a
!! (Int
position forall a. Num a => a -> a -> a
- Int
1) in Loc
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
-}