    {-# 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 -- deliberately leave the methods unimplemented
    instance Read (NoShow a) where -- deliberately leave the methods unimplemented

    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