Globber.hs

module Globber (matchGlob, parseGlob, GlobPattern) where

type GlobPattern = String

type AST = [Node]
data Node = Literal Char | AnyChar | AnyString | SetMatch Ranges String deriving (Show, Eq)
type Ranges = [(Char, Char)]

parseGlob :: GlobPattern -> AST
parseGlob [] = []
parseGlob ('?':xs) = AnyChar : parseGlob xs
parseGlob ('*':xs) = AnyString : parseGlob xs
parseGlob ('\\':x:xs) = Literal x : parseGlob xs
parseGlob ('[':xs) = let (setmatch, remaining) = parseSet xs in setmatch : parseGlob remaining
parseGlob (x:xs) = Literal x : parseGlob xs

parseSet :: GlobPattern -> (Node, GlobPattern)
parseSet glob = parseSetH (SetMatch [] []) glob
  where
    parseSetH :: Node -> GlobPattern -> (Node, GlobPattern)
    parseSetH setmatch (']':xs) = (setmatch, xs)
    parseSetH (SetMatch ranges literals) (x:'-':']':xs) = (SetMatch ranges (x:'-':literals), xs)
    parseSetH (SetMatch ranges literals) (x:'-':y:xs) = parseSetH (SetMatch ((x, y):ranges) literals) xs
    parseSetH (SetMatch ranges literals) ('\\':x:xs) = parseSetH (SetMatch ranges (x:literals)) xs
    parseSetH (SetMatch ranges literals) (x:xs) = parseSetH (SetMatch ranges (x:literals)) xs

matchGlob :: GlobPattern -> String -> Bool
matchGlob glob str = match (parseGlob glob) str
  where
    match [] [] = True
    match (Literal x:xs) (y:ys) = (x == y) && match xs ys
    match (AnyChar:xs) (_:ys) = match xs ys
    match (AnyString:[]) [] = True
    match (AnyString:xs) (y:ys) = match xs (y:ys) || match (AnyString:xs) ys
    match (SetMatch ranges literals:xs) (y:ys) = matchSet (SetMatch ranges literals) y && match xs ys
    match _ [] = False
    match [] _ = False

matchSet :: Node -> Char -> Bool
matchSet (SetMatch ranges literals) x = x `elem` literals || any inRange ranges
  where
    inRange (lo, hi) = x >= lo && x <= hi