-- <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 r e t m a a
id = Prod r e (L t) (L (a -> m a)) -> ArrowProd r e t m a a
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 (Prod r e (L t) (L (a -> m a)) -> ArrowProd r e t m a a)
-> Prod r e (L t) (L (a -> m a)) -> ArrowProd r e t m a a
forall a b. (a -> b) -> a -> b
$ L (a -> m a) -> Prod r e (L t) (L (a -> m a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (L (a -> m a) -> Prod r e (L t) (L (a -> m a)))
-> L (a -> m a) -> Prod r e (L t) (L (a -> m a))
forall a b. (a -> b) -> a -> b
$ Loc -> (a -> m a) -> L (a -> m a)
forall a. Loc -> a -> L a
L Loc
NoLoc a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ArrowProd Prod r e (L t) (L (b -> m c))
x . :: 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 = Prod r e (L t) (L (a -> m c)) -> ArrowProd r e t m 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 (Prod r e (L t) (L (a -> m c)) -> ArrowProd r e t m a c)
-> Prod r e (L t) (L (a -> m c)) -> ArrowProd r e t m a c
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 $ Loc -> (a -> m c) -> L (a -> m c)
forall a. Loc -> a -> L a
L (Loc
yl Loc -> Loc -> Loc
forall a b. (Located a, Located b) => a -> b -> Loc
<--> Loc
xl) ((a -> m c) -> L (a -> m c)) -> (a -> m c) -> L (a -> m c)
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 :: (b -> c) -> ArrowProd r e t m b c
arr b -> c
f = Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b 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 (Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c)
-> Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c
forall a b. (a -> b) -> a -> b
$ L (b -> m c) -> Prod r e (L t) (L (b -> m c))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (L (b -> m c) -> Prod r e (L t) (L (b -> m c)))
-> L (b -> m c) -> Prod r e (L t) (L (b -> m c))
forall a b. (a -> b) -> a -> b
$ Loc -> (b -> m c) -> L (b -> m c)
forall a. Loc -> a -> L a
L Loc
NoLoc (\b
b -> c -> m c
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> m c) -> c -> m c
forall a b. (a -> b) -> a -> b
$ b -> c
f b
b)
  first :: 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) = Prod r e (L t) (L ((b, d) -> m (c, d)))
-> ArrowProd r e t m (b, d) (c, d)
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 (Prod r e (L t) (L ((b, d) -> m (c, d)))
 -> ArrowProd r e t m (b, d) (c, d))
