packages feed

yamlparse-applicative (empty) → 0.0.0.0

raw patch · 11 files changed

+981/−0 lines, 11 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, bytestring, genvalidity-aeson, genvalidity-hspec, genvalidity-scientific, genvalidity-text, hspec, optparse-applicative, path, path-io, prettyprinter, scientific, text, unordered-containers, validity, validity-text, vector, yaml, yamlparse-applicative

Files

+ src/YamlParse/Applicative.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Yamlparse applicative+--+-- Implement Yaml parsing and get documentation for it for free.+--+--+-- = Usage example+--+-- For more examples, see the `yamlparse-applicative-demo` examples [in the github repository](https://github.com/NorfairKing/yamlparse-applicative/blob/master/yamlparse-applicative-demo/src/YamlParse/Applicative/Demo.hs)+--+-- Suppose you have some tool and you want to have it read its configuration from a file.+-- You make a type for the configuration:+--+-- > data Configuration+-- >   = Configuration+-- >   { confUrl :: Maybe Text+-- >   , confPort :: Int+-- >   , confToken :: Text+-- >   } deriving (Show, Eq)+--+-- Instead of implementing a 'Data.Yaml.FromJSON' instance, you now implement a 'YamlSchema' instance like so:+--+-- > instance YamlSchema Configuration+-- >   yamlSchema =+-- >     object $ -- Declare that it is a Yaml object+-- >       Configuration+-- >         <$> optionalField -- An optional key may be in the file+-- >             "url"+-- >             "The url to host the server at. It will be hosted on 'localhost' by default."+-- >         <*> optionalFieldWithDefault -- An optional key with default _may_ in the file, the default will be used otherwise+-- >             "port"+-- >             8000+-- >             "The post to host the server at."+-- >         <*> requiredField -- A required field must be in the file+-- >             "token"+-- >             "The authorisation token that clients can use to authenticate themselves."+--+-- Now you've already documented the configuration in code.+-- This will make sure that your documentation stays correct because it will be type-checked.+--+-- Now you can implement 'Data.Yaml.FromJSON' like so:+--+-- > instance FromJSON Configuration+-- >   parseJSON = viaYamlSchema+--+-- And you can get user-facing documentation about the format for free using 'prettySchema . explainParser':+--+-- > # Configuration+-- > url: # optional+-- >   # The url to host the server at. It will be hosted on 'localhost' by default.+-- >   <string>+-- > port: # optional, default: 8000+-- >   # The post to host the server at.+-- >   <number>+-- > token: # required+-- >   # The authorisation token that clients can use to authenticate themselves.+-- >   <bool>+--+-- If you are also using 'optparse-applicative', you can even add this documentation to your `--help` page as well using 'confDesc':+--+-- > argParser :: ParserInfo SomethingElse+-- > argParser =+-- >   info+-- >     (helper <$> parseSomethingElse)+-- >     (confDesc (yamlSchema :: YamlParser Configuration))+module YamlParse.Applicative+  ( -- * The YamlSchema Class+    YamlSchema (..),++    -- ** Implementing YamlSchema instances+    object,+    unnamedObject,+    (<?>),+    (<??>),+    requiredField,+    requiredField',+    requiredFieldWith,+    requiredFieldWith',+    optionalField,+    optionalField',+    optionalFieldWith,+    optionalFieldWith',+    optionalFieldWithDefault,+    optionalFieldWithDefault',+    optionalFieldWithDefaultWith,+    optionalFieldWithDefaultWith',+    literalString,+    literalValue,+    literalShowValue,+    alternatives,++    -- * Parser+    YamlParser,+    ObjectParser,+    Parser (..),++    -- * Using a yaml schema++    -- ** Parsing Yaml via a YamlSchema instance+    viaYamlSchema,+    ViaYamlSchema (..),++    -- ** Getting a parser implemntation from a 'Parser'+    implementParser,++    -- * Documentation for a 'Parser'+    explainParser,+    Schema (..),++    -- ** Showing the schema to the user+    prettySchema,++    -- * Interface with 'optparse-applicative'+    confDesc,++    -- * Parsing a file+    readConfigFile,+    readFirstConfigFile,+  )+where++import YamlParse.Applicative.Class+import YamlParse.Applicative.Explain+import YamlParse.Applicative.IO+import YamlParse.Applicative.Implement+import YamlParse.Applicative.OptParse+import YamlParse.Applicative.Parser+import YamlParse.Applicative.Pretty
+ src/YamlParse/Applicative/Class.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module YamlParse.Applicative.Class where++import qualified Data.Aeson as JSON+import Data.Scientific+import qualified Data.Text as T+import Data.Text (Text)+import Data.Vector (Vector)+import qualified Data.Vector as V+import qualified Data.Yaml as Yaml+import GHC.Generics (Generic)+import YamlParse.Applicative.Implement+import YamlParse.Applicative.Parser++-- | A class of types for which a schema is defined.+--+-- Note that you do not have to use this class and can just use your own parser values.+-- Note also that the parsing of a type of this class should correspond to the parsing of the type in the FromJSON class.+class YamlSchema a where+  {-# MINIMAL yamlSchema #-}++  -- | A yamlschema for one value+  --+  -- See the sections on helper functions for implementing this for plenty of examples.+  yamlSchema :: YamlParser a++  -- | A yamlschema for a list of values+  --+  -- This is really only useful for cases like 'Char' and 'String'+  yamlSchemaList :: YamlParser [a]+  yamlSchemaList = V.toList <$> ParseArray Nothing (ParseList yamlSchema)++instance YamlSchema Bool where+  yamlSchema = ParseBool Nothing ParseAny++instance YamlSchema Char where+  yamlSchema =+    ParseString Nothing $+      ParseMaybe+        ( \cs -> case T.unpack cs of+            [] -> Nothing+            [c] -> Just c+            _ -> Nothing+        )+        ParseAny+  yamlSchemaList = T.unpack <$> yamlSchema++instance YamlSchema Text where+  yamlSchema = ParseString Nothing ParseAny++instance YamlSchema Scientific where+  yamlSchema = ParseNumber Nothing ParseAny++instance YamlSchema Yaml.Object where+  yamlSchema = ParseObject Nothing ParseAny++instance YamlSchema Yaml.Value where+  yamlSchema = ParseAny++instance YamlSchema a => YamlSchema (Vector a) where+  yamlSchema = ParseArray Nothing (ParseList yamlSchema)++instance YamlSchema a => YamlSchema [a] where+  yamlSchema = yamlSchemaList++-- | A parser for a required field in an object at a given key+requiredField :: YamlSchema a => Text -> Text -> ObjectParser a+requiredField k h = requiredFieldWith k h yamlSchema++-- | A parser for a required field in an object at a given key without a help text+requiredField' :: YamlSchema a => Text -> ObjectParser a+requiredField' k = requiredFieldWith' k yamlSchema++-- | A parser for an optional field in an object at a given key+optionalField :: YamlSchema a => Text -> Text -> ObjectParser (Maybe a)+optionalField k h = optionalFieldWith k h yamlSchema++-- | A parser for an optional field in an object at a given key without a help text+optionalField' :: YamlSchema a => Text -> ObjectParser (Maybe a)+optionalField' k = optionalFieldWith' k yamlSchema++-- | A parser for an optional field in an object at a given key with a default value+optionalFieldWithDefault :: (Show a, YamlSchema a) => Text -> a -> Text -> ObjectParser a+optionalFieldWithDefault k d h = optionalFieldWithDefaultWith k d h yamlSchema++-- | A parser for an optional field in an object at a given key with a default value without a help text+optionalFieldWithDefault' :: (Show a, YamlSchema a) => Text -> a -> ObjectParser a+optionalFieldWithDefault' k d = optionalFieldWithDefaultWith' k d yamlSchema++-- | Helper function to implement 'FromJSON' via 'YamlSchema'+--+-- Example:+--+-- > instance FromJSON Config where+-- >   parseJSON = viaYamlSchema+viaYamlSchema :: YamlSchema a => Yaml.Value -> Yaml.Parser a+viaYamlSchema = implementParser yamlSchema++-- | A helper newtype to parse a yaml value using the YamlSchema parser.+--+-- Example:+--+-- > case Data.Yaml.decodeEither' contents of+-- >   Left e -> die $ show e+-- >   Right (ViaYamlSchema res) -> print res+--+-- This only helps you when you really don't want to implement a 'FromJSON' instance.+-- See 'viaYamlSchema' if you do.+newtype ViaYamlSchema a = ViaYamlSchema a+  deriving (Show, Eq, Generic)++instance YamlSchema a => Yaml.FromJSON (ViaYamlSchema a) where+  parseJSON = fmap ViaYamlSchema . viaYamlSchema
+ src/YamlParse/Applicative/Explain.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module YamlParse.Applicative.Explain where++import qualified Data.Text as T+import Data.Text (Text)+import Data.Validity+import Data.Validity.Text ()+import GHC.Generics (Generic)+import YamlParse.Applicative.Parser++-- A schema for a parser.+--+-- This is used to produce documentation for what/how the parser parses.+data Schema+  = EmptySchema+  | AnySchema+  | ExactSchema Text+  | 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+  | ApSchema Schema Schema -- We'll take this to mean 'and'+  | AltSchema [Schema]+  | CommentSchema Text Schema+  deriving (Show, Eq, Generic)++instance Validity Schema++-- | Use a parser to produce a schema that describes it for documentation.+--+-- Nothing means that nothing even needs to be parsed, you just get the 'a' without parsing anything.+-- This is for the 'pure' case.+explainParser :: Parser i o -> Schema+explainParser = go+  where+    go :: Parser i o -> Schema+    go = \case+      ParseAny -> AnySchema+      ParseMaybe _ p -> go p+      ParseEq _ t _ -> ExactSchema t+      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+      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+      ParsePure _ -> EmptySchema+      ParseFmap _ p -> go p+      ParseAp pf p -> ApSchema (go pf) (go p)+      ParseAlt ps -> AltSchema $ map go ps+      ParseComment t p -> CommentSchema t $ go p
+ src/YamlParse/Applicative/IO.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module YamlParse.Applicative.IO where++import qualified Data.ByteString as SB+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import Path+import Path.IO+import System.Exit+import YamlParse.Applicative.Class+import YamlParse.Applicative.Explain+import YamlParse.Applicative.Parser+import YamlParse.Applicative.Pretty++-- | Helper function to read a config file for a type in 'YamlSchema'+readConfigFile :: (YamlSchema a, Yaml.FromJSON a) => Path r File -> IO (Maybe a)+readConfigFile p = readFirstConfigFile [p]++-- | Helper function to read the first in a list of config files+readFirstConfigFile :: forall a r. (Yaml.FromJSON a, YamlSchema a) => [Path r File] -> IO (Maybe a)+readFirstConfigFile files = go files+  where+    go :: [Path r File] -> IO (Maybe a)+    go =+      \case+        [] -> pure Nothing+        (p : ps) -> do+          mc <- forgivingAbsence $ SB.readFile $ toFilePath p+          case mc of+            Nothing -> go ps+            Just contents ->+              case Yaml.decodeEither' contents of+                Left err -> do+                  let failedMsgs =+                        [ "Failed to parse yaml file",+                          toFilePath p,+                          "with error:",+                          Yaml.prettyPrintParseException err+                        ]+                      triedFilesMsgs = case files of+                        [] -> []+                        [f] -> ["While parsing file: " <> toFilePath f]+                        fs -> "While parsing files:" : map (("* " <>) . toFilePath) fs+                      referenceMsgs =+                        [ "Reference: ",+                          T.unpack $ prettySchema $ explainParser (yamlSchema :: YamlParser a)+                        ]+                  die+                    $ unlines+                    $ concat+                      [ failedMsgs,+                        triedFilesMsgs,+                        referenceMsgs+                      ]+                Right (ViaYamlSchema conf) -> pure $ Just conf
+ src/YamlParse/Applicative/Implement.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++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.Text as T+import qualified Data.Yaml as Yaml+import YamlParse.Applicative.Parser++-- | Use a 'Parser' to parse a value from Yaml.+--+-- A 'Parser i o' corresponds exactly to a 'i -> Yaml.Parser o' and this function servers as evidence for that.+implementParser :: Parser i o -> (i -> Yaml.Parser o)+implementParser = go+  where+    go :: Parser i o -> (i -> Yaml.Parser o)+    go = \case+      ParseAny -> pure+      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+      -- 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+        Nothing -> \v -> case v of+          Yaml.Bool o -> go p o+          _ -> Aeson.typeMismatch "Bool" v+      ParseString mt p -> case mt of+        Just t -> Yaml.withText (T.unpack t) $ go p+        Nothing -> \v -> case v of+          Yaml.String o -> go p o+          _ -> Aeson.typeMismatch "String" v+      ParseNumber mt p -> case mt of+        Just t -> Yaml.withScientific (T.unpack t) $ go p+        Nothing -> \v -> case v of+          Yaml.Number o -> go p o+          _ -> Aeson.typeMismatch "Number" v+      ParseArray mt p -> case mt of+        Just t -> Yaml.withArray (T.unpack t) $ go p+        Nothing -> \v -> case v of+          Yaml.Array o -> go p o+          _ -> Aeson.typeMismatch "Array" v+      ParseObject mt p -> case mt of+        Just t -> Yaml.withObject (T.unpack t) $ go p+        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+          go p v Aeson.<?> Aeson.Key key+        FieldParserOptional p -> do+          mv <- o Yaml..:? key+          case mv of+            Nothing -> pure Nothing+            Just v -> Just <$> go p v Aeson.<?> Aeson.Key key+        FieldParserOptionalWithDefault p d -> do+          mv <- o Yaml..:? key+          case mv of+            Nothing -> pure d+            Just v -> go p v Aeson.<?> Aeson.Key key+      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+      ParseFmap f p -> fmap f . go p+      ParseComment _ p -> go p
+ src/YamlParse/Applicative/OptParse.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module YamlParse.Applicative.OptParse where++import qualified Data.Text as T+import qualified Options.Applicative as OptParse+import qualified Options.Applicative.Help as OptParse+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
+ src/YamlParse/Applicative/Parser.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module YamlParse.Applicative.Parser where++import Control.Applicative+import qualified Data.Aeson as JSON+import qualified Data.ByteString.Lazy as LB+import Data.Scientific+import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Data.Validity.Text ()+import Data.Vector (Vector)+import qualified Data.Yaml as Yaml++-- | A parser that takes values of type 'i' as input and parses them into values of type 'o'+--+-- Note that there is no 'Monad' instance.+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+  -- | Match an exact value+  ParseEq ::+    (Show o, Eq o) =>+    o ->+    -- | Shown version of the o in the previous argument+    Text ->+    Parser i o ->+    Parser i o+  -- | Parse a boolean value+  ParseBool :: Maybe Text -> Parser Bool o -> Parser Yaml.Value o+  -- | Parse a String value+  ParseString ::+    -- | Extra info about what the string represents+    -- This info will be used during parsing for error messages and in the schema for documentation.+    Maybe Text ->+    Parser Text o ->+    Parser Yaml.Value o+  -- | Parse a numeric value+  ParseNumber ::+    -- | Extra info about what the number represents+    -- This info will be used during parsing for error messages and in the schema for documentation.+    Maybe Text ->+    Parser Scientific o ->+    Parser Yaml.Value o+  -- | Parse an array+  ParseArray ::+    -- | Extra info about what the array represents+    -- This info will be used during parsing for error messages and in the schema for documentation.+    Maybe Text ->+    Parser Yaml.Array o ->+    Parser Yaml.Value o+  -- | Parse an object+  ParseObject ::+    -- | Extra info about what the object represents+    -- This info will be used during parsing for error messages and in the schema for documentation.+    Maybe Text ->+    Parser Yaml.Object a ->+    Parser Yaml.Value a+  -- | Parse a list of elements all in the same way+  ParseList ::+    Parser Yaml.Value o ->+    Parser Yaml.Array (Vector o)+  -- | Parse a field of an object+  ParseField ::+    -- | The key of the field+    Text ->+    FieldParser o ->+    Parser Yaml.Object o+  -- | A pure value+  ParsePure :: a -> Parser i a+  -- | To implement Functor+  ParseFmap :: (a -> b) -> Parser i a -> Parser i b+  -- | To implement Applicative+  ParseAp :: Parser i (a -> b) -> Parser i a -> Parser i b+  -- | To implement Alternative+  ParseAlt :: [Parser i o] -> Parser i o+  -- | Add comments to the parser.+  -- This info will be used in the schema for documentation.+  ParseComment :: Text -> Parser i o -> Parser i o++instance Functor (Parser i) where+  fmap = ParseFmap++-- Realy only makes sense for 'Parser Yaml.Object', but we need 'Parser i' here to get the 'Alternative' instance to work+instance Applicative (Parser i) where+  pure = ParsePure+  (<*>) = ParseAp++instance Alternative (Parser i) where+  empty = ParseAlt []+  l <|> r = ParseAlt [l, r]+  some = undefined -- TODO figure out what to do here+  many = undefined++data FieldParser o where+  FieldParserRequired :: YamlParser o -> FieldParser o+  FieldParserOptional :: YamlParser o -> FieldParser (Maybe o)+  FieldParserOptionalWithDefault :: Show o => YamlParser o -> o -> FieldParser o++type YamlParser a = Parser Yaml.Value a++type ObjectParser a = Parser Yaml.Object a++-- | Declare a parser of a named object+object :: Text -> ObjectParser o -> YamlParser o+object name = ParseObject (Just name)++-- | Declare a parser of an unnamed object+--+-- Prefer 'object' if you can.+unnamedObject :: ObjectParser o -> YamlParser o+unnamedObject = ParseObject Nothing++-- | Declare a parser for an exact string.+--+-- You can use this to parse a constructor in an enum for example:+--+-- > data Fruit = Apple | Banana+-- >+-- > instance YamlSchema Fruit where+-- >   yamlSchema = Apple <$ literalString "Apple" <|> Banana <$ literalString "Banana"+literalString :: Text -> YamlParser Text+literalString t = ParseString Nothing $ ParseEq t t ParseAny++-- | Declare a parser for a value using its show instance+--+-- Note that no value is read. The parsed string is just compared to the shown given value.+--+-- You can use this to parse a constructor in an enum when it has a 'Show' instance.+--+-- For example:+--+-- > data Fruit = Apple | Banana | Melon+-- >   deriving (Show, Eq)+-- >+-- > instance YamlSchema Fruit where+-- >   yamlSchema = alternatives+-- >      [ literalShowString Apple+-- >      , literalShowString Banana+-- >      , literalShowString Melon+-- >      ]+literalShowValue :: Show a => a -> YamlParser a+literalShowValue v = v <$ literalString (T.pack $ show v)++-- | Declare a parser for a value using its show instance+--+-- Note that no value is read. The parsed string is just compared to the shown given value.+--+-- You can use this to parse a constructor in an enum when it has a 'ToJSON' instance.+--+-- For example+--+-- > data Fruit = Apple | Banana | Melon+-- >   deriving (Eq, Generic)+-- >+-- > instance ToJSON Fruit+-- >+-- > instance YamlSchema Fruit where+-- >   yamlSchema = alternatives+-- >      [ literalValue Apple+-- >      , literalValue Banana+-- >      , literalValue Melon+-- >      ]+literalValue :: Yaml.ToJSON a => a -> YamlParser a+literalValue v = v <$ ParseEq (Yaml.toJSON v) (TE.decodeUtf8 $ LB.toStrict $ JSON.encode v) ParseAny++-- | Use the first parser of the given list that succeeds+--+-- You can use this to parse a constructor in an enum.+--+-- For example:+--+-- > data Fruit = Apple | Banana | Melon+-- >+-- > instance YamlSchema Fruit where+-- >   yamlSchema = alternatives+-- >      [ Apple <$ literalString "Apple"+-- >      , Banana <$ literalString "Banana"+-- >      , Melon <$ literalString "Melon"+-- >      ]+alternatives :: [Parser i o] -> Parser i o+alternatives = ParseAlt++-- | Add a comment to a parser+--+-- This info will be used in the schema for documentation.+--+-- For example:+--+-- > data Result = Error | Ok+-- > instance YamlSchema Result where+-- >   yamlSchema = alternatives+-- >     [ Error <$ literalString "Error" <?> "An error"+-- >     , Ok <$ literalString "Ok" <?> "Oll Klear"+-- >     ]+(<?>) :: Parser i a -> Text -> Parser i a+(<?>) = flip ParseComment++-- | Add a list of lines of comments to a parser+--+-- This info will be used in the schema for documentation.+--+-- For example:+--+-- > data Result = Error | Ok+-- > instance YamlSchema Result where+-- >   yamlSchema = alternatives+-- >     [ Error <$ literalString "Error" <??> ["Just an error", "but I've got a lot to say about this"]+-- >     , Ok <$ literalString "Ok" <??> ["Oll Klear", "I really don't know where 'OK' comes from?!"]+-- >     ]+(<??>) :: Parser i a -> [Text] -> Parser i a+(<??>) p ts = p <?> T.unlines ts++-- | A parser for a required field at a given key with a parser for what is found at that key+requiredFieldWith :: Text -> Text -> YamlParser a -> ObjectParser a+requiredFieldWith k h func = ParseComment h $ ParseField k $ FieldParserRequired func++-- | A parser for a required field at a given key with a parser for what is found at that key without a help text+requiredFieldWith' :: Text -> YamlParser a -> ObjectParser a+requiredFieldWith' k func = ParseField k $ FieldParserRequired func++-- | A parser for an optional field at a given key with a parser for what is found at that key+optionalFieldWith :: Text -> Text -> YamlParser a -> ObjectParser (Maybe a)+optionalFieldWith k h func = ParseComment h $ ParseField k $ FieldParserOptional func++-- | A parser for an optional field at a given key with a parser for what is found at that key without a help text+optionalFieldWith' :: Text -> YamlParser a -> ObjectParser (Maybe a)+optionalFieldWith' k func = ParseField k $ FieldParserOptional func++-- | A parser for an optional field at a given key with a default value and a parser for what is found at that key+--+-- For the sake of documentation, the default value needs to be showable.+optionalFieldWithDefaultWith :: Show a => Text -> a -> Text -> YamlParser a -> ObjectParser a+optionalFieldWithDefaultWith k d h func = ParseComment h $ ParseField k $ FieldParserOptionalWithDefault func d++-- | A parser for an optional field at a given key with a default value and a parser for what is found at that key without a help text+--+-- 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
+ src/YamlParse/Applicative/Pretty.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module YamlParse.Applicative.Pretty where++import qualified Data.Text as T+import Data.Text (Text)+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Text+import YamlParse.Applicative.Explain++-- | Render a schema as pretty text.+--+-- This is meant for humans.+-- The output may look like YAML but it is not.+prettySchema :: Schema -> Text+prettySchema = renderStrict . layoutPretty defaultLayoutOptions . schemaDoc++-- | A list of comments+newtype Comments = Comments {commentsList :: [Doc ()]}+  deriving (Show)++instance Semigroup Comments where+  (Comments l1) <> (Comments l2) = Comments $ l1 <> l2++instance Monoid Comments where+  mempty = emptyComments+  mappend = (<>)++-- | No comments+emptyComments :: Comments+emptyComments = Comments []++-- | A raw text as comments+comment :: Text -> Comments+comment t = Comments $ map pretty $ T.lines t++-- | Prettyprint a 'Schema'+schemaDoc :: Schema -> Doc ()+schemaDoc = go emptyComments+  where+    go :: Comments -> Schema -> Doc ()+    go cs =+      let g = go cs+          ge = go emptyComments+          mkComment :: Doc () -> Doc ()+          mkComment = ("# " <>)+          mkCommentsMDoc :: Comments -> Maybe (Doc ())+          mkCommentsMDoc = \case+            Comments [] -> Nothing+            Comments l -> Just $ align $ vsep $ map mkComment l+          addMComment :: Comments -> Maybe Text -> Comments+          addMComment c = \case+            Nothing -> c+            Just t -> c <> comment t+          e :: Doc () -> Comments -> Doc ()+          e s cs' =+            case mkCommentsMDoc cs' of+              Nothing -> s+              Just cd -> vsep [cd, s]+       in \case+            EmptySchema -> e "# Nothing to parse" cs+            AnySchema -> e "<any>" cs+            ExactSchema t -> e (pretty t) cs+            BoolSchema t -> e "<bool>" $ addMComment cs t+            NumberSchema t -> e "<number>" $ addMComment cs t+            StringSchema t -> e "<string>" $ addMComment cs t+            ArraySchema t s -> "-" <+> align (go (addMComment cs t) s)+            -- 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+                  requiredDoc :: Doc a+                  requiredDoc =+                    if r+                      then "required"+                      else case md of+                        Nothing -> "optional"+                        Just d -> "optional, default:" <+> pretty d+               in vsep+                    [ keyDoc <> ":" <+> mkComment requiredDoc,+                      indent 2 $ g s+                    ]+            ApSchema s1 s2 -> align $ vsep [g s1, g s2]+            AltSchema ss ->+              let listDoc :: [Doc a] -> Doc a+                  listDoc = \case+                    [] -> "[]"+                    (d : ds) -> vsep ["[" <+> nest 2 d, vsep $ map (("," <+>) . nest 2) ds, "]"]+               in e (listDoc $ map ge ss) cs+            CommentSchema t s -> go (cs <> comment t) s
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/YamlParse/ApplicativeSpec.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module YamlParse.ApplicativeSpec where++import qualified Data.Aeson.Types as Aeson+import Data.GenValidity.Aeson ()+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Typeable+import GHC.Generics (Generic)+import Test.Hspec+import Test.QuickCheck+import Test.Validity+import Test.Validity.Utils+import YamlParse.Applicative as Yaml++spec :: Spec+spec =+  describe "implementParser" $ do+    implementationsSpec @Bool+    implementationsSpec @Char+    implementationsSpec @String+    implementationsSpec @Text+    implementationsSpec @Scientific+    implementationsSpec @Aeson.Array+    implementationsSpec @Aeson.Object+    implementationsSpec @Aeson.Value+    implementationsSpec @[Text]+    implementationsSpec @[Text]+    implementationsSpec @Fruit++data Fruit = Apple | Banana | Melon+  deriving (Show, Eq, Generic)++instance Aeson.FromJSON Fruit++instance Aeson.ToJSON Fruit++instance YamlSchema Fruit where+  yamlSchema =+    alternatives+      [ literalShowValue Apple,+        literalShowValue Banana,+        literalShowValue Melon+      ]++instance Validity Fruit++instance GenUnchecked Fruit++instance GenValid Fruit++implementationsSpec ::+  forall a.+  ( Show a,+    Eq a,+    Typeable a,+    GenValid a,+    Aeson.FromJSON a,+    Aeson.ToJSON a,+    YamlSchema a+  ) =>+  Spec+implementationsSpec = specify ("The implementation of 'parseJSON' matches the implementation of 'implementParser yamlSchema' for " <> nameOf @a) $ implementationsMatch @a++implementationsMatch ::+  forall a.+  ( Show a,+    Eq a,+    GenValid a,+    Aeson.FromJSON a,+    Aeson.ToJSON a,+    YamlSchema a+  ) =>+  Property+implementationsMatch =+  forAllValid $+    \a -> do+      let v = Aeson.toJSON (a :: a)+      let aesonResult = Aeson.parseEither Aeson.parseJSON v :: Either String a+          yamlResult = Aeson.parseEither (implementParser yamlSchema) v+      yamlResult `shouldBe` aesonResult
+ yamlparse-applicative.cabal view
@@ -0,0 +1,76 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 90b9b5088eb7782c23eff327325b065eece4efe16e382e85e087f7dcc0f0fd19++name:           yamlparse-applicative+version:        0.0.0.0+description:    See https://github.com/NorfairKing/yamlparse-applicative+homepage:       https://github.com/NorfairKing/confparse#readme+bug-reports:    https://github.com/NorfairKing/confparse/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+copyright:      2020 Tom Sydney Kerckhove+license:        MIT+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/NorfairKing/confparse++library+  exposed-modules:+      YamlParse.Applicative+      YamlParse.Applicative.Class+      YamlParse.Applicative.Explain+      YamlParse.Applicative.Implement+      YamlParse.Applicative.IO+      YamlParse.Applicative.OptParse+      YamlParse.Applicative.Parser+      YamlParse.Applicative.Pretty+  other-modules:+      Paths_yamlparse_applicative+  hs-source-dirs:+      src+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , optparse-applicative+    , path+    , path-io+    , prettyprinter+    , scientific+    , text+    , unordered-containers+    , validity+    , validity-text+    , vector+    , yaml+  default-language: Haskell2010++test-suite yamlparse-applicative-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      YamlParse.ApplicativeSpec+      Paths_yamlparse_applicative+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , genvalidity-aeson+    , genvalidity-hspec+    , genvalidity-scientific+    , genvalidity-text+    , hspec+    , scientific+    , text+    , yamlparse-applicative+  default-language: Haskell2010