module Aasam
    ( m
    , module Grammars
    , AasamError(..)
    ) where

import Data.Function (on)
import Data.List (groupBy)
import qualified Data.List.NonEmpty as DLNe
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Set (Set, insert, union)
import qualified Data.Set as Set
import Grammars
    ( CfgProduction
    , CfgString
    , ContextFree
    , NonTerminal(..)
    , Precedence
    , PrecedenceProduction(..)
    , Terminal(..)
    )
import Util ((>.), (|>), unwrapOr)

import Data.Bifunctor (Bifunctor(bimap, second))
import Data.Data (toConstr)
import qualified Data.Foldable
import qualified Data.List as List

import qualified Data.Text as Text
import Data.Text (Text)

doGeneric :: PrecedenceProduction -> (Int -> NonEmpty Text -> a) -> a
doGeneric :: forall a. PrecedenceProduction -> (Int -> NonEmpty Text -> a) -> a
doGeneric (Prefix Int
prec NonEmpty Text
words) Int -> NonEmpty Text -> a
f = Int -> NonEmpty Text -> a
f Int
prec NonEmpty Text
words
doGeneric (Postfix Int
prec NonEmpty Text
words) Int -> NonEmpty Text -> a
f = Int -> NonEmpty Text -> a
f Int
prec NonEmpty Text
words
doGeneric (Infixl Int
prec NonEmpty Text
words) Int -> NonEmpty Text -> a
f = Int -> NonEmpty Text -> a
f Int
prec NonEmpty Text
words
doGeneric (Infixr Int
prec NonEmpty Text
words) Int -> NonEmpty Text -> a
f = Int -> NonEmpty Text -> a
f Int
prec NonEmpty Text
words
doGeneric (Closed NonEmpty Text
words) Int -> NonEmpty Text -> a
f = Int -> NonEmpty Text -> a
f Int
0 NonEmpty Text
words

getWords :: PrecedenceProduction -> [Text]
getWords :: PrecedenceProduction -> [Text]
getWords = (PrecedenceProduction
 -> (Int -> NonEmpty Text -> [Text]) -> [Text])
-> (Int -> NonEmpty Text -> [Text])
-> PrecedenceProduction
-> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip PrecedenceProduction -> (Int -> NonEmpty Text -> [Text]) -> [Text]
forall a. PrecedenceProduction -> (Int -> NonEmpty Text -> a) -> a
doGeneric ((NonEmpty Text -> [Text]) -> Int -> NonEmpty Text -> [Text]
forall a b. a -> b -> a
const NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
DLNe.toList)

prec :: PrecedenceProduction -> Int
prec :: PrecedenceProduction -> Int
prec = (PrecedenceProduction -> (Int -> NonEmpty Text -> Int) -> Int)
-> (Int -> NonEmpty Text -> Int) -> PrecedenceProduction -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip PrecedenceProduction -> (Int -> NonEmpty Text -> Int) -> Int
forall a. PrecedenceProduction -> (Int -> NonEmpty Text -> a) -> a
doGeneric Int -> NonEmpty Text -> Int
forall a b. a -> b -> a
const

