content: module Haste.Args (parseArgs, printHelp) where
  import System.Console.GetOpt
  import Data.List
  
  -- | Parse a list of command line arguments into a config, a list of args
  --   for GHC, and a list of error messages.
  --   Non-options are passed directly to GHC.
  parseArgs :: [OptDescr (a -> a)]
            -> String
            -> [String]
            -> Either String (a -> a, [String], [String])
  parseArgs opts hdr args
    | "--help" `elem` args || "-?" `elem` args =
      Left $ printHelp hdr opts
    | otherwise =
      let (hasteArgs, ghcArgs) = splitOpts opts args
          (cfgs, _, errs) = getOpt Permute opts hasteArgs
      in Right (foldl' (flip (.)) id cfgs, ghcArgs, errs)
  
  -- | 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
        | opt == "--make"       = False
        | otherwise             = and $ zipWith (==) "--" opt
  
  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]
  