{-# OPTIONS_GHC -fglasgow-exts #-}

{-

  This needs to be redone as a proper Haskell parser,
  which will be one of my next projects. But so far,
  this works.

  The operators are simple prefix operators
  with zero or one argument, except for everything
  that ultimatively goes into @ARGS for the Pugs
  script.

  If you change anything here, make sure all tests under
  t/pugsrun/ still pass. Otherwise you might break building
  for everybody, once you commit.

-}

-- | Command line argument parser for pugs.
module Pugs.Run.Args (
    canonicalArgs,
    gatherArgs,
    unpackOptions,
) where
import Pugs.Internals

{- | 
  Convert command line arguments into canonical form for 
  'Pugs.Run.runWithArgs'.  The switch ordering is defined
  by compareArgs and is currently:

  > (-h -v -V) (-I) (-d) (-w) (-c) (-C) (--external) (-M) (-n -p) (-0 -e other)

  Args -M, -n and -p are converted to -e scripts by desugarDashE.
-}
canonicalArgs :: [String] -> [String]
canonicalArgs x = concatMap procArg
                . concatDashE
                . desugarDashE
                . sortBy compareArgs
                . gatherArgs
                . unpackOptions
                $ x

concatDashE :: [Arg] -> [Arg]
concatDashE (Opt "-e" e:xs) = (Opt "-e" $ concat (intersperse "\n" (e:map optArg es))) : rest
    where
    (es, rest)          = partition isOptE xs
    isOptE (Opt "-e" _) = True
    isOptE _            = False
concatDashE (x:xs) = (x:concatDashE xs)
concatDashE xs = xs

data Arg
    = File !String
    | Switch !Char
    | Opt { _optFlag :: !String, optArg :: !String }
    deriving Show

procArg :: Arg -> [String]
procArg (Opt name arg)  = [name, arg]
procArg (File name)     = [name]
procArg (Switch name)   = ['-':name:[]]

unpackOptions :: [String] -> [String]
unpackOptions []                = []
unpackOptions (("-"):rest)      = ("-":unpackOptions rest)
unpackOptions opts@("--":_)     = opts
unpackOptions (('-':opt):arg:rest)
    | takesArg opt              = unpackOption opt ++ (arg:unpackOptions rest)
unpackOptions (('-':opt):rest)  = unpackOption opt ++ unpackOptions rest
unpackOptions opts@[_]          = opts
unpackOptions (filename:rest)   = filename : "--" : rest

takesArg :: String -> Bool
takesArg xs     | xs `elem` withParam   = True
takesArg (x:xs) | x `elem` composable   = takesArg xs
takesArg _                              = False

unpackOption :: String -> [String]
unpackOption "" = [] -- base case for composing
unpackOption opt
    | Just short <- lookup ('-':opt) longOptions = [short]
    | head opt `elem` composable = ['-', head opt] : unpackOption (tail opt)
    | Just (prefix, param) <- prefixOpt opt = ['-':prefix, param]
    | otherwise = ['-':opt]

-- | List of options with long and sort variants, as tupples of long, short (with the dashes).
longOptions :: [(String, String)]
longOptions = [("--help", "-h"), ("--version", "-v")]

-- | List of options that can have their argument just after, with no space.
composable :: [Char]
composable = "cdlnpw"

-- | List of options that can take arguments
withParam :: [String]
withParam = words "e C B I M V:"

prefixOpt :: [Char] -> Maybe (String, String)
prefixOpt opt = msum $ map (findArg opt) withParam

findArg :: Eq a => [a] -> [a] -> Maybe ([a], [a])
findArg arg prefix = do
    param <- afterPrefix prefix arg
    guard (not (null param))
    return (prefix, param)

{-
  Enforce a canonical order of command line switches.  Currently this is:

  > (-h -v -V) (-I) (-d) (-w) (-c) (-C) (--external) (-M) (-n -p) (-0 -e other)

  This makes pattern matching more convenient

  Backwards incompatible changes:

   *  -p and -n autochomp.

   *  -p uses say() instead of print()
-}

compareArgs :: Arg -> Arg -> Ordering
compareArgs a b = compare (argRank a) (argRank b)

argRank :: Arg -> Int
argRank (Switch 'h')         = -1
argRank (Switch 'v')         = -1
argRank (Opt "-V:" _)        = -1
argRank (Switch 'V')         = -1
argRank (Opt "-I" _)         = 0
argRank (Switch 'd')         = 1
argRank (Switch 'w')         = 2
argRank (Switch 'c')         = 3
argRank (Opt "-C" _)         = 4
argRank (Opt "-B" _)         = 4
argRank (Opt "--external" _) = 5
argRank (Opt "-M" _)         = 98
argRank (Switch 'n')         = 99   -- translated into Perl code (later)
argRank (Switch 'p')         = 99   -- translated into Perl code (later)
argRank (Switch 'l')         = 100  -- translated into Perl code (later)
argRank (Switch '0')         = 100  -- translated into Perl code (later)
argRank (Opt "-e" _)         = 100  -- translated into Perl code
argRank _                    = 100  -- filename or @ARGS or whatever

gatherArgs :: [String] -> [Arg]
gatherArgs [] = []
gatherArgs ("-e":frag:rest)        = [Opt "-e" frag] ++ gatherArgs(rest)
gatherArgs ("--external":mod:rest) = [Opt "--external" mod] ++ gatherArgs(rest)
gatherArgs ("-I":dir:rest)         = [Opt "-I" dir] ++ gatherArgs(rest)
gatherArgs ("-M":mod:rest)         = [Opt "-M" mod] ++ gatherArgs(rest)
gatherArgs ("-C":backend:rest)     = [Opt "-C" backend] ++ gatherArgs(rest)
gatherArgs ("-B":backend:rest)     = [Opt "-B" backend] ++ gatherArgs(rest)
gatherArgs ("-V:":item:rest)       = [Opt "-V:" item] ++ gatherArgs(rest)
gatherArgs (('-':[]):xs)           = [File "-"] ++ gatherArgs(xs)
gatherArgs (("--"):rest)           = [File x | x <- rest]
gatherArgs (('-':x:[]):xs)         = [Switch x] ++ gatherArgs(xs)
gatherArgs (x:xs)                  = [File x] ++ gatherArgs(xs)

{- collect "-e" switches together,
   handle transformation of "-M", "-n"
   and "-p" into "-e" fragments
-}
desugarDashE :: [Arg] -> [Arg]
desugarDashE [] = []
desugarDashE ((Switch 'p'):args) = desugarDashE $
    (Opt "-e" "env $_; while (defined($_ = =<>)) { " : args) ++ [Opt "-e" "; say $_; }"]
desugarDashE ((Switch 'n'):args) = desugarDashE $
    (Opt "-e" "env $_; while (defined($_ = =<>)) { " : args) ++ [Opt "-e" "}"]

-- -E is like -e, but not accessible as a normal parameter and used only
-- internally:
--   "-e foo bar.pl" executes "foo" with @*ARGS[0] eq "bar.pl",
--   "-E foo bar.pl" executes "foo" and then bar.pl.
desugarDashE ((Opt "-M" mod):args)
    | (mod', (_:args)) <- break (== '=') mod
    = useWith $ mod' ++ " '" ++ escape args ++ "'.split(',')"
    | otherwise
    = useWith mod
    where
    useWith mod = desugarDashE ((Opt "-E" (";use " ++ mod ++ ";\n")):args)
    escape [] = []
    escape ('\'':xs) = '\\':'\'':escape xs
    escape ('\\':xs) = '\\':'\\':escape xs
    escape (x:xs) = x:escape xs


-- Preserve the curious Perl5 behaviour:
--   perl -e 'print CGI->VERSION' -MCGI     # works
--   perl print_cgi.pl -MCGI                # fails
desugarDashE (x@(Opt "-e" _):y@(Opt "-E" _):args) = desugarDashE (y:x:args)
desugarDashE ((Opt "-E" a):y@(Opt "-e" _):args) = desugarDashE ((Opt "-e" a):y:args)
desugarDashE (x:xs) = (x:desugarDashE xs)