nt :: Int -> Int -> Int -> NonTerminal
nt :: Int -> Int -> Int -> NonTerminal
nt Int
prec Int
p Int
q = (Text -> NonTerminal
NonTerminal (Text -> NonTerminal) -> (String -> Text) -> String -> NonTerminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (Int -> String
forall a. Show a => a -> String
show Int
prec String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
q)

-- TODO: write a proper implementation of this that doesn't depend on List
groupSetBy :: Ord a => (a -> a -> Bool) -> Set a -> Set (Set a)
groupSetBy :: forall a. Ord a => (a -> a -> Bool) -> Set a -> Set (Set a)
groupSetBy a -> a -> Bool
projection = Set a -> [a]
forall a. Set a -> [a]
Set.toList (Set a -> [a]) -> ([a] -> [[a]]) -> Set a -> [[a]]
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy a -> a -> Bool
projection (Set a -> [[a]]) -> ([[a]] -> [Set a]) -> Set a -> [Set a]
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. ([a] -> Set a) -> [[a]] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList (Set a -> [Set a])
-> ([Set a] -> Set (Set a)) -> Set a -> Set (Set a)
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. [Set a] -> Set (Set a)
forall a. Ord a => [a] -> Set a
Set.fromList

makeClasses :: Precedence -> Set Precedence
makeClasses :: Set PrecedenceProduction -> Set (Set PrecedenceProduction)
makeClasses = (PrecedenceProduction -> PrecedenceProduction -> Bool)
-> Set PrecedenceProduction -> Set (Set PrecedenceProduction)
forall a. Ord a => (a -> a -> Bool) -> Set a -> Set (Set a)
groupSetBy PrecedenceProduction -> PrecedenceProduction -> Bool
fixeq
  where
    fixeq :: PrecedenceProduction -> PrecedenceProduction -> Bool
fixeq = (Constr -> Constr -> Bool)
-> (PrecedenceProduction -> Constr)
-> PrecedenceProduction
-> PrecedenceProduction
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
(==) PrecedenceProduction -> Constr
forall a. Data a => a -> Constr
toConstr
        -- equivalence relation of fixity on precedence productions

type UniquenessPair = (PrecedenceProduction, Precedence)

-- This function returns a set of upairs. A upair contains a production of a single precedence on the left,
-- and the set of all productions of that precedence on the right (including the one on the left).
classToPairSet :: Precedence -> Set UniquenessPair
classToPairSet :: Set PrecedenceProduction -> Set UniquenessPair
classToPairSet = (PrecedenceProduction -> PrecedenceProduction -> Bool)
-> Set PrecedenceProduction -> Set (Set PrecedenceProduction)
forall a. Ord a => (a -> a -> Bool) -> Set a -> Set (Set a)
groupSetBy PrecedenceProduction -> PrecedenceProduction -> Bool
preceq (Set PrecedenceProduction -> Set (Set PrecedenceProduction))
-> (Set (Set PrecedenceProduction) -> Set UniquenessPair)
-> Set PrecedenceProduction
-> Set UniquenessPair
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. (Set PrecedenceProduction -> UniquenessPair)
-> Set (Set PrecedenceProduction) -> Set UniquenessPair
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Set PrecedenceProduction -> UniquenessPair
pair
  where
    pair :: Precedence -> UniquenessPair
    pair :: Set PrecedenceProduction -> UniquenessPair
pair Set PrecedenceProduction
prec = (Int -> Set PrecedenceProduction -> PrecedenceProduction
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set PrecedenceProduction
prec, Set PrecedenceProduction
prec)
    preceq :: PrecedenceProduction -> PrecedenceProduction -> Bool
    preceq :: PrecedenceProduction -> PrecedenceProduction -> Bool
preceq PrecedenceProduction
a PrecedenceProduction
b = PrecedenceProduction -> Int
prec PrecedenceProduction
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== PrecedenceProduction -> Int
prec PrecedenceProduction
b

pairifyClasses :: Set Precedence -> Set (Set UniquenessPair)
pairifyClasses :: Set (Set PrecedenceProduction) -> Set (Set UniquenessPair)
pairifyClasses = (Set PrecedenceProduction -> Set UniquenessPair)
-> Set (Set PrecedenceProduction) -> Set (Set UniquenessPair)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Set PrecedenceProduction -> Set UniquenessPair
classToPairSet

type PqQuad = (Int, Int, PrecedenceProduction, Precedence)

pqboundUPair :: Set UniquenessPair -> Set UniquenessPair -> UniquenessPair -> PqQuad
pqboundUPair :: Set UniquenessPair
-> Set UniquenessPair -> UniquenessPair -> PqQuad
pqboundUPair Set UniquenessPair
pre Set UniquenessPair
post (PrecedenceProduction
r, Set PrecedenceProduction
s) = (Set UniquenessPair -> Int -> Int
greater Set UniquenessPair
pre (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PrecedenceProduction -> Int
prec PrecedenceProduction
r, Set UniquenessPair -> Int -> Int
greater Set UniquenessPair
post (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PrecedenceProduction -> Int
prec PrecedenceProduction
r, PrecedenceProduction
r, Set PrecedenceProduction
s)
  where
    greater :: Set UniquenessPair -> Int -> Int
    greater :: Set UniquenessPair -> Int -> Int
greater Set UniquenessPair
upairs Int
n = Set UniquenessPair -> Int
forall a. Set a -> Int
Set.size (Set UniquenessPair -> Int) -> Set UniquenessPair -> Int
forall a b. (a -> b) -> a -> b
$ (UniquenessPair -> Bool)
-> Set UniquenessPair -> Set UniquenessPair
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) (Int -> Bool) -> (UniquenessPair -> Int) -> UniquenessPair -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecedenceProduction -> Int
prec (PrecedenceProduction -> Int)
-> (UniquenessPair -> PrecedenceProduction)
-> UniquenessPair
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniquenessPair -> PrecedenceProduction
forall a b. (a, b) -> a
fst) Set UniquenessPair
upairs

pqboundClasses :: Set UniquenessPair -> Set UniquenessPair -> Set (Set UniquenessPair) -> Set (Set PqQuad)
pqboundClasses :: Set UniquenessPair
-> Set UniquenessPair
-> Set (Set UniquenessPair)
-> Set (Set PqQuad)
pqboundClasses Set UniquenessPair
pre Set UniquenessPair
post = (Set UniquenessPair -> Set PqQuad)
-> Set (Set UniquenessPair) -> Set (Set PqQuad)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((UniquenessPair -> PqQuad) -> Set UniquenessPair -> Set PqQuad
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Set UniquenessPair
-> Set UniquenessPair -> UniquenessPair -> PqQuad
pqboundUPair Set UniquenessPair
pre Set UniquenessPair
post))

intersperseStart :: NonEmpty Text -> CfgString
intersperseStart :: NonEmpty Text -> [Either Terminal NonTerminal]
intersperseStart =
    (Text -> Either Terminal NonTerminal)
-> NonEmpty Text -> NonEmpty (Either Terminal NonTerminal)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
DLNe.map (Terminal -> Either Terminal NonTerminal
forall a b. a -> Either a b
Left (Terminal -> Either Terminal NonTerminal)
-> (Text -> Terminal) -> Text -> Either Terminal NonTerminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Terminal
Terminal) (NonEmpty Text -> NonEmpty (Either Terminal NonTerminal))
-> (NonEmpty (Either Terminal NonTerminal)
    -> NonEmpty (Either Terminal NonTerminal))
-> NonEmpty Text
-> NonEmpty (Either Terminal NonTerminal)
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. Either Terminal NonTerminal
-> NonEmpty (Either Terminal NonTerminal)
-> NonEmpty (Either Terminal NonTerminal)
forall a. a -> NonEmpty a -> NonEmpty a
DLNe.intersperse (NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right ((Text -> NonTerminal
NonTerminal (Text -> NonTerminal) -> (String -> Text) -> String -> NonTerminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) String
"!start")) (NonEmpty Text -> NonEmpty (Either Terminal NonTerminal))
-> (NonEmpty (Either Terminal NonTerminal)
    -> [Either Terminal NonTerminal])
-> NonEmpty Text
-> [Either Terminal NonTerminal]
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. NonEmpty (Either Terminal NonTerminal)
-> [Either Terminal NonTerminal]
forall a. NonEmpty a -> [a]
DLNe.toList

fill :: Precedence -> Set CfgProduction -> Set CfgProduction
fill :: Set PrecedenceProduction -> Set CfgProduction -> Set CfgProduction
fill Set PrecedenceProduction
s Set CfgProduction
cfgprods = Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set CfgProduction
withTerminals Set CfgProduction
withoutTerminals
  where
    (Set CfgProduction
left, Set CfgProduction
withoutTerminals) = (CfgProduction -> Bool)
-> Set CfgProduction -> (Set CfgProduction, Set CfgProduction)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition CfgProduction -> Bool
hasTerminal Set CfgProduction
cfgprods
      where
        hasTerminal :: CfgProduction -> Bool
        hasTerminal :: CfgProduction -> Bool
