-- BNFC 3
-- (C) 2021 Andreas Abel

-- | Converting back to and forth from LBNF regular regular expression.

module BNFC.Check.Regex
  ( normRegex
  , ReifyRegex(reifyRegex)
  ) where

import BNFC.Prelude
import BNFC.Types.Regex

import qualified BNFC.Abs as A

-- | Convert LBNF regular expression into internal format.

normRegex :: A.Reg -> Regex
normRegex :: Reg -> Regex
normRegex = \case
  -- Character classes
  A.RChar   BNFC'Position
_ Char
c     -> Char -> Regex
rChar Char
c
  A.RDigit  BNFC'Position
_       -> CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ CharClass
cDigit
  A.RLetter BNFC'Position
_       -> CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ CharClass
cLetter
  A.RUpper  BNFC'Position
_       -> CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ CharClass
cUpper
  A.RLower  BNFC'Position
_       -> CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ CharClass
cLower
  A.RAny    BNFC'Position
_       -> CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ CharClass
cAny
  A.RAlts   BNFC'Position
_ String
cs    -> CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ String -> CharClass
cAlts String
cs
  -- Sum, difference
  A.RAlt    BNFC'Position
_ Reg
r1 Reg
r2 -> Reg -> Regex
normRegex Reg
r1 Regex -> Regex -> Regex
`rAlt`   Reg -> Regex
normRegex Reg
r2
  A.RMinus  BNFC'Position
_ Reg
r1 Reg
r2 -> Reg -> Regex
normRegex Reg
r1 Regex -> Regex -> Regex
`rMinus` Reg -> Regex
normRegex Reg
r2
  -- Sequences
  A.RSeq    BNFC'Position
_ Reg
r1 Reg
r2 -> Reg -> Regex
normRegex Reg
r1 Regex -> Regex -> Regex
`rSeq`   Reg -> Regex
normRegex Reg
r2
  A.RSeqs   BNFC'Position
_ String
cs    -> [Regex] -> Regex
rSeqs ([Regex] -> Regex) -> [Regex] -> Regex
forall a b. (a -> b) -> a -> b
$ (Char -> Regex) -> String -> [Regex]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Regex
rChar String
cs
  A.REps    BNFC'Position
_       -> Regex
REps
  -- Iteration
  A.RStar   BNFC'Position
_ Reg
r     -> Regex -> Regex
rStar (Regex -> Regex) -> Regex -> Regex
forall a b. (a -> b) -> a -> b
$ Reg -> Regex
normRegex Reg
r
  A.RPlus   BNFC'Position
_ Reg
r     -> Regex -> Regex
rPlus (Regex -> Regex) -> Regex -> Regex
forall a b. (a -> b) -> a -> b
$ Reg -> Regex
normRegex Reg
r
  A.ROpt    BNFC'Position
_ Reg
r     -> Regex -> Regex
rOpt  (Regex -> Regex) -> Regex -> Regex
forall a b. (a -> b) -> a -> b
$ Reg -> Regex
normRegex Reg
r

-- | Convert from internal format to LBNF regular expression.

class ReifyRegex a where
  reifyRegex :: a -> A.Reg

instance ReifyRegex Regex where
  reifyRegex :: Regex -> Reg
reifyRegex = \case
    RChar CharClass
c                -> CharClass -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex CharClass
c
    Regex
REps                   -> BNFC'Position -> Reg
forall a. a -> Reg' a
A.REps  BNFC'Position
forall a. Maybe a
nop
    RStar Regex
r                -> BNFC'Position -> Reg -> Reg
forall a. a -> Reg' a -> Reg' a
A.RStar BNFC'Position
forall a. Maybe a
nop (Reg -> Reg) -> Reg -> Reg
forall a b. (a -> b) -> a -> b
$ Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r
    RPlus Regex
r                -> BNFC'Position -> Reg -> Reg
forall a. a -> Reg' a -> Reg' a
A.RPlus BNFC'Position
forall a. Maybe a
nop (Reg -> Reg) -> Reg -> Reg
forall a b. (a -> b) -> a -> b
$ Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r
    ROpt  Regex
r                -> BNFC'Position -> Reg -> Reg
forall a. a -> Reg' a -> Reg' a
A.ROpt  BNFC'Position
forall a. Maybe a
nop (Reg -> Reg) -> Reg -> Reg
forall a b. (a -> b) -> a -> b
$ Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r
    -- left associative:
    RAlts (List2 Regex
r1 Regex
r2 [Regex]
rs) -> (Reg -> Reg -> Reg) -> Reg -> [Reg] -> Reg
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Reg -> Reg -> Reg
forall a. Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
arAlt (Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r1 Reg -> Reg -> Reg
forall a. Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
`arAlt` Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r2) ([Reg] -> Reg) -> [Reg] -> Reg
forall a b. (a -> b) -> a -> b
$ (Regex -> Reg) -> [Regex] -> [Reg]
forall a b. (a -> b) -> [a] -> [b]
map Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex [Regex]
rs
    RSeqs (List2 Regex
r1 Regex
r2 [Regex]
rs) -> (Reg -> Reg -> Reg) -> Reg -> [Reg] -> Reg
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Reg -> Reg -> Reg
forall a. Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
arSeq (Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r1 Reg -> Reg -> Reg
forall a. Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
`arSeq` Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r2) ([Reg] -> Reg) -> [Reg] -> Reg
forall a b. (a -> b) -> a -> b
$ (Regex -> Reg) -> [Regex] -> [Reg]
forall a b. (a -> b) -> [a] -> [b]
map Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex [Regex]
rs
    RMinus Regex
