example.hs

{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

import Data.List

-- unchanged from blog post apart from signature
compile :: Compilable a => String -> a
compile []          = empty
compile ('?'   :cs) = anyChar   `append` compile cs
compile ('*'   :cs) = whatever  `append` compile cs
compile ('\\':c:cs) = char c    `append` compile cs
compile (     c:cs) = char c    `append` compile cs

-- extract this out into an interface
-- this is parametrized over the return type
class Compilable a where
    empty :: a
    anyChar :: a
    whatever :: a
    char :: Char -> a

    -- this is the interesting case!
    append :: a -> a -> a

-- we can pretty print the expression
instance Compilable String where
    empty = ""
    anyChar = "?"
    whatever = "*"
    char c
        | c == '?' || c == '*' = '\\' : [c]
        | otherwise = [c]

    append x y = x ++ y

-- or we could read it into an AST (the initial representation)
data AST = Empty | AnyChar | Whatever | Char Char | Append AST AST deriving (Show)

instance Compilable AST where
    empty = Empty
    anyChar = AnyChar
    whatever = Whatever
    char = Char
    append = Append

-- or we can form the product of two:
instance (Compilable a, Compilable b) => Compilable (a, b) where
    empty = (empty, empty)
    anyChar = (anyChar, anyChar)
    whatever = (whatever, whatever)
    char c = (char c, char c)
    append (x, x') (y, y') = (append x y, append x' y')

-- either fail or the number of chars matched
data MatchResult = Fail | Success Int deriving (Eq, Show)
type Matcher = String -> MatchResult

instance Compilable Matcher where
    empty [] = Success 0
    empty _ = Fail
    
    anyChar [x] = Success 1
    anyChar _ = Fail

    whatever x = Success (length x)
    
    char c [x]
        | c == x = Success 1
        | otherwise = Fail
    char c _ = Fail

    append l r s = case result of [] -> Fail; otherwise -> head result
        where
        result = filter (/= Fail) $ flip map (reverse $ inits s) (\s' ->
                    case l s' of
                        Success n ->
                            case r (drop n s) of
                                Success m -> if n+m == slen then Success (n + m) else Fail
                                Fail -> Fail
                        Fail -> Fail)
        slen = length s


main = do
    let input = "foo?test*.txt"

    -- compile the AST
    let ast = compile input :: AST

    -- compile the String
    let pp  = compile input :: String

    let matcher = compile input :: Matcher
    print $ matcher "foo1test.txt"
    print $ matcher "foo12test.txt"
    print $ matcher "foo1test123.txt"
    print $ matcher "foo1test123.txt."

    -- compile two at once
    let both = compile input :: (String, AST)

    print ast
    print pp
    print both
    
{-

Outputs:

Success 12
Fail
Success 15
Fail
Append (Char 'f') (Append (Char 'o') (Append (Char 'o') (Append AnyChar (Append (Char 't') (Append (Char 'e') (Append (Char 's') (Append (Char 't') (Append Whatever (Append (Char '.') (Append (Char 't') (Append (Char 'x') (Append (Char 't') Empty))))))))))))
"foo?test*.txt"
("foo?test*.txt",Append (Char 'f') (Append (Char 'o') (Append (Char 'o') (Append AnyChar (Append (Char 't') (Append (Char 'e') (Append (Char 's') (Append (Char 't') (Append Whatever (Append (Char '.') (Append (Char 't') (Append (Char 'x') (Append (Char 't') Empty)))))))))))))

-}