0 | module Text.Regex.Parser.Glob
 1 |
 2 | import Data.List
 3 |
 4 | import public Text.Regex.Interface
 5 | import public Text.Regex.Parser
 6 |
 7 | import Data.SnocList
 8 |
 9 | %default total
10 |
11 | data GlobLex
12 |   = S (SnocList Char)
13 |   | AnyC
14 |   | AnyS
15 |   | AnySS
16 |   | Cs Bool (List BracketChars) -- [...] and [!...]/[^...], bool `False` for [!...]/[^...]
17 |
18 | pushChar : Char -> SnocList GlobLex -> SnocList GlobLex
19 | pushChar c (sx :< S cs) = sx :< S (cs :< c)
20 | pushChar c sx           = sx :< S (pure c)
21 |
22 | lexGlob : List Char -> Either BadRegex $ SnocList GlobLex
23 | lexGlob orig with (length orig)
24 |   _ | orL = go [<] orig where
25 |     go : SnocList GlobLex -> List Char -> Either BadRegex $ SnocList GlobLex
26 |     go acc []               = pure acc
27 |     go acc ('\\'::x  :: xs) = go (pushChar x acc) xs
28 |     go acc ('?'      :: xs) = go (acc :< AnyC) xs
29 |     go acc ('*'::'*' :: xs) = go (acc :< AnySS) xs
30 |     go acc ('*'      :: xs) = go (acc :< AnyS) xs
31 |     go acc xxs@('['  :: xs) = do let uc = uncons' xs
32 |                                  let positive = let h = map fst uc in h /= Just '^' && h /= Just '!'
33 |                                  (rest, cs) <- parseCharsSet (orL `minus` length xxs) orL True [<] $ fromMaybe xs $ map snd uc
34 |                                  go (acc :< Cs positive cs) $ assert_smaller xs rest
35 |     go acc (x        :: xs) = go (pushChar x acc) xs
36 |
37 | export %inline
38 | parseGlob : Regex rx => String -> Either BadRegex $ rx String
39 | parseGlob = map (composeRx []) . lexGlob . unpack where
40 |   nonDirChar : rx Char
41 |   nonDirChar = sym (/= '/')
42 |   composeRx : All rx tys -> SnocList GlobLex -> rx String
43 |   composeRx acc [<]             = matchOf $ all acc
44 |   composeRx acc (sx :< S [<])   = composeRx acc sx
45 |   composeRx acc (sx :< S [<c])  = composeRx (char c :: acc) sx
46 |   composeRx acc (sx :< S sc)    = composeRx (string (pack $ toList sc) :: acc) sx
47 |   composeRx acc (sx :< AnyC)    = composeRx (nonDirChar :: acc) sx
48 |   composeRx acc (sx :< AnyS)    = composeRx (rep nonDirChar :: acc) sx
49 |   composeRx acc (sx :< AnySS)   = composeRx (rep (anyChar Text) :: acc) sx
50 |   composeRx acc (sx :< Cs p cs) = composeRx (bracketMatcher p cs :: acc) sx
51 |