2 -- hfusk is a Haskell implementation of a "Fusker". For
3 -- more information, see http://en.wikipedia.org/wiki/Fusker.
5 -- Copyright Michael Orlitzky
7 -- http://michael.orlitzky.com/
9 -- This program is free software: you can redistribute it and/or modify
10 -- it under the terms of the GNU General Public License as published by
11 -- the Free Software Foundation, either version 3 of the License, or
12 -- (at your option) any later version.
14 -- This program is distributed in the hope that it will be useful,
15 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
16 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 -- GNU General Public License for more details.
19 -- http://www.fsf.org/licensing/licenses/gpl.html
22 -- Valid patterns involve (possibly nested) combinations of the following:
23 -- Text : Everything except the patterns below will be used literally.
24 -- [x-y] : Produces all integers between x and y inclusive.
25 -- {x,y,z..} : Produces x, y, and z.
30 -- hfusk "http://mail[1-3].google.com/"
31 -- -> "http://mail1.google.com/"
32 -- -> "http://mail2.google.com/"
33 -- -> "http://mail3.google.com/"
35 -- hfusk "http://{mail1,mail2}.google.com/"
36 -- -> "http://mail1.google.com/"
37 -- -> "http://mail2.google.com/"
41 import Data.List (nub)
42 import System.Console.GetOpt
43 import System.Environment (getArgs)
45 import System.IO (hPutStrLn, stderr)
46 import Text.ParserCombinators.Parsec
49 -----------------------
50 -- Command-line flags -
51 -----------------------
56 deriving (Eq, Ord, Enum, Show, Bounded)
59 -- The list of flags we accept
60 flags :: [OptDescr Flag]
61 flags = [ Option ['h'][] (NoArg Help) "Prints this help message.",
62 Option ['q'][] (NoArg Quiet) "Quiet mode: produce no standard output." ]
67 usage = "Usage: hfusk [-hq] <pattern>"
70 -- The usage header, and all available flags (as generated by GetOpt)
72 help = usageInfo usage flags
75 -- Return a list of options and a list of patterns if everything
76 -- goes well. Otherwise, bail and show the help.
77 parse_command_line :: [String] -> IO ([Flag], [String])
78 parse_command_line argv =
79 case (getOpt Permute flags argv) of
80 (options, pattern, []) ->
81 return (options, pattern)
83 hPutStrLn stderr (concat errors)
88 -----------------------
89 -- Cartesian Product --
90 -----------------------
92 cartesian_product :: [[a]] -> [[a]] -> [[a]]
93 cartesian_product set1 set2 =
94 [ concat [x, y] | x <- set1, y <- set2 ]
102 = Range (Pattern, Pattern)
109 class Listable a where
110 to_list :: a -> [[String]]
113 first_readable_int :: [[String]] -> Integer
114 first_readable_int x = (read (head (head x)))
116 to_integer_range :: Pattern -> Pattern -> [Integer]
117 to_integer_range x y =
118 [(first_readable_int (to_list x)) .. (first_readable_int (to_list y))]
121 instance Listable Pattern where
122 to_list (Range (x, y)) = map (\n -> [show n]) (to_integer_range x y)
123 to_list (Set x) = concat (map to_list x)
124 to_list (LiteralInt x) = [[show x]]
125 to_list (Url x) = [[x]]
129 -- An integer is one or more digits, as far as I can tell.
130 int_parser :: Parser Pattern
133 return $ LiteralInt (read val)
136 -- Parse a traditional Unix shell-style range,
138 range_parser :: Parser Pattern
145 return $ Range (inf, sup)
148 -- Parse sets of the form {a, b, c..., z}
149 set_parser :: Parser Pattern
152 elements <- sepBy1 value_parser set_separator_parser
154 return $ Set elements
157 -- Parse past a comma surrounded by zero or more spaces.
158 set_separator_parser :: Parser ()
159 set_separator_parser = do
165 -- Ad-hoc compilation of characters that I think
167 url_characters :: GenParser Char st Char
168 url_characters = alphaNum <|>
182 -- Will parse one or more url_characters
183 url_parser :: Parser Pattern
185 val <- many1 url_characters
189 -- Will parse any of the defined patterns.
190 value_parser :: Parser Pattern
198 -- Uses value_parser to walk the input string,
199 -- returning the list of parsed Patterns.
200 main_parser :: Parser [Pattern]
202 val <- many1 value_parser
211 collapse_ast :: [Pattern] -> [String]
213 nub (map concat (foldr1 cartesian_product (map to_list ast)))
216 print_list :: Show a => [a] -> IO ()
217 print_list xs = mapM_ (putStrLn . show) xs
224 (options, pattern) <- parse_command_line argv
226 -- If the user asked for help, show it and exit successfully.
227 if (Help `elem` options)
233 -- If the user didn't supply a pattern we also show the
234 -- help, but then exit with a failure code.
242 case (parse main_parser "" (head pattern)) of
244 putStrLn ("Error " ++ (show err))
247 print_list (collapse_ast ast)