r1 Regex
r2           -> Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r1 Reg -> Reg -> Reg
forall a. Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
`arMinus` Regex -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex Regex
r2

arAlt, arSeq, arMinus :: A.Reg' (Maybe a) -> A.Reg' (Maybe a) -> A.Reg' (Maybe a)
arAlt :: Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
arAlt   = Maybe a -> Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
forall a. a -> Reg' a -> Reg' a -> Reg' a
A.RAlt   Maybe a
forall a. Maybe a
nop
arSeq :: Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
arSeq   = Maybe a -> Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
forall a. a -> Reg' a -> Reg' a -> Reg' a
A.RSeq   Maybe a
forall a. Maybe a
nop
arMinus :: Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
arMinus = Maybe a -> Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
forall a. a -> Reg' a -> Reg' a -> Reg' a
A.RMinus Maybe a
forall a. Maybe a
nop
nop :: Maybe a
nop :: Maybe a
nop    = Maybe a
forall a. Maybe a
Nothing

instance ReifyRegex CharClass where
  reifyRegex :: CharClass -> Reg
reifyRegex (CMinus CharClassUnion
p CharClassUnion
m)
    | CharClassUnion
m CharClassUnion -> CharClassUnion -> Bool
forall a. Eq a => a -> a -> Bool
== CharClassUnion
forall a. Monoid a => a
mempty = CharClassUnion -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex CharClassUnion
p
    | CharClassUnion
p CharClassUnion -> CharClassUnion -> Bool
forall a. Eq a => a -> a -> Bool
== CharClassUnion
forall a. Monoid a => a
mempty = BNFC'Position -> String -> Reg
forall a. a -> String -> Reg' a
A.RAlts BNFC'Position
forall a. Maybe a
nop String
""
    | Bool
otherwise = CharClassUnion -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex CharClassUnion
p Reg -> Reg -> Reg
forall a. Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
`arMinus` CharClassUnion -> Reg
forall a. ReifyRegex a => a -> Reg
reifyRegex CharClassUnion
m

instance ReifyRegex CharClassUnion where
  reifyRegex :: CharClassUnion -> Reg
reifyRegex CharClassUnion
CAny      = BNFC'Position -> Reg
forall a. a -> Reg' a
A.RAny BNFC'Position
forall a. Maybe a
nop
  reifyRegex (CAlt [CharClassAtom]
cs) = case [Reg]
forall a. [Reg' (Maybe a)]
rs of
      []   -> BNFC'Position -> String -> Reg
forall a. a -> String -> Reg' a
A.RAlts BNFC'Position
forall a. Maybe a
nop String
""
      [Reg
r]  -> Reg
r
      [Reg]
rss  -> (Reg -> Reg -> Reg) -> [Reg] -> Reg
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Reg -> Reg -> Reg
forall a. Reg' (Maybe a) -> Reg' (Maybe a) -> Reg' (Maybe a)
arAlt [Reg]
rss
    where
    -- collect elements of cs into St
    start :: St
start = Bool -> Bool -> Bool -> String -> St
St Bool
False Bool
False Bool
False []
    step :: St -> CharClassAtom -> St
step St
st = \case
      CChar Char
c -> St
st { stAlts :: String
stAlts = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: St -> String
stAlts St
st }
      CharClassAtom
CDigit  -> St
st { stDigit :: Bool
stDigit = Bool
True }
      CharClassAtom
CLower  -> St
st { stLower :: Bool
stLower = Bool
True }
      CharClassAtom
CUpper  -> St
st { stUpper :: Bool
stUpper = Bool
True }
    (St Bool
digit Bool
upper Bool
lower String
alts) = (CharClassAtom -> St -> St) -> St -> [CharClassAtom] -> St
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((St -> CharClassAtom -> St) -> CharClassAtom -> St -> St
forall a b c. (a -> b -> c) -> b -> a -> c
flip St -> CharClassAtom -> St
step) St
start [CharClassAtom]
cs
    rs :: [Reg' (Maybe a)]
rs = [[Reg' (Maybe a)]] -> [Reg' (Maybe a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ Maybe a -> Char -> Reg' (Maybe a)
forall a. a -> Char -> Reg' a
A.RChar   Maybe a
forall a. Maybe a
nop Char
c    | [Char
c] <- [String
alts]      ]
      , [ Maybe a -> String -> Reg' (Maybe a)
forall a. a -> String -> Reg' a
A.RAlts   Maybe a
forall a. Maybe a
nop String
alts | (Char
_:Char
_:String
_) <- [String
alts]  ]
      , [ Maybe a -> Reg' (Maybe a)
forall a. a -> Reg' a
A.RDigit  Maybe a
forall a. Maybe a
nop      | Bool
digit              ]
      , [ Maybe a -> Reg' (Maybe a)
forall a. a -> Reg' a
A.RLetter Maybe a
forall a. Maybe a
nop      | Bool
upper Bool -> Bool -> Bool
&& Bool
lower     ]
      , [ Maybe a -> Reg' (Maybe a)
forall a. a -> Reg' a
A.RUpper  Maybe a
forall a. Maybe a
nop      | Bool
upper Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
lower ]
      , [ Maybe a -> Reg' (Maybe a)
forall a. a -> Reg' a
A.RLower  Maybe a
forall a. Maybe a
nop      | Bool
lower Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
upper ]
      ]

  -- Local state type
data St = St { St -> Bool
stDigit, St -> Bool
stUpper, St -> Bool
stLower :: Bool, St -> String
stAlts :: String }