Attribute.hs

{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, GADTs, FlexibleInstances,
             PatternGuards, FunctionalDependencies, UndecidableInstances,
             TypeSynonymInstances, OverlappingInstances, Rank2Types,
             DeriveDataTypeable #-}
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

-- Attributes.

data Attribute =
  -- | Set a list of short flags (single character per flag, like in @-c@,
  -- @-h@) for an option. Without the leading @-@.
  Short [Char]
  -- | Set a list of long flags for an option.
  | Long [String]
  -- | Set a list of long flags for an inversion of the option. Only used for
  -- boolean invertible options. See also "long".
  | InvLong [String]

  -- | Whether this option is invertible. Only applies to boolean options and
  -- defaults to True. (Invertible means that for --foo, there are --no-foo and
  -- --foo=no alternatives. A non-invertible option will only create --foo.)
  | Invertible Bool

  -- | Set help string (one-line summary) for an option. Displayed in help.
  | Help String

  -- | When True, this option will contain the list of non-option arguments
  -- passed to the command. Only applicable to [String]-typed options. Options
  -- marked extra will not show up in help and neither will they be recognized
  -- by their name on commandline.
  | Extra Bool

  -- | When set, this option will not show up on help and won't create a flag
  -- (similar to Extra), but instead it will contain the n-th non-option
  -- argument. The argument used up by such a positional option will not show
  -- up in the list of non-option arguments.
  | Positional Int

  -- | When True, this option will require that the argument must be provided.
  -- If the argument is also Positional, any preceeding Positional arguments
  -- should also be Required.
  | Required Bool

  -- | Set the help string for an argument, the @FOO@ in @--wibblify=FOO@.
  | ArgHelp String

  -- | Set default value for this option. The default is only applied when its
  -- type matches the option's parameter type, otherwise it is ignored.
  | forall a. Data a => Default a

  -- | When this attribute is given, the flag's value will be passed to the
  -- provided IO action (which would presumably record the flag's value in a
  -- global IORef for later use). Like with Default, the attribute is only
  -- effective if the parameter type of the provided function matches the
  -- parameter type of the option to which the attribute is applied.
  | forall a. Data a => Global (a -> IO ())

  -- | Whether the option is enabled. Disabled options are not recognized and
  -- are not shown in help (effectively, they do not exist). Used to enable a
  -- subset of all available options for a given command. For Record-based
  -- commands (see "RecordCommand"), this is handled automatically based on
  -- fields available in the command's constructor. Otherwise, constructs like
  --
  -- > enable <% option1 +% option2 +% option3 %% disable <% option4
  --
  -- may be quite useful.
  | Enabled Bool

  -- | Set the group name for this option. The groups are used to section the
  -- help output (the options of a given group are shown together, under the
  -- heading of the group). The ordering of the groups is given by the first
  -- flag of each group. Flags themselves are in the order in which they are
  -- given in the ADT or Record in question.
  | 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

-- | Join attribute mappings. E.g. @Key1 %> Attr1 %+ Attr2 %% Key2 %> Attr3 %+
-- Attr4@. Also possible is @[ Key1 %> Attr1, Key2 %> Attr2 ] %% Key3 %>
-- Attr3@, or many other variations.
(%%) :: (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 _ = [] -- can't extract...
  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 ()

-- | Create a group. This extracts all the keys that are (explicitly) mentioned
-- in the body of the group and assigns the corresponding Group attribute to
-- them. Normally used like this:
--
-- > group "Group name" [ option %> Help "some help"
-- >                    , another %> Help "some other help" ]
--
-- Do not let the type confuse you too much. :)
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])]

-- | For convenience. Same as "Enabled" True.
enable :: Attribute
enable = Enabled True

-- | For convenience. Same as "Enabled" False.
disable :: Attribute
disable = Enabled False

simple :: [Attribute]
simple = Invertible False %+ Default False

-- | For convenience. Same as "Long" ["foo"] %+ "InvLong" ["no-foo"]
long :: String -> [Attribute]
long n = Long [n] %+ InvLong ["no-" ++ n]

-- | For convenience. Same as "Short" ['x']
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

-- | Join multiple attributes into a list. Available for convenience (using
-- [Attribute] directly works just as well if preferred, although this is not
-- the case with keys, see @"+%"@).
(%+) :: (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

-- | Attach a (list of) attributes to a key. The key is usually either an ADT
-- constructor (for use with "ADTFlag"-style flags) or a record selector (for
-- use with "RecordFlag"s).
--
-- > data RFlags = Flags { wibblify :: Int, simplify :: Bool }
-- > data AFlag = Simplify | Wibblify Int
-- > rattr = wibblify %> Help "Add a wibblification pass." (%% ...)
-- > aattr = Wibblify %> Help "Add a wibblification pass." (%% ...)
--
-- @"%+"@ can be used to chain multiple attributes:
--
-- > attrs = wibblify %> Help "some help" %+ Default (3 :: Int) %+ ArgHelp "intensity"
--
-- But lists work just as fine:
--
-- > attrs = wibblify %> [ Help "some help", Default (3 :: Int), ArgHelp "intensity" ]
(%>) :: (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

-- | Attach an attribute to multiple keys: written from right to left,
-- i.e. @Attribute <% Key1 +% Key2@. Useful for setting up option groups
-- (although using "group" may be more convenient in this case) and option
-- enablement.
(<%) :: forall keys. (Keys keys) => Attribute -> keys -> AttributeMap Key
attr <% keys = SingletonMap $ zip (toKeys keys) (repeat [attr])

-- | Join multiple keys into a list, e.g. @Key1 +% Key2@. Useful with @"<%"@ to
-- list multiple (possibly heterogenously-typed) keys.
(+%) :: forall a b. (Keys a, Keys b) => a -> b -> [Key]
a +% b = toKeys a ++ toKeys b

infixl 8 %>
infixl 8 <%
infixl 7 %%

-- | Set an attribute on all keys.
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)
          {-# NOINLINE isup #-}
          iospoon a = unsafePerformIO $
                         (Just `fmap` evaluate a) `catch` (\(e :: SomeException) -> return Nothing)
          {-# NOINLINE iospoon #-}
          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)