yamlparse-applicative 0.0.0.0 → 0.1.0.0

raw patch · 9 files changed

+237/−36 lines, 9 filesdep +containersdep +genvalidity-containersdep +genvalidity-unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, genvalidity-containers, genvalidity-unordered-containers

API changes (from Hackage documentation)

Files

• src/YamlParse/Applicative.hs +9/−4
• src/YamlParse/Applicative/Class.hs +89/−3
• src/YamlParse/Applicative/Explain.hs +12/−4
• src/YamlParse/Applicative/Implement.hs +18/−8
• src/YamlParse/Applicative/OptParse.hs +9/−3
• src/YamlParse/Applicative/Parser.hs +72/−7
• src/YamlParse/Applicative/Pretty.hs +5/−1
• test/YamlParse/ApplicativeSpec.hs +12/−1
• yamlparse-applicative.cabal +11/−5

@@ -26,7 +26,7 @@ -- -- > instance YamlSchema Configuration -- >   yamlSchema =--- >     object $ -- Declare that it is a Yaml object+-- >     objectParser $ -- Declare that it is a Yaml object -- >       Configuration -- >         <$> optionalField -- An optional key may be in the file -- >             "url"@@ -66,14 +66,18 @@ -- > argParser = -- >   info -- >     (helper <$> parseSomethingElse)--- >     (confDesc (yamlSchema :: YamlParser Configuration))+-- >     (confDesc @Configuration) module YamlParse.Applicative   ( -- * The YamlSchema Class     YamlSchema (..),+    YamlKeySchema (..),      -- ** Implementing YamlSchema instances-    object,-    unnamedObject,+    objectParser,+    unnamedObjectParser,+    maybeParser,+    eitherParser,+    extraParser,     (<?>),     (<??>),     requiredField,@@ -88,6 +92,7 @@     optionalFieldWithDefault',     optionalFieldWithDefaultWith,     optionalFieldWithDefaultWith',+    viaRead,     literalString,     literalValue,     literalShowValue,

@@ -7,13 +7,21 @@ module YamlParse.Applicative.Class where  import qualified Data.Aeson as JSON+import Data.HashMap.Strict (HashMap)+import Data.Int+import Data.List.NonEmpty as NE+import Data.Map (Map) import Data.Scientific+import Data.Set (Set)+import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) import Data.Vector (Vector) import qualified Data.Vector as V+import Data.Word import qualified Data.Yaml as Yaml import GHC.Generics (Generic)+import Path import YamlParse.Applicative.Implement import YamlParse.Applicative.Parser @@ -35,13 +43,20 @@   yamlSchemaList :: YamlParser [a]   yamlSchemaList = V.toList <$> ParseArray Nothing (ParseList yamlSchema) +-- | A class of types for which a schema for keys is defined.+class YamlKeySchema a where+  yamlKeySchema :: KeyParser a++instance YamlSchema () where+  yamlSchema = pure ()+ instance YamlSchema Bool where   yamlSchema = ParseBool Nothing ParseAny  instance YamlSchema Char where   yamlSchema =     ParseString Nothing $-      ParseMaybe+      maybeParser         ( \cs -> case T.unpack cs of             [] -> Nothing             [c] -> Just c@@ -53,20 +68,91 @@ instance YamlSchema Text where   yamlSchema = ParseString Nothing ParseAny +instance YamlKeySchema Text where+  yamlKeySchema = ParseAny++instance YamlKeySchema String where+  yamlKeySchema = T.unpack <$> yamlKeySchema+ instance YamlSchema Scientific where   yamlSchema = ParseNumber Nothing ParseAny -instance YamlSchema Yaml.Object where-  yamlSchema = ParseObject Nothing ParseAny+instance YamlSchema Int where+  yamlSchema = boundedIntegerSchema +instance YamlSchema Int8 where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Int16 where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Int32 where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Int64 where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Word where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Word8 where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Word16 where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Word32 where+  yamlSchema = boundedIntegerSchema++instance YamlSchema Word64 where+  yamlSchema = boundedIntegerSchema++boundedIntegerSchema :: (Integral i, Bounded i) => YamlParser i+boundedIntegerSchema = maybeParser toBoundedInteger $ ParseNumber Nothing ParseAny++instance YamlSchema (Path Rel File) where+  yamlSchema = maybeParser parseRelFile yamlSchema++instance YamlSchema (Path Rel Dir) where+  yamlSchema = maybeParser parseRelDir yamlSchema++instance YamlSchema (Path Abs File) where+  yamlSchema = maybeParser parseAbsFile yamlSchema++instance YamlSchema (Path Abs Dir) where+  yamlSchema = maybeParser parseAbsDir yamlSchema+ instance YamlSchema Yaml.Value where   yamlSchema = ParseAny +instance YamlSchema a => YamlSchema (Maybe a) where+  yamlSchema = ParseMaybe yamlSchema+ instance YamlSchema a => YamlSchema (Vector a) where   yamlSchema = ParseArray Nothing (ParseList yamlSchema)  instance YamlSchema a => YamlSchema [a] where   yamlSchema = yamlSchemaList++instance YamlSchema a => YamlSchema (NonEmpty a) where+  yamlSchema = extraParser go yamlSchema+    where+      go :: [a] -> Yaml.Parser (NonEmpty a)+      go as = case NE.nonEmpty as of+        Nothing -> fail "Nonempty list expected, but got an empty list"+        Just ne -> pure ne++instance (Ord a, YamlSchema a) => YamlSchema (Set a) where+  yamlSchema = S.fromList <$> yamlSchema++instance (Ord k, YamlKeySchema k, YamlSchema v) => YamlSchema (Map k v) where+  yamlSchema = ParseObject Nothing $ ParseMapKeys yamlKeySchema $ ParseMap yamlSchema++-- | There is no instance using YamlKeySchema k yet.+-- Ideally there wouldn't be one for HashMap Text either because it's insecure,+-- but the yaml arrives in a HashMap anyway so we might as well expose this.+instance YamlSchema v => YamlSchema (HashMap Text v) where+  yamlSchema = ParseObject Nothing $ ParseMap yamlSchema  -- | A parser for a required field in an object at a given key requiredField :: YamlSchema a => Text -> Text -> ObjectParser a

@@ -21,13 +21,17 @@   = EmptySchema   | AnySchema   | ExactSchema Text+  | NullSchema+  | MaybeSchema Schema   | BoolSchema (Maybe Text)   | NumberSchema (Maybe Text)   | StringSchema (Maybe Text)   | ArraySchema (Maybe Text) Schema   | ObjectSchema (Maybe Text) Schema-  | ListSchema Schema   | FieldSchema Text Bool (Maybe Text) Schema+  | ListSchema Schema+  | MapSchema Schema+  | MapKeysSchema Schema   | ApSchema Schema Schema -- We'll take this to mean 'and'   | AltSchema [Schema]   | CommentSchema Text Schema@@ -45,19 +49,23 @@     go :: Parser i o -> Schema     go = \case       ParseAny -> AnySchema-      ParseMaybe _ p -> go p+      ParseExtra _ p -> go p       ParseEq _ t _ -> ExactSchema t+      ParseNull -> NullSchema+      ParseMaybe p -> MaybeSchema $ go p       ParseBool t _ -> BoolSchema t       ParseNumber t _ -> NumberSchema t       ParseString t ParseAny -> StringSchema t       ParseString _ p -> go p       ParseArray t p -> ArraySchema t $ go p-      ParseList p -> ListSchema $ go p+      ParseObject t p -> ObjectSchema t $ go p       ParseField k fp -> case fp of         FieldParserRequired p -> FieldSchema k True Nothing $ go p         FieldParserOptional p -> FieldSchema k False Nothing $ go p         FieldParserOptionalWithDefault p d -> FieldSchema k False (Just $ T.pack $ show d) $ go p-      ParseObject t p -> ObjectSchema t $ go p+      ParseList p -> ListSchema $ go p+      ParseMap p -> MapSchema $ go p+      ParseMapKeys _ p -> MapKeysSchema $ go p       ParsePure _ -> EmptySchema       ParseFmap _ p -> go p       ParseAp pf p -> ApSchema (go pf) (go p)

@@ -8,9 +8,10 @@ module YamlParse.Applicative.Implement where  import Control.Applicative-import Control.Monad import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Yaml as Yaml import YamlParse.Applicative.Parser@@ -24,14 +25,18 @@     go :: Parser i o -> (i -> Yaml.Parser o)     go = \case       ParseAny -> pure+      ParseExtra ef p -> \i -> do+        o <- go p i+        ef o       ParseEq v t p -> \i -> do         r <- go p i         if r == v then pure r else fail $ "Expected " <> T.unpack t <> " exactly but got: " <> show r-      ParseMaybe mf p -> \i -> do-        o <- go p i-        case mf o of-          Nothing -> fail "Parsing failed"-          Just u -> pure u+      ParseNull -> \v -> case v of+        Yaml.Null -> pure ()+        _ -> fail $ "Expected 'null' but got: " <> show v+      ParseMaybe p -> \v -> case v of+        Yaml.Null -> pure Nothing+        _ -> Just <$> go p v       -- We can't just do 'withBool (maybe "Bool" T.unpack mt)' because then there is an extra context in the error message.       ParseBool mt p -> case mt of         Just t -> Yaml.withBool (T.unpack t) $ go p@@ -58,7 +63,6 @@         Nothing -> \v -> case v of           Yaml.Object o -> go p o           _ -> Aeson.typeMismatch "Object" v-      ParseList p -> \l -> forM l $ \v -> go p v       ParseField key fp -> \o -> case fp of         FieldParserRequired p -> do           v <- o Yaml..: key@@ -73,10 +77,16 @@           case mv of             Nothing -> pure d             Just v -> go p v Aeson.<?> Aeson.Key key+      ParseList p -> mapM (go p)+      ParseMap p -> HM.traverseWithKey $ \_ v -> go p v+      ParseMapKeys p pm -> \val -> do+        hm <- go pm val+        M.fromList <$> mapM (\(k, v) -> (,) <$> go p k <*> pure v) (HM.toList hm)       ParsePure v -> const $ pure v       ParseAp pf p -> \v -> go pf v <*> go p v       ParseAlt ps -> \v -> case ps of         [] -> fail "No alternatives."-        (p : ps') -> go p v <|> go (ParseAlt ps') v+        [p] -> go p v+        (p' : ps') -> go p' v <|> go (ParseAlt ps') v       ParseFmap f p -> fmap f . go p       ParseComment _ p -> go p

@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}@@ -8,10 +9,15 @@ import qualified Data.Text as T import qualified Options.Applicative as OptParse import qualified Options.Applicative.Help as OptParse+import YamlParse.Applicative.Class import YamlParse.Applicative.Explain import YamlParse.Applicative.Parser import YamlParse.Applicative.Pretty --- | Helper function to add the schema documentation to the optparse applicative help output-confDesc :: Parser i o -> OptParse.InfoMod a-confDesc p = OptParse.footerDoc $ Just $ OptParse.string . T.unpack . prettySchema $ explainParser p+-- | Helper function to add the schema documentation for a 'YamlSchema' parser to the optparse applicative help output+confDesc :: forall o a. YamlSchema o => OptParse.InfoMod a+confDesc = confDescWith (yamlSchema :: YamlParser o)++-- | Helper function to add the schema documentation for a given parser to the optparse applicative help output+confDescWith :: Parser i o -> OptParse.InfoMod a+confDescWith p = OptParse.footerDoc $ Just $ OptParse.string . T.unpack . prettySchema $ explainParser p

@@ -8,6 +8,8 @@ import Control.Applicative import qualified Data.Aeson as JSON import qualified Data.ByteString.Lazy as LB+import Data.HashMap.Strict (HashMap)+import Data.Map (Map) import Data.Scientific import qualified Data.Text as T import Data.Text (Text)@@ -15,6 +17,7 @@ import Data.Validity.Text () import Data.Vector (Vector) import qualified Data.Yaml as Yaml+import Text.Read  -- | A parser that takes values of type 'i' as input and parses them into values of type 'o' --@@ -22,8 +25,8 @@ data Parser i o where   -- | Return the input   ParseAny :: Parser i i-  -- | Parse via a parser function-  ParseMaybe :: (o -> Maybe u) -> Parser i o -> Parser i u+  -- | Parse via an extra parsing function+  ParseExtra :: (o -> Yaml.Parser u) -> Parser i o -> Parser i u   -- | Match an exact value   ParseEq ::     (Show o, Eq o) =>@@ -32,6 +35,10 @@     Text ->     Parser i o ->     Parser i o+  -- | Parse 'null' only.+  ParseNull :: Parser Yaml.Value ()+  -- | Parse 'null' as 'Nothing' and the rest as 'Just'.+  ParseMaybe :: Parser Yaml.Value o -> Parser Yaml.Value (Maybe o)   -- | Parse a boolean value   ParseBool :: Maybe Text -> Parser Bool o -> Parser Yaml.Value o   -- | Parse a String value@@ -66,6 +73,17 @@   ParseList ::     Parser Yaml.Value o ->     Parser Yaml.Array (Vector o)+  -- | Parse a map where the keys are the yaml keys+  ParseMap ::+    Parser Yaml.Value v ->+    Parser Yaml.Object (HashMap Text v)+  -- | Parse a map's keys via a given parser+  ParseMapKeys ::+    Ord k =>+    Parser Text k ->+    Parser Yaml.Object (HashMap Text v) ->+    Parser Yaml.Object (Map k v) -- Once we get out of a HashMap, we'll want to stay out.+   -- | Parse a field of an object   ParseField ::     -- | The key of the field@@ -107,16 +125,24 @@  type ObjectParser a = Parser Yaml.Object a +type KeyParser a = Parser Text a+ -- | Declare a parser of a named object-object :: Text -> ObjectParser o -> YamlParser o-object name = ParseObject (Just name)+objectParser :: Text -> ObjectParser o -> YamlParser o+objectParser name = ParseObject (Just name)  -- | Declare a parser of an unnamed object ----- Prefer 'object' if you can.-unnamedObject :: ObjectParser o -> YamlParser o-unnamedObject = ParseObject Nothing+-- Prefer 'objectParser' if you can.+unnamedObjectParser :: ObjectParser o -> YamlParser o+unnamedObjectParser = ParseObject Nothing +-- | Parse a string-like thing by 'Read'-ing it+--+-- You probably don't want to use 'Read'.+viaRead :: Read a => YamlParser a+viaRead = maybeParser readMaybe $ T.unpack <$> ParseString Nothing ParseAny+ -- | Declare a parser for an exact string. -- -- You can use this to parse a constructor in an enum for example:@@ -244,3 +270,42 @@ -- For the sake of documentation, the default value needs to be showable. optionalFieldWithDefaultWith' :: Show a => Text -> a -> YamlParser a -> ObjectParser a optionalFieldWithDefaultWith' k d func = ParseField k $ FieldParserOptionalWithDefault func d++-- | Make a parser that parses a value using the given extra parsing function+--+-- You can use this to make a parser for a type with a smart constructor.+-- Prefer 'eitherParser' if you can so you get better error messages.+--+-- Example:+--+-- > parseUsername :: Text -> Maybe Username+-- >+-- > instance YamlSchema Username where+-- >   yamlSchema = maybeParser parseUsername yamlSchema+maybeParser :: Show o => (o -> Maybe u) -> Parser i o -> Parser i u+maybeParser func = ParseExtra $ \o -> case func o of+  Nothing -> fail $ "Parsing of " <> show o <> " failed."+  Just u -> pure u++-- | Make a parser that parses a value using the given extra parsing function+--+-- You can use this to make a parser for a type with a smart constructor.+-- If you don't have a 'Show' instance for your 'o', then you can use 'extraParser' instead.+--+-- Example:+--+-- > parseUsername :: Text -> Either String Username+-- >+-- > instance YamlSchema Username where+-- >   yamlSchema = eitherParser parseUsername yamlSchema+eitherParser :: Show o => (o -> Either String u) -> Parser i o -> Parser i u+eitherParser func = ParseExtra $ \o -> case func o of+  Left err -> fail $ "Parsing of " <> show o <> " failed with error: " <> err <> "."+  Right u -> pure u++-- | Make a parser that parses a value using the given extra parsing function+--+-- You can use this to make a parser for a type with a smart constructor.+-- Prefer 'eitherParser' if you can, use this if you don't have a 'Show' instance for your 'o'.+extraParser :: (o -> Yaml.Parser u) -> Parser i o -> Parser i u+extraParser = ParseExtra

@@ -66,6 +66,8 @@             EmptySchema -> e "# Nothing to parse" cs             AnySchema -> e "<any>" cs             ExactSchema t -> e (pretty t) cs+            NullSchema -> e "null" cs+            MaybeSchema s -> go (cs <> comment "or <null>") s             BoolSchema t -> e "<bool>" $ addMComment cs t             NumberSchema t -> e "<number>" $ addMComment cs t             StringSchema t -> e "<string>" $ addMComment cs t@@ -73,7 +75,6 @@             -- The comments really only work on the object level             -- so they are erased when going down             ObjectSchema t s -> e (ge s) (addMComment cs t)-            ListSchema s -> g s             FieldSchema k r md s ->               let keyDoc :: Doc a                   keyDoc = pretty k@@ -88,6 +89,9 @@                     [ keyDoc <> ":" <+> mkComment requiredDoc,                       indent 2 $ g s                     ]+            ListSchema s -> g s+            MapSchema s -> e ("<key>: " <> nest 2 (g s)) cs+            MapKeysSchema s -> g s             ApSchema s1 s2 -> align $ vsep [g s1, g s2]             AltSchema ss ->               let listDoc :: [Doc a] -> Doc a

@@ -7,7 +7,13 @@  import qualified Data.Aeson.Types as Aeson import Data.GenValidity.Aeson ()+import Data.GenValidity.Containers ()+import Data.GenValidity.UnorderedContainers ()+import Data.HashMap.Strict (HashMap)+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map) import Data.Scientific (Scientific)+import Data.Set (Set) import Data.Text (Text) import Data.Typeable import GHC.Generics (Generic)@@ -29,7 +35,12 @@     implementationsSpec @Aeson.Object     implementationsSpec @Aeson.Value     implementationsSpec @[Text]-    implementationsSpec @[Text]+    implementationsSpec @(NonEmpty Text)+    implementationsSpec @(Maybe Text)+    implementationsSpec @(Set Text)+    implementationsSpec @(Map Text Int)+    implementationsSpec @(HashMap Text Int)+    implementationsSpec @(Map String Int)     implementationsSpec @Fruit  data Fruit = Apple | Banana | Melon