hasTerminal (NonTerminal
_, [Either Terminal NonTerminal]
words) = (Either Terminal NonTerminal -> Bool)
-> [Either Terminal NonTerminal] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any Either Terminal NonTerminal -> Bool
isTerminal [Either Terminal NonTerminal]
words
    isTerminal :: Either Terminal NonTerminal -> Bool
    isTerminal :: Either Terminal NonTerminal -> Bool
isTerminal (Right (NonTerminal Text
_)) = Bool
False
    isTerminal (Left (Terminal Text
_)) = Bool
True
    withTerminals :: Set CfgProduction
withTerminals = Set PrecedenceProduction -> Set CfgProduction -> Set CfgProduction
fill' Set PrecedenceProduction
s Set CfgProduction
left
        -- TODO: write a proper implementation of this composition that doesn't depend on List
      where
        fill' :: Precedence -> Set CfgProduction -> Set CfgProduction
        fill' :: Set PrecedenceProduction -> Set CfgProduction -> Set CfgProduction
fill' Set PrecedenceProduction
s = Set CfgProduction -> [CfgProduction]
forall a. Set a -> [a]
Set.toList (Set CfgProduction -> [CfgProduction])
-> ([CfgProduction] -> [[CfgProduction]])
-> Set CfgProduction
-> [[CfgProduction]]
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. [CfgProduction] -> [[CfgProduction]]
forall a. a -> [a]
repeat (Set CfgProduction -> [[CfgProduction]])
-> ([[CfgProduction]] -> [[CfgProduction]])
-> Set CfgProduction
-> [[CfgProduction]]
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. (PrecedenceProduction -> [CfgProduction] -> [CfgProduction])
-> [PrecedenceProduction] -> [[CfgProduction]] -> [[CfgProduction]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PrecedenceProduction -> [CfgProduction] -> [CfgProduction]
reset (Set PrecedenceProduction -> [PrecedenceProduction]
forall a. Set a -> [a]
Set.toList Set PrecedenceProduction
s) (Set CfgProduction -> [[CfgProduction]])
-> ([[CfgProduction]] -> [CfgProduction])
-> Set CfgProduction
-> [CfgProduction]
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. [[CfgProduction]] -> [CfgProduction]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Set CfgProduction -> [CfgProduction])
-> ([CfgProduction] -> Set CfgProduction)
-> Set CfgProduction
-> Set CfgProduction
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. [CfgProduction] -> Set CfgProduction
forall a. Ord a => [a] -> Set a
Set.fromList
          where
            reset :: PrecedenceProduction -> [CfgProduction] -> [CfgProduction]
            reset :: PrecedenceProduction -> [CfgProduction] -> [CfgProduction]
reset PrecedenceProduction
pp = (CfgProduction -> CfgProduction)
-> [CfgProduction] -> [CfgProduction]
forall a b. (a -> b) -> [a] -> [b]
map (([Either Terminal NonTerminal] -> [Either Terminal NonTerminal])
-> CfgProduction -> CfgProduction
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
re)
              where
                re :: CfgString -> CfgString
                re :: [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
re [Either Terminal NonTerminal]
str =
                    case PrecedenceProduction
pp of
                        Infixl Int
prec NonEmpty Text
words -> [Either Terminal NonTerminal]
-> NonEmpty Text -> [Either Terminal NonTerminal]
kansas [Either Terminal NonTerminal]
str NonEmpty Text
words
                        Infixr Int
prec NonEmpty Text
words -> [Either Terminal NonTerminal]
-> NonEmpty Text -> [Either Terminal NonTerminal]
kansas [Either Terminal NonTerminal]
str NonEmpty Text
words
                        PrecedenceProduction
_ ->
                            String -> [Either Terminal NonTerminal]
forall a. HasCallStack => String -> a
error
                                String
"This is a bug in Aasam. Somehow, I got a CfgProduction that hasn't any terminals, or a Closed production."
                  where
                    kansas :: CfgString -> NonEmpty Text -> CfgString
                    kansas :: [Either Terminal NonTerminal]
-> NonEmpty Text -> [Either Terminal NonTerminal]
kansas [Either Terminal NonTerminal]
str NonEmpty Text
words = [Either Terminal NonTerminal] -> Either Terminal NonTerminal
forall a. [a] -> a
List.head [Either Terminal NonTerminal]
str Either Terminal NonTerminal
-> [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
forall a. a -> [a] -> [a]
: NonEmpty Text -> [Either Terminal NonTerminal]
intersperseStart NonEmpty Text
words [Either Terminal NonTerminal]
-> [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
forall a. [a] -> [a] -> [a]
++ [[Either Terminal NonTerminal] -> Either Terminal NonTerminal
forall a. [a] -> a
List.last [Either Terminal NonTerminal]
str]

-- The CE production on `closedrule` must go to a non-terminal.
-- Relevant terminals in these rules are all added by `fill`. Those added immediately in the rule bodies are just to signal to fill.
--   If an "evil" non-terminal appears anywhere in the output of a *rule fuctions, that's a bug.
prerule :: Int -> Int -> PqQuad -> Set CfgProduction
prerule :: Int -> Int -> PqQuad -> Set CfgProduction
prerule Int
p Int
q (Int
_, Int
_, PrecedenceProduction
r, Set PrecedenceProduction
s) = Set PrecedenceProduction -> Set CfgProduction -> Set CfgProduction
fill Set PrecedenceProduction
s (Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> Set CfgProduction
forall a b. (a -> b) -> a -> b
$ CfgProduction -> Set CfgProduction
forall a. a -> Set a
Set.singleton (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
p Int
q, [NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
q)])

postrule :: Int -> Int -> PqQuad -> Set CfgProduction
postrule :: Int -> Int -> PqQuad -> Set CfgProduction
postrule Int
p Int
q (Int
_, Int
_, PrecedenceProduction
r, Set PrecedenceProduction
s) = Set PrecedenceProduction -> Set CfgProduction -> Set CfgProduction
fill Set PrecedenceProduction
s (Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> Set CfgProduction
forall a b. (a -> b) -> a -> b
$ CfgProduction -> Set CfgProduction
forall a. a -> Set a
Set.singleton (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
p Int
q, [NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
p (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))])

inlrule :: Int -> Int -> PqQuad -> Set CfgProduction
inlrule :: Int -> Int -> PqQuad -> Set CfgProduction
inlrule Int
p Int
q (Int
_, Int
_, PrecedenceProduction
r, Set PrecedenceProduction
s) = Set PrecedenceProduction -> Set CfgProduction -> Set CfgProduction
fill Set PrecedenceProduction
s (Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> Set CfgProduction
forall a b. (a -> b) -> a -> b
$ [CfgProduction] -> Set CfgProduction
forall a. Ord a => [a] -> Set a
Set.fromList [CfgProduction
a, CfgProduction
forall {a}. (NonTerminal, [Either a NonTerminal])
b]
  where
    a :: CfgProduction
a =
        ( Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
p Int
q
        , [NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
0 Int
q), Terminal -> Either Terminal NonTerminal
forall a b. a -> Either a b
Left ((Text -> Terminal
Terminal (Text -> Terminal) -> (String -> Text) -> String -> Terminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) String
"evil"), NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
p Int
0)])
    b :: (NonTerminal, [Either a NonTerminal])
b = (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
p Int
q, [NonTerminal -> Either a NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
p Int
q)])

inrrule :: Int -> Int -> PqQuad -> Set CfgProduction
inrrule :: Int -> Int -> PqQuad -> Set CfgProduction
inrrule Int
p Int
q (Int
_, Int
_, PrecedenceProduction
r, Set PrecedenceProduction
s) = Set PrecedenceProduction -> Set CfgProduction -> Set CfgProduction
fill Set PrecedenceProduction
s (Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> Set CfgProduction
forall a b. (a -> b) -> a -> b
$ [CfgProduction] -> Set CfgProduction
forall a. Ord a => [a] -> Set a
Set.fromList [CfgProduction
a, CfgProduction
forall {a}. (NonTerminal, [Either a NonTerminal])
b]
  where
    a :: CfgProduction
a =
        ( Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
p Int
q
        , [NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
0 Int
q), Terminal -> Either Terminal NonTerminal
forall a b. a -> Either a b
Left ((Text -> Terminal
Terminal (Text -> Terminal) -> (String -> Text) -> String -> Terminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) String
"evil"), NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
p Int
0)])
    b :: (NonTerminal, [Either a NonTerminal])
