module Env.Parse
( Parser(..)
, VarF(..)
, static
, Error(..)
, Mod(..)
, Info(..)
, defaultInfo
, header
, desc
, footer
, prefixed
, var
, Var(..)
, defaultVar
, Reader
, str
, nonempty
, auto
, def
, helpDef
, flag
, switch
, Flag
, HasHelp
, help
) where
import Control.Applicative
import Data.Map (Map)
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
import Data.String (IsString(..))
import Env.Free
import Env.Val
static :: Parser b -> [(String, String)] -> Either [Error] b
static (Parser p) (Map.fromList -> env) =
toEither (runAlt go p)
where
go v = maybe id (\d x -> x <|> pure d) (varfDef v) (fromEither (readVar v =<< lookupVar v env))
lookupVar :: VarF a -> Map String String -> Either [Error] String
lookupVar v = note [ENoExistError (varfName v)] . Map.lookup (varfName v)
readVar :: VarF a -> String -> Either [Error] a
readVar v = mapLeft (pure . ParseError (varfName v)) . varfReader v
note :: a -> Maybe b -> Either a b
note a = maybe (Left a) Right
mapLeft :: (a -> b) -> Either a t -> Either b t
mapLeft f = either (Left . f) Right
newtype Parser a = Parser { unParser :: Alt VarF a }
deriving (Functor)
instance Applicative Parser where
pure = Parser . pure
Parser f <*> Parser x = Parser (f <*> x)
instance Alternative Parser where
empty = Parser empty
Parser f <|> Parser x = Parser (f <|> x)
prefixed :: String -> Parser a -> Parser a
prefixed pre =
Parser . hoistAlt (\v -> v { varfName = pre ++ varfName v }) . unParser
data Error
= ParseError String String
| ENoExistError String
deriving (Show, Eq)
data VarF a = VarF
{ varfName :: String
, varfReader :: Reader a
, varfHelp :: Maybe String
, varfDef :: Maybe a
, varfHelpDef :: Maybe String
} deriving (Functor)
type Reader a = String -> Either String a
var :: Reader a -> String -> Mod Var a -> Parser a
var r n (Mod f) = Parser . liftAlt $ VarF
{ varfName = n
, varfReader = r
, varfHelp = varHelp
, varfDef = varDef
, varfHelpDef = varHelpDef <*> varDef
}
where
Var { varHelp, varDef, varHelpDef } = f defaultVar
flag
:: a
-> a
-> String -> Mod Flag a -> Parser a
flag f t n (Mod g) = Parser . liftAlt $ VarF
{ varfName = n
, varfReader = Right . either (const f) (const t) . (nonempty :: Reader String)
, varfHelp = flagHelp
, varfDef = Just f
, varfHelpDef = Nothing
}
where
Flag { flagHelp } = g defaultFlag
switch :: String -> Mod Flag Bool -> Parser Bool
switch = flag False True
str :: IsString s => Reader s
str = Right . fromString
nonempty :: IsString s => Reader s
nonempty = fmap fromString . go where go [] = Left "a non-empty string is expected"; go xs = Right xs
auto :: Read a => Reader a
auto = \s -> case reads s of [(v, "")] -> Right v; _ -> Left (show s ++ " is an invalid value")
newtype Mod t a = Mod (t a -> t a)
instance Monoid (Mod t a) where
mempty = Mod id
mappend (Mod f) (Mod g) = Mod (g . f)
data Info a = Info
{ infoHeader :: Maybe String
, infoDesc :: Maybe String
, infoFooter :: Maybe String
}
defaultInfo :: Info a
defaultInfo = Info
{ infoHeader = Nothing
, infoDesc = Nothing
, infoFooter = Nothing
}
header :: String -> Mod Info a
header h = Mod (\i -> i { infoHeader = Just h })
desc :: String -> Mod Info a
desc h = Mod (\i -> i { infoDesc = Just h })
footer :: String -> Mod Info a
footer h = Mod (\i -> i { infoFooter = Just h })
data Var a = Var
{ varHelp :: Maybe String
, varHelpDef :: Maybe (a -> String)
, varDef :: Maybe a
}
defaultVar :: Var a
defaultVar = Var
{ varHelp = Nothing
, varDef = Nothing
, varHelpDef = Nothing
}
def :: a -> Mod Var a
def d = Mod (\v -> v { varDef = Just d })
data Flag a = Flag
{ flagHelp :: Maybe String
}
defaultFlag :: Flag a
defaultFlag = Flag { flagHelp = Nothing }
helpDef :: (a -> String) -> Mod Var a
helpDef d = Mod (\v -> v { varHelpDef = Just d })
class HasHelp t where
setHelp :: String -> t a -> t a
instance HasHelp Var where
setHelp h v = v { varHelp = Just h }
instance HasHelp Flag where
setHelp h v = v { flagHelp = Just h }
help :: HasHelp t => String -> Mod t a
help = Mod . setHelp