--
-- hfusk is a Haskell implementation of a "Fusker". For
-- more information, see http://en.wikipedia.org/wiki/Fusker.
--
-- Copyright Michael Orlitzky
--
-- http://michael.orlitzky.com/
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- http://www.fsf.org/licensing/licenses/gpl.html
--
--
-- Valid patterns involve (possibly nested) combinations of the following:
-- Text      : Everything except the patterns below will be used literally.
-- [x-y]     : Produces all integers between x and y inclusive.
-- {x,y,z..} : Produces x, y, and z.
--
--
-- Examples:
--
-- hfusk "http://mail[1-3].google.com/"
-- -> "http://mail1.google.com/"
-- -> "http://mail2.google.com/"
-- -> "http://mail3.google.com/"
--
-- hfusk "http://{mail1,mail2}.google.com/"
-- -> "http://mail1.google.com/"
-- -> "http://mail2.google.com/"
--


import Data.List (nub)
import System.Console.GetOpt
import System.Environment (getArgs)
import System.Exit
import System.IO (hPutStrLn, stderr)
import Text.ParserCombinators.Parsec


-----------------------
-- Command-line flags -
-----------------------

data Flag
    = Help -- -h
    | Quiet -- -q
    deriving (Eq, Ord, Enum, Show, Bounded)


-- The list of flags we accept
flags :: [OptDescr Flag]
flags = [ Option ['h'][] (NoArg Help) "Prints this help message.",
          Option ['q'][] (NoArg Quiet) "Quiet mode: produce no standard output." ]


-- The usage header
usage :: String
usage = "Usage: hfusk [-hq] <pattern>"


-- The usage header, and all available flags (as generated by GetOpt)
help :: String
help = usageInfo usage flags


-- Return a list of options and a list of patterns if everything
-- goes well. Otherwise, bail and show the help.
parse_command_line :: [String] -> IO ([Flag], [String])
parse_command_line argv =
    case (getOpt Permute flags argv) of 
    (options, pattern, []) ->
        return (options, pattern)
    (_, _, errors) -> do
         hPutStrLn stderr (concat errors)
         hPutStrLn stderr help
         exitFailure


-----------------------         
-- Cartesian Product --
-----------------------

cartesian_product :: [[a]] -> [[a]] -> [[a]]
cartesian_product set1 set2 =
    [ concat [x, y] | x <- set1, y <- set2 ]


----------------
-- Parser junk -
----------------

data Pattern
    = Range (Pattern, Pattern)
    | Set [Pattern]
    | LiteralInt Integer
    | Url String
      deriving (Show)


class Listable a where
  to_list :: a -> [[String]]


first_readable_int :: [[String]] -> Integer
first_readable_int x = (read (head (head  x)))

to_integer_range :: Pattern -> Pattern -> [Integer]
to_integer_range x y =
  [(first_readable_int (to_list x)) .. (first_readable_int (to_list y))]


instance Listable Pattern where
  to_list (Range (x, y)) = map (\n -> [show n]) (to_integer_range x y)
  to_list (Set x) = concat (map to_list x)
  to_list (LiteralInt x) = [[show x]]
  to_list (Url x) = [[x]]

  
  
-- An integer is one or more digits, as far as I can tell.
int_parser :: Parser Pattern
int_parser = do
  val <- many1 digit
  return $ LiteralInt (read val)
         

-- Parse a traditional Unix shell-style range,
-- i.e. [1-100]
range_parser :: Parser Pattern
range_parser = do 
  char '['
  inf <- int_parser
  char '-'
  sup <- int_parser
  char ']'
  return $ Range (inf, sup)


-- Parse sets of the form {a, b, c..., z}
set_parser :: Parser Pattern
set_parser = do
  char '{'
  elements <- sepBy1 value_parser set_separator_parser
  char '}'
  return $ Set elements


-- Parse past a comma surrounded by zero or more spaces.
set_separator_parser :: Parser ()
set_separator_parser = do
  skipMany space
  char ','
  skipMany space


-- Ad-hoc compilation of characters that I think
-- are valid in URLs
url_characters :: GenParser Char st Char
url_characters = alphaNum <|>
                 char '.' <|>
                 char ':' <|>
                 char '_' <|>
                 char '-' <|>
                 char '%' <|>
                 char '~' <|>
                 char '?' <|>
                 char '/' <|>
                 char '#' <|>
                 char '&' <|>
                 char '+'


-- Will parse one or more url_characters
url_parser :: Parser Pattern
url_parser = do
  val <- many1 url_characters
  return $ Url val
         

-- Will parse any of the defined patterns.
value_parser :: Parser Pattern
value_parser =
    range_parser <|>
    set_parser <|>
    url_parser <|>
    int_parser


-- Uses value_parser to walk the input string,
-- returning the list of parsed Patterns.
main_parser :: Parser [Pattern]
main_parser = do
  val <- many1 value_parser
  return val



---------  
-- Main -
---------

collapse_ast :: [Pattern] -> [String]
collapse_ast ast =
  nub (map concat (foldr1 cartesian_product (map to_list ast)))


print_list :: Show a => [a] -> IO ()
print_list xs = mapM_ (putStrLn . show) xs


  
main :: IO ()
main = do
  argv <- getArgs
  (options, pattern) <- parse_command_line argv

  -- If the user asked for help, show it and exit successfully.
  if (Help `elem` options)
      then do
            putStrLn help
            exitWith ExitSuccess
      else return ()

  -- If the user didn't supply a pattern we also show the
  -- help, but then exit with a failure code.
  if (pattern == [])
     then do
           putStrLn help
           exitFailure
     else return ()
          
           
  case (parse main_parser "" (head pattern)) of
    Left err -> do
      putStrLn ("Error " ++ (show err))
      exitFailure
    Right ast -> do
      print_list (collapse_ast ast)
      exitWith ExitSuccess