Internal.hs

-- | Internal workings of 'Betsy', the Cartel flag maker.  Use of this
-- module may break 'Betsy' invariants.
module Cartel.Betsy.Internal where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Cartel.Types
import Control.Applicative

-- | Errors that may result from running a 'Betsy' computation.
data Error
  = DuplicateFlag FlagName
  -- ^ The user requested creation of a duplicate flag.
  | Failed String
  -- ^ 'fail' was invoked.
  | EmptyFlagName
  -- ^ The user requested creation of a flag with an empty name.
  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"]

-- | Computations that can create and use Cabal flags.  Use of this
-- type, along with the 'Cartel.defaultMain' function ensures that any
-- 'FlagName' you use has been properly set up by using 'makeFlag'.
-- That way, you don't use flags in a 'Cartel.flag' without actually
-- declaring the flag.  When 'Cartel.defaultMain' creates your Cabal
-- file, it will print the necessary @Flag@ sections.
--
-- 'Betsy' is parameterized on a type, @m@.  When this type is a
-- monad, 'Betsy' is also a monad, allowing you to use use the usual
-- monad combinators and @do@ notation.  'Betsy' is also a monad transformer.

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

-- ** Flags

-- | The name of a flag, paired with its options.
data Flag = Flag FlagName FlagOpts
  deriving (Eq, Ord, Show)

-- | Options for flags, except for the flag's name.
data FlagOpts = FlagOpts
  { flagDescription :: String
  -- ^ A one-line description of what the flag does; this is optional.
  , flagDefault :: Bool
  -- ^ Is this flag on or off by default?
  , flagManual :: Bool
  -- ^ If a flag is manual, Cabal will not change its value.  If a
  -- flag is not manual, Cabal will change its value automatically to
  -- attempt to satisfy the package's dependencies.
  } deriving (Eq, Ord, Show)

-- | The name of a flag.  Only 'makeFlag' creates flags; it will
-- return a 'FlagName' to you.  You can then use that 'FlagName' in a
-- conditional using 'Cartel.flag'.
data FlagName = FlagName
  { flagNameHead :: Char
  , flagNameTail :: String
  } deriving (Eq, Ord, Show)

-- | Creates new flags.
makeFlag
  :: Applicative m
  => NonEmptyString
  -- ^ Name of flag
  -> FlagOpts
  -- ^ Options for the flag
  -> Betsy m FlagName
  -- ^ This operation will fail if there is already a flag with the
  -- name you gave.
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]))
  -- ^ Returns 'Left' if the making of a flag failed.  Otherwise,
  -- returns the result of the computation, along with a list of all
  -- flags made.
runBetsy (Betsy f) = f []


-- | Returns a list of all flags made so far.
currentFlags :: Applicative f => Betsy f [Flag]
currentFlags = Betsy $ \ls -> pure (Right (ls, ls))