Distributor.hs

{-|
Module      : Text.Grammar.Distributor
Description : grammars
Copyright   : (C) 2025 - Eitan Chatav
License     : BSD-style (see the file LICENSE)
Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
Stability   : provisional
Portability : non-portable

See Joachim Breitner,
[Showcasing Applicative]
(https://www.joachim-breitner.de/blog/710-Showcasing_Applicative)
for idea to unify grammars.
-}

module Text.Grammar.Distributor
  ( -- * Grammar
    Grammar, Grammarr, Grammatical (..)
    -- * Generators
  , genReadS
  , readGrammar
  , genShowS
  , showGrammar
  , genRegEx
  , genGrammar
  , printGrammar
    -- * RegEx
  , RegEx (..)
  , regexNorm
  , regexParse
  , regexString
  , regexGrammar
  ) where

import Control.Applicative
import Control.Lens
import Control.Lens.PartialIso
import Data.Char
import Data.Coerce
import Data.Foldable
import Data.Function
import Data.Profunctor
import Data.Profunctor.Distributor
import Data.Set (Set, insert)
import Data.String
import GHC.Generics
import Witherable

{- | `Grammar` is a Backus-Naur form grammar,
extended by regular expressions,
embedded in Haskell, with combinators:

* pattern matching `>?`, `>?<`
* alternation `<|>`
* sequencing `>*<`, `>*`, `*<`
* Kleene quantifiers `optionalP`, `manyP`, `someP`
* any character `anyToken`
* regular predicates `inClass`, `notInClass`, `inCategory`, `notInCategory`
* nonregular predicate `satisfy`
* terminal strings `tokens`, `fromString` and -XOverloadedStrings
* nonterminal rules `rule`, `ruleRec`
* and more.

To see an example of a `Grammar`, look at the source of `regexGrammar`.
-}
type Grammar a = forall p. Grammatical p => p a a

{- | A `Grammarr` is just a function of `Grammar`s,
useful for expressing one in terms of another `Grammar`.
The arr is for arrow; and it should be pronounced like a pirate.
-}
type Grammarr a b = forall p. Grammatical p => p a a -> p b b

{- | One can create new generators from a `Grammar` by defining
instances of `Grammatical`. For instance, one could create
generators for Parsec style parsers, and use `rule` for
labeling of parse errors.

A `Grammatical` `Profunctor` is a partial distributor,
being an `Alternator` & `Filtrator`.
It is also `Tokenized` with `Char` input & output tokens,
and `IsString` with the property:

prop> fromString = tokens

`Grammatical` has defaults for methods
`inClass`, `notInClass`, `inCategory`, `notInCategory`
in terms of `satisfy`;
and `rule` & `ruleRec` in terms of `id` & `fix`.
-}
class
  ( Alternator p
  , Filtrator p
  , Tokenized Char Char p
  , forall t. t ~ p () () => IsString t
  ) => Grammatical p where

    {- | Only characters which are in the given `String`.-}
    inClass :: String -> p Char Char
    inClass str = satisfy $ \ch -> elem ch str

    {- | Only characters which are not in the given `String`.-}
    notInClass :: String -> p Char Char
    notInClass str = satisfy $ \ch -> notElem ch str

    {- | Only characters which are in the given `GeneralCategory`.-}
    inCategory :: GeneralCategory -> p Char Char
    inCategory cat = satisfy $ \ch -> cat == generalCategory ch

    {- | Only characters which are not in the given `GeneralCategory`.-}
    notInCategory :: GeneralCategory -> p Char Char
    notInCategory cat = satisfy $ \ch -> cat /= generalCategory ch

    {- | A nonterminal rule. -}
    rule :: String -> p a a -> p a a
    rule _ = id

    {- | A recursive, nonterminal rule. -}
    ruleRec :: String -> (p a a -> p a a) -> p a a
    ruleRec name = rule name . fix

instance (Alternative f, Cons s s Char Char)
  => Grammatical (Printor s f)
instance (Monad f, Alternative f, Filterable f, Cons s s Char Char)
  => Grammatical (Parsor s f)

-- RegEx --

{- | A version of regular expressions extended by nonterminals. -}
data RegEx
  = Terminal String -- ^ @abc123etc\\.@
  | Sequence RegEx RegEx -- ^ @xy@
  | Fail -- ^ @\\q@
  | Alternate RegEx RegEx -- ^ @x|y@
  | KleeneOpt RegEx -- ^ @x?@
  | KleeneStar RegEx -- ^ @x*@
  | KleenePlus RegEx -- ^ @x+@
  | AnyChar -- ^ @.@
  | InClass String -- ^ @[abc]@
  | NotInClass String -- ^ @[^abc]@
  | InCategory GeneralCategory -- ^ @\\p{Lu}@
  | NotInCategory GeneralCategory -- ^ @\\P{Ll}@
  | NonTerminal String -- ^ @\\q{rule-name}@
  deriving stock (Eq, Ord, Show, Generic)
makeNestedPrisms ''RegEx
makeNestedPrisms ''GeneralCategory

(-*-), (|||) :: RegEx -> RegEx -> RegEx

Terminal "" -*- rex = rex
rex -*- Terminal "" = rex
Fail -*- _ = Fail
_ -*- Fail = Fail
Terminal str0 -*- Terminal str1 = Terminal (str0 <> str1)
KleeneStar rex0 -*- rex1 | rex0 == rex1 = plusK rex0
rex0 -*- KleeneStar rex1 | rex0 == rex1 = plusK rex0
rex0 -*- rex1 = Sequence rex0 rex1

KleenePlus rex ||| Terminal "" = starK rex
Terminal "" ||| KleenePlus rex = starK rex
rex ||| Terminal "" = optK rex
Terminal "" ||| rex = optK rex
rex ||| Fail = rex
Fail ||| rex = rex
rex0 ||| rex1 | rex0 == rex1 = rex0
rex0 ||| rex1 = Alternate rex0 rex1

optK, starK, plusK :: RegEx -> RegEx

optK Fail = Terminal ""
optK (Terminal "") = Terminal ""
optK (KleenePlus rex) = starK rex
optK rex = KleeneOpt rex

starK Fail = Terminal ""
starK (Terminal "") = Terminal ""
starK rex = KleeneStar rex

plusK Fail = Fail
plusK (Terminal "") = Terminal ""
plusK rex = KleenePlus rex

{- | Normalize a `RegEx`.

>>> regexNorm (Sequence (Terminal "abc") (Terminal "xyz"))
Terminal "abcxyz"
-}
regexNorm :: RegEx -> RegEx
regexNorm = \case
  Sequence rex0 rex1 -> regexNorm rex0 -*- regexNorm rex1
  Alternate rex0 rex1 -> regexNorm rex0 ||| regexNorm rex1
  KleeneOpt rex -> optK (regexNorm rex)
  KleeneStar rex -> starK (regexNorm rex)
  KleenePlus rex -> plusK (regexNorm rex)
  otherRegEx -> otherRegEx

{- | Parse a `RegEx` from a `String`.

>>> let str = "xy|z+"
>>> regexParse str
Alternate (Terminal "xy") (KleenePlus (Terminal "z"))

`Fail` if the `String` is not a valid regular expression.

>>> let bad = ")("
>>> regexParse bad
Fail
-}
regexParse :: String -> RegEx
regexParse str = case readGrammar regexGrammar str of
  [] -> Fail
  rex:_ -> regexNorm rex

{- | The `RegEx` `String`.

>>> let rex = Alternate (Terminal "xy") (KleenePlus (Terminal "z"))
>>> putStrLn (regexString rex)
xy|z+
-}
regexString :: RegEx -> String
regexString rex = maybe "\\q" id (showGrammar regexGrammar rex)

-- RegEx Generator --

newtype DiRegEx a b = DiRegEx RegEx
instance Functor (DiRegEx a) where fmap = rmap
instance Applicative (DiRegEx a) where
  pure _ = DiRegEx (Terminal [])
  DiRegEx rex1 <*> DiRegEx rex2 = DiRegEx (rex1 -*- rex2)
instance Alternative (DiRegEx a) where
  empty = DiRegEx Fail
  DiRegEx rex1 <|> DiRegEx rex2 = DiRegEx (rex1 ||| rex2)
  many (DiRegEx rex) = DiRegEx (KleeneStar rex)
  some (DiRegEx rex) = DiRegEx (KleenePlus rex)
instance Filterable (DiRegEx a) where
  mapMaybe _ = coerce
instance Profunctor DiRegEx where
  dimap _ _ = coerce
instance Distributor DiRegEx where
  zeroP = DiRegEx Fail
  DiRegEx rex1 >+< DiRegEx rex2 = DiRegEx (rex1 ||| rex2)
  optionalP (DiRegEx rex) = DiRegEx (optK rex)
  manyP (DiRegEx rex) = DiRegEx (starK rex)
instance Choice DiRegEx where
  left' = coerce
  right' = coerce
instance Cochoice DiRegEx where
  unleft = coerce
  unright = coerce
instance Alternator DiRegEx where
  someP (DiRegEx rex) = DiRegEx (plusK rex)
instance Filtrator DiRegEx
instance IsString (DiRegEx () ()) where
  fromString str = DiRegEx (Terminal str)
instance Tokenized Char Char DiRegEx where
  anyToken = DiRegEx AnyChar
instance Grammatical DiRegEx where
  inClass str = DiRegEx (InClass str)
  notInClass str = DiRegEx (NotInClass str)
  inCategory cat = DiRegEx (InCategory cat)
  notInCategory cat = DiRegEx (NotInCategory cat)

-- Grammar Generator --

data DiGrammar a b = DiGrammar
  { grammarStart :: DiRegEx a b
  , grammarRules :: Set (String, RegEx)
  }
instance Functor (DiGrammar a) where fmap = rmap
instance Applicative (DiGrammar a) where
  pure b = DiGrammar (pure b) mempty
  DiGrammar start1 rules1 <*> DiGrammar start2 rules2 =
    DiGrammar (start1 <*> start2) (rules1 <> rules2)
instance Alternative (DiGrammar a) where
  empty = DiGrammar empty mempty
  DiGrammar start1 rules1 <|> DiGrammar start2 rules2 =
    DiGrammar (start1 <|> start2) (rules1 <> rules2)
  many (DiGrammar start rules) = DiGrammar (many start) rules
  some (DiGrammar start rules) = DiGrammar (some start) rules
instance Filterable (DiGrammar a) where
  mapMaybe f (DiGrammar start rules) =
    DiGrammar (mapMaybe f start) rules
instance Profunctor DiGrammar where
  dimap f g (DiGrammar start rules) =
    DiGrammar (dimap f g start) rules
instance Distributor DiGrammar where
  zeroP = DiGrammar zeroP mempty
  DiGrammar start1 rules1 >+< DiGrammar start2 rules2 =
    DiGrammar (start1 >+< start2) (rules1 <> rules2)
  optionalP (DiGrammar start rules) =
    DiGrammar (optionalP start) rules
  manyP (DiGrammar start rules) =
    DiGrammar (manyP start) rules
instance Choice DiGrammar where
  left' = coerce
  right' = coerce
instance Cochoice DiGrammar where
  unleft = coerce
  unright = coerce
instance Alternator DiGrammar where
  someP (DiGrammar start rules) =
    DiGrammar (someP start) rules
instance Filtrator DiGrammar
instance IsString (DiGrammar () ()) where
  fromString str = DiGrammar (fromString str) mempty
instance Tokenized Char Char DiGrammar where
  anyToken = DiGrammar anyToken mempty
instance Grammatical DiGrammar where
  inClass str = DiGrammar (inClass str) mempty
  notInClass str = DiGrammar (notInClass str) mempty
  inCategory str = DiGrammar (inCategory str) mempty
  rule name gram = 
    let
      start = DiRegEx (NonTerminal name)
      DiRegEx newRule = grammarStart gram
      rules = insert (name, newRule) (grammarRules gram)
    in
      DiGrammar start rules
  ruleRec name f =
    let
      start = DiRegEx (NonTerminal name)
      gram = f (DiGrammar start mempty)
      DiRegEx newRule = grammarStart gram
      rules = insert (name, newRule) (grammarRules gram)
    in
      DiGrammar start rules

-- Generators --

{- | Generate a `ReadS` parser from a `Grammar`. -}
genReadS :: Grammar a -> ReadS a
genReadS = runParsor

{- | Use a `Grammar` to parse a `String`. -}
readGrammar :: Grammar a -> String -> [a]
readGrammar grammar str =
  [ a
  | (a, remaining) <- genReadS grammar str
  , remaining == []
  ]

{- | Generate `ShowS` printers from a `Grammar`. -}
genShowS :: Alternative f => Grammar a -> a -> f ShowS
genShowS = runPrintor

{- | Use a `Grammar` to print `String`s. -}
showGrammar :: Alternative f => Grammar a -> a -> f String
showGrammar grammar a = ($ "") <$> genShowS grammar a

{- | Generate a `RegEx` from a `Grammar`.
This will infinite loop if your `Grammar` includes a `ruleRec`,
otherwise it will inline all rules and produce a regular expression.
-}
genRegEx :: Grammar a -> RegEx
genRegEx (DiRegEx rex) = rex

{- | Generate a context free grammar,
consisting of @"start"@ & named `RegEx` rules, from a `Grammar`.
-}
genGrammar :: Grammar a -> [(String, RegEx)]
genGrammar (DiGrammar (DiRegEx start) rules) =
  ("start", start) : toList rules

{- | Print a `Grammar`.-}
printGrammar :: Grammar a -> IO ()
printGrammar gram = for_ (genGrammar gram) $ \(name_i, rule_i) -> do
  putStr name_i
  putStr " = "
  putStrLn (regexString rule_i)

-- RegEx Grammar --

{- | `regexGrammar` provides an important example of a `Grammar`.
Take a look at the source to see its definition.

>>> printGrammar regexGrammar
start = \q{regex}
alternate = \q{sequence}(\|\q{sequence})*
any = \.
atom = \q{nonterminal}|\q{fail}|\q{class-in}|\q{class-not-in}|\q{category-in}|\q{category-not-in}|\q{char}|\q{any}|\q{parenthesized}
category = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn
category-in = \\p\{\q{category}\}
category-not-in = \\P\{\q{category}\}
char = \q{char-literal}|\q{char-escaped}
char-escaped = \\[\$\(\)\*\+\.\?\[\\\]\^\{\|\}]
char-literal = [^\$\(\)\*\+\.\?\[\\\]\^\{\|\}]
class-in = \[\q{char}*\]
class-not-in = \[\^\q{char}*\]
expression = \q{terminal}|\q{kleene-optional}|\q{kleene-star}|\q{kleene-plus}|\q{atom}
fail = \\q
kleene-optional = \q{atom}\?
kleene-plus = \q{atom}\+
kleene-star = \q{atom}\*
nonterminal = \\q\{\q{char}*\}
parenthesized = \(\q{regex}\)
regex = \q{alternate}
sequence = \q{expression}*
terminal = \q{char}+

-}
regexGrammar :: Grammar RegEx
regexGrammar = ruleRec "regex" $ \rex -> altG rex

altG :: Grammarr RegEx RegEx
altG rex = rule "alternate" $
  chainl1 _Alternate (sepBy "|") (seqG rex)

anyG :: Grammar RegEx
anyG = rule "any" $ _AnyChar >?< "."

atomG :: Grammarr RegEx RegEx
atomG rex = rule "atom" $
  nonterminalG
  <|> failG
  <|> classInG
  <|> classNotInG
  <|> categoryInG
  <|> categoryNotInG
  <|> _Terminal >?< charG >:< pure ""
  <|> anyG
  <|> parenG rex

categoryG :: Grammar GeneralCategory
categoryG = rule "category" $
  _LowercaseLetter >?< "Ll"
  <|> _UppercaseLetter >?< "Lu"
  <|> _TitlecaseLetter >?< "Lt"
  <|> _ModifierLetter >?< "Lm"
  <|> _OtherLetter >?< "Lo"
  <|> _NonSpacingMark >?< "Mn"
  <|> _SpacingCombiningMark >?< "Mc"
  <|> _EnclosingMark >?< "Me"
  <|> _DecimalNumber >?< "Nd"
  <|> _LetterNumber >?< "Nl"
  <|> _OtherNumber >?< "No"
  <|> _ConnectorPunctuation >?< "Pc"
  <|> _DashPunctuation >?< "Pd"
  <|> _OpenPunctuation >?< "Ps"
  <|> _ClosePunctuation >?< "Pe"
  <|> _InitialQuote >?< "Pi"
  <|> _FinalQuote >?< "Pf"
  <|> _OtherPunctuation >?< "Po"
  <|> _MathSymbol >?< "Sm"
  <|> _CurrencySymbol >?< "Sc"
  <|> _ModifierSymbol >?< "Sk"
  <|> _OtherSymbol >?< "So"
  <|> _Space >?< "Zs"
  <|> _LineSeparator >?< "Zl"
  <|> _ParagraphSeparator >?< "Zp"
  <|> _Control >?< "Cc"
  <|> _Format >?< "Cf"
  <|> _Surrogate >?< "Cs"
  <|> _PrivateUse >?< "Co"
  <|> _NotAssigned >?< "Cn"

categoryInG :: Grammar RegEx
categoryInG = rule "category-in" $
  _InCategory >?< "\\p{" >* categoryG *< "}"

categoryNotInG :: Grammar RegEx
categoryNotInG = rule "category-not-in" $
  _NotInCategory >?< "\\P{" >* categoryG *< "}"

charG :: Grammar Char
charG = rule "char" $ charLiteralG <|> charEscapedG

charEscapedG :: Grammar Char
charEscapedG = rule "char-escaped" $ "\\" >* inClass charsReserved

charLiteralG :: Grammar Char
charLiteralG = rule "char-literal" $ notInClass charsReserved

charsReserved :: String
charsReserved = "$()*+.?[\\]^{|}"

classInG :: Grammar RegEx
classInG = rule "class-in" $
  _InClass >?< "[" >* manyP charG *< "]"

classNotInG :: Grammar RegEx
classNotInG = rule "class-not-in" $
  _NotInClass >?< "[^" >* manyP charG *< "]"

exprG :: Grammarr RegEx RegEx
exprG rex = rule "expression" $
  terminalG
  <|> kleeneOptG rex
  <|> kleeneStarG rex
  <|> kleenePlusG rex
  <|> atomG rex

failG :: Grammar RegEx
failG = rule "fail" $ _Fail >?< "\\q"

nonterminalG :: Grammar RegEx
nonterminalG = rule "nonterminal" $
  _NonTerminal >?< "\\q{" >* manyP charG *< "}"

parenG :: Grammarr a a
parenG rex = rule "parenthesized" $
  "(" >* rex *< ")"

kleeneOptG :: Grammarr RegEx RegEx
kleeneOptG rex = rule "kleene-optional" $
  _KleeneOpt >?< atomG rex *< "?"

kleeneStarG :: Grammarr RegEx RegEx
kleeneStarG rex = rule "kleene-star" $
  _KleeneStar >?< atomG rex *< "*"

kleenePlusG :: Grammarr RegEx RegEx
kleenePlusG rex = rule "kleene-plus" $
  _KleenePlus >?< atomG rex *< "+"

seqG :: Grammarr RegEx RegEx
seqG rex = rule "sequence" $
  chainl _Sequence (_Terminal . _Empty) noSep (exprG rex)

terminalG :: Grammar RegEx
terminalG = rule "terminal" $
  _Terminal >?< someP charG