content: {-# LANGUAGE RecordWildCards, TypeSynonymInstances, FlexibleInstances #-}
  
  -- | Module for implementing CmdArgs helpers. A CmdArgs helper is an external program,
  --   that helps a user construct the command line arguments. To use a helper set the
  --   environment variable @$CMDARGS_HELPER@ (or @$CMDARGS_HELPER_/YOURPROGRAM/@) to
  --   one of:
  --
  -- * @echo /foo/@ will cause @/foo/@ to be used as the command arguments.
  --
  -- * @cmdargs-browser@ will cause a web browser to appear to help entering the arguments.
  --   For this command to work, you will need to install the @cmdargs-browser@ package:
  --   <http://hackage.haskell.org/package/cmdargs-browser>
  module System.Console.CmdArgs.Helper(
      -- * Called by the main program
      execute,
      -- * Called by the helper program
      Unknown, receive, reply, comment
      ) where
  -- Should really be under Explicit, but want to export it top-level as Helper
  
  import System.Console.CmdArgs.Explicit.Type
  import System.Console.CmdArgs.Explicit.SplitJoin
  import System.Process
  import Control.Exception
  import Control.Monad
  import Data.Char
  import Data.IORef
  import Data.List
  import Data.Maybe
  import System.Exit
  import System.IO
  import System.IO.Unsafe
  
  
  hOut h x = do
      hPutStrLn h x
      hFlush h
  
  
  -- | Run a remote command line entry.
  execute
      :: String -- ^ Name of the command to run, e.g. @echo argument@, @cmdargs-browser@
      -> Mode a -- ^ Mode to run remotely
      -> [String] -- ^ Initial set of command line flags (not supported by all helpers)
      -> IO (Either String [String]) -- ^ Either an error message, or a list of flags to use
  execute cmd mode args
      | "echo" == takeWhile (not . isSpace) cmd = return $ Right $ splitArgs $ drop 4 cmd
      | otherwise = withBuffering stdout NoBuffering $ do
          (Just hin, Just hout, _, _) <- createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe}
          -- none of the buffering seems necessary in practice, but better safe than sorry
          hSetBuffering hin LineBuffering
          hSetBuffering hout LineBuffering
          (m, ans) <- saveMode mode
          hOut hin m
          loop ans hin hout
      where
          loop ans hin hout = do
              x <- hGetLine hout
              if "Result " `isPrefixOf` x then
                  return $ read $ drop 7 x
               else if "Send " `isPrefixOf` x then do
                  hOut hin =<< ans (drop 5 x)
                  loop ans hin hout
               else if "#" `isPrefixOf` x then do
                  hOut stdout x
                  loop ans hin hout
               else
                  return $ Left $ "Unexpected message from program: " ++ show x
  
  
  withBuffering hndl mode act = bracket
      (do old <- hGetBuffering hndl; hSetBuffering hndl mode; return old)
      (hSetBuffering hndl)
      (const act)
  
  
  -- | Unknown value, representing the values stored within the 'Mode' structure. While the values
  --   are not observable, they behave identically to the original values.
  newtype Unknown = Unknown {fromUnknown :: Value} -- wrap Value so the Pack instance doesn't leak
  
  
  -- | Receive information about the mode to display.
  receive :: IO (Mode Unknown)
  receive = do
      m <- getLine
      return $ remap2 Unknown fromUnknown $ loadMode m $ \msg -> unsafePerformIO $ do
          hOut stdout $ "Send " ++ msg
          getLine
  
  
  -- | Send a reply with either an error, or a list of flags to use. This function exits the helper program.
  reply :: Either String [String] -> IO ()
  reply x = do
      hOut stdout $ "Result " ++ show x
      exitWith ExitSuccess
  
  
  -- | Send a comment which will be displayed on the calling console, mainly useful for debugging.
  comment :: String -> IO ()
  comment x = hOut stdout $ "# " ++ x
  
  
  ---------------------------------------------------------------------
  -- IO MAP
  
  data IOMap a = IOMap (IORef (Int,[(Int,a)]))
  
  newIOMap :: IO (IOMap a)
  newIOMap = fmap IOMap $ newIORef (0, [])
  
  addIOMap :: IOMap a -> a -> IO Int
  addIOMap (IOMap ref) x = atomicModifyIORef ref $ \(i,xs) -> let j = i+1 in ((j,(j,x):xs), j)
  
  getIOMap :: IOMap a -> Int -> IO a
  getIOMap (IOMap ref) i = do (_,xs) <- readIORef ref; return $ fromJust $ lookup i xs
  
  
  ---------------------------------------------------------------------
  -- SERIALISE A MODE
  
  newtype Value = Value Int
  
  
  {-# NOINLINE toValue #-}
  toValue :: Mode a -> Mode Value
  -- fairly safe, use of a table and pointers from one process to another, but referentially transparent
  toValue x = unsafePerformIO $ do
      -- the ref accumulates, so is a space leak
      -- but it will all disappear after the helper goes, so not too much of an issue
      mp <- newIOMap
      let embed x = unsafePerformIO $ fmap Value $ addIOMap mp x
          proj (Value x) = unsafePerformIO $ getIOMap mp x
      return $ remap2 embed proj x
  
  
  saveMode :: Mode a -> IO (String, String -> IO String) -- (value, ask questions from stdin)
  saveMode m = do
      mp <- newIOMap
      res <- add mp $ pack $ toValue m
      return $ (show res, fmap show . get mp . read)
      where
          add :: IOMap (Pack -> Pack) -> Pack -> IO Pack
          add mp x = flip transformM x $ \x -> case x of
              Func (NoShow f) -> do i <- addIOMap mp f; return $ FuncId i
              x -> return x
  
          get :: IOMap (Pack -> Pack) -> (Int,Pack) -> IO Pack
          get mp (i,x) = do
              f <- getIOMap mp i
              add mp $ f x
  
  
  loadMode :: String -> (String -> String) -> Mode Value -- given serialised, question asker, give me a value
  loadMode x f = unpack $ rep $ read x
      where
          rep :: Pack -> Pack
          rep x = flip transform x $ \x -> case x of
              FuncId i -> Func $ NoShow $ \y -> rep $ read $ f $ show (i,y)
              x -> x
  
  
  -- Support data types
  
  data Pack = Ctor String [(String, Pack)]
            | List [Pack]
            | Char Char
            | Int Int
            | Func (NoShow (Pack -> Pack))
            | FuncId Int -- Never passed to pack/unpack, always transfromed away by saveMode/loadMode
            | String String
            | None -- ^ Never generated, only used for reading in bad cases
              deriving (Show,Read)
  
  newtype NoShow a = NoShow a
  instance Show (NoShow a) where showsPrec = error "Cannot show value of type NoShow"
  instance Read (NoShow a) where readsPrec = error "Cannot read value of type NoShow"
  
  
  transformM, descendM :: Monad m => (Pack -> m Pack) -> Pack -> m Pack
  transformM f x = f =<< descendM (transformM f) x
  descendM f x = let (a,b) = uniplate x in liftM b $ mapM f a
  
  transform, descend :: (Pack -> Pack) -> Pack -> Pack
  transform f = f . descend (transform f)
  descend f x = let (a,b) = uniplate x in b $ map f a
  
  uniplate :: Pack -> ([Pack], [Pack] -> Pack)
  uniplate (List xs) = (xs, List)
  uniplate (Ctor x ys) = (map snd ys, Ctor x . zip (map fst ys))
  uniplate x = ([], const x)
  
  
  class Packer a where
      pack :: a -> Pack
      unpack :: Pack -> a
  
  add a b = (a, pack b)
  ctor x (Ctor y xs) | x == y = xs
  ctor _ _ = []
  get a b = unpack $ fromMaybe None $ lookup a b
  
  
  -- General instances
  
  instance Packer a => Packer [a] where
      pack xs = if length ys == length zs && not (null ys) then String zs else List ys
          where ys = map (pack) xs
                zs = [x | Char x <- ys]
  
      unpack (String xs) = unpack $ List $ map Char xs
      unpack (List xs) = map (unpack) xs
      unpack _ = []
  
  instance (Packer a, Packer b) => Packer (a -> b) where
      pack f = Func $ NoShow $ pack . f . unpack
      unpack (Func (NoShow f)) = unpack . f . pack
  
  instance Packer Value where
      pack (Value x) = pack x
      unpack x = Value $ unpack x
  
  instance Packer Char where
      pack = Char
      unpack (Char x) = x
      unpack _ = ' '
  
  instance Packer Int where
      pack = Int
      unpack (Int x) = x
      unpack _ = -1
  
  instance (Packer a, Packer b) => Packer (a,b) where
      pack (a,b) = Ctor "(,)" [add "fst" a, add "snd" b]
      unpack x = (get "fst" y, get "snd" y)
          where y = ctor "(,)" x
  
  instance Packer a => Packer (Maybe a) where
      pack Nothing = Ctor "Nothing" []
      pack (Just x) = Ctor "Just" [add "fromJust" x]
      unpack x@(Ctor "Just" _) = Just $ get "fromJust" $ ctor "Just" x
      unpack _ = Nothing
  
  instance (Packer a, Packer b) => Packer (Either a b) where
      pack (Left x) = Ctor "Left" [add "fromLeft" x]
      pack (Right x) = Ctor "Right" [add "fromRight" x]
      unpack x@(Ctor "Left" _) = Left $ get "fromLeft" $ ctor "Left" x
      unpack x@(Ctor "Right" _) = Right $ get "fromRight" $ ctor "Right" x
      unpack _ = Left $ unpack None
  
  instance Packer Bool where
      pack True = Ctor "True" []
      pack _ = Ctor "False" []
      unpack (Ctor "True" _) = True
      unpack _ = False
  
  
  -- CmdArgs specific
  
  instance Packer a => Packer (Group a) where
      pack Group{..} = Ctor "Group"
          [add "groupUnnamed" groupUnnamed
          ,add "groupHidden" groupHidden
          ,add "groupNamed" groupNamed]
      unpack x = let y = ctor "Group" x in Group
          {groupUnnamed = get "groupUnnamed" y
          ,groupHidden = get "groupHidden" y
          ,groupNamed = get "groupNamed" y}
  
  instance Packer a => Packer (Mode a) where
      pack Mode{..} = Ctor "Mode"
          [add "modeGroupModes" modeGroupModes
          ,add "modeNames" modeNames
          ,add "modeHelp" modeHelp
          ,add "modeHelpSuffix" modeHelpSuffix
          ,add "modeArgs" modeArgs
          ,add "modeGroupFlags" modeGroupFlags
          ,add "modeValue" modeValue
          ,add "modeCheck" modeCheck
          ,add "modeReform" modeReform
          ,add "modeExpandAt" modeExpandAt]
      unpack x = let y = ctor "Mode" x in Mode
          {modeGroupModes = get "modeGroupModes" y
          ,modeNames = get "modeNames" y
          ,modeHelp = get "modeHelp" y
          ,modeHelpSuffix = get "modeHelpSuffix" y
          ,modeArgs = get "modeArgs" y
          ,modeGroupFlags = get "modeGroupFlags" y
          ,modeValue = get "modeValue" y
          ,modeCheck = get "modeCheck" y
          ,modeReform = get "modeReform" y
          ,modeExpandAt = get "modeExpandAt" y}
  
  instance Packer a => Packer (Flag a) where
      pack Flag{..} = Ctor "Flag"
          [add "flagNames" flagNames
          ,add "flagInfo" flagInfo
          ,add "flagType" flagType
          ,add "flagHelp" flagHelp
          ,add "flagValue" flagValue]
      unpack x = let y = ctor "Flag" x in Flag
          {flagNames = get "flagNames" y
          ,flagInfo = get "flagInfo" y
          ,flagType = get "flagType" y
          ,flagHelp = get "flagHelp" y
          ,flagValue = get "flagValue" y}
  
  instance Packer a => Packer (Arg a) where
      pack Arg{..} = Ctor "Arg"
          [add "argType" argType
          ,add "argRequire" argRequire
          ,add "argValue" argValue]
      unpack x = let y = ctor "Arg" x in Arg
          {argType = get "argType" y
          ,argRequire = get "argRequire" y
          ,argValue = get "argValue" y}
  
  instance Packer FlagInfo where
      pack FlagReq = Ctor "FlagReq" []
      pack (FlagOpt x) = Ctor "FlagOpt" [add "fromFlagOpt" x]
      pack (FlagOptRare x) = Ctor "FlagOptRare" [add "fromFlagOpt" x]
      pack FlagNone = Ctor "FlagNone" []
      unpack x@(Ctor name _) = case name of
          "FlagReq" -> FlagReq
          "FlagOpt" -> FlagOpt $ get "fromFlagOpt" $ ctor name x
          "FlagOptRare" -> FlagOptRare $ get "fromFlagOpt" $ ctor name x
          "FlagNone" -> FlagNone
      unpack _ = FlagNone
  