b = (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
p Int
q, [NonTerminal -> Either a NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
p Int
q)])

closedrule :: Set UniquenessPair -> Set UniquenessPair -> Int -> Int -> PqQuad -> Set CfgProduction
closedrule :: Set UniquenessPair
-> Set UniquenessPair -> Int -> Int -> PqQuad -> Set CfgProduction
closedrule Set UniquenessPair
pres Set UniquenessPair
posts Int
p Int
q (Int
_, Int
_, PrecedenceProduction
r, Set PrecedenceProduction
s) = CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => a -> Set a -> Set a
insert CfgProduction
forall {a}. (NonTerminal, [Either a NonTerminal])
ae Set CfgProduction
isets Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
`union` Set CfgProduction
jsets
  where
    ae :: (NonTerminal, [Either a NonTerminal])
ae = (Int -> Int -> Int -> NonTerminal
nt Int
0 Int
p Int
q, [NonTerminal -> Either a NonTerminal
forall a b. b -> Either a b
Right ((Text -> NonTerminal
NonTerminal (Text -> NonTerminal) -> (String -> Text) -> String -> NonTerminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) String
"CE")])
    isets :: Set CfgProduction
    isets :: Set CfgProduction
isets = (Set CfgProduction -> (UniquenessPair, Int) -> Set CfgProduction)
-> Set CfgProduction
-> [(UniquenessPair, Int)]
-> Set CfgProduction
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((UniquenessPair, Int) -> Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> (UniquenessPair, Int) -> Set CfgProduction
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
union (Set CfgProduction -> Set CfgProduction -> Set CfgProduction)
-> ((UniquenessPair, Int) -> Set CfgProduction)
-> (UniquenessPair, Int)
-> Set CfgProduction
-> Set CfgProduction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniquenessPair, Int) -> Set CfgProduction
ido)) Set CfgProduction
forall a. Set a
Set.empty ([UniquenessPair] -> [Int] -> [(UniquenessPair, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set UniquenessPair -> [UniquenessPair]
forall a. Set a -> [a]
Set.toList Set UniquenessPair
pres) [Int
1 .. Int
p])
      where
        ido :: (UniquenessPair, Int) -> Set CfgProduction
        ido :: (UniquenessPair, Int) -> Set CfgProduction
ido ((PrecedenceProduction
r, Set PrecedenceProduction
s), Int
i) =
            CfgProduction -> Set CfgProduction
forall a. a -> Set a
Set.singleton
                (Int -> Int -> Int -> NonTerminal
nt Int
0 Int
p Int
q, NonEmpty Text -> [Either Terminal NonTerminal]
intersperseStart (PrecedenceProduction -> [Text]
getWords PrecedenceProduction
r [Text] -> ([Text] -> NonEmpty Text) -> NonEmpty Text
forall a b. a -> (a -> b) -> b
|> [Text] -> NonEmpty Text
forall a. [a] -> NonEmpty a
DLNe.fromList) [Either Terminal NonTerminal]
-> [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
forall a. [a] -> [a] -> [a]
++ [NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int
0)])
    jsets :: Set CfgProduction
    jsets :: Set CfgProduction
jsets = (Set CfgProduction -> (UniquenessPair, Int) -> Set CfgProduction)
-> Set CfgProduction
-> [(UniquenessPair, Int)]
-> Set CfgProduction
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((UniquenessPair, Int) -> Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> (UniquenessPair, Int) -> Set CfgProduction
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
union (Set CfgProduction -> Set CfgProduction -> Set CfgProduction)
-> ((UniquenessPair, Int) -> Set CfgProduction)
-> (UniquenessPair, Int)
-> Set CfgProduction
-> Set CfgProduction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniquenessPair, Int) -> Set CfgProduction
jdo)) Set CfgProduction
forall a. Set a
Set.empty ([UniquenessPair] -> [Int] -> [(UniquenessPair, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set UniquenessPair -> [UniquenessPair]
forall a. Set a -> [a]
Set.toList Set UniquenessPair
posts) [Int
1 .. Int
q])
      where
        jdo :: (UniquenessPair, Int) -> Set CfgProduction
        jdo :: (UniquenessPair, Int) -> Set CfgProduction
jdo ((PrecedenceProduction
r, Set PrecedenceProduction
s), Int
j) =
            CfgProduction -> Set CfgProduction
forall a. a -> Set a
Set.singleton
                (Int -> Int -> Int -> NonTerminal
nt Int
0 Int
p Int
q, NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt (PrecedenceProduction -> Int
prec PrecedenceProduction
r) Int
0 (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)) Either Terminal NonTerminal
-> [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
forall a. a -> [a] -> [a]
: NonEmpty Text -> [Either Terminal NonTerminal]
intersperseStart (PrecedenceProduction -> [Text]
getWords PrecedenceProduction
r [Text] -> ([Text] -> NonEmpty Text) -> NonEmpty Text
forall a b. a -> (a -> b) -> b
|> [Text] -> NonEmpty Text
forall a. [a] -> NonEmpty a
DLNe.fromList))

convertClass :: (Int -> Int -> PqQuad -> Set CfgProduction) -> Set PqQuad -> Set CfgProduction
convertClass :: (Int -> Int -> PqQuad -> Set CfgProduction)
-> Set PqQuad -> Set CfgProduction
convertClass Int -> Int -> PqQuad -> Set CfgProduction
rule = (Set CfgProduction -> PqQuad -> Set CfgProduction)
-> Set CfgProduction -> Set PqQuad -> Set CfgProduction
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((PqQuad -> Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> PqQuad -> Set CfgProduction
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
union (Set CfgProduction -> Set CfgProduction -> Set CfgProduction)
-> (PqQuad -> Set CfgProduction)
-> PqQuad
-> Set CfgProduction
-> Set CfgProduction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PqQuad -> Set CfgProduction
psets)) Set CfgProduction
forall a. Set a
Set.empty
  where
    psets :: PqQuad -> Set CfgProduction
psets (Int
pbound, Int
qbound, PrecedenceProduction
r, Set PrecedenceProduction
s) = (Set CfgProduction -> Int -> Set CfgProduction)
-> Set CfgProduction -> [Int] -> Set CfgProduction
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Int -> Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction -> Int -> Set CfgProduction
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
union (Set CfgProduction -> Set CfgProduction -> Set CfgProduction)
-> (Int -> Set CfgProduction)
-> Int
-> Set CfgProduction
-> Set CfgProduction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Set CfgProduction
qsets)) Set CfgProduction
forall a. Set a
Set.empty [Int
0 .. Int
pbound]
      where
        qsets :: Int -> Set CfgProduction
