cmdargs-0.10.22: System/Console/CmdArgs/Helper.hs
{-# 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