module Cartel.Betsy.Internal where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Cartel.Types
import Control.Applicative
data Error
= DuplicateFlag FlagName
| Failed String
| EmptyFlagName
deriving (Eq, Ord, Show)
renderError :: Error -> String
renderError e = unlines $
"Error while attempting to generate Cabal file from Cartel source."
: case e of
DuplicateFlag (FlagName c cs) ->
["Duplicated flag: " ++ (c:cs)]
Failed s -> ["The \"fail\" function was invoked: " ++ s]
EmptyFlagName -> ["Empty flag name"]
data State = State [(FlagName, FlagOpts)]
deriving (Eq, Ord, Show)
newtype Betsy m a = Betsy (State -> m (Either Error (a, State)))
instance Monad m => Monad (Betsy m) where
return a = Betsy $ \s -> return (Right (a, s))
(Betsy l) >>= f = Betsy $ \s -> do
ei <- l s
case ei of
Left e -> return (Left e)
Right (g, s') -> do
let Betsy r = f g
r s'
fail s = Betsy $ \_ -> return (Left (Failed s))
instance Functor m => Functor (Betsy m) where
fmap f (Betsy k) = Betsy $ fmap (fmap f') k
where
f' ei = fmap (\(a, s) -> (f a, s)) ei
instance (Monad m, Functor m) => Applicative (Betsy m) where
pure = return
(<*>) = ap
instance MonadTrans Betsy where
lift k = Betsy $ \st -> do
a <- k
return $ Right (a, st)
instance MonadIO m => MonadIO (Betsy m) where
liftIO = lift . liftIO
data FlagOpts = FlagOpts
{ flagDescription :: String
, flagDefault :: Bool
, flagManual :: Bool
} deriving (Eq, Ord, Show)
data FlagName = FlagName
{ flagNameHead :: Char
, flagNameTail :: String
} deriving (Eq, Ord, Show)
makeFlag
:: Applicative m
=> NonEmptyString
-> FlagOpts
-> Betsy m FlagName
makeFlag nes opts = Betsy $ \(State fls) -> pure $
case nes of
[] -> Left EmptyFlagName
x:xs ->
let nm = FlagName x xs
in case lookup nm fls of
Nothing ->
let st' = State ((nm, opts) : fls)
in Right (nm, st')
Just _ -> Left (DuplicateFlag nm)
runBetsy
:: Functor m
=> Betsy m a
-> m (Either Error (a, [(FlagName, FlagOpts)]))
runBetsy (Betsy f) = fmap (fmap g) $ f (State [])
where
g (a, State ls) = (a, ls)
currentFlags :: Applicative f => Betsy f [(FlagName, FlagOpts)]
currentFlags = Betsy $ \(State ls) -> pure (Right (ls, State ls))