{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
module System.Console.CmdLib.ADTs where

import System.Console.CmdLib.Attribute
import System.Console.CmdLib.Flag
import System.Console.GetOpt
import Control.Exception ( throw, evaluate )
import Data.Data
import Data.Generics.Aliases( extB )
import Data.Maybe( fromMaybe )

-- | The ADT wrapper type allows use of classic ADTs (algebraic data types) for
-- flag representation. The flags are then passed to the command as a list of
-- values of this type. However, you need to make the type an instance of the
-- Attributes first (if you do not wish to attach any attributes, you may keep
-- the instance body empty). E.g.:
--
-- > data Flag = Simplify | Wibblify Int
-- > instance Attributes where
-- >     attributes _ = Wibblify %> Help "Add a wibblification pass." %+ ArgHelp "intensity" %%
-- >                    Simplify %> Help "Enable a two-pass simplifier."
--
-- The "Command" instances should then use @(ADT Flag)@ for their second type
-- parameter (the flag type).
newtype (Attributes adt) => ADT adt = ADT adt deriving Eq

instance (Eq (ADT adt), Attributes adt, Data adt) => FlagType (ADT adt) where
  type Folded (ADT adt) = [adt]

  flag_attrkey (ADT x) = KeyC $ toConstr x
  flag_empty _ = []
  flag_fold _ flags defs = flags' ++ [ f | f <- defs, toConstr f `notElem` map toConstr flags' ]
    where flags' = foldr ($) [] flags
  flag_type (ADT flag) _ = optionType (gmapQ dataTypeOf flag) (gmapQ typeOf flag)

  flag_list = [ ADT $ fromConstr x | x <- dataTypeConstrs $ dataTypeOf (undefined :: adt) ]
  flag_defaults attr initial = [ setdef f | ADT f <- flag_list, length (gmapQ typeOf f) == 1,
                                            enabled (attr $ ADT f) ] ++ initial
    where setdef :: adt -> adt
          setdef f = fromConstrB (if required (attr $ ADT f)
                                     then throw RequiredArgException
                                     else defvalue $ attrs (ADT f) attr) (toConstr f)

  flag_attrs (ADT flag) = (attrFun $ attributes flag) (KeyC $ toConstr flag) %+
                          long (nameFromConstr $ toConstr flag) %+
                          defaults

  flag_set (ADT flag) v = (fromConstrB ((error "flag_set" `extB` v) ()) (toConstr flag) :)
  flag_parse (ADT flag) str = (fromConstrB (readFlag (undefined :: adt) str) (toConstr flag) :)
  flag_eval (ADT flag) folded = case [ f | f <- folded, toConstr f == toConstr flag ] of
    (x:_) -> gmapM evaluate x >> return ()
    [] -> return ()

  flag_args (ADT flag) attr = case flag_type (ADT flag) attr of
    BooleanOption -> OptArg addoptional ""
    OptionalArgument -> OptArg addoptional ""
    RequiredArgument -> ReqArg add ""
    SimpleOption -> NoArg (flag:)

    where reify :: Data a => String -> a
          reify y = fromConstrB (readFlag (undefined :: adt) y) (toConstr flag)
          add x = (reify x :)
          addoptional x = (reify (fromMaybe "" x) :)