-> Prod r e (L t) (L ((b, d) -> m (c, d)))
-> ArrowProd r e t m (b, d) (c, d)
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 $ Loc -> ((b, d) -> m (c, d)) -> L ((b, d) -> m (c, d))
forall a. Loc -> a -> L a
L Loc
l (((b, d) -> m (c, d)) -> L ((b, d) -> m (c, d)))
-> ((b, d) -> m (c, d)) -> L ((b, d) -> m (c, d))
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 :: (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) = Prod r e (L t) (L (b -> m b)) -> ArrowProd r e t m b b
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 (Prod r e (L t) (L (b -> m b)) -> ArrowProd r e t m b b)
-> Prod r e (L t) (L (b -> m b)) -> ArrowProd r e t m b b
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 $ Loc -> (b -> m b) -> L (b -> m b)
forall a. Loc -> a -> L a
L Loc
l ((b -> m b) -> L (b -> m b)) -> (b -> m b) -> L (b -> m b)
forall a b. (a -> b) -> a -> b
$ \b
b -> a -> b
f (a -> b) -> m a -> m b
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 :: a -> ArrowProd r e t m b a
pure a
c = Prod r e (L t) (L (b -> m a)) -> ArrowProd r e t m b a
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 (Prod r e (L t) (L (b -> m a)) -> ArrowProd r e t m b a)
-> Prod r e (L t) (L (b -> m a)) -> ArrowProd r e t m b a
forall a b. (a -> b) -> a -> b
$ L (b -> m a) -> Prod r e (L t) (L (b -> m a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (L (b -> m a) -> Prod r e (L t) (L (b -> m a)))
-> L (b -> m a) -> Prod r e (L t) (L (b -> m a))
forall a b. (a -> b) -> a -> b
$ Loc -> (b -> m a) -> L (b -> m a)
forall a. Loc -> a -> L a
L Loc
NoLoc ((b -> m a) -> L (b -> m a)) -> (b -> m a) -> L (b -> m a)
forall a b. (a -> b) -> a -> b
$ \b
_ -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
c
  ArrowProd Prod r e (L t) (L (b -> m (a -> b)))
x <*> :: 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 = Prod r e (L t) (L (b -> m b)) -> ArrowProd r e t m b b
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 (Prod r e (L t) (L (b -> m b)) -> ArrowProd r e t m b b)
-> Prod r e (L t) (L (b -> m b)) -> ArrowProd r e t m b b
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 $ Loc -> (b -> m b) -> L (b -> m b)
forall a. Loc -> a -> L a
L (Loc
xl Loc -> Loc -> Loc
forall a b. (Located a, Located b) => a -> b -> Loc
<--> Loc
yl) ((b -> m b) -> L (b -> m b)) -> (b -> m b) -> L (b -> m b)
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 :: ArrowProd r e t m b a
empty = Prod r e (L t) (L (b -> m a)) -> ArrowProd r e t m b a
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 Prod r e (L t) (L (b -> m a))
forall (f :: * -> *) a. Alternative f => f a
empty
  ArrowProd Prod r e (L t) (L (b -> m a))
x <|> :: 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 = Prod r e (L t) (L (b -> m a)) -> ArrowProd r e t m b a
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 (Prod r e (L t) (L (b -> m a)) -> ArrowProd r e t m b a)
-> Prod r e (L t) (L (b -> m a)) -> ArrowProd r e t m b a
forall a b. (a -> b) -> a -> b
$ Prod r e (L t) (L (b -> m a))
x Prod r e (L t) (L (b -> m a))
-> Prod r e (L t) (L (b -> m a)) -> Prod r e (L t) (L (b -> m a))
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 :: 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) = Prod r e (L t) (L (b -> m [a])) -> ArrowProd r e t m b [a]
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 (Prod r e (L t) (L (b -> m [a])) -> ArrowProd r e t m b [a])
-> Prod r e (L t) (L (b -> m [a])) -> ArrowProd r e t m b [a]
forall a b. (a -> b) -> a -> b
$ do {
    [L (b -> m a)]
list <- Prod r e (L t) (L (b -> m a)) -> Prod r e (L t) [L (b -> m a)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Prod r e (L t) (L (b -> m a))
x;
    pure $ Loc -> (b -> m [a]) -> L (b -> m [a])
forall a. Loc -> a -> L a
L ((Loc -> Loc -> Loc) -> Loc -> [Loc] -> Loc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Loc -> Loc -> Loc
forall a b. (Located a, Located b) => a -> b -> Loc
(<-->) Loc
NoLoc ([Loc] -> Loc) -> [Loc] -> Loc
forall a b. (a -> b) -> a -> b
$ (L (b -> m a) -> Loc) -> [L (b -> m a)] -> [Loc]
forall a b. (a -> b) -> [a] -> [b]
map (\(L Loc
l b -> m a
_) -> Loc
l) [L (b -> m a)]
list) ((b -> m [a]) -> L (b -> m [a])) -> (b -> m [a]) -> L (b -> m [a])
forall a b. (a -> b) -> a -> b
$ \b
b -> [L (b -> m a)] -> (L (b -> m a) -> m a) -> m [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [L (b -> m a)]
list ((L (b -> m a) -> m a) -> m [a]) -> (L (b -> m a) -> m a) -> m [a]
forall a b. (a -> b) -> a -> b
$ \(L Loc
_ b -> m a
arr1) -> b -> m a
arr1 b
b;
  }
  some :: ArrowProd r e t m b a -> ArrowProd r e t m b [a]
some ArrowProd r e t m b a
x = (:) (a -> [a] -> [a])
-> ArrowProd r e t m b a -> ArrowProd r e t m b ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArrowProd r e t m b a
x ArrowProd r e t m b ([a] -> [a])
-> ArrowProd r e t m b [a] -> ArrowProd r e t m b [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArrowProd r e t m b a -> ArrowProd r e t m b [a]
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 :: (t -> Maybe c) -> ArrowProd r e t m () c
msym t -> Maybe c
f = Prod r e (L t) (L (() -> m c)) -> ArrowProd r e t m () 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 (Prod r e (L t) (L (() -> m c)) -> ArrowProd r e t m () c)
-> Prod r e (L t) (L (() -> m c)) -> ArrowProd r e t m () c
forall a b. (a -> b) -> a -> b
$ (L t -> Maybe (L (() -> m c))) -> Prod r e (L t) (L (() -> m c))
forall t a (r :: * -> * -> * -> *) e.
(t -> Maybe a) -> Prod r e t a
terminal ((L t -> Maybe (L (() -> m c))) -> Prod r e (L t) (L (() -> m c)))
-> (L t -> Maybe (L (() -> m c))) -> Prod r e (L t) (L (() -> m c))
forall a b. (a -> b) -> a -> b
$ \(L Loc
l t
input) -> case t -> Maybe c
f t
input of {
  Just c
result -> L (() -> m c) -> Maybe (L (() -> m c))
forall a. a -> Maybe a
Just (L (() -> m c) -> Maybe (L (() -> m c)))
-> L (() -> m c) -> Maybe (L (() -> m c))
forall a b. (a -> b) -> a -> b
$ Loc -> (() -> m c) -> L (() -> m c)
forall a. Loc -> a -> L a
L Loc
l (\() -> c -> m c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
result);
  Maybe c
Nothing -> Maybe (L (() -> m c))
forall a. Maybe a
Nothing;
}

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

lift :: ArrowProd r e t m (m c) c
lift :: ArrowProd r e t m (m c) c
lift = Prod r e (L t) (L (m c -> m c)) -> ArrowProd r e t m (m c) 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 (Prod r e (L t) (L (m c -> m c)) -> ArrowProd r e t m (m c) c)
-> Prod r e (L t) (L (m c -> m c)) -> ArrowProd r e t m (m c) c
forall a b. (a -> b) -> a -> b
$ L (m c -> m c) -> Prod r e (L t) (L (m c -> m c))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (L (m c -> m c) -> Prod r e (L t) (L (m c -> m c)))
-> L (m c -> m c) -> Prod r e (L t) (L (m c -> m c))
forall a b. (a -> b) -> a -> b
$ Loc -> (m c -> m c) -> L (m c -> m c)
forall a. Loc -> a -> L a
L Loc
NoLoc m c -> m c
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 :: 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) = Prod r e (L t) (L (b -> m (L c))) -> ArrowProd r e t m b (L 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 (Prod r e (L t) (L (b -> m (L c))) -> ArrowProd r e t m b (L c))
-> Prod r e (L t) (L (b -> m (L c))) -> ArrowProd r e t m b (L c)
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 $ Loc -> (b -> m (L c)) -> L (b -> m (L c))
forall a. Loc -> a -> L a
L Loc
l ((b -> m (L c)) -> L (b -> m (L c)))
-> (b -> m (L c)) -> L (b -> m (L c))
forall a b. (a -> b) -> a -> b
$ \b
b -> (Loc -> c -> L c
forall a. Loc -> a -> L a
L Loc
l) (c -> L c) -> m c -> m (L c)
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 :: 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) = Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b 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 (Prod r e (L t) (L (b -> m c)) -> ArrowProd r e t m b c)
-> Grammar r (Prod r e (L t) (L (b -> m c)))
-> Grammar r (ArrowProd r e t m b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Prod r e (L t) (L (b -> m c))
-> Grammar r (Prod r e (L t) (L (b -> m c)))
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 (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 (r :: * -> * -> * -> *). Grammar r (Prod r e (L t) (m c)))
-> Parser e [L t] (m c)
forall i t e a.
ListLike i t =>
(forall (r :: * -> * -> * -> *). Grammar r (Prod r e t a))
-> Parser e i a
parser ((forall (r :: * -> * -> * -> *). Grammar r (Prod r e (L t) (m c)))
 -> Parser e [L t] (m c))
-> (forall (r :: * -> * -> * -> *).
    Grammar r (Prod r e (L t) (m c)))
-> Parser e [L t] (m c)
forall a b. (a -> b) -> a -> b
$ do {
  ArrowProd Prod r e (L t) (L (() -> m c))
x <- Grammar r (ArrowProd r e t m () c)
forall (r :: * -> * -> * -> *). Grammar r (ArrowProd r e t m () c)
g;
  Prod r e (L t) (m c) -> Grammar r (Prod r e (L t) (m c))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prod r e (L t) (m c) -> Grammar r (Prod r e (L t) (m c)))
-> Prod r e (L t) (m c) -> Grammar r (Prod r e (L t) (m c))
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col2

positionToLoc :: [L a] -> Int -> Loc
positionToLoc :: [L a] -> Int -> Loc
positionToLoc [L a]
list Int
position = if Int
position Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [L a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [L a]
list then let L Loc
l a
_ = [L a]
list [L a] -> Int -> L a
forall a. [a] -> Int -> a
!! Int
position in Loc
l else if Int
position Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Loc
NoLoc else let L Loc
l a
_ = [L a]
list [L a] -> Int -> L a
forall a. [a] -> Int -> a
!! (Int
position Int -> Int -> Int
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 { -- RecursiveDo
  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 -- Trivial lexer similar to "words"
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
-}