Icelandjack · May 9, 2025 14:38 · May 9, 2025
diff --git a/regexp.hs b/regexp.hs
@@ -0,0 +1,80 @@
+-- | 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)
No results found