A famous applicative

optparse.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Data.String (IsString)

newtype OptionName = OptionName String
    deriving (Show, Eq, Ord, IsString)

newtype OptionValue = OptionValue {optionValue :: String}
    deriving (Show, Eq, IsString)

data Parser a
    = Pure a
    | forall b.
        Option
        { name :: OptionName
        , patch :: OptionValue -> Maybe (b -> a)
        , rest :: Parser b
        }

-- example: clean --input foo --output bar --verbose true
-- example: clean --input foo --verbose false --output bar
data Clean = Clean
    { input :: String
    , output :: String
    , verbose :: Bool
    }
    deriving (Show, Eq)

test1 :: Bool
test1 =
    interpret
        parseClean
        [ ("--input", "foo")
        , ("--output", "bar")
        , ("--verbose", "true")
        ]
        == Just (Clean "foo" "bar" True)

test2 :: Bool
test2 =
    interpret
        parseClean
        [ ("--input", "foo")
        , ("--verbose", "false")
        , ("--output", "bar")
        ]
        == Just (Clean "foo" "bar" False)

type Args = [(OptionName, OptionValue)]

interpret :: Parser a -> Args -> Maybe a
interpret (Pure x) _xs = Just x
interpret Option{..} xs = do
    case lookup name xs of
        Nothing -> Nothing -- option name not found
        Just x -> do
            -- option name found
            f <- patch x
            x' <- interpret rest xs
            return $ f x'

parseClean :: Parser Clean
parseClean = Clean <$> parseInput <*> parseOutput <*> parseVerbose

mkOption :: OptionName -> (OptionValue -> Maybe b) -> Parser b
mkOption name patch = Option name (fmap (fmap const) patch) $ Pure ()

parseInput :: Parser String
parseInput = mkOption "--input" $ Just . optionValue

parseOutput :: Parser String
parseOutput = mkOption "--output" $ Just . optionValue

parseVerbose :: Parser Bool
parseVerbose = mkOption "--verbose" $ \case
    "true" -> Just True
    "false" -> Just False
    _ -> Nothing

instance Functor Parser where
    fmap :: (a -> b) -> Parser a -> Parser b
    fmap = error "TODO"

instance Applicative Parser where
    pure :: a -> Parser a
    pure = error " TODO"

    (<*>) :: Parser (b -> a) -> Parser b -> Parser a
    (<*>) = error "TODO"