Permalink
Browse files

Make Builder more type-safe.

  • Loading branch information...
1 parent 79c54f7 commit 8342008c0214e1492897ef0c4986aff14e593bec @pcapriotti committed May 9, 2012
Showing with 180 additions and 140 deletions.
  1. +17 −69 Options/Applicative.hs
  2. +94 −62 Options/Applicative/Builder.hs
  3. +5 −4 Options/Applicative/Extra.hs
  4. +59 −0 Options/Applicative/Types.hs
  5. +3 −3 hello.hs
  6. +2 −2 modes.hs
View
86 Options/Applicative.hs
@@ -1,18 +1,14 @@
-{-# LANGUAGE GADTs, Rank2Types, DeriveFunctor #-}
-
+{-# LANGUAGE Rank2Types, PatternGuards #-}
module Options.Applicative where
import Control.Applicative
-import Control.Monad
+import Data.Lens.Common
import Data.List
import Data.Maybe
import Data.Monoid
import Options.Applicative.Utils
-
-data OptName = OptShort !Char
- | OptLong !String
- deriving (Eq, Ord)
+import Options.Applicative.Types
optNameStr :: OptName -> String
optNameStr (OptLong name) = name
@@ -24,26 +20,10 @@ isLong _ = False
isShort (OptShort _ ) = True
isShort _ = False
-data Option r a = Option
- { optMain :: OptReader r
- , optDefault :: Maybe a
- , optShow :: Bool
- , optHelp :: String
- , optMetaVar :: String
- , optCont :: r -> Maybe (Parser a) }
- deriving Functor
-
-data OptReader a
- = OptReader [OptName] (String -> Maybe a)
- | FlagReader [OptName] !a
- | ArgReader (String -> Maybe a)
- | CmdReader (String -> Maybe (Parser a))
- deriving Functor
-
-optNames :: OptReader a -> [OptName]
-optNames (OptReader names _) = names
-optNames (FlagReader names _) = names
-optNames _ = []
+optionNames :: OptReader a -> [OptName]
+optionNames (OptReader names _) = names
+optionNames (FlagReader names _) = names
+optionNames _ = []
liftOpt :: Option r a -> Parser a
liftOpt opt = ConsP (fmap const opt) (pure ())
@@ -97,48 +77,15 @@ optMatches rdr arg = case rdr of
(a : rest) -> Just (OptShort a, Just rest)
| otherwise = Nothing
-
-data Parser a where
- NilP :: a -> Parser a
- ConsP :: Option r (a -> b)
- -> Parser a
- -> Parser b
-
-instance Functor Parser where
- fmap f (NilP x) = NilP (f x)
- fmap f (ConsP opt p) = ConsP (fmap (f.) opt) p
-
-instance Applicative Parser where
- pure = NilP
- NilP f <*> p = fmap f p
- ConsP opt p1 <*> p2 =
- ConsP (fmap uncurry opt) $ (,) <$> p1 <*> p2
-
-data P a
- = ParseError
- | ParseResult a
- deriving Functor
-
-instance Monad P where
- return = ParseResult
- ParseError >>= _ = ParseError
- ParseResult a >>= f = f a
- fail _ = ParseError
-
-instance Applicative P where
- pure = return
- (<*>) = ap
-
tryP :: Maybe a -> P a
tryP = maybe ParseError return
stepParser :: Parser a -> String -> [String] -> P (Parser a, [String])
stepParser (NilP _) _ _ = ParseError
stepParser (ConsP opt p) arg args
- -- take first matcher
- | Just matcher <- optMatches (optMain opt) arg
+ | Just matcher <- optMatches (opt^.optMain) arg
= do (r, args') <- matcher args
- liftOpt' <- tryP $ optCont opt r
+ liftOpt' <- tryP $ getL optCont opt r
return (liftOpt' <*> p, args')
| otherwise
= do (p', args') <- stepParser p arg args
@@ -155,7 +102,7 @@ runParser p args = case args of
evalParser :: Parser a -> Maybe a
evalParser (NilP r) = pure r
-evalParser (ConsP opt p) = optDefault opt <*> evalParser p
+evalParser (ConsP opt p) = opt^.optDefault <*> evalParser p
mapParser :: (forall r x . Option r x -> b)
-> Parser a
@@ -174,16 +121,16 @@ data OptDescStyle = OptDescStyle
optDesc :: OptDescStyle -> Option r a -> String
optDesc style opt =
- let ns = optNames $ optMain opt
- mv = optMetaVar opt
+ let ns = optionNames $ opt^.optMain
+ mv = opt^.optMetaVar
descs = map showOption (sort ns)
desc' = intercalate (descSep style) descs <+> mv
render text
- | not (optShow opt) && not (descHidden style)
+ | not (opt^.optShow) && not (descHidden style)
= ""
| null text || not (descSurround style)
= text
- | isJust (optDefault opt)
+ | isJust (opt^.optDefault)
= "[" ++ text ++ "]"
| null (drop 1 descs)
= text
@@ -204,9 +151,10 @@ fullDesc = tabulate' . catMaybes . mapParser doc
where
doc opt
| null n = Nothing
- | null (optHelp opt) = Nothing
- | otherwise = Just (n, optHelp opt)
+ | null h = Nothing
+ | otherwise = Just (n, h)
where n = optDesc style opt
+ h = opt^.optHelp
style = OptDescStyle
{ descSep = ","
, descHidden = True
View
156 Options/Applicative/Builder.hs
@@ -1,30 +1,52 @@
+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
module Options.Applicative.Builder where
import Control.Applicative
+import Control.Category
import Data.Lens.Common
+import Data.Lens.Template
+
import Options.Applicative
+import Options.Applicative.Types
+
+import Prelude hiding (id, (.))
+
+data OptionFields a = OptionFields
+ { _optNames :: [OptName]
+ , _optReader :: String -> Maybe a }
+
+data FlagFields a = FlagFields
+ { _flagNames :: [OptName] }
+
+data ArgFields a = ArgFields
+
+data CmdFields a = CmdFields
--- lenses --
+$( makeLenses [ ''OptionFields
+ , ''FlagFields ])
-mainL :: Lens (Option r a) (OptReader r)
-mainL = lens optMain $ \m opt -> opt { optMain = m }
+class HasName f where
+ name :: OptName -> f a -> f a
-defaultL :: Lens (Option r a) (Maybe a)
-defaultL = lens optDefault $ \x opt -> opt { optDefault = x }
+instance HasName OptionFields where
+ name n = modL optNames (n:)
-helpL :: Lens (Option r a) String
-helpL = lens optHelp $ \h opt -> opt { optHelp = h }
+instance HasName FlagFields where
+ name n = modL flagNames (n:)
-metaVarL :: Lens (Option r a) String
-metaVarL = lens optMetaVar $ \mv opt -> opt { optMetaVar = mv }
+-- mod --
-showL :: Lens (Option r a) Bool
-showL = lens optShow $ \s opt -> opt { optShow = s }
+data Mod f r a b = Mod (f r -> f r) (Option r a -> Option r b)
-addName :: OptName -> OptReader a -> OptReader a
-addName name (OptReader names p) = OptReader (name : names) p
-addName name (FlagReader names x) = FlagReader (name : names) x
-addName _ opt = opt
+optionMod :: (Option r a -> Option r b) -> Mod f r a b
+optionMod = Mod id
+
+fieldMod :: (f r -> f r) -> Mod f r a a
+fieldMod f = Mod f id
+
+instance Category (Mod f r) where
+ id = Mod id id
+ Mod f1 g1 . Mod f2 g2 = Mod (f1 . f2) (g1 . g2)
-- readers --
@@ -41,69 +63,79 @@ disabled = const Nothing
-- combinators --
-long :: String -> Option r a -> Option r a
-long = modL mainL . addName . OptLong
+short :: HasName f => Char -> Mod f r a a
+short = fieldMod . name . OptShort
-short :: Char -> Option r a -> Option r a
-short = modL mainL . addName . OptShort
+long :: HasName f => String -> Mod f r a a
+long = fieldMod . name . OptLong
-value :: a -> Option r a -> Option r a
-value r = defaultL ^= Just r
+value :: a -> Mod f r a a
+value = optionMod . setL optDefault . Just
-help :: String -> Option r a -> Option r a
-help htext = helpL ^= htext
+help :: String -> Mod f r a a
+help = optionMod . setL optHelp
-reader :: (String -> Maybe r) -> Option r a -> Option r a
-reader p = modL mainL $ \opt -> case opt of
- OptReader names _ -> OptReader names p
- _ -> opt
+reader :: (String -> Maybe r) -> Mod OptionFields r a a
+reader = fieldMod . setL optReader
-metavar :: String -> Option r a -> Option r a
-metavar = setL metaVarL
+metavar :: String -> Mod f r a a
+metavar = optionMod . setL optMetaVar
-hide :: Option r a -> Option r a
-hide = showL ^= False
+hide :: Mod f r a a
+hide = optionMod $ optShow^=False
-multi :: Option r a -> Option r [a]
-multi opt = mkOptGroup []
+multi :: Mod f r a [a]
+multi = optionMod f
where
- mkOptGroup xs = opt
- { optDefault = Just xs
- , optCont = mkCont xs }
- mkCont xs r = do
- p' <- optCont opt r
- x <- evalParser p'
- return $ liftOpt (mkOptGroup (x:xs))
+ f opt = mkOptGroup []
+ where
+ mkOptGroup xs = opt
+ { _optDefault = Just xs
+ , _optCont = mkCont xs }
+ mkCont xs r = do
+ p' <- getL optCont opt r
+ x <- evalParser p'
+ return $ liftOpt (mkOptGroup (x:xs))
baseOpts :: OptReader a -> Option a a
baseOpts opt = Option
- { optMain = opt
- , optMetaVar = ""
- , optShow = True
- , optCont = Just . pure
- , optHelp = ""
- , optDefault = Nothing }
+ { _optMain = opt
+ , _optMetaVar = ""
+ , _optShow = True
+ , _optCont = Just . pure
+ , _optHelp = ""
+ , _optDefault = Nothing }
-baseParser :: OptReader a -> (Option a a -> Option a b) -> Parser b
-baseParser opt f = liftOpt $ f (baseOpts opt)
+command :: (String -> Maybe (Parser a)) -> Mod f a a b -> Parser b
+command cmd m = liftOpt . g . baseOpts $ CmdReader cmd
+ where Mod _ g = m . metavar "COMMAND"
-command :: (String -> Maybe (Parser a)) -> (Option a a -> Option a b) -> Parser b
-command cmd f = baseParser (CmdReader cmd) (f . metavar "COMMAND")
+argument :: (String -> Maybe a) -> Mod f a a b -> Parser b
+argument p (Mod _ g) = liftOpt . g . baseOpts $ ArgReader p
-argument :: (String -> Maybe a) -> (Option a a -> Option a b) -> Parser b
-argument = baseParser . ArgReader
+arguments :: (String -> Maybe a) -> Mod f a [a] b -> Parser b
+arguments p m = argument p (m . multi)
-arguments :: (String -> Maybe a) -> (Option a [a] -> Option a b) -> Parser b
-arguments p f = argument p (f . multi)
+flag :: a -> Mod FlagFields a a b -> Parser b
+flag x (Mod f g) = liftOpt . g . baseOpts $ rdr
+ where
+ rdr = let fields = f (FlagFields [])
+ in FlagReader (fields^.flagNames) x
+
+nullOption :: Mod OptionFields a a b -> Parser b
+nullOption (Mod f g) = liftOpt . g . baseOpts $ rdr
+ where
+ rdr = let fields = f (OptionFields [] disabled)
+ in OptReader (fields^.optNames) (fields^.optReader)
-flag :: a -> (Option a a -> Option a b) -> Parser b
-flag = baseParser . FlagReader []
+strOption :: Mod OptionFields String String a -> Parser a
+strOption m = nullOption $ m . reader str
-nullOption :: (Option a a -> Option a b) -> Parser b
-nullOption = baseParser $ OptReader [] disabled
+option :: Read a => Mod OptionFields a a b -> Parser b
+option m = nullOption $ m . reader auto
-strOption :: (Option String String -> Option String a) -> Parser a
-strOption f = nullOption $ f . reader str
+idm :: Mod f r a a
+idm = id
-option :: Read a => (Option a a -> Option a b) -> Parser b
-option f = nullOption $ f . reader auto
+(&) :: Mod f r a b -> Mod f r b c -> Mod f r a c
+(&) = flip (.)
View
9 Options/Applicative/Extra.hs
@@ -3,6 +3,7 @@ module Options.Applicative.Extra where
import Control.Monad
import Data.Default
import Options.Applicative
+import Options.Applicative.Types
import Options.Applicative.Builder
import Options.Applicative.Utils
import System.Environment
@@ -27,10 +28,10 @@ instance Default ExecOptions where
helper :: Parser (a -> a)
helper = nullOption
( long "help"
- . short 'h'
- . help "Show this help text"
- . value id
- . hide )
+ & short 'h'
+ & help "Show this help text"
+ & value id
+ & hide )
execParser :: ExecOptions -> Parser a -> IO a
execParser opts p = do
View
59 Options/Applicative/Types.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE GADTs, DeriveFunctor, TemplateHaskell #-}
+module Options.Applicative.Types where
+
+import Control.Applicative
+import Control.Monad
+import Data.Lens.Template
+
+data OptName = OptShort !Char
+ | OptLong !String
+ deriving (Eq, Ord)
+
+data Option r a = Option
+ { _optMain :: OptReader r
+ , _optDefault :: Maybe a
+ , _optShow :: Bool
+ , _optHelp :: String
+ , _optMetaVar :: String
+ , _optCont :: r -> Maybe (Parser a) }
+ deriving Functor
+
+data OptReader a
+ = OptReader [OptName] (String -> Maybe a)
+ | FlagReader [OptName] !a
+ | ArgReader (String -> Maybe a)
+ | CmdReader (String -> Maybe (Parser a))
+ deriving Functor
+
+data Parser a where
+ NilP :: a -> Parser a
+ ConsP :: Option r (a -> b)
+ -> Parser a
+ -> Parser b
+
+instance Functor Parser where
+ fmap f (NilP x) = NilP (f x)
+ fmap f (ConsP opt p) = ConsP (fmap (f.) opt) p
+
+instance Applicative Parser where
+ pure = NilP
+ NilP f <*> p = fmap f p
+ ConsP opt p1 <*> p2 =
+ ConsP (fmap uncurry opt) $ (,) <$> p1 <*> p2
+
+data P a
+ = ParseError
+ | ParseResult a
+ deriving Functor
+
+instance Monad P where
+ return = ParseResult
+ ParseError >>= _ = ParseError
+ ParseResult a >>= f = f a
+ fail _ = ParseError
+
+instance Applicative P where
+ pure = return
+ (<*>) = ap
+
+$( makeLenses [''Option] )
View
6 hello.hs
@@ -1,6 +1,6 @@
import Control.Applicative
import Data.Default
-import Options.Applicative
+import Options.Applicative.Types
import Options.Applicative.Builder
import Options.Applicative.Extra
@@ -11,8 +11,8 @@ sample :: Parser Sample
sample = Sample
<$> strOption
( long "hello"
- . metavar "TARGET"
- . help "Target for the greeting" )
+ & metavar "TARGET"
+ & help "Target for the greeting" )
greet :: Sample -> IO ()
greet (Sample h) = putStrLn $ "Hello, " ++ h
View
4 modes.hs
@@ -1,6 +1,6 @@
import Control.Applicative
import Data.Default
-import Options.Applicative
+import Options.Applicative.Types
import Options.Applicative.Builder
import Options.Applicative.Extra
@@ -15,7 +15,7 @@ sample :: Parser Sample
sample = command (`lookup`
[("hello", hello)
,("goodbye", pure Goodbye)])
- id
+ idm
run :: Sample -> IO ()
run (Hello target) = putStrLn $ "Hello, " ++ target ++ "!"

0 comments on commit 8342008

Please sign in to comment.