{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
module Console.Options.Monad
( ProgramDesc(..)
, ProgramMeta(..)
, OptionDesc
, gatherDesc
, getNextID
, getNextIndex
, modify
) where
import Control.Applicative
import Console.Options.Nid
import Console.Options.Types
import Console.Options.Utils
import System.Exit
import Foundation.Monad
import Foundation.Monad.State
data ProgramDesc r = ProgramDesc
{ stMeta :: ProgramMeta
, stCT :: Command r
, stNextID :: !NidGenerator
, stNextIndex :: !UnnamedIndex
}
data ProgramMeta = ProgramMeta
{ programMetaName :: Maybe String
, programMetaDescription :: Maybe String
, programMetaVersion :: Maybe String
, programMetaHelp :: [String]
}
programMetaDefault :: ProgramMeta
programMetaDefault = ProgramMeta Nothing Nothing Nothing ["-h", "--help"]
newtype OptionDesc r a = OptionDesc { runOptionDesc :: StateT (ProgramDesc r) Identity a }
deriving (Functor,Applicative,Monad)
instance MonadState (OptionDesc r) where
type State (OptionDesc r) = ProgramDesc r
withState f = OptionDesc $ withState f
gatherDesc :: OptionDesc r a -> ProgramDesc r
gatherDesc dsl = snd $ runIdentity $ runStateT (runOptionDesc dsl) initialProgramDesc
initialProgramDesc :: ProgramDesc r
initialProgramDesc = ProgramDesc { stMeta = programMetaDefault
, stCT = iniCommand
, stNextID = nidGenerator
, stNextIndex = 0
}
where
iniCommand :: Command r
iniCommand = Command (CommandLeaf []) "..." [] NoActionWrapped
getNextID :: OptionDesc r Nid
getNextID = do
(nid, nidGen) <- nidNext . stNextID <$> get
withState $ \st -> ((), st { stNextID = nidGen })
return nid
modify :: (ProgramDesc r -> ProgramDesc r) -> OptionDesc r ()
modify f = withState $ \st -> ((), f st)
getNextIndex :: OptionDesc r UnnamedIndex
getNextIndex = do
idx <- stNextIndex <$> get
withState $ \st -> ((), st { stNextIndex = idx + 1 })
return idx