Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 83 lines (64 sloc) 2.24 KB
#!/usr/bin/env stack
-- stack --install-ghc ghci --package free --package transformers
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
import Control.Alternative.Free
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State
import Data.Char
import Data.Foldable
import Data.List
import Data.Maybe
data Prim a = Prim Char a
deriving Functor
type RegExp = Alt Prim
-- | charAs: Parse a given character as a given constant result.
charAs :: Char -> a -> RegExp a
charAs c x = liftAlt (Prim c x) -- liftAlt lets us use the underlying
-- functor Prim in RegExp
-- | char: Parse a given character as itself.
char :: Char -> RegExp Char
char c = charAs c c
-- | string: Parse a given string as itself.
string :: String -> RegExp String
string = traverse char -- neat, huh
testRegExp_ :: RegExp ()
testRegExp_ = void $ (char 'a' <|> char 'b')
*> many (string "cd")
*> char 'e'
testRegExp :: RegExp Int
testRegExp = (char 'a' <|> char 'b')
*> (length <$> many (string "cd"))
<* char 'e'
testRegExpDo :: RegExp Int
testRegExpDo = do
char 'a' <|> char 'b'
cds <- many (string "cd")
char 'e'
pure (length cds)
digit :: RegExp Int
digit = asum [ charAs (intToDigit i) i | i <- [0..9] ]
bracketDigit :: RegExp Int
bracketDigit = char '[' *> digit <* char ']'
processPrim :: Prim a -> StateT String Maybe a
processPrim (Prim c x) = do
d:ds <- get
guard (c == d)
put ds
pure x
matchPrefix :: RegExp a -> String -> Maybe a
matchPrefix re = evalStateT (runAlt processPrim re)
matchAlts :: RegExp a -> String -> Maybe a
matchAlts (Alt res) xs = asum [ matchChain re xs | re <- res ]
matchChain :: AltF Prim a -> String -> Maybe a
matchChain (Ap (Prim c x) next) cs = case cs of
[] -> Nothing
d:ds | c == d -> matchAlts (($ x) <$> next) ds
| otherwise -> Nothing
matchChain (Pure x) _ = Just x
matches :: RegExp a -> String -> [a]
matches re = mapMaybe (matchPrefix re) . tails
firstMatch :: RegExp a -> String -> Maybe a
firstMatch re = listToMaybe . matches re
You can’t perform that action at this time.