-- 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 = \case
  -- Character classes
  A.RChar   _ c     -> rChar c
  A.RDigit  _       -> RChar $ cDigit
  A.RLetter _       -> RChar $ cLetter
  A.RUpper  _       -> RChar $ cUpper
  A.RLower  _       -> RChar $ cLower
  A.RAny    _       -> RChar $ cAny
  A.RAlts   _ cs    -> RChar $ cAlts cs
  -- Sum, difference
  A.RAlt    _ r1 r2 -> normRegex r1 `rAlt`   normRegex r2
  A.RMinus  _ r1 r2 -> normRegex r1 `rMinus` normRegex r2
  -- Sequences
  A.RSeq    _ r1 r2 -> normRegex r1 `rSeq`   normRegex r2
  A.RSeqs   _ cs    -> rSeqs $ map rChar cs
  A.REps    _       -> REps
  -- Iteration
  A.RStar   _ r     -> rStar $ normRegex r
  A.RPlus   _ r     -> rPlus $ normRegex r
  A.ROpt    _ r     -> rOpt  $ normRegex r

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

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

instance ReifyRegex Regex where
  reifyRegex = \case
    RChar c                -> reifyRegex c
    REps                   -> A.REps  nop
    RStar r                -> A.RStar nop $ reifyRegex r
    RPlus r                -> A.RPlus nop $ reifyRegex r
    ROpt  r                -> A.ROpt  nop $ reifyRegex r
    -- left associative:
    RAlts (List2 r1 r2 rs) -> foldl arAlt (reifyRegex r1 `arAlt` reifyRegex r2) $ map reifyRegex rs
    RSeqs (List2 r1 r2 rs) -> foldl arSeq (reifyRegex r1 `arSeq` reifyRegex r2) $ map reifyRegex rs
    RMinus r1 r2           -> reifyRegex r1 `arMinus` reifyRegex r2

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

instance ReifyRegex CharClass where
  reifyRegex (CMinus p m)
    | m == mempty = reifyRegex p
    | p == mempty = A.RAlts nop ""
    | otherwise = reifyRegex p `arMinus` reifyRegex m

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

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