module Haste.Args (parseArgs) where
import System.Console.GetOpt
import Data.List

-- | Parse a list of command line arguments into a config and a list of args
--   for GHC. Non-options are passed directly to GHC.
parseArgs :: [OptDescr (a -> a)]
          -> String
          -> [String]
          -> Either String (a -> a, [String])
parseArgs opts hdr args
  | "--help" `elem` args || "-?" `elem` args =
    Left $ printHelp hdr opts
  | otherwise =
    let (hasteArgs, ghcArgs) = splitOpts opts args
        (cfgs, _, _) = getOpt Permute opts hasteArgs
    in Right (foldl' (flip (.)) id cfgs, ghcArgs)

-- | Split opts into Haste options and others.
splitOpts :: [OptDescr a] -> [String] -> ([String], [String])
splitOpts opts args =
    (hasteArgs ++ outopts, filter (\x -> take 2 x /= "--") others)
  where
    (hasteArgs, others) =
      partition isHasteOpt nonouts

    (outopts, nonouts) =
      findOutputs ([], [], []) args

    -- TODO: this is a horrible hack to generally mangle arguments until
    --       stuff works - replace ASAP with less hacky solution!
    findOutputs (outs, nouts, fin) ("--libinstall" : xs) =
      findOutputs (outs, nouts, "--libinstall" : fin) xs
    findOutputs (outs, nouts, fin) ("-o" : out : xs) =
      findOutputs (("--out=" ++ out) : outs, nouts, fin) xs
    findOutputs (outs, nouts, fin) ("-outputdir" : out : xs) =
      findOutputs (("--outdir=" ++ out) : outs, nouts, fin) xs
    findOutputs (outs, nouts, fin) (x@('-':'o':out) : xs)
      | out == "hi"        = findOutputs (outs, x:nouts, fin) xs
      | out == "suf"       = findOutputs (outs, x:nouts, fin) xs
      | out == "dir"       = findOutputs (outs, x:nouts, fin) xs
      | take 2 out == "pt" = findOutputs (outs, x:nouts, fin) xs
      | otherwise          = findOutputs (("--out="++out):outs,nouts,fin) xs
    findOutputs (outs, nouts, fin) (x:xs) =
      findOutputs (outs, x : nouts, fin) xs
    findOutputs (outs, nouts, fin) _ =
      (reverse outs ++ reverse fin, reverse nouts)

    isHasteOpt opt
      | "-o" `isPrefixOf` opt = False
      | otherwise             = prefixElem opt optnames

    optnames =
      concatMap names opts

    names (Option short long _ _) =
      map (\c -> ['-',c]) short ++ map ("--" ++) long

-- | Does the given list exist as a prefix of some element in the list of
--   lists?
prefixElem :: Eq a => [a] -> [[a]] -> Bool
prefixElem x = or . map (\y -> take (length y) x == y)

printHelp :: String -> [OptDescr a] -> String
printHelp hdr = (hdr ++) . ("\n" ++) . unlines . map helpString

helpString :: OptDescr a -> String
helpString (Option short long opt help) =
    shorts ++ longs ++ "\n" ++ formatHelpMessage 80 help
  where
    (longarg, shortarg) =
      case opt of
        NoArg _    -> ("", "")
        ReqArg _ a -> ('=':a, ' ':a)
        OptArg _ a -> ("[=" ++ a ++ "]", " [" ++ a ++ "]")
    shorts =
      case intercalate ", " (map (\c -> ['-',c]) short) of
        s | null s    -> ""
          | otherwise -> s ++ shortarg ++ ", "
    longs =
      case intercalate ", " (map (\s -> "--" ++ s) long) of
        l | null l    -> ""
          | otherwise -> l ++ longarg

-- | Break lines at n chars, add two spaces before each.
formatHelpMessage :: Int -> String -> String
formatHelpMessage chars help =
    unlines . map ("  " ++) . breakLines 0 [] $ words help
  where
    breakLines len ln (w:ws)
      | length w >= chars-2     = w:unwords (reverse ln):breakLines 0 [] ws
      | len+length w >= chars-2 = unwords (reverse ln):breakLines 0 [] (w:ws)
      | otherwise               = breakLines (len+1+length w) (w:ln) ws
    breakLines _ ln _ =
      [unwords $ reverse ln]