regexp.hs

regexp.hs

-- | parseAlt "ok|
-- 
-- > parseAlt "one|two|three" `runParser` "four!"
-- Right ("","four!")
-- > parseAlt "one|two|three" `runParser` "one!"
-- Right ("one","!")
parseAlt :: forall (regexp :: Symbol) -> ParseAlt regexp => Parser String
parseAlt regexp = parseAlt' @(SplitPipe (ToList regexp))

-- | Implementation

newtype Parser a = Parser { runParser :: String -> Either String (a, String) }
  deriving (Functor, Applicative, Monad, Alternative)
  via StateT String (Either String)

satisfy :: (Char -> Bool) -> Parser Char
satisfy p = Parser \case
  c:cs | p c -> Right (c, cs)
  _ -> Left "satisfy: input does not match predicate or is empty"

char :: Char -> Parser Char
char c = satisfy (== c)

type ToList :: Symbol -> [Char]
type ToList symbol = ToList' (UnconsSymbol symbol)

type
  ToList' :: Maybe (Char, Symbol) -> [Char]
type family
  ToList' maybe where
  ToList' Nothing           = '[]
  ToList' (Just '(ch, str)) = ch : ToList str

type
  SplitPipe :: [Char] -> [[Char]]
type family
  SplitPipe chars where
  SplitPipe chars = SplitPipe' (BreakPipe chars)

type
  SplitPipe' :: ([Char], [Char]) -> [[Char]]
type family
  SplitPipe' pair where
  SplitPipe' '(as, '[]) = '[as]
  SplitPipe' '(as, '|':bs) = as : SplitPipe bs

type
  BreakPipe :: [Char] -> ([Char], [Char])
type family
  BreakPipe as where
  BreakPipe '[]      = '( '[], '[] )
  BreakPipe ('|':as) = '( '[], '|':as )
  BreakPipe (a:as)   = Cons a (BreakPipe as)

type
  Cons :: a -> ([a], [a]) -> ([a], [a])
type family
  Cons x pair where
  Cons a '(as, bs) = '(a:as, bs)

type ParseAlt :: Symbol -> Constraint
type ParseAlt as = ParseAlt' (SplitPipe (ToList as))

type  ParseAlt' :: [[Char]] -> Constraint
class ParseAlt' charss where
  parseAlt' :: Parser String
instance ParseAlt' '[] where
  parseAlt' = pure ""
instance (ParseStr c, ParseAlt' cs) => ParseAlt' (c:cs) where
  parseAlt' = parseStr @c <|> parseAlt' @cs

type  ParseStr :: [Char] -> Constraint
class ParseStr chars where
  parseStr :: Parser String
instance ParseStr '[] where
  parseStr :: Parser String
  parseStr = pure ""
instance (KnownChar char, ParseStr chars) => ParseStr (char:chars) where
  parseStr :: Parser String
  parseStr = liftA2 (:) (char (charVal @char Proxy)) (parseStr @chars)