{-# LANGUAGE TypeOperators, RankNTypes, DeriveFunctor #-} | |
-- Response to chapter 9 of http://paolocapriotti.com/assets/applicative.pdf | |
import Control.Applicative | |
import Control.Monad (guard) | |
import Data.Functor.HFree | |
import Data.Functor.Product | |
import Data.Monoid (Any(..)) | |
import Data.Maybe (listToMaybe) | |
----- Code different from the paper ----- | |
type FreeA = HFree Applicative | |
one :: Option a -> FreeA Option a | |
one = liftFree | |
raise :: Applicative g => (f :~> g) -> FreeA f :~> g | |
raise = rightAdjunct | |
matchOpt :: String -> String -> FreeA Option a -> Maybe (FreeA Option a) | |
matchOpt opt value = any2Maybe . raise findMatch | |
where | |
any2Maybe (Pair (Const (Any b)) fa) = guard b >> Just fa | |
findMatch g = case ('-':'-':optName g == opt, optReader g value) of | |
(True, Just b) -> Pair (Const (Any True)) (pure b) | |
_ -> Pair (Const (Any False)) (one g) | |
----- Code from the paper ----- | |
data User = User | |
{ username :: String | |
, fullname :: String | |
, id :: Int | |
} deriving Show | |
data Option a = Option | |
{ optName :: String | |
, optDefault :: Maybe a | |
, optReader :: String -> Maybe a | |
} deriving Functor | |
userP :: FreeA Option User | |
userP = User | |
<$> one (Option "username" Nothing Just) | |
<*> one (Option "fullname" (Just "") Just) | |
<*> one (Option "id" Nothing maybeRead) | |
maybeRead :: Read a => String -> Maybe a | |
maybeRead = fmap fst . listToMaybe . filter (null . snd) . reads | |
parserDefault :: FreeA Option a -> Maybe a | |
parserDefault = raise optDefault | |
runParser :: FreeA Option a -> [String] -> Maybe a | |
runParser p (opt : value : args) = do | |
p' <- matchOpt opt value p | |
runParser p' args | |
runParser p [] = parserDefault p | |
runParser _ _ = Nothing |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment