{-# 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 #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ApplicativeDo #-}
module ParserUnbiasedChoiceMonadEmbedding ( 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
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
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