{-# LANGUAGE RecordWildCards, TypeSynonymInstances, FlexibleInstances #-}
module System.Console.CmdArgs.Helper(
execute,
Unknown, receive, reply, comment
) where
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 :: Handle -> String -> IO ()
hOut h :: Handle
h x :: String
x = do
Handle -> String -> IO ()
hPutStrLn Handle
h String
x
Handle -> IO ()
hFlush Handle
h
execute
:: String
-> Mode a
-> [String]
-> IO (Either String [String])
execute :: String -> Mode a -> [String] -> IO (Either String [String])
execute cmd :: String
cmd mode :: Mode a
mode args :: [String]
args
| "echo" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) String
cmd = Either String [String] -> IO (Either String [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [String] -> IO (Either String [String]))
-> Either String [String] -> IO (Either String [String])
forall a b. (a -> b) -> a -> b
$ [String] -> Either String [String]
forall a b. b -> Either a b
Right ([String] -> Either String [String])
-> [String] -> Either String [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitArgs (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 4 String
cmd
| Bool
otherwise = Handle
-> BufferMode
-> IO (Either String [String])
-> IO (Either String [String])
forall c. Handle -> BufferMode -> IO c -> IO c
withBuffering Handle
stdout BufferMode
NoBuffering (IO (Either String [String]) -> IO (Either String [String]))
-> IO (Either String [String]) -> IO (Either String [String])
forall a b. (a -> b) -> a -> b
$ do
(Just hin :: Handle
hin, Just hout :: Handle
hout, _, _) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> CreateProcess
shell String
cmd){std_in :: StdStream
std_in=StdStream
CreatePipe, std_out :: StdStream
std_out=StdStream
CreatePipe}
Handle -> BufferMode -> IO ()
hSetBuffering Handle
hin BufferMode
LineBuffering
Handle -> BufferMode -> IO ()
hSetBuffering Handle
hout BufferMode
LineBuffering
(m :: String
m, ans :: String -> IO String
ans) <- Mode a -> IO (String, String -> IO String)
forall a. Mode a -> IO (String, String -> IO String)
saveMode Mode a
mode
Handle -> String -> IO ()
hOut Handle
hin String
m
(String -> IO String)
-> Handle -> Handle -> IO (Either String [String])
forall b.
Read b =>
(String -> IO String) -> Handle -> Handle -> IO (Either String b)
loop String -> IO String
ans Handle
hin Handle
hout
where
loop :: (String -> IO String) -> Handle -> Handle -> IO (Either String b)
loop ans :: String -> IO String
ans hin :: Handle
hin hout :: Handle
hout = do
String
x <- Handle -> IO String
hGetLine Handle
hout
if "Result " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x then
Either String b -> IO (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> IO (Either String b))
-> Either String b -> IO (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a. Read a => String -> a
read (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 7 String
x
else if "Send " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x then do
Handle -> String -> IO ()
hOut Handle
hin (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
ans (Int -> String -> String
forall a. Int -> [a] -> [a]
drop 5 String
x)
(String -> IO String) -> Handle -> Handle -> IO (Either String b)
loop String -> IO String
ans Handle
hin Handle
hout
else if "#" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x then do
Handle -> String -> IO ()
hOut Handle
stdout String
x
(String -> IO String) -> Handle -> Handle -> IO (Either String b)
loop String -> IO String
ans Handle
hin Handle
hout
else
Either String b -> IO (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> IO (Either String b))
-> Either String b -> IO (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ "Unexpected message from program: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x
withBuffering :: Handle -> BufferMode -> IO c -> IO c
withBuffering hndl :: Handle
hndl mode :: BufferMode
mode act :: IO c
act = IO BufferMode
-> (BufferMode -> IO ()) -> (BufferMode -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(do BufferMode
old <- Handle -> IO BufferMode
hGetBuffering Handle
hndl; Handle -> BufferMode -> IO ()
hSetBuffering Handle
hndl BufferMode
mode; BufferMode -> IO BufferMode
forall (m :: * -> *) a. Monad m => a -> m a
return BufferMode
old)
(Handle -> BufferMode -> IO ()
hSetBuffering Handle
hndl)
(IO c -> BufferMode -> IO c
forall a b. a -> b -> a
const IO c
act)
newtype Unknown = Unknown {Unknown -> Value
fromUnknown :: Value}
receive :: IO (Mode Unknown)
receive :: IO (Mode Unknown)
receive = do
String
m <- IO String
getLine
Mode Unknown -> IO (Mode Unknown)
forall (m :: * -> *) a. Monad m => a -> m a
return (Mode Unknown -> IO (Mode Unknown))
-> Mode Unknown -> IO (Mode Unknown)
forall a b. (a -> b) -> a -> b
$ (Value -> Unknown)
-> (Unknown -> Value) -> Mode Value -> Mode Unknown
forall (m :: * -> *) a b.
Remap m =>
(a -> b) -> (b -> a) -> m a -> m b
remap2 Value -> Unknown
Unknown Unknown -> Value
fromUnknown (Mode Value -> Mode Unknown) -> Mode Value -> Mode Unknown
forall a b. (a -> b) -> a -> b
$ String -> (String -> String) -> Mode Value
loadMode String
m ((String -> String) -> Mode Value)
-> (String -> String) -> Mode Value
forall a b. (a -> b) -> a -> b
$ \msg :: String
msg -> IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hOut Handle
stdout (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Send " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
IO String
getLine
reply :: Either String [String] -> IO ()
reply :: Either String [String] -> IO ()
reply x :: Either String [String]
x = do
Handle -> String -> IO ()
hOut Handle
stdout (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Result " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Either String [String] -> String
forall a. Show a => a -> String
show Either String [String]
x
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
comment :: String -> IO ()
x :: String
x = Handle -> String -> IO ()
hOut Handle
stdout (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "# " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
data IOMap a = IOMap (IORef (Int,[(Int,a)]))
newIOMap :: IO (IOMap a)
newIOMap :: IO (IOMap a)
newIOMap = (IORef (Int, [(Int, a)]) -> IOMap a)
-> IO (IORef (Int, [(Int, a)])) -> IO (IOMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef (Int, [(Int, a)]) -> IOMap a
forall a. IORef (Int, [(Int, a)]) -> IOMap a
IOMap (IO (IORef (Int, [(Int, a)])) -> IO (IOMap a))
-> IO (IORef (Int, [(Int, a)])) -> IO (IOMap a)
forall a b. (a -> b) -> a -> b
$ (Int, [(Int, a)]) -> IO (IORef (Int, [(Int, a)]))
forall a. a -> IO (IORef a)
newIORef (0, [])
addIOMap :: IOMap a -> a -> IO Int
addIOMap :: IOMap a -> a -> IO Int
addIOMap (IOMap ref :: IORef (Int, [(Int, a)])
ref) x :: a
x = IORef (Int, [(Int, a)])
-> ((Int, [(Int, a)]) -> ((Int, [(Int, a)]), Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Int, [(Int, a)])
ref (((Int, [(Int, a)]) -> ((Int, [(Int, a)]), Int)) -> IO Int)
-> ((Int, [(Int, a)]) -> ((Int, [(Int, a)]), Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i,xs :: [(Int, a)]
xs) -> let j :: Int
j = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1 in ((Int
j,(Int
j,a
x)(Int, a) -> [(Int, a)] -> [(Int, a)]
forall a. a -> [a] -> [a]
:[(Int, a)]
xs), Int
j)
getIOMap :: IOMap a -> Int -> IO a
getIOMap :: IOMap a -> Int -> IO a
getIOMap (IOMap ref :: IORef (Int, [(Int, a)])
ref) i :: Int
i = do (_,xs :: [(Int, a)]
xs) <- IORef (Int, [(Int, a)]) -> IO (Int, [(Int, a)])
forall a. IORef a -> IO a
readIORef IORef (Int, [(Int, a)])
ref; a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, a)]
xs
newtype Value = Value Int
{-# NOINLINE toValue #-}
toValue :: Mode a -> Mode Value
toValue :: Mode a -> Mode Value
toValue x :: Mode a
x = IO (Mode Value) -> Mode Value
forall a. IO a -> a
unsafePerformIO (IO (Mode Value) -> Mode Value) -> IO (Mode Value) -> Mode Value
forall a b. (a -> b) -> a -> b
$ do
IOMap a
mp <- IO (IOMap a)
forall a. IO (IOMap a)
newIOMap
let embed :: a -> Value
embed x :: a
x = IO Value -> Value
forall a. IO a -> a
unsafePerformIO (IO Value -> Value) -> IO Value -> Value
forall a b. (a -> b) -> a -> b
$ (Int -> Value) -> IO Int -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Value
Value (IO Int -> IO Value) -> IO Int -> IO Value
forall a b. (a -> b) -> a -> b
$ IOMap a -> a -> IO Int
forall a. IOMap a -> a -> IO Int
addIOMap IOMap a
mp a
x
proj :: Value -> a
proj (Value x :: Int
x) = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ IOMap a -> Int -> IO a
forall a. IOMap a -> Int -> IO a
getIOMap IOMap a
mp Int
x
Mode Value -> IO (Mode Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Mode Value -> IO (Mode Value)) -> Mode Value -> IO (Mode Value)
forall a b. (a -> b) -> a -> b
$ (a -> Value) -> (Value -> a) -> Mode a -> Mode Value
forall (m :: * -> *) a b.
Remap m =>
(a -> b) -> (b -> a) -> m a -> m b
remap2 a -> Value
embed Value -> a
proj Mode a
x
saveMode :: Mode a -> IO (String, String -> IO String)
saveMode :: Mode a -> IO (String, String -> IO String)
saveMode m :: Mode a
m = do
IOMap (Pack -> Pack)
mp <- IO (IOMap (Pack -> Pack))
forall a. IO (IOMap a)
newIOMap
Pack
res <- IOMap (Pack -> Pack) -> Pack -> IO Pack
add IOMap (Pack -> Pack)
mp (Pack -> IO Pack) -> Pack -> IO Pack
forall a b. (a -> b) -> a -> b
$ Mode Value -> Pack
forall a. Packer a => a -> Pack
pack (Mode Value -> Pack) -> Mode Value -> Pack
forall a b. (a -> b) -> a -> b
$ Mode a -> Mode Value
forall a. Mode a -> Mode Value
toValue Mode a
m
(String, String -> IO String) -> IO (String, String -> IO String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String -> IO String) -> IO (String, String -> IO String))
-> (String, String -> IO String)
-> IO (String, String -> IO String)
forall a b. (a -> b) -> a -> b
$ (Pack -> String
forall a. Show a => a -> String
show Pack
res, (Pack -> String) -> IO Pack -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pack -> String
forall a. Show a => a -> String
show (IO Pack -> IO String)
-> (String -> IO Pack) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOMap (Pack -> Pack) -> (Int, Pack) -> IO Pack
get IOMap (Pack -> Pack)
mp ((Int, Pack) -> IO Pack)
-> (String -> (Int, Pack)) -> String -> IO Pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Int, Pack)
forall a. Read a => String -> a
read)
where
add :: IOMap (Pack -> Pack) -> Pack -> IO Pack
add :: IOMap (Pack -> Pack) -> Pack -> IO Pack
add mp :: IOMap (Pack -> Pack)
mp x :: Pack
x = ((Pack -> IO Pack) -> Pack -> IO Pack)
-> Pack -> (Pack -> IO Pack) -> IO Pack
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Pack -> IO Pack) -> Pack -> IO Pack
forall (m :: * -> *). Monad m => (Pack -> m Pack) -> Pack -> m Pack
transformM Pack
x ((Pack -> IO Pack) -> IO Pack) -> (Pack -> IO Pack) -> IO Pack
forall a b. (a -> b) -> a -> b
$ \x :: Pack
x -> case Pack
x of
Func (NoShow f :: Pack -> Pack
f) -> do Int
i <- IOMap (Pack -> Pack) -> (Pack -> Pack) -> IO Int
forall a. IOMap a -> a -> IO Int
addIOMap IOMap (Pack -> Pack)
mp Pack -> Pack
f; Pack -> IO Pack
forall (m :: * -> *) a. Monad m => a -> m a
return (Pack -> IO Pack) -> Pack -> IO Pack
forall a b. (a -> b) -> a -> b
$ Int -> Pack
FuncId Int
i
x :: Pack
x -> Pack -> IO Pack
forall (m :: * -> *) a. Monad m => a -> m a
return Pack
x
get :: IOMap (Pack -> Pack) -> (Int,Pack) -> IO Pack
get :: IOMap (Pack -> Pack) -> (Int, Pack) -> IO Pack
get mp :: IOMap (Pack -> Pack)
mp (i :: Int
i,x :: Pack
x) = do
Pack -> Pack
f <- IOMap (Pack -> Pack) -> Int -> IO (Pack -> Pack)
forall a. IOMap a -> Int -> IO a
getIOMap IOMap (Pack -> Pack)
mp Int
i
IOMap (Pack -> Pack) -> Pack -> IO Pack
add IOMap (Pack -> Pack)
mp (Pack -> IO Pack) -> Pack -> IO Pack
forall a b. (a -> b) -> a -> b
$ Pack -> Pack
f Pack
x
loadMode :: String -> (String -> String) -> Mode Value
loadMode :: String -> (String -> String) -> Mode Value
loadMode x :: String
x f :: String -> String
f = Pack -> Mode Value
forall a. Packer a => Pack -> a
unpack (Pack -> Mode Value) -> Pack -> Mode Value
forall a b. (a -> b) -> a -> b
$ Pack -> Pack
rep (Pack -> Pack) -> Pack -> Pack
forall a b. (a -> b) -> a -> b
$ String -> Pack
forall a. Read a => String -> a
read String
x
where
rep :: Pack -> Pack
rep :: Pack -> Pack
rep x :: Pack
x = ((Pack -> Pack) -> Pack -> Pack) -> Pack -> (Pack -> Pack) -> Pack
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Pack -> Pack) -> Pack -> Pack
transform Pack
x ((Pack -> Pack) -> Pack) -> (Pack -> Pack) -> Pack
forall a b. (a -> b) -> a -> b
$ \x :: Pack
x -> case Pack
x of
FuncId i :: Int
i -> NoShow (Pack -> Pack) -> Pack
Func (NoShow (Pack -> Pack) -> Pack) -> NoShow (Pack -> Pack) -> Pack
forall a b. (a -> b) -> a -> b
$ (Pack -> Pack) -> NoShow (Pack -> Pack)
forall a. a -> NoShow a
NoShow ((Pack -> Pack) -> NoShow (Pack -> Pack))
-> (Pack -> Pack) -> NoShow (Pack -> Pack)
forall a b. (a -> b) -> a -> b
$ \y :: Pack
y -> Pack -> Pack
rep (Pack -> Pack) -> Pack -> Pack
forall a b. (a -> b) -> a -> b
$ String -> Pack
forall a. Read a => String -> a
read (String -> Pack) -> String -> Pack
forall a b. (a -> b) -> a -> b
$ String -> String
f (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Int, Pack) -> String
forall a. Show a => a -> String
show (Int
i,Pack
y)
x :: Pack
x -> Pack
x
data Pack = Ctor String [(String, Pack)]
| List [Pack]
| Char Char
| Int Int
| Func (NoShow (Pack -> Pack))
| FuncId Int
| String String
| None
deriving (Int -> Pack -> String -> String
[Pack] -> String -> String
Pack -> String
(Int -> Pack -> String -> String)
-> (Pack -> String) -> ([Pack] -> String -> String) -> Show Pack
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Pack] -> String -> String
$cshowList :: [Pack] -> String -> String
show :: Pack -> String
$cshow :: Pack -> String
showsPrec :: Int -> Pack -> String -> String
$cshowsPrec :: Int -> Pack -> String -> String
Show,ReadPrec [Pack]
ReadPrec Pack
Int -> ReadS Pack
ReadS [Pack]
(Int -> ReadS Pack)
-> ReadS [Pack] -> ReadPrec Pack -> ReadPrec [Pack] -> Read Pack
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Pack]
$creadListPrec :: ReadPrec [Pack]
readPrec :: ReadPrec Pack
$creadPrec :: ReadPrec Pack
readList :: ReadS [Pack]
$creadList :: ReadS [Pack]
readsPrec :: Int -> ReadS Pack
$creadsPrec :: Int -> ReadS Pack
Read)
newtype NoShow a = NoShow a
instance Show (NoShow a) where showsPrec :: Int -> NoShow a -> String -> String
showsPrec = String -> Int -> NoShow a -> String -> String
forall a. HasCallStack => String -> a
error "Cannot show value of type NoShow"
instance Read (NoShow a) where readsPrec :: Int -> ReadS (NoShow a)
readsPrec = String -> Int -> ReadS (NoShow a)
forall a. HasCallStack => String -> a
error "Cannot read value of type NoShow"
transformM, descendM :: Monad m => (Pack -> m Pack) -> Pack -> m Pack
transformM :: (Pack -> m Pack) -> Pack -> m Pack
transformM f :: Pack -> m Pack
f x :: Pack
x = Pack -> m Pack
f (Pack -> m Pack) -> m Pack -> m Pack
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Pack -> m Pack) -> Pack -> m Pack
forall (m :: * -> *). Monad m => (Pack -> m Pack) -> Pack -> m Pack
descendM ((Pack -> m Pack) -> Pack -> m Pack
forall (m :: * -> *). Monad m => (Pack -> m Pack) -> Pack -> m Pack
transformM Pack -> m Pack
f) Pack
x
descendM :: (Pack -> m Pack) -> Pack -> m Pack
descendM f :: Pack -> m Pack
f x :: Pack
x = let (a :: [Pack]
a,b :: [Pack] -> Pack
b) = Pack -> ([Pack], [Pack] -> Pack)
uniplate Pack
x in ([Pack] -> Pack) -> m [Pack] -> m Pack
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Pack] -> Pack
b (m [Pack] -> m Pack) -> m [Pack] -> m Pack
forall a b. (a -> b) -> a -> b
$ (Pack -> m Pack) -> [Pack] -> m [Pack]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pack -> m Pack
f [Pack]
a
transform, descend :: (Pack -> Pack) -> Pack -> Pack
transform :: (Pack -> Pack) -> Pack -> Pack
transform f :: Pack -> Pack
f = Pack -> Pack
f (Pack -> Pack) -> (Pack -> Pack) -> Pack -> Pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pack -> Pack) -> Pack -> Pack
descend ((Pack -> Pack) -> Pack -> Pack
transform Pack -> Pack
f)
descend :: (Pack -> Pack) -> Pack -> Pack
descend f :: Pack -> Pack
f x :: Pack
x = let (a :: [Pack]
a,b :: [Pack] -> Pack
b) = Pack -> ([Pack], [Pack] -> Pack)
uniplate Pack
x in [Pack] -> Pack
b ([Pack] -> Pack) -> [Pack] -> Pack
forall a b. (a -> b) -> a -> b
$ (Pack -> Pack) -> [Pack] -> [Pack]
forall a b. (a -> b) -> [a] -> [b]
map Pack -> Pack
f [Pack]
a
uniplate :: Pack -> ([Pack], [Pack] -> Pack)
uniplate :: Pack -> ([Pack], [Pack] -> Pack)
uniplate (List xs :: [Pack]
xs) = ([Pack]
xs, [Pack] -> Pack
List)
uniplate (Ctor x :: String
x ys :: [(String, Pack)]
ys) = (((String, Pack) -> Pack) -> [(String, Pack)] -> [Pack]
forall a b. (a -> b) -> [a] -> [b]
map (String, Pack) -> Pack
forall a b. (a, b) -> b
snd [(String, Pack)]
ys, String -> [(String, Pack)] -> Pack
Ctor String
x ([(String, Pack)] -> Pack)
-> ([Pack] -> [(String, Pack)]) -> [Pack] -> Pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [Pack] -> [(String, Pack)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, Pack) -> String) -> [(String, Pack)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Pack) -> String
forall a b. (a, b) -> a
fst [(String, Pack)]
ys))
uniplate x :: Pack
x = ([], Pack -> [Pack] -> Pack
forall a b. a -> b -> a
const Pack
x)
class Packer a where
pack :: a -> Pack
unpack :: Pack -> a
add :: a -> a -> (a, Pack)
add a :: a
a b :: a
b = (a
a, a -> Pack
forall a. Packer a => a -> Pack
pack a
b)
ctor :: String -> Pack -> [(String, Pack)]
ctor x :: String
x (Ctor y :: String
y xs :: [(String, Pack)]
xs) | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y = [(String, Pack)]
xs
ctor _ _ = []
get :: a -> [(a, Pack)] -> a
get a :: a
a b :: [(a, Pack)]
b = Pack -> a
forall a. Packer a => Pack -> a
unpack (Pack -> a) -> Pack -> a
forall a b. (a -> b) -> a -> b
$ Pack -> Maybe Pack -> Pack
forall a. a -> Maybe a -> a
fromMaybe Pack
None (Maybe Pack -> Pack) -> Maybe Pack -> Pack
forall a b. (a -> b) -> a -> b
$ a -> [(a, Pack)] -> Maybe Pack
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a [(a, Pack)]
b
instance Packer a => Packer [a] where
pack :: [a] -> Pack
pack xs :: [a]
xs = if [Pack] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pack]
ys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
zs Bool -> Bool -> Bool
&& Bool -> Bool
not ([Pack] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pack]
ys) then String -> Pack
String String
zs else [Pack] -> Pack
List [Pack]
ys
where ys :: [Pack]
ys = (a -> Pack) -> [a] -> [Pack]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Pack
forall a. Packer a => a -> Pack
pack) [a]
xs
zs :: String
zs = [Char
x | Char x :: Char
x <- [Pack]
ys]
unpack :: Pack -> [a]
unpack (String xs :: String
xs) = Pack -> [a]
forall a. Packer a => Pack -> a
unpack (Pack -> [a]) -> Pack -> [a]
forall a b. (a -> b) -> a -> b
$ [Pack] -> Pack
List ([Pack] -> Pack) -> [Pack] -> Pack
forall a b. (a -> b) -> a -> b
$ (Char -> Pack) -> String -> [Pack]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Pack
Char String
xs
unpack (List xs :: [Pack]
xs) = (Pack -> a) -> [Pack] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Pack -> a
forall a. Packer a => Pack -> a
unpack) [Pack]
xs
unpack _ = []
instance (Packer a, Packer b) => Packer (a -> b) where
pack :: (a -> b) -> Pack
pack f :: a -> b
f = NoShow (Pack -> Pack) -> Pack
Func (NoShow (Pack -> Pack) -> Pack) -> NoShow (Pack -> Pack) -> Pack
forall a b. (a -> b) -> a -> b
$ (Pack -> Pack) -> NoShow (Pack -> Pack)
forall a. a -> NoShow a
NoShow ((Pack -> Pack) -> NoShow (Pack -> Pack))
-> (Pack -> Pack) -> NoShow (Pack -> Pack)
forall a b. (a -> b) -> a -> b
$ b -> Pack
forall a. Packer a => a -> Pack
pack (b -> Pack) -> (Pack -> b) -> Pack -> Pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> b) -> (Pack -> a) -> Pack -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pack -> a
forall a. Packer a => Pack -> a
unpack
unpack :: Pack -> a -> b
unpack (Func (NoShow f :: Pack -> Pack
f)) = Pack -> b
forall a. Packer a => Pack -> a
unpack (Pack -> b) -> (a -> Pack) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pack -> Pack
f (Pack -> Pack) -> (a -> Pack) -> a -> Pack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Pack
forall a. Packer a => a -> Pack
pack
instance Packer Value where
pack :: Value -> Pack
pack (Value x :: Int
x) = Int -> Pack
forall a. Packer a => a -> Pack
pack Int
x
unpack :: Pack -> Value
unpack x :: Pack
x = Int -> Value
Value (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Pack -> Int
forall a. Packer a => Pack -> a
unpack Pack
x
instance Packer Char where
pack :: Char -> Pack
pack = Char -> Pack
Char
unpack :: Pack -> Char
unpack (Char x :: Char
x) = Char
x
unpack _ = ' '
instance Packer Int where
pack :: Int -> Pack
pack = Int -> Pack
Int
unpack :: Pack -> Int
unpack (Int x :: Int
x) = Int
x
unpack _ = -1
instance (Packer a, Packer b) => Packer (a,b) where
pack :: (a, b) -> Pack
pack (a :: a
a,b :: b
b) = String -> [(String, Pack)] -> Pack
Ctor "(,)" [String -> a -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "fst" a
a, String -> b -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "snd" b
b]
unpack :: Pack -> (a, b)
unpack x :: Pack
x = (String -> [(String, Pack)] -> a
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "fst" [(String, Pack)]
y, String -> [(String, Pack)] -> b
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "snd" [(String, Pack)]
y)
where y :: [(String, Pack)]
y = String -> Pack -> [(String, Pack)]
ctor "(,)" Pack
x
instance Packer a => Packer (Maybe a) where
pack :: Maybe a -> Pack
pack Nothing = String -> [(String, Pack)] -> Pack
Ctor "Nothing" []
pack (Just x :: a
x) = String -> [(String, Pack)] -> Pack
Ctor "Just" [String -> a -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "fromJust" a
x]
unpack :: Pack -> Maybe a
unpack x :: Pack
x@(Ctor "Just" _) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ String -> [(String, Pack)] -> a
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "fromJust" ([(String, Pack)] -> a) -> [(String, Pack)] -> a
forall a b. (a -> b) -> a -> b
$ String -> Pack -> [(String, Pack)]
ctor "Just" Pack
x
unpack _ = Maybe a
forall a. Maybe a
Nothing
instance (Packer a, Packer b) => Packer (Either a b) where
pack :: Either a b -> Pack
pack (Left x :: a
x) = String -> [(String, Pack)] -> Pack
Ctor "Left" [String -> a -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "fromLeft" a
x]
pack (Right x :: b
x) = String -> [(String, Pack)] -> Pack
Ctor "Right" [String -> b -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "fromRight" b
x]
unpack :: Pack -> Either a b
unpack x :: Pack
x@(Ctor "Left" _) = a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> a -> Either a b
forall a b. (a -> b) -> a -> b
$ String -> [(String, Pack)] -> a
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "fromLeft" ([(String, Pack)] -> a) -> [(String, Pack)] -> a
forall a b. (a -> b) -> a -> b
$ String -> Pack -> [(String, Pack)]
ctor "Left" Pack
x
unpack x :: Pack
x@(Ctor "Right" _) = b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> b -> Either a b
forall a b. (a -> b) -> a -> b
$ String -> [(String, Pack)] -> b
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "fromRight" ([(String, Pack)] -> b) -> [(String, Pack)] -> b
forall a b. (a -> b) -> a -> b
$ String -> Pack -> [(String, Pack)]
ctor "Right" Pack
x
unpack _ = a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> a -> Either a b
forall a b. (a -> b) -> a -> b
$ Pack -> a
forall a. Packer a => Pack -> a
unpack Pack
None
instance Packer Bool where
pack :: Bool -> Pack
pack True = String -> [(String, Pack)] -> Pack
Ctor "True" []
pack _ = String -> [(String, Pack)] -> Pack
Ctor "False" []
unpack :: Pack -> Bool
unpack (Ctor "True" _) = Bool
True
unpack _ = Bool
False
instance Packer a => Packer (Group a) where
pack :: Group a -> Pack
pack Group{..} = String -> [(String, Pack)] -> Pack
Ctor "Group"
[String -> [a] -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "groupUnnamed" [a]
groupUnnamed
,String -> [a] -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "groupHidden" [a]
groupHidden
,String -> [(String, [a])] -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "groupNamed" [(String, [a])]
groupNamed]
unpack :: Pack -> Group a
unpack x :: Pack
x = let y :: [(String, Pack)]
y = String -> Pack -> [(String, Pack)]
ctor "Group" Pack
x in Group :: forall a. [a] -> [a] -> [(String, [a])] -> Group a
Group
{groupUnnamed :: [a]
groupUnnamed = String -> [(String, Pack)] -> [a]
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "groupUnnamed" [(String, Pack)]
y
,groupHidden :: [a]
groupHidden = String -> [(String, Pack)] -> [a]
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "groupHidden" [(String, Pack)]
y
,groupNamed :: [(String, [a])]
groupNamed = String -> [(String, Pack)] -> [(String, [a])]
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "groupNamed" [(String, Pack)]
y}
instance Packer a => Packer (Mode a) where
pack :: Mode a -> Pack
pack Mode{..} = String -> [(String, Pack)] -> Pack
Ctor "Mode"
[String -> Group (Mode a) -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeGroupModes" Group (Mode a)
modeGroupModes
,String -> [String] -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeNames" [String]
modeNames
,String -> String -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeHelp" String
modeHelp
,String -> [String] -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeHelpSuffix" [String]
modeHelpSuffix
,String -> ([Arg a], Maybe (Arg a)) -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeArgs" ([Arg a], Maybe (Arg a))
modeArgs
,String -> Group (Flag a) -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeGroupFlags" Group (Flag a)
modeGroupFlags
,String -> a -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeValue" a
modeValue
,String -> (a -> Either String a) -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeCheck" a -> Either String a
modeCheck
,String -> (a -> Maybe [String]) -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeReform" a -> Maybe [String]
modeReform
,String -> Bool -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "modeExpandAt" Bool
modeExpandAt]
unpack :: Pack -> Mode a
unpack x :: Pack
x = let y :: [(String, Pack)]
y = String -> Pack -> [(String, Pack)]
ctor "Mode" Pack
x in Mode :: forall a.
Group (Mode a)
-> [String]
-> a
-> (a -> Either String a)
-> (a -> Maybe [String])
-> Bool
-> String
-> [String]
-> ([Arg a], Maybe (Arg a))
-> Group (Flag a)
-> Mode a
Mode
{modeGroupModes :: Group (Mode a)
modeGroupModes = String -> [(String, Pack)] -> Group (Mode a)
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeGroupModes" [(String, Pack)]
y
,modeNames :: [String]
modeNames = String -> [(String, Pack)] -> [String]
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeNames" [(String, Pack)]
y
,modeHelp :: String
modeHelp = String -> [(String, Pack)] -> String
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeHelp" [(String, Pack)]
y
,modeHelpSuffix :: [String]
modeHelpSuffix = String -> [(String, Pack)] -> [String]
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeHelpSuffix" [(String, Pack)]
y
,modeArgs :: ([Arg a], Maybe (Arg a))
modeArgs = String -> [(String, Pack)] -> ([Arg a], Maybe (Arg a))
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeArgs" [(String, Pack)]
y
,modeGroupFlags :: Group (Flag a)
modeGroupFlags = String -> [(String, Pack)] -> Group (Flag a)
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeGroupFlags" [(String, Pack)]
y
,modeValue :: a
modeValue = String -> [(String, Pack)] -> a
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeValue" [(String, Pack)]
y
,modeCheck :: a -> Either String a
modeCheck = String -> [(String, Pack)] -> a -> Either String a
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeCheck" [(String, Pack)]
y
,modeReform :: a -> Maybe [String]
modeReform = String -> [(String, Pack)] -> a -> Maybe [String]
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeReform" [(String, Pack)]
y
,modeExpandAt :: Bool
modeExpandAt = String -> [(String, Pack)] -> Bool
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "modeExpandAt" [(String, Pack)]
y}
instance Packer a => Packer (Flag a) where
pack :: Flag a -> Pack
pack Flag{..} = String -> [(String, Pack)] -> Pack
Ctor "Flag"
[String -> [String] -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "flagNames" [String]
flagNames
,String -> FlagInfo -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "flagInfo" FlagInfo
flagInfo
,String -> String -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "flagType" String
flagType
,String -> String -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "flagHelp" String
flagHelp
,String -> Update a -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "flagValue" Update a
flagValue]
unpack :: Pack -> Flag a
unpack x :: Pack
x = let y :: [(String, Pack)]
y = String -> Pack -> [(String, Pack)]
ctor "Flag" Pack
x in Flag :: forall a.
[String] -> FlagInfo -> Update a -> String -> String -> Flag a
Flag
{flagNames :: [String]
flagNames = String -> [(String, Pack)] -> [String]
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "flagNames" [(String, Pack)]
y
,flagInfo :: FlagInfo
flagInfo = String -> [(String, Pack)] -> FlagInfo
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "flagInfo" [(String, Pack)]
y
,flagType :: String
flagType = String -> [(String, Pack)] -> String
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "flagType" [(String, Pack)]
y
,flagHelp :: String
flagHelp = String -> [(String, Pack)] -> String
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "flagHelp" [(String, Pack)]
y
,flagValue :: Update a
flagValue = String -> [(String, Pack)] -> Update a
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "flagValue" [(String, Pack)]
y}
instance Packer a => Packer (Arg a) where
pack :: Arg a -> Pack
pack Arg{..} = String -> [(String, Pack)] -> Pack
Ctor "Arg"
[String -> String -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "argType" String
argType
,String -> Bool -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "argRequire" Bool
argRequire
,String -> Update a -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "argValue" Update a
argValue]
unpack :: Pack -> Arg a
unpack x :: Pack
x = let y :: [(String, Pack)]
y = String -> Pack -> [(String, Pack)]
ctor "Arg" Pack
x in Arg :: forall a. Update a -> String -> Bool -> Arg a
Arg
{argType :: String
argType = String -> [(String, Pack)] -> String
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "argType" [(String, Pack)]
y
,argRequire :: Bool
argRequire = String -> [(String, Pack)] -> Bool
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "argRequire" [(String, Pack)]
y
,argValue :: Update a
argValue = String -> [(String, Pack)] -> Update a
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "argValue" [(String, Pack)]
y}
instance Packer FlagInfo where
pack :: FlagInfo -> Pack
pack FlagReq = String -> [(String, Pack)] -> Pack
Ctor "FlagReq" []
pack (FlagOpt x :: String
x) = String -> [(String, Pack)] -> Pack
Ctor "FlagOpt" [String -> String -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "fromFlagOpt" String
x]
pack (FlagOptRare x :: String
x) = String -> [(String, Pack)] -> Pack
Ctor "FlagOptRare" [String -> String -> (String, Pack)
forall a a. Packer a => a -> a -> (a, Pack)
add "fromFlagOpt" String
x]
pack FlagNone = String -> [(String, Pack)] -> Pack
Ctor "FlagNone" []
unpack :: Pack -> FlagInfo
unpack x :: Pack
x@(Ctor name :: String
name _) = case String
name of
"FlagReq" -> FlagInfo
FlagReq
"FlagOpt" -> String -> FlagInfo
FlagOpt (String -> FlagInfo) -> String -> FlagInfo
forall a b. (a -> b) -> a -> b
$ String -> [(String, Pack)] -> String
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "fromFlagOpt" ([(String, Pack)] -> String) -> [(String, Pack)] -> String
forall a b. (a -> b) -> a -> b
$ String -> Pack -> [(String, Pack)]
ctor String
name Pack
x
"FlagOptRare" -> String -> FlagInfo
FlagOptRare (String -> FlagInfo) -> String -> FlagInfo
forall a b. (a -> b) -> a -> b
$ String -> [(String, Pack)] -> String
forall a a. (Packer a, Eq a) => a -> [(a, Pack)] -> a
get "fromFlagOpt" ([(String, Pack)] -> String) -> [(String, Pack)] -> String
forall a b. (a -> b) -> a -> b
$ String -> Pack -> [(String, Pack)]
ctor String
name Pack
x
"FlagNone" -> FlagInfo
FlagNone
unpack _ = FlagInfo
FlagNone