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"]
newtype Betsy m a = Betsy ([Flag] -> m (Either Error (a, [Flag])))
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 Flag = Flag FlagName FlagOpts
deriving (Eq, Ord, Show)
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 $ \fls -> pure $
case nes of
[] -> Left EmptyFlagName
x:xs ->
let nm = FlagName x xs
in case lookup nm . map (\(Flag n v) -> (n, v)) $ fls of
Nothing ->
let st' = Flag nm opts : fls
in Right (nm, st')
Just _ -> Left (DuplicateFlag nm)
runBetsy
:: Functor m
=> Betsy m a
-> m (Either Error (a, [Flag]))
runBetsy (Betsy f) = f []
currentFlags :: Applicative f => Betsy f [Flag]
currentFlags = Betsy $ \ls -> pure (Right (ls, ls))