parse-config.hs

{-# LANGUAGE OverloadedStrings #-}
import Control.Applicative
import Data.Aeson
import Data.Monoid
import Data.Maybe

data Quto = Quto (Maybe Int) (Maybe String) deriving Show

-- Парсер поддерживающий отсуствие значений
instance FromJSON Quto where
  parseJSON = withObject "Quto" $ \v -> Quto <$> v .:? "value"
                                             <*> v .:? "help"

-- Дефолтный конфиг (просто так)
defaultQuoto = Quto (Just 42) (Just "Pepi")

-- Средство объединения конфигов, работает как First
-- по каждому из полей
instance Monoid Quto where
  mempty = Quto Nothing Nothing
  Quto a1 b1 `mappend` Quto a2 b2 =
    Quto (getFirst (First a1 <> First a2))
         (getFirst (First b1 <> First b2))

-- Просто тестирование парсера

test1 :: Maybe Quto
test1 = decode "{\"value\":15}"
-- > Just (Quto (Just 15) Nothing)

test2 :: Maybe Quto
test2 = decode "{}"
-- > Just (Quto Nothing Nothing)

-- Дозаполнение структуры значениями по умолчанию:

test3 :: Maybe Quto
test3 =  fmap (<> defaultQuoto) (decode "{}")
-- > Just (Quto (Just 42) (Just "Pepi"))

test4 :: Maybe Quto
test4 = fmap (<> defaultQuoto) (decode "{\"value\":666}")
-- > Just (Quto (Just 666) (Just "Pepi"))


-- Получение значений по умолчанию из окружения

test5 :: IO (Maybe Quto)
test5 = do
  n <- getLine
  return $ fmap (<> Quto (Just (read n)) (Just n)) (decode "{\"help\":\"kek\"}")
-- > Just (Quto (Just 5) (Just "kek")

test6 :: IO Quto
test6 = case decode "{\"help\":\"mok\"}" of
          Nothing -> error ":("
          Just x  -> populate x
  where
    populate (Quto Nothing a) = populate =<< Quto <$> iAmIO 5 <*> pure a
    populate (Quto a Nothing) = populate =<< Quto <$> pure a <*> iAmIO "yo!"
    populate w = return w
    iAmIO :: a -> IO (Maybe a)
    iAmIO = return . Just

-- тоже самое можно и через case-

-- И наконец, если хочется показать, что в итоговой структуре невозможно
-- иметь Nothing, т.е. все значения заполнены, то предыдущую можно использовать
-- как прокси:

data Final = Final Int String

toFinal :: Quto -> IO Final
toFinal (Quto Nothing a) = toFinal =<< Quto <$> return  (Just 7) <*> pure a -- или выкинуть ошибку
toFinal (Quto a Nothing) = toFinal =<< Quto <$> pure a    <*> return  (Just "s") -- или выкинуть ошибку
toFinal (Quto (Just a) (Just b)) = return $ Final a b

-- Можно всячески извращаься и обзединить Quto и Final