sjoerdvisscher / matchOpt.hs

Last active April 05, 2013


    
    View matchOpt.hs 
  
  
      matchOpt.hs
    
    
        Raw
      
    
    File suppressed. Click to show.
  
  
            1
            2
            3
            4
            5
            6
            7
            8
            9
            10
            11
            12
            13
            14
            15
            16
            17
            18
            19
            20
            21
            22
            23
            24
            25
            26
            27
            28
            29
            30
            31
            32
            33
            34
            35
            36
            37
            38
            39
            40
            41
            42
            43
            44
            45
            46
            47
            48
            49
            50
            51
            52
            53
            54
            55
            56
            57
            58
            59
            60
            61
            62
            63
            64
          
          
            {-# 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