@@ -4,13 +4,14 @@ -- -- see: https://github.com/sol/hpack ----- hash: 90b9b5088eb7782c23eff327325b065eece4efe16e382e85e087f7dcc0f0fd19+-- hash: 672687e38104a0d33d85b5105076de8eb8e5fcf05a7978598b47f291c3bfcaac  name:           yamlparse-applicative-version:        0.0.0.0+version:        0.1.0.0+synopsis:       Declaritive configuration parsing with free docs description:    See https://github.com/NorfairKing/yamlparse-applicative-homepage:       https://github.com/NorfairKing/confparse#readme-bug-reports:    https://github.com/NorfairKing/confparse/issues+homepage:       https://github.com/NorfairKing/yamlparse-applicative#readme+bug-reports:    https://github.com/NorfairKing/yamlparse-applicative/issues author:         Tom Sydney Kerckhove maintainer:     syd@cs-syd.eu copyright:      2020 Tom Sydney Kerckhove@@ -19,7 +20,7 @@  source-repository head   type: git-  location: https://github.com/NorfairKing/confparse+  location: https://github.com/NorfairKing/yamlparse-applicative  library   exposed-modules:@@ -39,6 +40,7 @@       aeson     , base >=4.7 && <5     , bytestring+    , containers     , optparse-applicative     , path     , path-io@@ -65,12 +67,16 @@       QuickCheck     , aeson     , base >=4.7 && <5+    , containers     , genvalidity-aeson+    , genvalidity-containers     , genvalidity-hspec     , genvalidity-scientific     , genvalidity-text+    , genvalidity-unordered-containers     , hspec     , scientific     , text+    , unordered-containers     , yamlparse-applicative   default-language: Haskell2010