module System.Console.CmdLib.Attribute where
import Prelude hiding ( catch )
import Control.Exception
import Data.Maybe( catMaybes, fromMaybe, listToMaybe )
import Data.List( elemIndex )
import Data.Data
import Data.Generics.Text( gshow )
import Control.Monad.State( evalState, State, get, put )
import System.IO.Unsafe
data Attribute =
Short [Char]
| Long [String]
| InvLong [String]
| Invertible Bool
| Help String
| Extra Bool
| Positional Int
| Required Bool
| ArgHelp String
| forall a. Data a => Default a
| forall a. Data a => Global (a -> IO ())
| Enabled Bool
| Group String
instance Show Attribute where
show (Short x) = "Short " ++ show x
show (Long x) = "Long " ++ show x
show (InvLong x) = "Long " ++ show x
show (Invertible x) = "Invertible " ++ show x
show (Help x) = "Help " ++ show x
show (ArgHelp x) = "ArgHelp " ++ show x
show (Default x) = "Default " ++ gshow x
show (Enabled x) = "Enabled " ++ show x
show (Group x) = "Group " ++ show x
data RequiredArgException = RequiredArgException deriving (Show, Typeable)
instance Exception RequiredArgException
class (Eq k) => AttributeMapLike k a | a -> k where
attrFun :: a -> k -> [Attribute]
attrKeys :: a -> [k]
data AttributeMap k where
(:%%) :: (AttributeMapLike k a, AttributeMapLike k b) => a -> b -> AttributeMap k
SingletonMap :: (AttributeMapLike k a) => a -> AttributeMap k
EmptyMap :: AttributeMap k
(%%) :: (AttributeMapLike k a, AttributeMapLike k b) => a -> b -> AttributeMap k
(%%) = (:%%)
instance (Eq k) => AttributeMapLike k [(k, [Attribute])] where
attrKeys = map fst
attrFun pairs = foldl pair (const []) [ \x -> if x == k then a else [] | (k, a) <- pairs ]
where pair f g k = f k ++ g k
instance (Eq k) => AttributeMapLike k (k -> [Attribute]) where
attrKeys _ = []
attrFun = id
instance (AttributeMapLike k x) => AttributeMapLike k [x] where
attrKeys = concatMap attrKeys
attrFun l = concat . zipWith ($) (map attrFun l) . repeat
instance (Eq k) => AttributeMapLike k (AttributeMap k) where
attrKeys (a :%% b) = attrKeys a ++ attrKeys b
attrKeys (SingletonMap x) = attrKeys x
attrKeys EmptyMap = []
attrFun (a :%% b) = \k -> attrFun a k ++ attrFun b k
attrFun (SingletonMap x) = attrFun x
attrFun EmptyMap = const []
getattr :: a -> (Attribute -> Maybe a) -> [Attribute] -> a
getattr def proj a = fromMaybe def $ go a
where go (x:xs) | Just k <- proj x = Just k
| otherwise = go xs
go [] = Nothing
enabled = getattr False $ \k -> case k of Enabled j -> Just j ; _ -> Nothing
extra = getattr False $ \k -> case k of Extra j -> Just j ; _ -> Nothing
longs = getattr [] $ \k -> case k of Long j -> Just j ; _ -> Nothing
shorts = getattr [] $ \k -> case k of Short j -> Just j ; _ -> Nothing
invlongs = getattr [] $ \k -> case k of InvLong j -> Just j ; _ -> Nothing
invertible = getattr True $ \k -> case k of Invertible j -> Just j ; _ -> Nothing
helpattr = getattr "(no help)" $ \k -> case k of Help j -> Just j ; _ -> Nothing
arghelp = getattr "X" $ \k -> case k of ArgHelp j -> Just j ; _ -> Nothing
getgroup = getattr "Options" $ \k -> case k of Group j -> Just j ; _ -> Nothing
required = getattr False $ \k -> case k of Required j -> Just j ; _ -> Nothing
positional = getattr Nothing $ \k -> case k of Positional j -> Just (Just j) ; _ -> Nothing
defvalue :: (Typeable a, Data a) => [Attribute] -> a
defvalue attr
| (Default v:rem) <- [ x | x@(Default _) <- attr ] =
fromMaybe (defvalue rem) (cast v)
| otherwise = error "No default value."
setglobal :: [Attribute] -> (forall a. (Typeable a, Data a) => a) -> IO ()
setglobal (Global set:rem) value = set value >> setglobal rem value
setglobal (_:rem) value = setglobal rem value
setglobal [] _ = return ()
group :: forall k a. (AttributeMapLike k a) => String -> a -> AttributeMap k
group name amap = foldl (%%) (SingletonMap amap) (map addgrp $ attrKeys amap)
where addgrp :: k -> AttributeMap k
addgrp key = SingletonMap [(key, [Group name])]
enable :: Attribute
enable = Enabled True
disable :: Attribute
disable = Enabled False
simple :: [Attribute]
simple = Invertible False %+ Default False
long :: String -> [Attribute]
long n = Long [n] %+ InvLong ["no-" ++ n]
short :: Char -> Attribute
short n = Short [n]
class AttributeList a where
toAttributes :: a -> [Attribute]
instance AttributeList Attribute where
toAttributes = (:[])
instance AttributeList [Attribute] where
toAttributes = id
(%+) :: (AttributeList a, AttributeList b) => a -> b -> [Attribute]
a %+ b = toAttributes a ++ toAttributes b
infixl 9 %+
attrs :: k -> (k -> [Attribute]) -> [Attribute]
attrs = flip ($)
data Key = KeyC Constr | KeyF TypeRep String
deriving (Eq, Show)
class ToKey a where
toKey :: a -> Key
instance (Data a) => ToKey a where
toKey = KeyC . toConstr
(%>) :: (ToKey k, AttributeList attr) => k -> attr -> AttributeMap Key
key %> attr = SingletonMap [(toKey key, toAttributes attr)]
class Keys a where
toKeys :: a -> [Key]
instance (ToKey a) => Keys a where
toKeys x = [toKey x]
instance Keys [Key] where
toKeys = id
(<%) :: forall keys. (Keys keys) => Attribute -> keys -> AttributeMap Key
attr <% keys = SingletonMap $ zip (toKeys keys) (repeat [attr])
(+%) :: forall a b. (Keys a, Keys b) => a -> b -> [Key]
a +% b = toKeys a ++ toKeys b
infixl 8 %>
infixl 8 <%
infixl 7 %%
everywhere :: (Eq k) => Attribute -> AttributeMap k
everywhere attr = SingletonMap $ const [attr]
instance (Data a, Data b) => ToKey (a -> b) where
toKey f | Just field <- fieldname = KeyF (typeOf (undefined :: a)) field
| Just constr <- constructor = KeyC constr
| otherwise = error $ "ToKey: " ++
show (typeOf (undefined :: a)) ++ " -> " ++
show (typeOf (undefined :: b))
where constrs = dataTypeConstrs $ dataTypeOf (undefined :: a)
fieldname = listToMaybe $ catMaybes [ nameIn c | c <- constrs ]
isup a = unsafePerformIO $
(undefined `fmap` evaluate a)
`catch` (\(e :: SomeException) -> case show e of
"up" -> return True
_ -> return False)
iospoon a = unsafePerformIO $
(Just `fmap` evaluate a) `catch` (\(e :: SomeException) -> return Nothing)
spooned c = [ isup (f $ test c i) | i <- [0..(length (constrFields c) 1)] ]
nameIn c = elemIndex True (spooned c) >>= \i -> return (constrFields c !! i)
test :: forall b. (Data b) => Constr -> Int -> b
test c i = evalState (gmapM (subst i) (fromConstr c)) 0
subst :: forall x. Data x => Int -> x -> State Int x
subst i _ = do x <- get
res <- if x == i then return $ error "up" else return $ error "down"
put $ x + 1
return res
constructor = iospoon $ toConstr (f undefined)