qsets Int
p = (Set CfgProduction -> Int -> Set CfgProduction)
-> Set CfgProduction -> [Int] -> Set CfgProduction
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((Set CfgProduction -> Set CfgProduction)
-> (Int -> Set CfgProduction) -> Int -> Set CfgProduction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> PqQuad -> Set CfgProduction)
-> PqQuad -> Int -> Set CfgProduction
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Int -> PqQuad -> Set CfgProduction
rule Int
p) (Int
pbound, Int
qbound, PrecedenceProduction
r, Set PrecedenceProduction
s)) ((Set CfgProduction -> Set CfgProduction)
 -> Int -> Set CfgProduction)
-> (Set CfgProduction -> Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction
-> Int
-> Set CfgProduction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
union) Set CfgProduction
forall a. Set a
Set.empty [Int
0 .. Int
qbound]

convertClasses :: Set UniquenessPair -> Set UniquenessPair -> Set (Set PqQuad) -> Set CfgProduction
convertClasses :: Set UniquenessPair
-> Set UniquenessPair -> Set (Set PqQuad) -> Set CfgProduction
convertClasses Set UniquenessPair
pres Set UniquenessPair
posts = (Set PqQuad -> Set CfgProduction)
-> Set (Set PqQuad) -> Set (Set CfgProduction)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Set PqQuad -> Set CfgProduction
convertClassBranching (Set (Set PqQuad) -> Set (Set CfgProduction))
-> (Set (Set CfgProduction) -> Set CfgProduction)
-> Set (Set PqQuad)
-> Set CfgProduction
forall a b c. (a -> b) -> (b -> c) -> a -> c
>. (Set CfgProduction -> Set CfgProduction -> Set CfgProduction)
-> Set CfgProduction
-> Set (Set CfgProduction)
-> Set CfgProduction
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
union Set CfgProduction
forall a. Set a
Set.empty
  where
    convertClassBranching :: Set PqQuad -> Set CfgProduction
    convertClassBranching :: Set PqQuad -> Set CfgProduction
convertClassBranching Set PqQuad
quads = (Int -> Int -> PqQuad -> Set CfgProduction)
-> Set PqQuad -> Set CfgProduction
convertClass Int -> Int -> PqQuad -> Set CfgProduction
rule Set PqQuad
quads
      where
        rule :: Int -> Int -> PqQuad -> Set CfgProduction
