{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
module BNFC.CF where
import Prelude hiding ((<>))
import Control.Arrow ( (&&&) )
import Control.Monad ( guard )
import Data.Char
import Data.Ord ( Down(..) )
import qualified Data.Either as Either
import Data.Function ( on )
import Data.List ( nub, sort, group )
import qualified Data.List as List
import Data.List.NonEmpty (pattern (:|))
import qualified Data.List.NonEmpty as List1
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (IsString(..))
import BNFC.Abs (Reg())
import BNFC.Par (pCat)
import BNFC.Lex (tokens)
import qualified BNFC.Abs as Abs
import BNFC.PrettyPrint
import BNFC.Utils (spanEnd)
type List1 = List1.NonEmpty
type CF = CFG RFun
type Rule = Rul RFun
data Rul function = Rule
{ forall function. Rul function -> function
funRule :: function
, forall function. Rul function -> RCat
valRCat :: RCat
, forall function. Rul function -> SentForm
rhsRule :: SentForm
, forall function. Rul function -> InternalRule
internal :: InternalRule
} deriving (Rul function -> Rul function -> Bool
forall function.
Eq function =>
Rul function -> Rul function -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rul function -> Rul function -> Bool
$c/= :: forall function.
Eq function =>
Rul function -> Rul function -> Bool
== :: Rul function -> Rul function -> Bool
$c== :: forall function.
Eq function =>
Rul function -> Rul function -> Bool
Eq, forall a b. a -> Rul b -> Rul a
forall a b. (a -> b) -> Rul a -> Rul b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Rul b -> Rul a
$c<$ :: forall a b. a -> Rul b -> Rul a
fmap :: forall a b. (a -> b) -> Rul a -> Rul b
$cfmap :: forall a b. (a -> b) -> Rul a -> Rul b
Functor)
data InternalRule
= Internal
| Parsable
deriving (InternalRule -> InternalRule -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InternalRule -> InternalRule -> Bool
$c/= :: InternalRule -> InternalRule -> Bool
== :: InternalRule -> InternalRule -> Bool
$c== :: InternalRule -> InternalRule -> Bool
Eq)
instance Pretty function => Pretty (Rul function) where
pretty :: Rul function -> Doc
pretty (Rule function
f RCat
cat SentForm
rhs InternalRule
internal) =
(if InternalRule
internal forall a. Eq a => a -> a -> Bool
== InternalRule
Internal then (Doc
"internal" Doc -> Doc -> Doc
<+>) else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
forall a. Pretty a => a -> Doc
pretty function
f Doc -> Doc -> Doc
<> Doc
"." Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty RCat
cat Doc -> Doc -> Doc
<+> Doc
"::=" Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> Doc
pretty (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)) SentForm
rhs)
type SentForm = [Either Cat String]
data CFG function = CFG
{ forall function. CFG function -> [Pragma]
cfgPragmas :: [Pragma]
, forall function. CFG function -> Set Cat
cfgUsedCats :: Set Cat
, forall function. CFG function -> [String]
cfgLiterals :: [Literal]
, forall function. CFG function -> [String]
cfgSymbols :: [Symbol]
, forall function. CFG function -> [String]
cfgKeywords :: [KeyWord]
, forall function. CFG function -> [Cat]
cfgReversibleCats :: [Cat]
, forall function. CFG function -> [Rul function]
cfgRules :: [Rul function]
, forall function. CFG function -> Signature
cfgSignature :: Signature
} deriving (forall a b. a -> CFG b -> CFG a
forall a b. (a -> b) -> CFG a -> CFG b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CFG b -> CFG a
$c<$ :: forall a b. a -> CFG b -> CFG a
fmap :: forall a b. (a -> b) -> CFG a -> CFG b
$cfmap :: forall a b. (a -> b) -> CFG a -> CFG b
Functor)
type Signature = Map String (WithPosition Type)
type Base = Base' String
data Base' a
= BaseT a
| ListT (Base' a)
deriving (Base' a -> Base' a -> Bool
forall a. Eq a => Base' a -> Base' a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Base' a -> Base' a -> Bool
$c/= :: forall a. Eq a => Base' a -> Base' a -> Bool
== :: Base' a -> Base' a -> Bool
$c== :: forall a. Eq a => Base' a -> Base' a -> Bool
Eq, Base' a -> Base' a -> Bool
Base' a -> Base' a -> Ordering
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
forall {a}. Ord a => Eq (Base' a)
forall a. Ord a => Base' a -> Base' a -> Bool
forall a. Ord a => Base' a -> Base' a -> Ordering
forall a. Ord a => Base' a -> Base' a -> Base' a
min :: Base' a -> Base' a -> Base' a
$cmin :: forall a. Ord a => Base' a -> Base' a -> Base' a
max :: Base' a -> Base' a -> Base' a
$cmax :: forall a. Ord a => Base' a -> Base' a -> Base' a
>= :: Base' a -> Base' a -> Bool
$c>= :: forall a. Ord a => Base' a -> Base' a -> Bool
> :: Base' a -> Base' a -> Bool
$c> :: forall a. Ord a => Base' a -> Base' a -> Bool
<= :: Base' a -> Base' a -> Bool
$c<= :: forall a. Ord a => Base' a -> Base' a -> Bool
< :: Base' a -> Base' a -> Bool
$c< :: forall a. Ord a => Base' a -> Base' a -> Bool
compare :: Base' a -> Base' a -> Ordering
$ccompare :: forall a. Ord a => Base' a -> Base' a -> Ordering
Ord, forall a b. a -> Base' b -> Base' a
forall a b. (a -> b) -> Base' a -> Base' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Base' b -> Base' a
$c<$ :: forall a b. a -> Base' b -> Base' a
fmap :: forall a b. (a -> b) -> Base' a -> Base' b
$cfmap :: forall a b. (a -> b) -> Base' a -> Base' b
Functor)
data Type = FunT [Base] Base
deriving (Type -> Type -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Eq Type
Type -> Type -> Bool
Type -> Type -> Ordering
Type -> Type -> Type
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 :: Type -> Type -> Type
$cmin :: Type -> Type -> Type
max :: Type -> Type -> Type
$cmax :: Type -> Type -> Type
>= :: Type -> Type -> Bool
$c>= :: Type -> Type -> Bool
> :: Type -> Type -> Bool
$c> :: Type -> Type -> Bool
<= :: Type -> Type -> Bool
$c<= :: Type -> Type -> Bool
< :: Type -> Type -> Bool
$c< :: Type -> Type -> Bool
compare :: Type -> Type -> Ordering
$ccompare :: Type -> Type -> Ordering
Ord)
dummyBase :: Base
dummyBase :: Base
dummyBase = forall a. a -> Base' a
BaseT String
"<DUMMY>"
dummyType :: Type
dummyType :: Type
dummyType = [Base] -> Base -> Type
FunT [] Base
dummyBase
instance Show Base where
show :: Base -> String
show (BaseT String
x) = String
x
show (ListT Base
t) = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Base
t forall a. [a] -> [a] -> [a]
++ String
"]"
instance Show Type where
show :: Type -> String
show (FunT [Base]
ts Base
t) = [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Base]
ts forall a. [a] -> [a] -> [a]
++ [String
"->", forall a. Show a => a -> String
show Base
t]
data Exp' f
= App f Type [Exp' f]
| Var String
| LitInt Integer
| LitDouble Double
| LitChar Char
| LitString String
deriving (Exp' f -> Exp' f -> Bool
forall f. Eq f => Exp' f -> Exp' f -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exp' f -> Exp' f -> Bool
$c/= :: forall f. Eq f => Exp' f -> Exp' f -> Bool
== :: Exp' f -> Exp' f -> Bool
$c== :: forall f. Eq f => Exp' f -> Exp' f -> Bool
Eq)
type Exp = Exp' String
instance (IsFun f, Pretty f) => Pretty (Exp' f) where
prettyPrec :: Int -> Exp' f -> Doc
prettyPrec Int
p Exp' f
e =
case forall {a}. IsFun a => Exp' a -> Either (Exp' a) [Exp' a]
listView Exp' f
e of
Right [Exp' f]
es -> Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0) [Exp' f]
es
Left (Var String
x) -> String -> Doc
text String
x
Left (App f
f Type
_ []) -> forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
p f
f
Left (App f
f Type
_ [Exp' f
e1,Exp' f
e2])
| forall a. IsFun a => a -> Bool
isConsFun f
f -> Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp' f
e1, Doc
":", forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0 Exp' f
e2 ]
Left (App f
f Type
_ [Exp' f]
es) -> Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 f
f forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
2) [Exp' f]
es
Left (LitInt Integer
n) -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Integer
n
Left (LitDouble Double
x) -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Double
x
Left (LitChar Char
c) -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Char
c
Left (LitString String
s) -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) String
s
where
listView :: Exp' a -> Either (Exp' a) [Exp' a]
listView (App a
f Type
_ [])
| forall a. IsFun a => a -> Bool
isNilFun a
f = forall a b. b -> Either a b
Right []
listView (App a
f Type
_ [Exp' a
e1,Exp' a
e2])
| forall a. IsFun a => a -> Bool
isConsFun a
f
, Right [Exp' a]
es <- Exp' a -> Either (Exp' a) [Exp' a]
listView Exp' a
e2 = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Exp' a
e1forall a. a -> [a] -> [a]
:[Exp' a]
es
listView Exp' a
e0 = forall a b. a -> Either a b
Left Exp' a
e0
data Pragma
= String
| (String, String)
| TokenReg RString Bool Reg
| EntryPoints [RCat]
| Layout LayoutKeyWords
| LayoutStop [KeyWord]
| LayoutTop Symbol
| FunDef Define
data Define = Define
{ Define -> RString
defName :: RFun
, Define -> Telescope
defArgs :: Telescope
, Define -> Exp
defBody :: Exp
, Define -> Base
defType :: Base
}
type Telescope = [(String, Base)]
isFunDef :: Pragma -> Either Pragma Define
isFunDef :: Pragma -> Either Pragma Define
isFunDef = \case
FunDef Define
d -> forall a b. b -> Either a b
Right Define
d
Pragma
p -> forall a b. a -> Either a b
Left Pragma
p
definitions :: CFG f -> [Define]
definitions :: forall f. CFG f -> [Define]
definitions CFG f
cf = [ Define
def | FunDef Define
def <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ]
type LayoutKeyWords = [(KeyWord, Delimiters)]
data Delimiters = Delimiters
{ Delimiters -> String
listSep :: Symbol
, Delimiters -> String
listOpen :: Symbol
, Delimiters -> String
listClose :: Symbol
} deriving Int -> Delimiters -> ShowS
[Delimiters] -> ShowS
Delimiters -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Delimiters] -> ShowS
$cshowList :: [Delimiters] -> ShowS
show :: Delimiters -> String
$cshow :: Delimiters -> String
showsPrec :: Int -> Delimiters -> ShowS
$cshowsPrec :: Int -> Delimiters -> ShowS
Show
tokenPragmas :: CFG f -> [(TokenCat,Reg)]
tokenPragmas :: forall f. CFG f -> [(String, Reg)]
tokenPragmas CFG f
cf = [ (forall a. WithPosition a -> a
wpThing RString
name, Reg
e) | TokenReg RString
name Bool
_ Reg
e <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ]
tokenNames :: CFG f -> [String]
tokenNames :: forall function. CFG function -> [String]
tokenNames CFG f
cf = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall f. CFG f -> [(String, Reg)]
tokenPragmas CFG f
cf)
layoutPragmas :: CF -> (Maybe Symbol, LayoutKeyWords, [KeyWord])
layoutPragmas :: CF -> (Maybe String, LayoutKeyWords, [String])
layoutPragmas CF
cf =
( forall a. [a] -> Maybe a
listToMaybe [ String
sep | LayoutTop String
sep <- [Pragma]
ps ]
, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ LayoutKeyWords
kws | Layout LayoutKeyWords
kws <- [Pragma]
ps ]
, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String]
kws | LayoutStop [String]
kws <- [Pragma]
ps ]
)
where
ps :: [Pragma]
ps = forall function. CFG function -> [Pragma]
cfgPragmas CF
cf
hasLayout_ :: (Maybe Symbol, LayoutKeyWords, [KeyWord]) -> Bool
hasLayout_ :: (Maybe String, LayoutKeyWords, [String]) -> Bool
hasLayout_ (Maybe String
top, LayoutKeyWords
kws, [String]
_) = forall a. Maybe a -> Bool
isJust Maybe String
top Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
kws)
hasLayout :: CF -> Bool
hasLayout :: CF -> Bool
hasLayout = (Maybe String, LayoutKeyWords, [String]) -> Bool
hasLayout_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> (Maybe String, LayoutKeyWords, [String])
layoutPragmas
type Literal = String
type Symbol = String
type KeyWord = String
data Position
= NoPosition
| Position
{ Position -> String
posFile :: FilePath
, Position -> Int
posLine :: Int
, Position -> Int
posColumn :: Int
} deriving (Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show, Position -> Position -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Eq Position
Position -> Position -> Bool
Position -> Position -> Ordering
Position -> Position -> Position
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 :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmax :: Position -> Position -> Position
>= :: Position -> Position -> Bool
$c>= :: Position -> Position -> Bool
> :: Position -> Position -> Bool
$c> :: Position -> Position -> Bool
<= :: Position -> Position -> Bool
$c<= :: Position -> Position -> Bool
< :: Position -> Position -> Bool
$c< :: Position -> Position -> Bool
compare :: Position -> Position -> Ordering
$ccompare :: Position -> Position -> Ordering
Ord)
prettyPosition :: Position -> String
prettyPosition :: Position -> String
prettyPosition = \case
Position
NoPosition -> String
""
Position String
file Int
line Int
col -> forall a. [a] -> [[a]] -> [a]
List.intercalate String
":" [ String
file, forall a. Show a => a -> String
show Int
line, forall a. Show a => a -> String
show Int
col, String
"" ]
data WithPosition a = WithPosition
{ forall a. WithPosition a -> Position
wpPosition :: Position
, forall a. WithPosition a -> a
wpThing :: a
} deriving (Int -> WithPosition a -> ShowS
forall a. Show a => Int -> WithPosition a -> ShowS
forall a. Show a => [WithPosition a] -> ShowS
forall a. Show a => WithPosition a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WithPosition a] -> ShowS
$cshowList :: forall a. Show a => [WithPosition a] -> ShowS
show :: WithPosition a -> String
$cshow :: forall a. Show a => WithPosition a -> String
showsPrec :: Int -> WithPosition a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> WithPosition a -> ShowS
Show, forall a b. a -> WithPosition b -> WithPosition a
forall a b. (a -> b) -> WithPosition a -> WithPosition b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WithPosition b -> WithPosition a
$c<$ :: forall a b. a -> WithPosition b -> WithPosition a
fmap :: forall a b. (a -> b) -> WithPosition a -> WithPosition b
$cfmap :: forall a b. (a -> b) -> WithPosition a -> WithPosition b
Functor, forall a. Eq a => a -> WithPosition a -> Bool
forall a. Num a => WithPosition a -> a
forall a. Ord a => WithPosition a -> a
forall m. Monoid m => WithPosition m -> m
forall a. WithPosition a -> Bool
forall a. WithPosition a -> Int
forall a. WithPosition a -> [a]
forall a. (a -> a -> a) -> WithPosition a -> a
forall m a. Monoid m => (a -> m) -> WithPosition a -> m
forall b a. (b -> a -> b) -> b -> WithPosition a -> b
forall a b. (a -> b -> b) -> b -> WithPosition a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => WithPosition a -> a
$cproduct :: forall a. Num a => WithPosition a -> a
sum :: forall a. Num a => WithPosition a -> a
$csum :: forall a. Num a => WithPosition a -> a
minimum :: forall a. Ord a => WithPosition a -> a
$cminimum :: forall a. Ord a => WithPosition a -> a
maximum :: forall a. Ord a => WithPosition a -> a
$cmaximum :: forall a. Ord a => WithPosition a -> a
elem :: forall a. Eq a => a -> WithPosition a -> Bool
$celem :: forall a. Eq a => a -> WithPosition a -> Bool
length :: forall a. WithPosition a -> Int
$clength :: forall a. WithPosition a -> Int
null :: forall a. WithPosition a -> Bool
$cnull :: forall a. WithPosition a -> Bool
toList :: forall a. WithPosition a -> [a]
$ctoList :: forall a. WithPosition a -> [a]
foldl1 :: forall a. (a -> a -> a) -> WithPosition a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> WithPosition a -> a
foldr1 :: forall a. (a -> a -> a) -> WithPosition a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> WithPosition a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
foldl :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
foldr :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
fold :: forall m. Monoid m => WithPosition m -> m
$cfold :: forall m. Monoid m => WithPosition m -> m
Foldable, Functor WithPosition
Foldable WithPosition
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
WithPosition (m a) -> m (WithPosition a)
forall (f :: * -> *) a.
Applicative f =>
WithPosition (f a) -> f (WithPosition a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> WithPosition a -> m (WithPosition b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithPosition a -> f (WithPosition b)
sequence :: forall (m :: * -> *) a.
Monad m =>
WithPosition (m a) -> m (WithPosition a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
WithPosition (m a) -> m (WithPosition a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> WithPosition a -> m (WithPosition b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> WithPosition a -> m (WithPosition b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
WithPosition (f a) -> f (WithPosition a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
WithPosition (f a) -> f (WithPosition a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithPosition a -> f (WithPosition b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithPosition a -> f (WithPosition b)
Traversable)
instance Eq a => Eq (WithPosition a) where == :: WithPosition a -> WithPosition a -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. WithPosition a -> a
wpThing
instance Ord a => Ord (WithPosition a) where compare :: WithPosition a -> WithPosition a -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. WithPosition a -> a
wpThing
instance Pretty a => Pretty (WithPosition a) where pretty :: WithPosition a -> Doc
pretty = forall a. Pretty a => a -> Doc
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing
noPosition :: a -> WithPosition a
noPosition :: forall a. a -> WithPosition a
noPosition = forall a. Position -> a -> WithPosition a
WithPosition Position
NoPosition
type RString = WithPosition String
blendInPosition :: RString -> String
blendInPosition :: RString -> String
blendInPosition (WithPosition Position
pos String
msg)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p = String
msg
| Bool
otherwise = [String] -> String
unwords [ String
p, String
msg ]
where
p :: String
p = Position -> String
prettyPosition Position
pos
type RCat = WithPosition Cat
valCat :: Rul fun -> Cat
valCat :: forall fun. Rul fun -> Cat
valCat = forall a. WithPosition a -> a
wpThing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> RCat
valRCat
npRule :: Fun -> Cat -> SentForm -> InternalRule -> Rule
npRule :: String -> Cat -> SentForm -> InternalRule -> Rule
npRule String
f Cat
c SentForm
r InternalRule
internal = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule (forall a. a -> WithPosition a
noPosition String
f) (forall a. a -> WithPosition a
noPosition Cat
c) SentForm
r InternalRule
internal
npIdentifier :: String -> Abs.Identifier
npIdentifier :: String -> Identifier
npIdentifier String
x = ((Int, Int), String) -> Identifier
Abs.Identifier ((Int
0, Int
0), String
x)
data Cat
= Cat String
| TokenCat TokenCat
| ListCat Cat
| CoercCat String Integer
deriving (Cat -> Cat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cat -> Cat -> Bool
$c/= :: Cat -> Cat -> Bool
== :: Cat -> Cat -> Bool
$c== :: Cat -> Cat -> Bool
Eq, Eq Cat
Cat -> Cat -> Bool
Cat -> Cat -> Ordering
Cat -> Cat -> Cat
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 :: Cat -> Cat -> Cat
$cmin :: Cat -> Cat -> Cat
max :: Cat -> Cat -> Cat
$cmax :: Cat -> Cat -> Cat
>= :: Cat -> Cat -> Bool
$c>= :: Cat -> Cat -> Bool
> :: Cat -> Cat -> Bool
$c> :: Cat -> Cat -> Bool
<= :: Cat -> Cat -> Bool
$c<= :: Cat -> Cat -> Bool
< :: Cat -> Cat -> Bool
$c< :: Cat -> Cat -> Bool
compare :: Cat -> Cat -> Ordering
$ccompare :: Cat -> Cat -> Ordering
Ord)
type TokenCat = String
type BaseCat = String
type NonTerminal = Cat
catToStr :: Cat -> String
catToStr :: Cat -> String
catToStr = \case
Cat String
s -> String
s
TokenCat String
s -> String
s
ListCat Cat
c -> String
"[" forall a. [a] -> [a] -> [a]
++ Cat -> String
catToStr Cat
c forall a. [a] -> [a] -> [a]
++ String
"]"
CoercCat String
s Integer
i -> String
s forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i
instance Show Cat where
show :: Cat -> String
show = Cat -> String
catToStr
instance Pretty Cat where
pretty :: Cat -> Doc
pretty = \case
Cat String
s -> String -> Doc
text String
s
TokenCat String
s -> String -> Doc
text String
s
ListCat Cat
c -> Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Cat
c
CoercCat String
s Integer
i -> String -> Doc
text String
s Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
pretty Integer
i
strToCat :: String -> Cat
strToCat :: String -> Cat
strToCat String
s =
case [Token] -> Err Cat
pCat (String -> [Token]
tokens String
s) of
Right Cat
c -> Cat -> Cat
cat2cat Cat
c
Left String
_ -> String -> Cat
Cat String
s
where
cat2cat :: Cat -> Cat
cat2cat = \case
Abs.IdCat (Abs.Identifier ((Int, Int)
_pos, String
x))
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds -> if String
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
specialCatsP then String -> Cat
TokenCat String
c else String -> Cat
Cat String
c
| Bool
otherwise -> String -> Integer -> Cat
CoercCat String
c (forall a. Read a => String -> a
read String
ds)
where (String
ds, String
c) = forall a. (a -> Bool) -> [a] -> ([a], [a])
spanEnd Char -> Bool
isDigit String
x
Abs.ListCat Cat
c -> Cat -> Cat
ListCat (Cat -> Cat
cat2cat Cat
c)
catString, catInteger, catDouble, catChar, catIdent :: TokenCat
catString :: String
catString = String
"String"
catInteger :: String
catInteger = String
"Integer"
catDouble :: String
catDouble = String
"Double"
catChar :: String
catChar = String
"Char"
catIdent :: String
catIdent = String
"Ident"
baseTokenCatNames :: [TokenCat]
baseTokenCatNames :: [String]
baseTokenCatNames = [ String
catChar, String
catDouble, String
catInteger, String
catString ]
specialCatsP :: [TokenCat]
specialCatsP :: [String]
specialCatsP = String
catIdent forall a. a -> [a] -> [a]
: [String]
baseTokenCatNames
isDataCat :: Cat -> Bool
isDataCat :: Cat -> Bool
isDataCat Cat
c = Cat -> Bool
isDataOrListCat Cat
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c)
isDataOrListCat :: Cat -> Bool
isDataOrListCat :: Cat -> Bool
isDataOrListCat (CoercCat String
_ Integer
_) = Bool
False
isDataOrListCat (Cat (Char
'@':String
_)) = Bool
False
isDataOrListCat (ListCat Cat
c) = Cat -> Bool
isDataOrListCat Cat
c
isDataOrListCat Cat
_ = Bool
True
sameCat :: Cat -> Cat -> Bool
sameCat :: Cat -> Cat -> Bool
sameCat = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Cat -> Cat
normCat
normCat :: Cat -> Cat
normCat :: Cat -> Cat
normCat (ListCat Cat
c) = Cat -> Cat
ListCat (Cat -> Cat
normCat Cat
c)
normCat (CoercCat String
c Integer
_) = String -> Cat
Cat String
c
normCat Cat
c = Cat
c
normCatOfList :: Cat -> Cat
normCatOfList :: Cat -> Cat
normCatOfList = Cat -> Cat
normCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
catOfList
identCat :: Cat -> String
identCat :: Cat -> String
identCat (ListCat Cat
c) = String
"List" forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat Cat
c
identCat Cat
c = Cat -> String
catToStr Cat
c
identType :: Base -> String
identType :: Base -> String
identType (ListT Base
t) = String
"List" forall a. [a] -> [a] -> [a]
++ Base -> String
identType Base
t
identType (BaseT String
s) = String
s
catOfType :: [TokenCat] -> Base -> Cat
catOfType :: [String] -> Base -> Cat
catOfType [String]
tk = \case
ListT Base
t -> Cat -> Cat
ListCat forall a b. (a -> b) -> a -> b
$ [String] -> Base -> Cat
catOfType [String]
tk Base
t
BaseT String
s
| String
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tk -> String -> Cat
TokenCat String
s
| Bool
otherwise -> String -> Cat
Cat String
s
isList :: Cat -> Bool
isList :: Cat -> Bool
isList (ListCat Cat
_) = Bool
True
isList Cat
_ = Bool
False
baseCat :: Cat -> Either BaseCat TokenCat
baseCat :: Cat -> Either String String
baseCat = \case
ListCat Cat
c -> Cat -> Either String String
baseCat Cat
c
CoercCat String
x Integer
_ -> forall a b. a -> Either a b
Left String
x
Cat String
x -> forall a b. a -> Either a b
Left String
x
TokenCat String
x -> forall a b. b -> Either a b
Right String
x
isTokenCat :: Cat -> Bool
isTokenCat :: Cat -> Bool
isTokenCat (TokenCat String
_) = Bool
True
isTokenCat Cat
_ = Bool
False
maybeTokenCat :: Cat -> Maybe TokenCat
maybeTokenCat :: Cat -> Maybe String
maybeTokenCat = \case
TokenCat String
c -> forall a. a -> Maybe a
Just String
c
Cat
_ -> forall a. Maybe a
Nothing
catOfList :: Cat -> Cat
catOfList :: Cat -> Cat
catOfList (ListCat Cat
c) = Cat
c
catOfList Cat
c = Cat
c
type Fun = String
type RFun = RString
instance IsString RFun where
fromString :: String -> RString
fromString = forall a. a -> WithPosition a
noPosition
class IsFun a where
funName :: a -> String
isNilFun :: a -> Bool
isOneFun :: a -> Bool
isConsFun :: a -> Bool
isConcatFun :: a -> Bool
isCoercion :: a -> Bool
isNilFun = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"[]")
isOneFun = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"(:[])")
isConsFun = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"(:)")
isConcatFun = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"(++)")
isCoercion = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"_")
instance IsFun String where
funName :: ShowS
funName = forall a. a -> a
id
instance IsFun a => IsFun (WithPosition a) where
funName :: WithPosition a -> String
funName = forall a. IsFun a => a -> String
funName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing
instance IsFun a => IsFun (Rul a) where
funName :: Rul a -> String
funName = forall a. IsFun a => a -> String
funName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> function
funRule
instance IsFun a => IsFun (k, a) where
funName :: (k, a) -> String
funName = forall a. IsFun a => a -> String
funName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
funNameSatisfies :: IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies :: forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies String -> Bool
f = String -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsFun a => a -> String
funName
isDefinedRule :: IsFun a => a -> Bool
isDefinedRule :: forall a. IsFun a => a -> Bool
isDefinedRule = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies forall a b. (a -> b) -> a -> b
$ \case
(Char
x:String
_) -> Char -> Bool
isLower Char
x
[] -> forall a. HasCallStack => String -> a
error String
"isDefinedRule: empty function name"
isProperLabel :: IsFun a => a -> Bool
isProperLabel :: forall a. IsFun a => a -> Bool
isProperLabel a
f = Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion a
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isDefinedRule a
f)
isNilCons :: IsFun a => a -> Bool
isNilCons :: forall a. IsFun a => a -> Bool
isNilCons a
f = forall a. IsFun a => a -> Bool
isNilFun a
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isOneFun a
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isConsFun a
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isConcatFun a
f
type Data = (Cat, [(String, [Cat])])
firstEntry :: CF -> Cat
firstEntry :: CF -> Cat
firstEntry CF
cf = forall a. NonEmpty a -> a
List1.head forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> List1 Cat
allEntryPoints CF
cf
allNames :: CF -> [RString]
allNames :: CF -> [RString]
allNames CF
cf =
[ RString
f | RString
f <- forall a b. (a -> b) -> [a] -> [b]
map forall function. Rul function -> function
funRule forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Rul function]
cfgRules CF
cf
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. IsFun a => a -> Bool
isNilCons RString
f
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. IsFun a => a -> Bool
isCoercion RString
f
] forall a. [a] -> [a] -> [a]
++
CF -> [RString]
allCatsIdNorm CF
cf
filterNonUnique :: (Ord a) => [a] -> [a]
filterNonUnique :: forall a. Ord a => [a] -> [a]
filterNonUnique [a]
xs = [ a
x | (a
x:a
_:[a]
_) <- forall a. Eq a => [a] -> [[a]]
group forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [a]
xs ]
commentPragmas :: [Pragma] -> [Pragma]
= forall a. (a -> Bool) -> [a] -> [a]
filter Pragma -> Bool
isComment
where isComment :: Pragma -> Bool
isComment (CommentS String
_) = Bool
True
isComment (CommentM (String, String)
_) = Bool
True
isComment Pragma
_ = Bool
False
lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, SentForm)
lookupRule :: forall f. Eq f => f -> [Rul f] -> Maybe (Cat, SentForm)
lookupRule f
f = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup f
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Rul a -> (a, (Cat, SentForm))
unRule
where unRule :: Rul a -> (a, (Cat, SentForm))
unRule (Rule a
f' RCat
c SentForm
rhs InternalRule
_internal) = (a
f', (forall a. WithPosition a -> a
wpThing RCat
c, SentForm
rhs))
rulesForCat :: CF -> Cat -> [Rule]
rulesForCat :: CF -> Cat -> [Rule]
rulesForCat CF
cf Cat
cat =
[ forall f. Rul f -> Rul f
removeWhiteSpaceSeparators Rule
r | Rule
r <- forall function. CFG function -> [Rul function]
cfgRules CF
cf, forall f. Rul f -> Bool
isParsable Rule
r, forall fun. Rul fun -> Cat
valCat Rule
r forall a. Eq a => a -> a -> Bool
== Cat
cat]
removeWhiteSpaceSeparators :: Rul f -> Rul f
removeWhiteSpaceSeparators :: forall f. Rul f -> Rul f
removeWhiteSpaceSeparators = forall f. (SentForm -> SentForm) -> Rul f -> Rul f
mapRhs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) forall a b. (a -> b) -> a -> b
$ \ String
sep ->
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
sep then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right String
sep)
mapRhs :: (SentForm -> SentForm) -> Rul f -> Rul f
mapRhs :: forall f. (SentForm -> SentForm) -> Rul f -> Rul f
mapRhs SentForm -> SentForm
f Rul f
r = Rul f
r { rhsRule :: SentForm
rhsRule = SentForm -> SentForm
f forall a b. (a -> b) -> a -> b
$ forall function. Rul function -> SentForm
rhsRule Rul f
r }
rulesForNormalizedCat :: CF -> Cat -> [Rule]
rulesForNormalizedCat :: CF -> Cat -> [Rule]
rulesForNormalizedCat CF
cf Cat
cat =
[Rule
r | Rule
r <- forall function. CFG function -> [Rul function]
cfgRules CF
cf, Cat -> Cat
normCat (forall fun. Rul fun -> Cat
valCat Rule
r) forall a. Eq a => a -> a -> Bool
== Cat
cat]
rulesForCat' :: CF -> Cat -> [Rule]
rulesForCat' :: CF -> Cat -> [Rule]
rulesForCat' CF
cf Cat
cat = [Rule
r | Rule
r <- forall function. CFG function -> [Rul function]
cfgRules CF
cf, forall fun. Rul fun -> Cat
valCat Rule
r forall a. Eq a => a -> a -> Bool
== Cat
cat]
allCats :: (InternalRule -> Bool) -> CFG f -> [Cat]
allCats :: forall f. (InternalRule -> Bool) -> CFG f -> [Cat]
allCats InternalRule -> Bool
pred = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall fun. Rul fun -> Cat
valCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (InternalRule -> Bool
pred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> InternalRule
internal) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. CFG function -> [Rul function]
cfgRules
reallyAllCats :: CFG f -> [Cat]
reallyAllCats :: forall function. CFG function -> [Cat]
reallyAllCats = forall f. (InternalRule -> Bool) -> CFG f -> [Cat]
allCats forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True
allParserCats :: CFG f -> [Cat]
allParserCats :: forall function. CFG function -> [Cat]
allParserCats = forall f. (InternalRule -> Bool) -> CFG f -> [Cat]
allCats (forall a. Eq a => a -> a -> Bool
== InternalRule
Parsable)
allCatsIdNorm :: CF -> [RString]
allCatsIdNorm :: CF -> [RString]
allCatsIdNorm = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cat -> String
identCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> RCat
valRCat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. CFG function -> [Rul function]
cfgRules
allCatsNorm :: CF -> [Cat]
allCatsNorm :: CF -> [Cat]
allCatsNorm = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Cat -> Cat
normCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall fun. Rul fun -> Cat
valCat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. CFG function -> [Rul function]
cfgRules
allParserCatsNorm :: CFG f -> [Cat]
allParserCatsNorm :: forall function. CFG function -> [Cat]
allParserCatsNorm = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. CFG function -> [Cat]
allParserCats
isUsedCat :: CFG f -> Cat -> Bool
isUsedCat :: forall f. CFG f -> Cat -> Bool
isUsedCat CFG f
cf = (forall a. Ord a => a -> Set a -> Bool
`Set.member` forall function. CFG function -> Set Cat
cfgUsedCats CFG f
cf)
ruleGroups :: CF -> [(Cat,[Rule])]
ruleGroups :: CF -> [(Cat, [Rule])]
ruleGroups CF
cf = [(Cat
c, CF -> Cat -> [Rule]
rulesForCat CF
cf Cat
c) | Cat
c <- forall function. CFG function -> [Cat]
allParserCats CF
cf]
ruleGroupsInternals :: CF -> [(Cat,[Rule])]
ruleGroupsInternals :: CF -> [(Cat, [Rule])]
ruleGroupsInternals CF
cf = [(Cat
c, CF -> Cat -> [Rule]
rulesForCat' CF
cf Cat
c) | Cat
c <- forall function. CFG function -> [Cat]
reallyAllCats CF
cf]
literals :: CFG f -> [TokenCat]
literals :: forall function. CFG function -> [String]
literals CFG f
cf = forall function. CFG function -> [String]
cfgLiterals CFG f
cf forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall f. CFG f -> [(String, Reg)]
tokenPragmas CFG f
cf)
reservedWords :: CFG f -> [String]
reservedWords :: forall function. CFG function -> [String]
reservedWords = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. CFG function -> [String]
cfgKeywords
cfTokens :: CFG f -> [(String,Int)]
cfTokens :: forall f. CFG f -> [(String, Int)]
cfTokens CFG f
cf = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Ord a => [a] -> [a]
sort (forall function. CFG function -> [String]
cfgSymbols CFG f
cf forall a. [a] -> [a] -> [a]
++ forall function. CFG function -> [String]
reservedWords CFG f
cf)) [Int
1..]
comments :: CF -> ([(String,String)],[String])
CF
cf = ([(String, String)
p | CommentM (String, String)
p <- [Pragma]
xs], [String
s | CommentS String
s <- [Pragma]
xs])
where
xs :: [Pragma]
xs = [Pragma] -> [Pragma]
commentPragmas (forall function. CFG function -> [Pragma]
cfgPragmas CF
cf)
numberOfBlockCommentForms :: CF -> Int
= forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> ([(String, String)], [String])
comments
hasIdent :: CFG f -> Bool
hasIdent :: forall f. CFG f -> Bool
hasIdent CFG f
cf = forall f. CFG f -> Cat -> Bool
isUsedCat CFG f
cf forall a b. (a -> b) -> a -> b
$ String -> Cat
TokenCat String
catIdent
specialCats :: CF -> [TokenCat]
specialCats :: CF -> [String]
specialCats CF
cf = (if forall f. CFG f -> Bool
hasIdent CF
cf then (String
catIdentforall a. a -> [a] -> [a]
:) else forall a. a -> a
id) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf))
getAbstractSyntax :: CF -> [Data]
getAbstractSyntax :: CF -> [Data]
getAbstractSyntax CF
cf = [ ( Cat
c, forall a. Eq a => [a] -> [a]
nub (Cat -> [(String, [Cat])]
constructors Cat
c) ) | Cat
c <- CF -> [Cat]
allCatsNorm CF
cf ]
where
constructors :: Cat -> [(String, [Cat])]
constructors Cat
cat = do
Rule
rule <- forall function. CFG function -> [Rul function]
cfgRules CF
cf
let f :: RString
f = forall function. Rul function -> function
funRule Rule
rule
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall a. IsFun a => a -> Bool
isDefinedRule RString
f)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat (forall fun. Rul fun -> Cat
valCat Rule
rule) forall a. Eq a => a -> a -> Bool
== Cat
cat
let cs :: [Cat]
cs = [Cat -> Cat
normCat Cat
c | Left Cat
c <- forall function. Rul function -> SentForm
rhsRule Rule
rule ]
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. WithPosition a -> a
wpThing RString
f, [Cat]
cs)
cf2data' :: (Cat -> Bool) -> CF -> [Data]
cf2data' :: (Cat -> Bool) -> CF -> [Data]
cf2data' Cat -> Bool
predicate CF
cf =
[(Cat
cat, forall a. Eq a => [a] -> [a]
nub (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Rul (WithPosition a) -> (a, [Cat])
mkData [Rule
r | Rule
r <- forall function. CFG function -> [Rul function]
cfgRules CF
cf,
let f :: RString
f = forall function. Rul function -> function
funRule Rule
r,
Bool -> Bool
not (forall a. IsFun a => a -> Bool
isDefinedRule RString
f),
Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f), Cat
cat forall a. Eq a => a -> a -> Bool
== Cat -> Cat
normCat (forall fun. Rul fun -> Cat
valCat Rule
r)]))
| Cat
cat <- forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
predicate forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Cat]
reallyAllCats CF
cf ]
where
mkData :: Rul (WithPosition a) -> (a, [Cat])
mkData (Rule WithPosition a
f RCat
_ SentForm
its InternalRule
_) = (forall a. WithPosition a -> a
wpThing WithPosition a
f, [Cat -> Cat
normCat Cat
c | Left Cat
c <- SentForm
its ])
cf2data :: CF -> [Data]
cf2data :: CF -> [Data]
cf2data = (Cat -> Bool) -> CF -> [Data]
cf2data' forall a b. (a -> b) -> a -> b
$ Cat -> Bool
isDataCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat
cf2dataLists :: CF -> [Data]
cf2dataLists :: CF -> [Data]
cf2dataLists = (Cat -> Bool) -> CF -> [Data]
cf2data' forall a b. (a -> b) -> a -> b
$ Cat -> Bool
isDataOrListCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat
specialData :: CF -> [Data]
specialData :: CF -> [Data]
specialData CF
cf = [(String -> Cat
TokenCat String
name, [(String
name, [String -> Cat
TokenCat String
catString])]) | String
name <- CF -> [String]
specialCats CF
cf]
sigLookup :: IsFun a => a -> CF -> Maybe (WithPosition Type)
sigLookup :: forall a. IsFun a => a -> CF -> Maybe (WithPosition Type)
sigLookup a
f = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. IsFun a => a -> String
funName a
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. CFG function -> Signature
cfgSignature
isParsable :: Rul f -> Bool
isParsable :: forall f. Rul f -> Bool
isParsable = (InternalRule
Parsable forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> InternalRule
internal
hasNilRule :: [Rule] -> Maybe Rule
hasNilRule :: [Rule] -> Maybe Rule
hasNilRule = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall a. IsFun a => a -> Bool
isNilFun
hasSingletonRule :: [Rule] -> Maybe Rule
hasSingletonRule :: [Rule] -> Maybe Rule
hasSingletonRule = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall a. IsFun a => a -> Bool
isOneFun
sortRulesByPrecedence :: [Rule] -> [(Integer,Rule)]
sortRulesByPrecedence :: [Rule] -> [(Integer, Rule)]
sortRulesByPrecedence = forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall f. Rul f -> Integer
precRule forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id)
isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat CF
cf = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. IsFun a => a -> Bool
isNilFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Cat -> [Rule]
rulesForCat' CF
cf
isNonterm :: Either Cat String -> Bool
isNonterm :: Either Cat String -> Bool
isNonterm = forall a b. Either a b -> Bool
Either.isLeft
revSepListRule :: Rul f -> Rul f
revSepListRule :: forall f. Rul f -> Rul f
revSepListRule (Rule f
f RCat
c SentForm
ts InternalRule
internal) = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule f
f RCat
c (Either Cat String
xs forall a. a -> [a] -> [a]
: Either Cat String
x forall a. a -> [a] -> [a]
: SentForm
sep) InternalRule
internal where
(Either Cat String
x,SentForm
sep,Either Cat String
xs) = (forall a. [a] -> a
head SentForm
ts, forall a. [a] -> [a]
init (forall a. [a] -> [a]
tail SentForm
ts), forall a. [a] -> a
last SentForm
ts)
findAllReversibleCats :: CF -> [Cat]
findAllReversibleCats :: CF -> [Cat]
findAllReversibleCats CF
cf = [Cat
c | (Cat
c,[Rule]
r) <- CF -> [(Cat, [Rule])]
ruleGroups CF
cf, forall {a}. IsFun a => Cat -> [Rul a] -> Bool
isRev Cat
c [Rule]
r]
where
isRev :: Cat -> [Rul a] -> Bool
isRev Cat
c = \case
[Rul a
r1,Rul a
r2] | Cat -> Bool
isList Cat
c -> if forall a. IsFun a => a -> Bool
isConsFun (forall function. Rul function -> function
funRule Rul a
r2) then forall {a} {a}. (IsFun a, IsFun a) => Rul a -> Rul a -> Bool
tryRev Rul a
r2 Rul a
r1
else forall a. IsFun a => a -> Bool
isConsFun (forall function. Rul function -> function
funRule Rul a
r1) Bool -> Bool -> Bool
&& forall {a} {a}. (IsFun a, IsFun a) => Rul a -> Rul a -> Bool
tryRev Rul a
r1 Rul a
r2
[Rul a]
_ -> Bool
False
tryRev :: Rul a -> Rul a -> Bool
tryRev (Rule a
f RCat
_ ts :: SentForm
ts@(Either Cat String
x:Either Cat String
_:SentForm
_) InternalRule
_) Rul a
r = forall a. IsFun a => Rul a -> Bool
isEmptyNilRule Rul a
r Bool -> Bool -> Bool
&&
forall a. IsFun a => a -> Bool
isConsFun a
f Bool -> Bool -> Bool
&& Either Cat String -> Bool
isNonterm Either Cat String
x Bool -> Bool -> Bool
&& Either Cat String -> Bool
isNonterm (forall a. [a] -> a
last SentForm
ts)
tryRev Rul a
_ Rul a
_ = Bool
False
isEmptyNilRule :: IsFun a => Rul a -> Bool
isEmptyNilRule :: forall a. IsFun a => Rul a -> Bool
isEmptyNilRule (Rule a
f RCat
_ SentForm
ts InternalRule
_) = forall a. IsFun a => a -> Bool
isNilFun a
f Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null SentForm
ts
precCat :: Cat -> Integer
precCat :: Cat -> Integer
precCat (CoercCat String
_ Integer
i) = Integer
i
precCat (ListCat Cat
c) = Cat -> Integer
precCat Cat
c
precCat Cat
_ = Integer
0
precRule :: Rul f -> Integer
precRule :: forall f. Rul f -> Integer
precRule = Cat -> Integer
precCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall fun. Rul fun -> Cat
valCat
hasIdentLikeTokens :: CFG g -> Bool
hasIdentLikeTokens :: forall f. CFG f -> Bool
hasIdentLikeTokens CFG g
cf = forall f. CFG f -> Bool
hasIdent CFG g
cf Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool -> Bool
not Bool
b | TokenReg RString
_ Bool
b Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CFG g
cf ]
hasTextualTokens :: CFG g -> Bool
hasTextualTokens :: forall f. CFG f -> Bool
hasTextualTokens CFG g
cf = forall f. CFG f -> Bool
hasIdent CFG g
cf Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | TokenReg{} <- forall function. CFG function -> [Pragma]
cfgPragmas CFG g
cf ]
hasPositionTokens :: CFG g -> Bool
hasPositionTokens :: forall f. CFG f -> Bool
hasPositionTokens CFG g
cf = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
b | TokenReg RString
_ Bool
b Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CFG g
cf ]
isPositionCat :: CFG f -> TokenCat -> Bool
isPositionCat :: forall f. CFG f -> String -> Bool
isPositionCat CFG f
cf String
cat = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
b | TokenReg RString
name Bool
b Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf, forall a. WithPosition a -> a
wpThing RString
name forall a. Eq a => a -> a -> Bool
== String
cat]
allEntryPoints :: CFG f -> List1 Cat
allEntryPoints :: forall f. CFG f -> List1 Cat
allEntryPoints CFG f
cf =
case forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [RCat]
cats | EntryPoints [RCat]
cats <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ] of
[] -> forall a. [a] -> NonEmpty a
List1.fromList forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Cat]
allParserCats CFG f
cf
RCat
c:[RCat]
cs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. WithPosition a -> a
wpThing (RCat
c forall a. a -> [a] -> NonEmpty a
:| [RCat]
cs)