rule =
            case Int -> Set PqQuad -> PqQuad
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set PqQuad
quads of
                (Int
_, Int
_, Infixl Int
_ NonEmpty Text
_, Set PrecedenceProduction
_) -> Int -> Int -> PqQuad -> Set CfgProduction
inlrule
                (Int
_, Int
_, Infixr Int
_ NonEmpty Text
_, Set PrecedenceProduction
_) -> Int -> Int -> PqQuad -> Set CfgProduction
inrrule
                (Int
_, Int
_, Prefix Int
_ NonEmpty Text
_, Set PrecedenceProduction
_) -> Int -> Int -> PqQuad -> Set CfgProduction
prerule
                (Int
_, Int
_, Postfix Int
_ NonEmpty Text
_, Set PrecedenceProduction
_) -> Int -> Int -> PqQuad -> Set CfgProduction
postrule
                (Int
_, Int
_, Closed NonEmpty Text
_, Set PrecedenceProduction
_) -> Set UniquenessPair
-> Set UniquenessPair -> Int -> Int -> PqQuad -> Set CfgProduction
closedrule Set UniquenessPair
pres Set UniquenessPair
posts

-- |The type of errors. Contains a list of strings, each of which describes an error of the input grammar.
newtype AasamError =
    AasamError [Text]
    deriving (Int -> AasamError -> String -> String
[AasamError] -> String -> String
AasamError -> String
(Int -> AasamError -> String -> String)
-> (AasamError -> String)
-> ([AasamError] -> String -> String)
-> Show AasamError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AasamError] -> String -> String
$cshowList :: [AasamError] -> String -> String
show :: AasamError -> String
$cshow :: AasamError -> String
showsPrec :: Int -> AasamError -> String -> String
$cshowsPrec :: Int -> AasamError -> String -> String
Show, AasamError -> AasamError -> Bool
(AasamError -> AasamError -> Bool)
-> (AasamError -> AasamError -> Bool) -> Eq AasamError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AasamError -> AasamError -> Bool
$c/= :: AasamError -> AasamError -> Bool
== :: AasamError -> AasamError -> Bool
$c== :: AasamError -> AasamError -> Bool
Eq, Eq AasamError
Eq AasamError
-> (AasamError -> AasamError -> Ordering)
-> (AasamError -> AasamError -> Bool)
-> (AasamError -> AasamError -> Bool)
-> (AasamError -> AasamError -> Bool)
-> (AasamError -> AasamError -> Bool)
-> (AasamError -> AasamError -> AasamError)
-> (AasamError -> AasamError -> AasamError)
-> Ord AasamError
AasamError -> AasamError -> Bool
AasamError -> AasamError -> Ordering
AasamError -> AasamError -> AasamError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AasamError -> AasamError -> AasamError
$cmin :: AasamError -> AasamError -> AasamError
max :: AasamError -> AasamError -> AasamError
$cmax :: AasamError -> AasamError -> AasamError
>= :: AasamError -> AasamError -> Bool
$c>= :: AasamError -> AasamError -> Bool
> :: AasamError -> AasamError -> Bool
$c> :: AasamError -> AasamError -> Bool
<= :: AasamError -> AasamError -> Bool
$c<= :: AasamError -> AasamError -> Bool
< :: AasamError -> AasamError -> Bool
$c< :: AasamError -> AasamError -> Bool
compare :: AasamError -> AasamError -> Ordering
$ccompare :: AasamError -> AasamError -> Ordering
Ord)

-- |Takes a distfix precedence grammar. If there is an error, produces an 'AasamError', else produces a corresponding unambiguous context-free grammar.
--
-- All possible errors are enumerated in the documentation for 'Precedence'.
m :: Precedence -> Either AasamError ContextFree
m :: Set PrecedenceProduction -> Either AasamError ContextFree
m Set PrecedenceProduction
precg =
    if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errors
        then ContextFree -> Either AasamError ContextFree
forall a b. b -> Either a b
Right (Int -> Int -> Int -> NonTerminal
nt Int
highestPrecedence Int
0 Int
0, Set CfgProduction -> Set CfgProduction
assignStart (Set CfgProduction -> Set CfgProduction
addCes Set CfgProduction
prods))
        else AasamError -> Either AasamError ContextFree
forall a b. a -> Either a b
Left ([Text] -> AasamError
AasamError [Text]
errors)
  where
    errors :: [Text]
errors = ([Text] -> Maybe Text -> [Text])
-> [Text] -> [Maybe Text] -> [Text]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Text] -> Maybe Text -> [Text]
fn [] [Maybe Text
positive, Maybe Text
noInitSubseq, Maybe Text
noInitWhole, Maybe Text
classesPrecDisjoint, Maybe Text
precContinue]
      where
        fn :: [Text] -> Maybe Text -> [Text]
        fn :: [Text] -> Maybe Text -> [Text]
fn [Text]
a Maybe Text
e =
            case Maybe Text
e of
                Maybe Text
Nothing -> [Text]
a
                Just Text
err -> Text
err Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
a
        positive :: Maybe Text
positive =
            if (PrecedenceProduction -> Bool) -> Set PrecedenceProduction -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PrecedenceProduction -> Bool
fn Set PrecedenceProduction
precg
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
errstr
          where
            fn :: PrecedenceProduction -> Bool
fn (Closed NonEmpty Text
_) = Bool
True
            fn PrecedenceProduction
x = PrecedenceProduction -> Int
prec PrecedenceProduction
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            errstr :: Text
errstr = String -> Text
Text.pack String
"All precedences must be positive integers."
        noInitSubseq :: Maybe Text
noInitSubseq =
            if Set Text -> Set Text -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set Text
initials Set Text
subsequents
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
errstr
          where
            (Set Text
initials, Set Text
subsequents) = ((Set Text, Set Text)
 -> PrecedenceProduction -> (Set Text, Set Text))
-> (Set Text, Set Text)
-> Set PrecedenceProduction
-> (Set Text, Set Text)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Set Text, Set Text)
-> PrecedenceProduction -> (Set Text, Set Text)
fn (Set Text
forall a. Set a
Set.empty, Set Text
forall a. Set a
Set.empty) Set PrecedenceProduction
precg
              where
                fn :: (Set Text, Set Text)
-> PrecedenceProduction -> (Set Text, Set Text)
fn (Set Text
i, Set Text
s) PrecedenceProduction
e = (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
insert ([Text] -> Text
forall a. [a] -> a
head [Text]
words) Set Text
i, ([Text] -> [Text]
forall a. [a] -> [a]
tail [Text]
words [Text] -> ([Text] -> Set Text) -> Set Text
forall a b. a -> (a -> b) -> b
|> [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList) Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`union` Set Text
s)
                  where
                    words :: [Text]
words = PrecedenceProduction -> [Text]
getWords PrecedenceProduction
e
            errstr :: Text
errstr = String -> Text
Text.pack String
"No initial word may also be a subsequent word of another production."
        noInitWhole :: Maybe Text
noInitWhole =
            if (PrecedenceProduction -> Bool) -> Set PrecedenceProduction -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PrecedenceProduction -> Bool
fx Set PrecedenceProduction
precg
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
errstr
          where
            fx :: PrecedenceProduction -> Bool
fx PrecedenceProduction
x = (PrecedenceProduction -> Bool) -> Set PrecedenceProduction -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PrecedenceProduction -> Bool
fy Set PrecedenceProduction
precg
              where
                fy :: PrecedenceProduction -> Bool
fy PrecedenceProduction
y = PrecedenceProduction -> [Text]
getWords PrecedenceProduction
x [Text] -> [Text] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`notPrefixedBy` PrecedenceProduction -> [Text]
getWords PrecedenceProduction
y Bool -> Bool -> Bool
|| PrecedenceProduction
x PrecedenceProduction -> PrecedenceProduction -> Bool
forall a. Eq a => a -> a -> Bool
== PrecedenceProduction
y
                  where
                    notPrefixedBy :: Eq a => [a] -> [a] -> Bool
                    notPrefixedBy :: forall a. Eq a => [a] -> [a] -> Bool
notPrefixedBy [] [] = Bool
False
                    notPrefixedBy (a
_:[a]
_) [] = Bool
False
                    notPrefixedBy [] (a
_:[a]
_) = Bool
True
                    notPrefixedBy (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y Bool -> Bool -> Bool
|| [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
notPrefixedBy [a]
xs [a]
ys
            errstr :: Text
errstr =
                String -> Text
Text.pack String
"No initial sequence of words may also be the whole sequence of another production."
        classesPrecDisjoint :: Maybe Text
classesPrecDisjoint =
            if [Set Int] -> Bool
forall a. Ord a => [Set a] -> Bool
allDisjoint [Set Int]
precGroups
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
errstr
          where
            allDisjoint :: Ord a => [Set a] -> Bool
            allDisjoint :: forall a. Ord a => [Set a] -> Bool
allDisjoint (Set a
x:[Set a]
xs) = (Set a -> Bool) -> [Set a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set a
x) [Set a]
xs Bool -> Bool -> Bool
&& [Set a] -> Bool
forall a. Ord a => [Set a] -> Bool
allDisjoint [Set a]
xs
            allDisjoint [] = Bool
True
            precGroups :: [Set Int]
            precGroups :: [Set Int]
precGroups = (Set PrecedenceProduction -> Set Int)
-> [Set PrecedenceProduction] -> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
List.map ((Set Int -> PrecedenceProduction -> Set Int)
-> Set Int -> Set PrecedenceProduction -> Set Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((PrecedenceProduction -> Set Int -> Set Int)
-> Set Int -> PrecedenceProduction -> Set Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
insert (Int -> Set Int -> Set Int)
-> (PrecedenceProduction -> Int)
-> PrecedenceProduction
-> Set Int
-> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecedenceProduction -> Int
prec)) Set Int
forall a. Set a
Set.empty) (Set (Set PrecedenceProduction) -> [Set PrecedenceProduction]
forall a. Set a -> [a]
Set.toList Set (Set PrecedenceProduction)
classes)
            errstr :: Text
errstr =
                String -> Text
Text.pack
                    String
"No precedence of a production of one fixity may also be the precedence of a production of another fixity."
        precContinue :: Maybe Text
precContinue =
            if Set Int
precedences Set Int -> Set Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int
lowestPrecedence .. Int
highestPrecedence]
                then Maybe Text
forall a. Maybe a
Nothing
                else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
errstr
          where
            errstr :: Text
errstr =
                String -> Text
Text.pack
                    String
"The set of precedences must be either empty or the set of integers between 1 and greatest precedence, inclusive."
    classes :: Set (Set PrecedenceProduction)
classes = Set PrecedenceProduction -> Set (Set PrecedenceProduction)
makeClasses Set PrecedenceProduction
precg
    upairClasses :: Set (Set UniquenessPair)
upairClasses = Set (Set PrecedenceProduction) -> Set (Set UniquenessPair)
pairifyClasses Set (Set PrecedenceProduction)
classes
    (Set UniquenessPair
pre, Set UniquenessPair
post) = ((Set UniquenessPair -> Bool) -> Set UniquenessPair
findBy Set UniquenessPair -> Bool
forall {b}. Set (PrecedenceProduction, b) -> Bool
isPre, (Set UniquenessPair -> Bool) -> Set UniquenessPair
findBy Set UniquenessPair -> Bool
forall {b}. Set (PrecedenceProduction, b) -> Bool
isPost)
      where
        isPre :: Set (PrecedenceProduction, b) -> Bool
isPre Set (PrecedenceProduction, b)
clas =
            case Int -> Set (PrecedenceProduction, b) -> (PrecedenceProduction, b)
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set (PrecedenceProduction, b)
clas of
                (Prefix Int
_ NonEmpty Text
_, b
_) -> Bool
True
                (PrecedenceProduction, b)
_ -> Bool
False
        isPost :: Set (PrecedenceProduction, b) -> Bool
isPost Set (PrecedenceProduction, b)
clas =
            case Int -> Set (PrecedenceProduction, b) -> (PrecedenceProduction, b)
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set (PrecedenceProduction, b)
clas of
                (Postfix Int
_ NonEmpty Text
_, b
_) -> Bool
True
                (PrecedenceProduction, b)
_ -> Bool
False
        findBy :: (Set UniquenessPair -> Bool) -> Set UniquenessPair
findBy Set UniquenessPair -> Bool
f = Set UniquenessPair
-> Maybe (Set UniquenessPair) -> Set UniquenessPair
forall a. a -> Maybe a -> a
unwrapOr Set UniquenessPair
forall a. Set a
Set.empty (Maybe (Set UniquenessPair) -> Set UniquenessPair)
-> Maybe (Set UniquenessPair) -> Set UniquenessPair
forall a b. (a -> b) -> a -> b
$ (Set UniquenessPair -> Bool)
-> Set (Set UniquenessPair) -> Maybe (Set UniquenessPair)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.Foldable.find Set UniquenessPair -> Bool
f Set (Set UniquenessPair)
upairClasses
    prods :: Set CfgProduction
prods = Set UniquenessPair
-> Set UniquenessPair
-> Set (Set UniquenessPair)
-> Set (Set PqQuad)
pqboundClasses Set UniquenessPair
pre Set UniquenessPair
post Set (Set UniquenessPair)
upairClasses Set (Set PqQuad)
-> (Set (Set PqQuad) -> Set CfgProduction) -> Set CfgProduction
forall a b. a -> (a -> b) -> b
|> Set UniquenessPair
-> Set UniquenessPair -> Set (Set PqQuad) -> Set CfgProduction
convertClasses Set UniquenessPair
pre Set UniquenessPair
post
    addCes :: Set CfgProduction -> Set CfgProduction
    addCes :: Set CfgProduction -> Set CfgProduction
addCes = Set CfgProduction -> Set CfgProduction -> Set CfgProduction
forall a. Ord a => Set a -> Set a -> Set a
union Set CfgProduction
ces
      where
        ces :: Set CfgProduction
        ces :: Set CfgProduction
ces =
            (PrecedenceProduction -> Bool)
-> Set PrecedenceProduction -> Set PrecedenceProduction
forall a. (a -> Bool) -> Set a -> Set a
Set.filter PrecedenceProduction -> Bool
isClosed Set PrecedenceProduction
precg Set PrecedenceProduction
-> (Set PrecedenceProduction -> Set CfgProduction)
-> Set CfgProduction
forall a b. a -> (a -> b) -> b
|>
            (PrecedenceProduction -> CfgProduction)
-> Set PrecedenceProduction -> Set CfgProduction
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\(Closed NonEmpty Text
words) -> ((Text -> NonTerminal
NonTerminal (Text -> NonTerminal) -> (String -> Text) -> String -> NonTerminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) String
"CE", NonEmpty Text -> [Either Terminal NonTerminal]
intersperseStart NonEmpty Text
words))
          where
            isClosed :: PrecedenceProduction -> Bool
            isClosed :: PrecedenceProduction -> Bool
isClosed (Closed NonEmpty Text
_) = Bool
True
            isClosed PrecedenceProduction
_ = Bool
False
    assignStart :: Set CfgProduction -> Set CfgProduction
    assignStart :: Set CfgProduction -> Set CfgProduction
assignStart = (CfgProduction -> CfgProduction)
-> Set CfgProduction -> Set CfgProduction
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((CfgProduction -> CfgProduction)
 -> Set CfgProduction -> Set CfgProduction)
-> (CfgProduction -> CfgProduction)
-> Set CfgProduction
-> Set CfgProduction
forall a b. (a -> b) -> a -> b
$ (NonTerminal -> NonTerminal)
-> ([Either Terminal NonTerminal] -> [Either Terminal NonTerminal])
-> CfgProduction
-> CfgProduction
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap NonTerminal -> NonTerminal
lhsMap [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
rhsMap
      where
        lhsMap :: NonTerminal -> NonTerminal
        lhsMap :: NonTerminal -> NonTerminal
lhsMap NonTerminal
lhs =
            if NonTerminal
lhs NonTerminal -> NonTerminal -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> NonTerminal
NonTerminal (Text -> NonTerminal) -> (String -> Text) -> String -> NonTerminal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) String
"!start"
                then Int -> Int -> Int -> NonTerminal
nt Int
highestPrecedence Int
0 Int
0
                else NonTerminal
lhs
        rhsMap :: [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
rhsMap = (Either Terminal NonTerminal -> Either Terminal NonTerminal)
-> [Either Terminal NonTerminal] -> [Either Terminal NonTerminal]
forall a b. (a -> b) -> [a] -> [b]
map Either Terminal NonTerminal -> Either Terminal NonTerminal
submap
          where
            submap :: Either Terminal NonTerminal -> Either Terminal NonTerminal
            submap :: Either Terminal NonTerminal -> Either Terminal NonTerminal
submap (Right NonTerminal
x) = NonTerminal -> Either Terminal NonTerminal
forall a b. b -> Either a b
Right (NonTerminal -> Either Terminal NonTerminal)
-> NonTerminal -> Either Terminal NonTerminal
forall a b. (a -> b) -> a -> b
$ NonTerminal -> NonTerminal
lhsMap NonTerminal
x
            submap Either Terminal NonTerminal
y = Either Terminal NonTerminal
y
    (Int
highestPrecedence, Int
lowestPrecedence, Set Int
precedences) =
        ((Int, Int, Set Int)
 -> PrecedenceProduction -> (Int, Int, Set Int))
-> (Int, Int, Set Int)
-> Set PrecedenceProduction
-> (Int, Int, Set Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
            (\(Int
ha, Int
la, Set Int
pa) PrecedenceProduction
e -> (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (PrecedenceProduction -> Int
prec PrecedenceProduction
e) Int
ha, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (PrecedenceProduction -> Int
prec PrecedenceProduction
e) Int
la, PrecedenceProduction -> Int
prec PrecedenceProduction
e Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
`insert` Set Int
pa))
            (Int
0, Int
0, Int -> Set Int
forall a. a -> Set a
Set.singleton Int
0)
            Set PrecedenceProduction
precg