yaml-marked (empty) → 0.1.0.0
raw patch · 18 files changed
+1840/−0 lines, 18 filesdep +aesondep +attoparsecdep +base
Dependencies added: aeson, attoparsec, base, bytestring, conduit, containers, dlist, hspec, hspec-expectations-json, libyaml, markdown-unlit, mtl, resourcet, scientific, semigroupoids, text, transformers, unliftio, unordered-containers, vector, yaml, yaml-marked
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- README.lhs +152/−0
- README.md +152/−0
- src/Data/Aeson/Compat.hs +18/−0
- src/Data/Aeson/Compat/Key.hs +22/−0
- src/Data/Aeson/Compat/KeyMap.hs +20/−0
- src/Data/Yaml/Marked.hs +67/−0
- src/Data/Yaml/Marked/Decode.hs +90/−0
- src/Data/Yaml/Marked/Internal.hs +379/−0
- src/Data/Yaml/Marked/Parse.hs +121/−0
- src/Data/Yaml/Marked/Replace.hs +138/−0
- src/Data/Yaml/Marked/Value.hs +45/−0
- test/Data/Yaml/Marked/DecodeSpec.hs +146/−0
- test/Data/Yaml/Marked/InternalSpec.hs +116/−0
- test/Data/Yaml/Marked/ReplaceSpec.hs +178/−0
- test/Spec.hs +2/−0
- yaml-marked.cabal +168/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## [_Unreleased_](https://github.com/pbrisbin/yaml-marked/compare/v0.1.0.0...main)++## [v0.1.0.0](https://github.com/pbrisbin/yaml-marked/tree/v0.1.0.0)++First tagged release.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2024 Patrick Brisbin++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.lhs view
@@ -0,0 +1,152 @@+## yaml-marked++[](https://hackage.haskell.org/package/yaml-marked)+[](http://stackage.org/nightly/package/yaml-marked)+[](http://stackage.org/lts/package/yaml-marked)+[](https://github.com/pbrisbin/yaml-marked/actions/workflows/ci.yml)++Like `Data.Yaml` but for when you need the source locations (aka `YamlMark`s)+for parsed elements.++## Motivation++While working on [`stack-lint-extra-deps`][sled], it became apparent it would be+impossible to implement an auto-fix in a way that preserved the source+formatting of the original Yaml. Sure, we could decode, modify, and encode, but+that loses all formatting, comments, and sorting -- which can be important for+documenting choices made in one's `stack.yaml`.++[sled]: https://github.com/freckle/stack-lint-extra-deps++That is, unless there were a Yaml parser that preserved source locations. Then,+I could use those to make targeted replacements within the original source+`ByteString`, while preserving everything else.++There didn't seem to be anything promising on Hackage, except for the fact that+`Text.Libyaml` (the library powering `Data.Yaml`) has functions that emit+`MarkedEvent`s, which `Data.Yaml` doesn't use.++So I began the process of modifying `Data.Yaml` internals to operate on+`MarkedEvent`s and, instead of assuming `FromJSON` to construct a `Value`, use a+provided decoding function and produce my own `Marked Value` type -- which is+basically the same, except holding the original `YamlMark` (recursively). Thus,+`Data.Yaml.Marked.Decode` was born.++Finally, I created something to approximate a non-typeclass `FromJSON`+(`Data.Yaml.Marked.Parse`), and a module to handle the tricky business of+applying replacements to `ByteString`s (`Data.Yaml.Marked.Replace`), and I can+finally do what I need to:++## Example++<!--+```haskell+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module Main (main) where+import Prelude+import Text.Markdown.Unlit ()+```+-->++### Imports++```haskell+import Data.Text (Text)+import qualified Data.ByteString.Char8 as BS8+import Data.Yaml.Marked+import Data.Yaml.Marked.Value+import Data.Yaml.Marked.Parse+import Data.Yaml.Marked.Decode+import Data.Yaml.Marked.Replace+```++### Decoding++Decoding is meant to look a lot like aeson. Your record should hold `Marked`+values anywhere you will need that:++```haskell+data StackYaml = StackYaml+ { resolver :: Marked Text+ , extraDeps :: Marked [Marked Text]+ }+```++Instead of making a `FromJSON` instance, you just define a function. The+`Data.Yaml.Marked.Parse` module exposes combinators to accomplish this:++```haskell+decodeStackYaml :: Marked Value -> Either String (Marked StackYaml)+decodeStackYaml = withObject "StackYaml" $ \o ->+ StackYaml+ <$> (text =<< (o .: "resolver"))+ <*> (array text =<< (o .: "extra-deps"))+```++Then we can give this and some source Yaml to+`Data.Yaml.Marked.Decode.decodeThrow` and get back a `Marked StackYaml`:++```haskell+example :: IO ()+example = do+ stackYaml <- BS8.readFile "stack.yaml"+ -- Imagine:+ --+ -- resolver: lts-20.0+ -- extra-deps:+ -- - ../local-package+ -- - hackage-dep-1.0+ --++ StackYaml {..} <-+ markedItem <$> decodeThrow decodeStackYaml "stack.yaml" stackYaml+```++Because our decoder returns a `Marked StackYaml`, that's what we get. We don't+need the location info for this (it just represents the entire file), so we+discard it here. We could've written our decoder to return just a `StackYaml`,+but then we could not have used `withObject`, which always returns `Marked` in+case it's being used somewhere other than the top-level document, where you+would indeed want `Marked` values.++Next, let's pretend we linted this value and discovered the resolver and the+second extra-dep can be updated. As part of doing this, we would presumably+build `Replace` values from the `Marked` items we linted:++```haskell+ let replaces =+ [ replaceMarked resolver "lts-20.11"+ , replaceMarked (markedItem extraDeps !! 1) "hackage-dep-2.0.1"+ ]+```++Then we can runs all of those on the original `ByteString`:++```haskell+ BS8.putStr =<< runReplaces replaces stackYaml+ --+ -- Outputs:+ --+ -- resolver: lts-20.11+ -- extra-deps:+ -- - ../local-package+ -- - hackage-dep-2.0.1+ --+```++<!--+```haskell+main :: IO ()+main = pure ()+```+--->++## Development & Tests++```console+stack build --fast --pedantic --test --file-watch+```++---++[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md)
+ README.md view
@@ -0,0 +1,152 @@+## yaml-marked++[](https://hackage.haskell.org/package/yaml-marked)+[](http://stackage.org/nightly/package/yaml-marked)+[](http://stackage.org/lts/package/yaml-marked)+[](https://github.com/pbrisbin/yaml-marked/actions/workflows/ci.yml)++Like `Data.Yaml` but for when you need the source locations (aka `YamlMark`s)+for parsed elements.++## Motivation++While working on [`stack-lint-extra-deps`][sled], it became apparent it would be+impossible to implement an auto-fix in a way that preserved the source+formatting of the original Yaml. Sure, we could decode, modify, and encode, but+that loses all formatting, comments, and sorting -- which can be important for+documenting choices made in one's `stack.yaml`.++[sled]: https://github.com/freckle/stack-lint-extra-deps++That is, unless there were a Yaml parser that preserved source locations. Then,+I could use those to make targeted replacements within the original source+`ByteString`, while preserving everything else.++There didn't seem to be anything promising on Hackage, except for the fact that+`Text.Libyaml` (the library powering `Data.Yaml`) has functions that emit+`MarkedEvent`s, which `Data.Yaml` doesn't use.++So I began the process of modifying `Data.Yaml` internals to operate on+`MarkedEvent`s and, instead of assuming `FromJSON` to construct a `Value`, use a+provided decoding function and produce my own `Marked Value` type -- which is+basically the same, except holding the original `YamlMark` (recursively). Thus,+`Data.Yaml.Marked.Decode` was born.++Finally, I created something to approximate a non-typeclass `FromJSON`+(`Data.Yaml.Marked.Parse`), and a module to handle the tricky business of+applying replacements to `ByteString`s (`Data.Yaml.Marked.Replace`), and I can+finally do what I need to:++## Example++<!--+```haskell+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module Main (main) where+import Prelude+import Text.Markdown.Unlit ()+```+-->++### Imports++```haskell+import Data.Text (Text)+import qualified Data.ByteString.Char8 as BS8+import Data.Yaml.Marked+import Data.Yaml.Marked.Value+import Data.Yaml.Marked.Parse+import Data.Yaml.Marked.Decode+import Data.Yaml.Marked.Replace+```++### Decoding++Decoding is meant to look a lot like aeson. Your record should hold `Marked`+values anywhere you will need that:++```haskell+data StackYaml = StackYaml+ { resolver :: Marked Text+ , extraDeps :: Marked [Marked Text]+ }+```++Instead of making a `FromJSON` instance, you just define a function. The+`Data.Yaml.Marked.Parse` module exposes combinators to accomplish this:++```haskell+decodeStackYaml :: Marked Value -> Either String (Marked StackYaml)+decodeStackYaml = withObject "StackYaml" $ \o ->+ StackYaml+ <$> (text =<< (o .: "resolver"))+ <*> (array text =<< (o .: "extra-deps"))+```++Then we can give this and some source Yaml to+`Data.Yaml.Marked.Decode.decodeThrow` and get back a `Marked StackYaml`:++```haskell+example :: IO ()+example = do+ stackYaml <- BS8.readFile "stack.yaml"+ -- Imagine:+ --+ -- resolver: lts-20.0+ -- extra-deps:+ -- - ../local-package+ -- - hackage-dep-1.0+ --++ StackYaml {..} <-+ markedItem <$> decodeThrow decodeStackYaml "stack.yaml" stackYaml+```++Because our decoder returns a `Marked StackYaml`, that's what we get. We don't+need the location info for this (it just represents the entire file), so we+discard it here. We could've written our decoder to return just a `StackYaml`,+but then we could not have used `withObject`, which always returns `Marked` in+case it's being used somewhere other than the top-level document, where you+would indeed want `Marked` values.++Next, let's pretend we linted this value and discovered the resolver and the+second extra-dep can be updated. As part of doing this, we would presumably+build `Replace` values from the `Marked` items we linted:++```haskell+ let replaces =+ [ replaceMarked resolver "lts-20.11"+ , replaceMarked (markedItem extraDeps !! 1) "hackage-dep-2.0.1"+ ]+```++Then we can runs all of those on the original `ByteString`:++```haskell+ BS8.putStr =<< runReplaces replaces stackYaml+ --+ -- Outputs:+ --+ -- resolver: lts-20.11+ -- extra-deps:+ -- - ../local-package+ -- - hackage-dep-2.0.1+ --+```++<!--+```haskell+main :: IO ()+main = pure ()+```+--->++## Development & Tests++```console+stack build --fast --pedantic --test --file-watch+```++---++[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md)
+ src/Data/Aeson/Compat.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE CPP #-}++module Data.Aeson.Compat+#if MIN_VERSION_aeson(2, 0, 0)+ ( module Data.Aeson+ ) where++import Data.Aeson+#else+ ( Key+ , module Data.Aeson+ ) where++import Data.Aeson+import Data.Text (Text)++type Key = Text+#endif
+ src/Data/Aeson/Compat/Key.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}++module Data.Aeson.Compat.Key+ ( Key+ , fromText+ , toText+ ) where++#if MIN_VERSION_aeson(2, 0, 0)+import Data.Aeson.Key+#else+import Prelude (id)+import Data.Text (Text)++type Key = Text++fromText :: Text -> Key+fromText = id++toText :: Key -> Text+toText = id+#endif
+ src/Data/Aeson/Compat/KeyMap.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}++module Data.Aeson.Compat.KeyMap+ ( KeyMap+ , union+ , keys+ , insert+ , member+ , lookup+ ) where++#if MIN_VERSION_aeson(2, 0, 0)+import Data.Aeson.KeyMap+import Data.HashMap.Strict ()+#else+import Data.HashMap.Strict+import Data.Text (Text)++type KeyMap = HashMap Text+#endif
+ src/Data/Yaml/Marked.hs view
@@ -0,0 +1,67 @@+module Data.Yaml.Marked+ ( Marked (..)+ , Location (..)++ -- * Interop with "Data.Yaml"+ , MarkedEvent+ , fromMarkedEvent+ ) where++import Prelude++import Numeric.Natural+import Text.Libyaml (Event, MarkedEvent (..), YamlMark (..))++data Marked a = Marked+ { markedItem :: a+ , markedPath :: FilePath+ , markedLocationStart :: Location+ -- ^ Location of the first character of the item+ --+ -- In the following example, marking @value@ will have a start location:+ --+ -- @+ -- key: value\n+ -- ^-- HERE+ -- @+ , markedLocationEnd :: Location+ -- ^ Location of the first character /after/ the item+ --+ -- In the following example, marking @value@ will have an end location:+ --+ -- @+ -- key: value\n+ -- ^-- HERE+ -- @+ }+ deriving stock (Eq, Show, Functor, Foldable, Traversable)++-- | Index, line, and column of a character+--+-- NB. All values are 0-based.+data Location = Location+ { locationIndex :: Natural+ , locationLine :: Natural+ , locationColumn :: Natural+ }+ deriving stock (Eq, Show)++locationFromYamlMark :: YamlMark -> Location+locationFromYamlMark YamlMark {..} =+ Location+ { locationIndex = int2nat yamlIndex+ , locationLine = int2nat yamlLine+ , locationColumn = int2nat yamlColumn+ }++fromMarkedEvent :: MarkedEvent -> FilePath -> Marked Event+fromMarkedEvent MarkedEvent {..} fp =+ Marked+ { markedItem = yamlEvent+ , markedPath = fp+ , markedLocationStart = locationFromYamlMark yamlStartMark+ , markedLocationEnd = locationFromYamlMark yamlEndMark+ }++int2nat :: Int -> Natural+int2nat = fromIntegral . max 0
+ src/Data/Yaml/Marked/Decode.hs view
@@ -0,0 +1,90 @@+module Data.Yaml.Marked.Decode+ ( decodeThrow+ , decodeAllThrow+ , decodeFileEither+ , decodeAllFileEither+ , decodeFileWithWarnings+ , decodeAllFileWithWarnings++ -- * Exceptions+ , ParseException (..)+ , YamlException (..)+ ) where++import Prelude++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Resource (MonadThrow, throwM)+import Data.ByteString (ByteString)+import Data.Yaml (ParseException (..))+import Data.Yaml.Marked+import Data.Yaml.Marked.Internal+import Data.Yaml.Marked.Value+import System.IO.Unsafe (unsafePerformIO)+import Text.Libyaml (YamlException (..))+import qualified Text.Libyaml as Y++decodeThrow+ :: MonadThrow m+ => (Marked Value -> Either String a)+ -> FilePath+ -- ^ Name of input being parsed+ -> ByteString+ -> m a+decodeThrow p fp = either throwM pure . decodeEither p fp++decodeAllThrow+ :: MonadThrow m+ => (Marked Value -> Either String a)+ -> FilePath+ -- ^ Name of input being parsed+ -> ByteString+ -> m [a]+decodeAllThrow p fp = either throwM pure . decodeAllEither p fp++decodeFileEither+ :: MonadIO m+ => (Marked Value -> Either String a)+ -> FilePath+ -> m (Either ParseException a)+decodeFileEither p = fmap (fmap fst) . decodeFileWithWarnings p++decodeAllFileEither+ :: MonadIO m+ => (Marked Value -> Either String a)+ -> FilePath+ -> m (Either ParseException [a])+decodeAllFileEither p = fmap (fmap fst) . decodeAllFileWithWarnings p++decodeFileWithWarnings+ :: MonadIO m+ => (Marked Value -> Either String a)+ -> FilePath+ -> m (Either ParseException (a, [Warning]))+decodeFileWithWarnings p fp = liftIO $ decodeHelper p fp $ Y.decodeFileMarked fp++decodeAllFileWithWarnings+ :: MonadIO m+ => (Marked Value -> Either String a)+ -> FilePath+ -> m (Either ParseException ([a], [Warning]))+decodeAllFileWithWarnings p fp =+ liftIO $ decodeAllHelper p fp $ Y.decodeFileMarked fp++decodeEither+ :: (Marked Value -> Either String a)+ -> FilePath+ -- ^ Name of input being parsed+ -> ByteString+ -> Either ParseException a+decodeEither p fp =+ fmap fst . unsafePerformIO . decodeHelper p fp . Y.decodeMarked++decodeAllEither+ :: (Marked Value -> Either String a)+ -> FilePath+ -- ^ Name of input being parsed+ -> ByteString+ -> Either ParseException [a]+decodeAllEither p fp =+ fmap fst . unsafePerformIO . decodeAllHelper p fp . Y.decodeMarked
+ src/Data/Yaml/Marked/Internal.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE TupleSections #-}++module Data.Yaml.Marked.Internal+ ( Warning (..)+ , decodeHelper+ , decodeAllHelper++ -- * Debugging helpers+ , debugEventStream_+ , debugEventStream+ ) where++import Prelude++import Conduit+import Control.Applicative ((<|>))+import Control.Monad (unless, void, when)+import Control.Monad.Reader (MonadReader (..), asks)+import Control.Monad.State (MonadState (..), gets, modify)+import Control.Monad.Trans.RWS.Strict (RWST, evalRWST)+import Control.Monad.Writer (MonadWriter (..), tell)+import Data.Aeson.Compat.Key (Key)+import qualified Data.Aeson.Compat.Key as Key+import Data.Aeson.Compat.KeyMap (KeyMap)+import qualified Data.Aeson.Compat.KeyMap as KeyMap+import Data.Aeson.Types (JSONPath, JSONPathElement (..))+import qualified Data.Attoparsec.Text as Atto+import Data.Bifunctor (first, second)+import Data.Bitraversable (Bitraversable, bimapM)+import Data.Bits (shiftL, (.|.))+import Data.ByteString (ByteString)+import Data.Char (isOctDigit, ord)+import Data.DList (DList)+import Data.Foldable (toList, traverse_)+import Data.List (foldl', (\\))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Scientific (Scientific)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Vector as V+import Data.Yaml (ParseException (..))+import Data.Yaml.Marked+import Data.Yaml.Marked.Value+import Text.Libyaml hiding (decode, decodeFile, encode, encodeFile)+import qualified Text.Libyaml as Y+import UnliftIO.Exception++newtype Warning = DuplicateKey JSONPath+ deriving stock (Eq, Show)++newtype ParseT m a = ParseT+ { unParseT :: RWST JSONPath (DList Warning) (Map String (Marked Value)) m a+ }+ deriving newtype+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadResource+ , MonadReader JSONPath+ , MonadWriter (DList Warning)+ , MonadState (Map String (Marked Value))+ )++runParseT :: Monad m => ParseT m a -> m (a, [Warning])+runParseT p = second toList <$> evalRWST (unParseT p) [] mempty++type Parse = ParseT (ResourceT IO)++runParse :: ConduitT () Void Parse a -> IO (a, [Warning])+runParse = runResourceT . runParseT . runConduit++defineAnchor+ :: MonadState (Map String (Marked Value)) m+ => String+ -> Marked Value+ -> m ()+defineAnchor name = modify . Map.insert name++lookupAnchor+ :: (MonadIO m, MonadState (Map String (Marked Value)) m)+ => String+ -> m (Marked Value)+lookupAnchor name =+ maybe (throwIO $ UnknownAlias name) pure =<< gets (Map.lookup name)++lookupAliasKey+ :: ( MonadIO m+ , MonadState (Map String (Marked Value)) m+ )+ => String+ -> m Key+lookupAliasKey an = do+ a <- lookupAnchor an+ case a of+ v | String t <- markedItem v -> pure $ Key.fromText t+ v -> throwIO $ NonStringKeyAlias an $ valueToValue $ markedItem v++decodeHelper+ :: MonadIO m+ => (Marked Value -> Either String a)+ -> FilePath+ -- ^ Name for file being parsed+ -> ConduitT () MarkedEvent Parse ()+ -- ^ "Text.Libyaml" source+ -> m (Either ParseException (a, [Warning]))+decodeHelper parse fp src =+ mkHelper parseOne go $ src .| mapC (`fromMarkedEvent` fp)+ where+ go = \case+ Nothing -> parse zeroMarkedNull+ Just mv -> parse mv++ zeroMarkedNull =+ Marked+ { markedItem = Null+ , markedPath = fp+ , markedLocationStart = Location 0 0 0+ , markedLocationEnd = Location 0 0 0+ }++decodeAllHelper+ :: MonadIO m+ => (Marked Value -> Either String a)+ -> FilePath+ -- ^ Name for file being parsed+ -> ConduitT () MarkedEvent Parse ()+ -- ^ "Text.Libyaml" source+ -> m (Either ParseException ([a], [Warning]))+decodeAllHelper parse fp src =+ mkHelper parseAll (traverse parse) $ src .| mapC (`fromMarkedEvent` fp)++mkHelper+ :: MonadIO m+ => ConduitT (Marked Event) Void Parse val+ -> (val -> Either String a)+ -> ConduitT () (Marked Event) Parse ()+ -> m (Either ParseException (a, [Warning]))+mkHelper eventParser f src = liftIO $ catches go handlers+ where+ go = first AesonException . firstM f <$> runParse (src .| eventParser)+ handlers =+ [ Handler $ \pe -> pure $ Left pe+ , Handler $ \ye -> pure $ Left $ InvalidYaml $ Just ye+ , Handler $ \ex -> pure $ Left $ OtherParseException ex+ ]++throwUnexpectedEvent :: MonadIO m => Maybe (Marked Event) -> m a+throwUnexpectedEvent me =+ throwIO $ UnexpectedEvent (markedItem <$> me) Nothing++requireEvent :: MonadIO m => Event -> ConduitT (Marked Event) o m ()+requireEvent e = do+ f <- fmap markedItem <$> headC+ unless (f == Just e) $ throwIO $ UnexpectedEvent f $ Just e++parseOne :: ConduitT (Marked Event) o Parse (Maybe (Marked Value))+parseOne = do+ docs <- parseAll+ case docs of+ [] -> pure Nothing+ [doc] -> pure $ Just doc+ _ -> throwIO MultipleDocuments++parseAll :: ConduitT (Marked Event) o Parse [Marked Value]+parseAll =+ headC >>= \case+ Nothing -> pure []+ Just me | EventStreamStart <- markedItem me -> parseStream+ x -> throwUnexpectedEvent x++parseStream :: ConduitT (Marked Event) o Parse [Marked Value]+parseStream =+ headC >>= \case+ Just me | EventStreamEnd <- markedItem me -> pure []+ Just me | EventDocumentStart <- markedItem me -> do+ res <- parseDocument+ requireEvent EventDocumentEnd+ (res :) <$> parseStream+ x -> throwUnexpectedEvent x++parseDocument :: ConduitT (Marked Event) o Parse (Marked Value)+parseDocument =+ headC >>= \case+ Just me+ | EventScalar v tag style a <- markedItem me ->+ parseScalar me v tag style a+ Just me+ | EventSequenceStart _ _ a <- markedItem me ->+ parseSequence (markedLocationStart me) Nothing 0 a id+ Just me+ | EventMappingStart _ _ a <- markedItem me ->+ parseMapping (markedLocationStart me) Nothing mempty a mempty+ Just me | EventAlias an <- markedItem me -> lookupAnchor an+ x -> throwIO $ UnexpectedEvent (markedItem <$> x) Nothing++parseSequence+ :: Location+ -- ^ Location where the sequence started+ -> Maybe Location+ -- ^ Ending location of last item within the sequence+ -> Int+ -> Anchor+ -> ([Marked Value] -> [Marked Value])+ -> ConduitT (Marked Event) o Parse (Marked Value)+parseSequence startLocation mEndLocation !n a front =+ peekC >>= \case+ Just me | EventSequenceEnd <- markedItem me -> do+ dropC 1+ let res =+ Marked+ { markedItem = Array $ V.fromList $ front []+ , markedPath = markedPath me+ , markedLocationStart = startLocation+ , markedLocationEnd = fromMaybe startLocation mEndLocation+ }+ res <$ traverse_ (`defineAnchor` res) a+ _ -> do+ o <- local (Index n :) parseDocument+ parseSequence startLocation (Just $ markedLocationEnd o) (succ n) a $+ front . (:) o++parseMapping+ :: Location+ -- ^ Location where the mapping started+ -> Maybe Location+ -- ^ Ending location of last item within the map+ -> Set Key+ -> Anchor+ -> KeyMap (Marked Value)+ -> ConduitT (Marked Event) o Parse (Marked Value)+parseMapping startLocation mEndLocation mergedKeys a front =+ headC >>= \case+ Just me | EventMappingEnd <- markedItem me -> do+ let res =+ Marked+ { markedItem = Object front+ , markedPath = markedPath me+ , markedLocationStart = startLocation+ , markedLocationEnd = fromMaybe startLocation mEndLocation+ }+ res <$ traverse_ (`defineAnchor` res) a+ me -> do+ s <- case me of+ Just me'+ | EventScalar v tag style a' <- markedItem me' ->+ parseScalarKey me' v tag style a'+ Just me'+ | EventAlias an <- markedItem me' ->+ lookupAliasKey an+ _ -> do+ path <- ask+ throwIO $ NonStringKey path++ ((mergedKeys', al'), endLocation) <- local (Key s :) $ do+ o <- parseDocument++ fmap (,markedLocationEnd o) $ do+ let al = do+ when (KeyMap.member s front && Set.notMember s mergedKeys) $ do+ path <- asks reverse+ tell $ pure $ DuplicateKey path+ pure+ ( Set.delete s mergedKeys+ , KeyMap.insert s o front+ )++ if s == "<<"+ then case markedItem o of+ Object l -> pure $ merge l+ Array l ->+ pure $+ merge $+ foldl' mergeMarkedObject mempty $+ toList l+ _ -> al+ else al++ parseMapping startLocation (Just endLocation) mergedKeys' a al'+ where+ merge xs =+ ( Set.fromList (KeyMap.keys xs \\ KeyMap.keys front)+ , KeyMap.union front xs+ )++mergeMarkedObject+ :: KeyMap (Marked Value) -> Marked Value -> KeyMap (Marked Value)+mergeMarkedObject al v | Object om <- markedItem v = KeyMap.union al om+mergeMarkedObject al _ = al++parseScalar+ :: Marked Event+ -> ByteString+ -> Tag+ -> Style+ -> Anchor+ -> ConduitT (Marked Event) o Parse (Marked Value)+parseScalar me v tag style a = do+ s <- parseScalarText me v tag style a+ pure $ textToValue style tag s <$ me++parseScalarKey+ :: Marked Event+ -> ByteString+ -> Tag+ -> Style+ -> Anchor+ -> ConduitT (Marked Event) o Parse Key+parseScalarKey me v tag style =+ fmap Key.fromText . parseScalarText me v tag style++parseScalarText+ :: Marked Event+ -> ByteString+ -> Tag+ -> Style+ -> Anchor+ -> ConduitT (Marked Event) o Parse Text+parseScalarText me v tag style = (res <$) . traverse_ (`defineAnchor` anc)+ where+ res = decodeUtf8With lenientDecode v+ anc = textToValue style tag res <$ me++textToValue :: Style -> Tag -> Text -> Value+textToValue SingleQuoted _ t = String t+textToValue DoubleQuoted _ t = String t+textToValue _ StrTag t = String t+textToValue Folded _ t = String t+textToValue _ _ t+ | t `isLike` "null" = Null+ | t `elem` ["~", ""] = Null+ | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True+ | any (t `isLike`) ["n", "no", "off", "false"] = Bool False+ | Right x <- textToScientific t = Number x+ | otherwise = String t+ where+ x `isLike` ref = x `elem` [ref, T.toUpper ref, T.toTitle ref]++textToScientific :: Text -> Either String Scientific+textToScientific = Atto.parseOnly (num <* Atto.endOfInput)+ where+ num =+ (fromInteger <$> ("0x" *> Atto.hexadecimal))+ <|> (fromInteger <$> ("0o" *> octal))+ <|> Atto.scientific++ octal = T.foldl' step 0 <$> Atto.takeWhile1 isOctDigit+ where+ step a c = (a `shiftL` 3) .|. fromIntegral (ord c - 48)++firstM :: (Bitraversable t, Applicative f) => (a -> f a') -> t a b -> f (t a' b)+firstM f = bimapM f pure++debugEventStream_ :: ByteString -> IO ()+debugEventStream_ = void . debugEventStream++debugEventStream :: ByteString -> IO [MarkedEvent]+debugEventStream bs =+ runResourceT $+ runConduit $+ Y.decodeMarked bs+ .| iterMC (liftIO . printEvent)+ .| sinkList+ where+ showMark YamlMark {..} = show (yamlIndex, yamlLine, yamlColumn)++ printEvent MarkedEvent {..} = do+ putStrLn $+ mconcat+ [ "Event: " <> show yamlEvent+ , ", location: " <> showMark yamlStartMark+ , "-" <> showMark yamlEndMark+ ]
+ src/Data/Yaml/Marked/Parse.hs view
@@ -0,0 +1,121 @@+module Data.Yaml.Marked.Parse+ ( withObject+ , withArray+ , withText+ , withScientific+ , withBool+ , (.:)+ , (.:?)+ , array+ , json+ , value+ , text+ , double+ , int+ , bool+ ) where++import Prelude++import Data.Aeson.Compat (FromJSON, Key)+import qualified Data.Aeson.Compat as Aeson+import qualified Data.Aeson.Compat.KeyMap as KeyMap+import Data.Bifunctor (first)+import Data.Foldable (toList)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Yaml.Marked+import Data.Yaml.Marked.Value++withObject+ :: String+ -> (MarkedObject -> Either String a)+ -> Marked Value+ -> Either String (Marked a)+withObject label f = traverse $ \case+ Object hm -> f hm+ v -> prependContext label $ typeMismatch "Object" v++withArray+ :: String+ -> (MarkedArray -> Either String a)+ -> Marked Value+ -> Either String (Marked a)+withArray label f = traverse $ \case+ Array v -> f v+ v -> prependContext label $ typeMismatch "Array" v++withText+ :: String+ -> (Text -> Either String a)+ -> Marked Value+ -> Either String (Marked a)+withText label f = traverse $ \case+ String t -> f t+ v -> prependContext label $ typeMismatch "String" v++withScientific+ :: String+ -> (Scientific -> Either String a)+ -> Marked Value+ -> Either String (Marked a)+withScientific label f = traverse $ \case+ Number s -> f s+ v -> prependContext label $ typeMismatch "Number" v++withBool+ :: String+ -> (Bool -> Either String a)+ -> Marked Value+ -> Either String (Marked a)+withBool label f = traverse $ \case+ Bool b -> f b+ v -> prependContext label $ typeMismatch "Bool" v++prependContext :: String -> Either String a -> Either String a+prependContext label = first (prefix <>)+ where+ prefix = "parsing " <> label <> " failed, "++typeMismatch :: String -> Value -> Either String a+typeMismatch expected =+ Left . (prefix <>) . \case+ Object {} -> "Object"+ Array {} -> "Array"+ String {} -> "String"+ Number {} -> "Number"+ Bool {} -> "Bool"+ Null -> "Null"+ where+ prefix = "expected " <> expected <> ", but encountered "++(.:) :: MarkedObject -> Key -> Either String (Marked Value)+(.:) km k = maybe (Left "Key not found") Right $ KeyMap.lookup k km++(.:?) :: MarkedObject -> Key -> Either String (Maybe (Marked Value))+(.:?) km k = Right $ KeyMap.lookup k km++array+ :: (Marked Value -> Either String (Marked a))+ -> Marked Value+ -> Either String (Marked [Marked a])+array f = withArray "an array" $ traverse f . toList++-- | Parse the value using its 'FromJSON' instance, passing along the marks+json :: FromJSON a => Marked Value -> Either String (Marked a)+json = traverse valueAsJSON++value :: Marked Value -> Either String (Marked Aeson.Value)+value = json++text :: Marked Value -> Either String (Marked Text)+text = json++double :: Marked Value -> Either String (Marked Double)+double = json++int :: Marked Value -> Either String (Marked Int)+int = json++bool :: Marked Value -> Either String (Marked Bool)+bool = json
+ src/Data/Yaml/Marked/Replace.hs view
@@ -0,0 +1,138 @@+module Data.Yaml.Marked.Replace+ ( Replace+ , newReplace+ , replaceMarked+ , ReplaceException (..)+ , runReplaces+ , runReplacesOnOverlapping+ ) where++import Prelude++import Control.Monad (void, when)+import Control.Monad.Trans.Resource (MonadThrow (..))+import Data.Bifunctor (second)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import Data.List (sortOn)+import Data.Yaml.Marked+import Numeric.Natural+import UnliftIO.Exception (Exception (..))++data Replace = Replace+ { replaceIndex :: Natural+ , replacedLength :: Natural+ , replacedBy :: ByteString+ }+ deriving stock (Eq, Show)++-- | Create a 'Replace' directly at given index and length+--+-- NB. This function is unsafe in that it can be used with negative literals and+-- will fail at runtime. Prefer 'replaceMarked'.+newReplace :: Natural -> Natural -> ByteString -> Replace+newReplace idx len bs =+ Replace+ { replaceIndex = idx+ , replacedLength = len+ , replacedBy = bs+ }++-- | Create a 'Replace' for something 'Marked'+replaceMarked :: Marked a -> ByteString -> Replace+replaceMarked Marked {..} = newReplace idx len+ where+ idx = locationIndex markedLocationStart+ end = locationIndex markedLocationEnd+ len+ | end >= idx = end - idx+ | otherwise = 0++data ReplaceException+ = ReplaceOutOfBounds Replace Natural+ | OverlappingReplace Replace+ deriving stock (Eq, Show)++instance Exception ReplaceException where+ displayException = \case+ ReplaceOutOfBounds r bLen ->+ "The replacement "+ <> show r+ <> " is trying to replace more characters than remain in the ByteString ("+ <> show bLen+ <> ")"+ OverlappingReplace r ->+ "The replacement "+ <> show r+ <> " is where an earlier replacement has already been made"++runReplaces :: MonadThrow m => [Replace] -> ByteString -> m ByteString+runReplaces = runReplacesOnOverlapping $ throwM . OverlappingReplace++runReplacesOnOverlapping+ :: MonadThrow m+ => (Replace -> m a)+ -- ^ What to do with the first overlapping 'Replace' if encountered+ --+ -- NB. the overlapping replace(s) will be ignored, but this allows you to log+ -- it as a warning, or use 'throwM' to halt (which 'runReplaces' does).+ -> [Replace]+ -> ByteString+ -> m ByteString+runReplacesOnOverlapping f rs bs = do+ rs' <- filterOverlapping f $ sortOn replaceIndex rs+ runReplaces' 0 "" rs' bs++runReplaces'+ :: MonadThrow m+ => Natural+ -> ByteString+ -> [Replace]+ -> ByteString+ -> m ByteString+runReplaces' _ acc [] bs = pure $ acc <> bs+runReplaces' offset acc (r : rs) bs = do+ (before, after) <- breakAtOffsetReplace offset r bs+ let newOffset = offset + fromIntegral (BS8.length before) + replacedLength r+ runReplaces' newOffset (acc <> before <> replacedBy r) rs after++filterOverlapping+ :: Monad m => (Replace -> m a) -> [Replace] -> m [Replace]+filterOverlapping onOverlap = go []+ where+ go acc [] = pure acc+ go acc (r : rs)+ | any (r `precedesEndOf`) acc = do+ void $ onOverlap r+ go acc rs+ | otherwise = go (acc <> [r]) rs++precedesEndOf :: Replace -> Replace -> Bool+precedesEndOf a b = replaceIndex a <= replaceIndex b + replacedLength b++-- | Break a 'ByteString' into the content before/after a replacement+--+-- Will throw 'ReplaceException' if the 'Replace' is not valid for the given+-- input.+breakAtOffsetReplace+ :: MonadThrow m+ => Natural+ -- ^ An amount to shift the 'replaceIndex' by+ --+ -- Since this function is called recursively to incrementally replace within+ -- an overall 'ByteString', to which the 'replaceIndex' is relative, we need+ -- to track how much to shift it as we recur.+ -> Replace+ -> ByteString+ -> m (ByteString, ByteString)+breakAtOffsetReplace offset r bs = do+ when (rLen > bLen) $ throwM $ ReplaceOutOfBounds r bLen+ pure $+ second (BS8.drop $ fromIntegral rLen) $+ BS8.splitAt (fromIntegral sIdx) bs+ where+ sIdx+ | offset > replaceIndex r = error "TODO"+ | otherwise = replaceIndex r - offset+ rLen = replacedLength r+ bLen = fromIntegral $ BS8.length bs
+ src/Data/Yaml/Marked/Value.hs view
@@ -0,0 +1,45 @@+module Data.Yaml.Marked.Value+ ( Value (..)+ , MarkedObject+ , MarkedArray+ , valueAsJSON+ , valueToValue+ ) where++import Prelude++import Data.Aeson (FromJSON (..))+import qualified Data.Aeson as Aeson+import Data.Aeson.Compat.KeyMap (KeyMap)+import Data.Aeson.Types (parseEither)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Yaml.Marked++data Value+ = Object !MarkedObject+ | Array !MarkedArray+ | String !Text+ | Number !Scientific+ | Bool !Bool+ | Null+ deriving stock (Eq, Show)++type MarkedObject = KeyMap (Marked Value)++type MarkedArray = Vector (Marked Value)++-- | Parse the value using its 'FromJSON', discarding any marks+valueAsJSON :: FromJSON a => Value -> Either String a+valueAsJSON = parseEither parseJSON . valueToValue++-- | Convert a 'Value' to an equivalent 'Data.Aeson.Value'+valueToValue :: Value -> Aeson.Value+valueToValue = \case+ Object km -> Aeson.Object $ valueToValue . markedItem <$> km+ Array v -> Aeson.Array $ valueToValue . markedItem <$> v+ String x -> Aeson.String x+ Number x -> Aeson.Number x+ Bool x -> Aeson.Bool x+ Null -> Aeson.Null
+ test/Data/Yaml/Marked/DecodeSpec.hs view
@@ -0,0 +1,146 @@+module Data.Yaml.Marked.DecodeSpec+ ( spec+ ) where++import Prelude++import Data.Functor.Alt ((<!>))+import Data.Text (Text)+import Data.Yaml.Marked+import Data.Yaml.Marked.Decode+import Data.Yaml.Marked.Parse+import Data.Yaml.Marked.Value+import Test.Hspec++data StackYaml = StackYaml+ { resolver :: Marked Text+ , extraDeps :: Marked [Marked ExtraDep]+ , someSetting :: Marked Bool+ }+ deriving stock (Eq, Show)++decodeStackYaml :: Marked Value -> Either String (Marked StackYaml)+decodeStackYaml = withObject "example" $ \o ->+ StackYaml+ <$> (text =<< (o .: "resolver"))+ <*> (array decodeExtraDep =<< (o .: "extra-deps"))+ <*> (bool =<< (o .: "some-setting"))++data ExtraDep+ = Plain Text+ | Git GitCommit+ deriving stock (Eq, Show)++decodeExtraDep :: Marked Value -> Either String (Marked ExtraDep)+decodeExtraDep x = (fmap Git <$> decodeGitCommit x) <!> (fmap Plain <$> text x)++data GitCommit = GitCommit+ { git :: Marked Text+ , commit :: Marked Text+ }+ deriving stock (Eq, Show)++decodeGitCommit :: Marked Value -> Either String (Marked GitCommit)+decodeGitCommit = withObject "GitCommit" $ \o ->+ GitCommit+ <$> (text =<< o .: "git")+ <*> (text =<< o .: "commit")++spec :: Spec+spec = do+ describe "decodeThrow" $ do+ it "decodes with marks" $ do+ let exampleYaml =+ mconcat+ [ "resolver: lts-20.11\n"+ , "extra-deps:\n"+ , " # A path\n"+ , " - ../local-package\n"+ , "\n"+ , " # A hackage package\n"+ , " - hackage-dep-1.0\n"+ , "\n"+ , " # A git ref\n"+ , " - git: foo\n"+ , " commit: abc\n"+ , "\n"+ , "# Trailing\n"+ , " - foo-0.0.0\n"+ , "\n"+ , "some-setting: Yes\n"+ , "\n"+ , "# Trailing comment"+ ]++ decodeThrow decodeStackYaml "<input>" exampleYaml+ `shouldReturn` Marked+ { markedItem =+ StackYaml+ { resolver =+ Marked+ { markedItem = "lts-20.11"+ , markedPath = "<input>"+ , markedLocationStart = Location 10 0 10+ , markedLocationEnd = Location 19 0 19+ }+ , extraDeps =+ Marked+ { markedItem =+ [ Marked+ { markedItem = Plain "../local-package"+ , markedPath = "<input>"+ , markedLocationStart = Location 45 3 3+ , markedLocationEnd = Location 61 3 19+ }+ , Marked+ { markedItem = Plain "hackage-dep-1.0"+ , markedPath = "<input>"+ , markedLocationStart = Location 87 6 3+ , markedLocationEnd = Location 102 6 18+ }+ , Marked+ { markedItem =+ Git $+ GitCommit+ { git =+ Marked+ { markedItem = "foo"+ , markedPath = "<input>"+ , markedLocationStart = Location 125 9 8+ , markedLocationEnd = Location 128 9 11+ }+ , commit =+ Marked+ { markedItem = "abc"+ , markedPath = "<input>"+ , markedLocationStart = Location 140 10 11+ , markedLocationEnd = Location 143 10 14+ }+ }+ , markedPath = "<input>"+ , markedLocationStart = Location 120 9 3+ , markedLocationEnd = Location 143 10 14+ }+ , Marked+ { markedItem = Plain "foo-0.0.0"+ , markedPath = "<input>"+ , markedLocationStart = Location 159 13 3+ , markedLocationEnd = Location 168 13 12+ }+ ]+ , markedPath = "<input>"+ , markedLocationStart = Location 43 3 1+ , markedLocationEnd = Location 168 13 12+ }+ , someSetting =+ Marked+ { markedItem = True+ , markedPath = "<input>"+ , markedLocationStart = Location 184 15 14+ , markedLocationEnd = Location 187 15 17+ }+ }+ , markedPath = "<input>"+ , markedLocationStart = Location 0 0 0+ , markedLocationEnd = Location 187 15 17+ }
+ test/Data/Yaml/Marked/InternalSpec.hs view
@@ -0,0 +1,116 @@+module Data.Yaml.Marked.InternalSpec+ ( spec+ ) where++import Prelude++import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import Data.Foldable (traverse_)+import qualified Data.Yaml as Yaml+import Data.Yaml.Marked+import Data.Yaml.Marked.Decode+import Data.Yaml.Marked.Parse+import Test.Hspec+import Test.Hspec.Expectations.Json++spec :: Spec+spec = do+ context "matching Data.Yaml.decode" $ do+ decodeTestCases+ [ "x: 1e-100000"+ , "x: 9.78159610558926e-5"+ , "12345"+ , "+12345"+ , "0o14"+ , "0o123"+ , "0xC"+ , "0xc"+ , "0xdeadBEEF"+ , "0xDEADBEEF"+ , "1.23015e+3"+ , "12.3015e+02"+ , "1230.15"+ , "---\na:\n &id5 value: 1.0\nb:\n *id5: 1.2"+ , "foo:\n - &anchor bin1\n - bin2\n - bin3"+ , "foo: &anchor\n - bin1\n - bin2\n - bin3"+ , "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"+ , "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"+ , "foo: !bar\n k: v\n k2: v2"+ , "foo: !\n k: v\n k2: v2"+ , "foo: !bar [x, y, z]"+ , "foo: ! [x, y, z]"+ , "foo: [x, y, z]"+ , "foo:\n- x\n- y\n- z\n"+ , "foo: { bar: 1, baz: 2 }"+ , "foo: bar\nbaz: quux"+ , "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"+ , "m1: &m1\n k1: !!str 1\n k2: !!str 2\nm2: &m2\n k1: !!str 3\n k3: !!str 4\nfoo1: foo\n<<: [ *m1, *m2 ]"+ , "- &anch foo\n- baz\n- *anch"+ , "seq: &anch\n - foo\n - baz\nseq2: *anch"+ , "map: &anch\n key1: foo\n key2: baz\nmap2: *anch"+ , "- &anch foo\n- baz\n- *anch\n- &anch boo\n- buz\n- *anch"+ , "foo1: foo\nfoo2: baz\nfoo1: buz"+ , "foo1: foo\nfoo2: baz\n<<:\n foo1: buz\n foo3: fuz"+ , "m1: &m1\n k1: !!str 1\n k2: !!str 2\nm2: &m2\n k1: !!str 3\n k3: !!str 4\nfoo1: foo\n<<: [ *m1, *m2 ]"+ , "foo: \"1234\""+ , "foo: 1234"+ , "foo: !!str 1234"+ , "1\n"+ , "foo: off\nbar: y\nbaz: true"+ , "foo: FALSE\nbar: Y\nbaz: ON"+ , "foo: No\nbar: Yes\nbaz: True"+ , "Default: &def\n foo: 1\n bar: 2\nObj:\n <<: *def\n key: 3\n"+ , "null"+ , "Null"+ , "NULL"+ , "~"+ , ""+ , "# comment\n"+ ]++ context "matching Data.Yaml.decodeAll" $ do+ decodeAllTestCases+ [ ""+ , "# foo\n# bar"+ , "foo: true"+ , "--- 1\n--- 2"+ ]++ context "decode failing" $ do+ decodeFailTestCases+ [ " - foo\n - baz\nbuz"+ , "\tthis is 'not' valid :-)"+ , "map: *anch\nmap2: &anch\n key1: foo\n key2: baz"+ , "map: &anch\n key1: foo\n key2: *anch"+ ]++decodeTestCases :: [ByteString] -> Spec+decodeTestCases = traverse_ $ \yaml -> do+ it ("for " <> toDocStringYaml yaml) $ do+ expected <- Yaml.decodeThrow yaml+ actual <- decodeThrow value "<input>" yaml+ expected `shouldBeJson` markedItem actual++decodeAllTestCases :: [ByteString] -> Spec+decodeAllTestCases = traverse_ $ \yaml -> do+ it ("for " <> toDocStringYaml yaml) $ do+ expected <- Yaml.decodeAllThrow @_ @Aeson.Value yaml+ actual <- decodeAllThrow value "<input>" yaml+ Aeson.toJSON expected `shouldBeJson` Aeson.toJSON (map markedItem actual)++decodeFailTestCases :: [ByteString] -> Spec+decodeFailTestCases = traverse_ $ \yaml -> do+ it ("for " <> toDocStringYaml yaml) $ do+ Yaml.decodeThrow @Maybe @Aeson.Value yaml `shouldBe` Nothing+ decodeThrow value "<input>" yaml `shouldBe` Nothing++toDocStringYaml :: ByteString -> String+toDocStringYaml yaml = show truncated+ where+ truncated+ | BS8.length yaml > limit = (<> "...") $ BS8.take (limit - 3) yaml+ | otherwise = yaml++ limit = 50
+ test/Data/Yaml/Marked/ReplaceSpec.hs view
@@ -0,0 +1,178 @@+module Data.Yaml.Marked.ReplaceSpec+ ( spec+ ) where++import Prelude++import Data.Yaml.Marked+import Data.Yaml.Marked.Decode+import Data.Yaml.Marked.Parse+import Data.Yaml.Marked.Replace+import Test.Hspec++spec :: Spec+spec = do+ describe "runReplaces" $ do+ it "works for a replacement at start" $ do+ let r = newReplace 0 4 "that"+ runReplaces [r] "this text" `shouldReturn` "that text"++ it "works for replacement at start and end" $ do+ let rs =+ [ newReplace 0 4 "that"+ , newReplace 13 3 "cold"+ ]++ runReplaces rs "this text is hot" `shouldReturn` "that text is cold"++ it "works for replacement at start, middle, and end" $ do+ let rs =+ [ newReplace 0 4 "that"+ , newReplace 18 3 "cold"+ , newReplace 10 4 "won't"+ ]++ runReplaces rs "this text will be hot"+ `shouldReturn` "that text won't be cold"++ context "validations" $ do+ it "ReplaceOutOfBounds" $ do+ let r = newReplace 0 3 ""+ runReplaces [r] "x" `shouldThrow` (== ReplaceOutOfBounds r 1)++ it "ReplaceOutOfBounds by start" $ do+ let r = newReplace 3 3 ""+ runReplaces [r] "x" `shouldThrow` (== ReplaceOutOfBounds r 1)++ it "ReplaceOutOfBounds with multiple" $ do+ let+ r = newReplace 7 3 ""+ rs =+ [ newReplace 0 2 ""+ , newReplace 3 3 ""+ , r+ ]++ runReplaces rs "123456" `shouldThrow` (== ReplaceOutOfBounds r 0)++ it "OverlappingReplace" $ do+ let+ overlapped = newReplace 2 3 ""+ overlapping = newReplace 3 3 ""+ rs =+ [ newReplace 0 1 ""+ , overlapping+ , newReplace 9 1 ""+ , overlapped+ , newReplace 12 1 ""+ ]++ runReplaces rs "123456789abcdefhigjkl"+ `shouldThrow` (== OverlappingReplace overlapping)++ it "works for a realistic stack.yaml example" $ do+ let+ exampleYaml =+ mconcat+ [ "resolver: lts-20.0\n"+ , "extra-deps:\n"+ , " - ../local-package\n"+ , " - hackage-dep-1.0\n"+ ]++ decodeExample = withObject "example" $ \o ->+ (,)+ <$> (text =<< (o .: "resolver"))+ <*> (array text =<< (o .: "extra-deps"))++ (resolver, extraDeps) <-+ markedItem <$> decodeThrow decodeExample "<input>" exampleYaml++ let replaces =+ [ replaceMarked resolver "lts-20.11"+ , replaceMarked (markedItem extraDeps !! 1) "hackage-dep-2.0.1"+ ]++ runReplaces replaces exampleYaml+ `shouldReturn` mconcat+ [ "resolver: lts-20.11\n"+ , "extra-deps:\n"+ , " - ../local-package\n"+ , " - hackage-dep-2.0.1\n"+ ]++ describe "runReplacesOnOverlapping" $ do+ it "can skip overlapping replaces" $ do+ let+ exampleYaml =+ mconcat+ [ "resolver: lts-18.18\n"+ , "\n"+ , "packages:\n"+ , " # Missing in Stackage, newer in Hackage\n"+ , " - freckle-app-1.0.1.1\n"+ , "\n"+ , " # Exists in resolver now, newer in Hackage too\n"+ , " - dhall-1.37.1@sha256:447031286e8fe270b0baacd9cc5a8af340d2ae94bb53b85807bee93381ca5287,35080\n"+ , " - generic-lens-2.0.0.0@sha256:7409fa0ce540d0bd41acf596edd1c5d0c0ab1cd1294d514cf19c5c24e8ef2550,3866\n"+ , "\n"+ , " # Newer in Hackage\n"+ , " - faktory-1.1.2.0@sha256:b2a1986095aefa645f6ad701504e1671ddfeb36f11b68434837fc9fcd3594ca8,9078\n"+ , " - hspec-core-2.8.3@sha256:e4c1e08e16842804c470c2b4722e417ed2a556a47a74107401ad42195522f7a7,4992\n"+ , " - hspec-2.8.3@sha256:43a42e23994a6c61a7adead7e8a412016680234f5a14a157f68c020871e59534,1709\n"+ , " - hspec-junit-formatter-1.0.1.0@sha256:6429871263be4532a3a6d08e72da5a8e4c00e8bfbfd7fc5b8352a3643f867453,2652\n"+ , "\n"+ , " # New version available\n"+ , " - network-3.1.2.5@sha256:433a5e076aaa8eb3e4158abae78fb409c6bd754e9af99bc2e87583d2bcd8404a,4888\n"+ , "\n"+ , " # Newer commits, version-like tag exists too\n"+ , " - github: freckle/yesod-routes-flow\n"+ , " commit: 2a9cd873880956dd9a0999b593022d3c746324e8\n"+ , "\n"+ , " # No suggestions (yet)\n"+ , " - git: https://github.com/freckle/asana\n"+ , " commit: 91ce6ade118674bb273966943370684eba71f227\n"+ ]++ replaces =+ [ newReplace 77 19 "freckle-app-1.12.0.0"+ , newReplace 151 90 "dhall-1.42.1"+ , newReplace 246 97 "generic-lens-2.2.2.0"+ , newReplace 370 92 "faktory-1.1.2.5"+ , newReplace 467 93 "hspec-core-2.11.7"+ , newReplace 565 88 "hspec-2.11.7"+ , newReplace 658 106 "hspec-junit-formatter-1.1.0.2"+ , newReplace 796 92 "network-3.1.4.0"+ , newReplace 941 86 "yesod-routes-flow-3.0.0.2"+ , newReplace 987 40 "94f9343305ef98d12026ab1f96460dd8b6d29f6f" -- < skipped due to overlap+ , newReplace 1108 40 "e9d43d953957efc06a0d20bef786a959d03198e6"+ ]++ runReplacesOnOverlapping (const $ pure ()) replaces exampleYaml+ `shouldReturn` mconcat+ [ "resolver: lts-18.18\n"+ , "\n"+ , "packages:\n"+ , " # Missing in Stackage, newer in Hackage\n"+ , " - freckle-app-1.12.0.0\n"+ , "\n"+ , " # Exists in resolver now, newer in Hackage too\n"+ , " - dhall-1.42.1\n"+ , " - generic-lens-2.2.2.0\n"+ , "\n"+ , " # Newer in Hackage\n"+ , " - faktory-1.1.2.5\n"+ , " - hspec-core-2.11.7\n"+ , " - hspec-2.11.7\n"+ , " - hspec-junit-formatter-1.1.0.2\n"+ , "\n"+ , " # New version available\n"+ , " - network-3.1.4.0\n"+ , "\n"+ , " # Newer commits, version-like tag exists too\n"+ , " - yesod-routes-flow-3.0.0.2\n"+ , "\n"+ , " # No suggestions (yet)\n"+ , " - git: https://github.com/freckle/asana\n"+ , " commit: e9d43d953957efc06a0d20bef786a959d03198e6\n"+ ]
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+ yaml-marked.cabal view
@@ -0,0 +1,168 @@+cabal-version: 1.18+name: yaml-marked+version: 0.1.0.0+license: MIT+license-file: LICENSE+maintainer: Pat Brisbin <pbrisbin@gmail.com>+author: Pat Brisbin <pbrisbin@gmail.com>+stability: stable+homepage: https://github.com/pbrisbin/yaml-marked#readme+bug-reports: https://github.com/pbrisbin/yaml-marked/issues+synopsis:+ Support for parsing and rendering YAML documents with marks.++description: Please see README.md+category: Data+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/pbrisbin/yaml-marked++library+ exposed-modules:+ Data.Aeson.Compat+ Data.Aeson.Compat.Key+ Data.Aeson.Compat.KeyMap+ Data.Yaml.Marked+ Data.Yaml.Marked.Decode+ Data.Yaml.Marked.Internal+ Data.Yaml.Marked.Parse+ Data.Yaml.Marked.Replace+ Data.Yaml.Marked.Value++ hs-source-dirs: src+ other-modules: Paths_yaml_marked+ default-language: Haskell2010+ default-extensions:+ BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor+ DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies+ FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving+ LambdaCase MultiParamTypeClasses NoImplicitPrelude+ NoMonomorphismRestriction OverloadedStrings RankNTypes+ RecordWildCards ScopedTypeVariables StandaloneDeriving+ TypeApplications TypeFamilies++ ghc-options:+ -Weverything -Wno-all-missed-specialisations+ -Wno-missed-specialisations -Wno-missing-exported-signatures+ -Wno-missing-import-lists -Wno-missing-local-signatures+ -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe++ build-depends:+ aeson >=1.4.7.1,+ attoparsec >=0.13.2.4,+ base >=4.13.0.0 && <5,+ bytestring >=0.10.10.1,+ conduit >=1.3.4,+ containers >=0.6.2.1,+ dlist >=0.8.0.8,+ libyaml >=0.1.2,+ mtl >=2.2.2,+ resourcet >=1.2.4.2,+ scientific >=0.3.6.2,+ text >=1.2.4.0,+ transformers >=0.5.6.2,+ unliftio >=0.2.13.1,+ unordered-containers >=0.2.10.0,+ vector >=0.12.1.2,+ yaml >=0.11.5.0++ if impl(ghc >=9.8)+ ghc-options: -Wno-missing-role-annotations++ if impl(ghc >=9.2)+ ghc-options: -Wno-missing-kind-signatures++ if impl(ghc >=8.10)+ ghc-options:+ -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++test-suite readme+ type: exitcode-stdio-1.0+ main-is: README.lhs+ other-modules: Paths_yaml_marked+ default-language: Haskell2010+ default-extensions:+ BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor+ DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies+ FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving+ LambdaCase MultiParamTypeClasses NoImplicitPrelude+ NoMonomorphismRestriction OverloadedStrings RankNTypes+ RecordWildCards ScopedTypeVariables StandaloneDeriving+ TypeApplications TypeFamilies++ ghc-options:+ -Weverything -Wno-all-missed-specialisations+ -Wno-missed-specialisations -Wno-missing-exported-signatures+ -Wno-missing-import-lists -Wno-missing-local-signatures+ -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -pgmL+ markdown-unlit++ build-depends:+ base >=4.13.0.0 && <5,+ bytestring >=0.10.10.1,+ markdown-unlit >=0.5.1,+ text >=1.2.4.0,+ yaml-marked++ if impl(ghc >=9.8)+ ghc-options: -Wno-missing-role-annotations++ if impl(ghc >=9.2)+ ghc-options: -Wno-missing-kind-signatures++ if impl(ghc >=8.10)+ ghc-options:+ -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules:+ Data.Yaml.Marked.DecodeSpec+ Data.Yaml.Marked.InternalSpec+ Data.Yaml.Marked.ReplaceSpec+ Paths_yaml_marked++ default-language: Haskell2010+ default-extensions:+ BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor+ DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies+ FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving+ LambdaCase MultiParamTypeClasses NoImplicitPrelude+ NoMonomorphismRestriction OverloadedStrings RankNTypes+ RecordWildCards ScopedTypeVariables StandaloneDeriving+ TypeApplications TypeFamilies++ ghc-options:+ -Weverything -Wno-all-missed-specialisations+ -Wno-missed-specialisations -Wno-missing-exported-signatures+ -Wno-missing-import-lists -Wno-missing-local-signatures+ -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded+ -rtsopts -with-rtsopts=-N++ build-depends:+ aeson >=1.4.7.1,+ base >=4.13.0.0 && <5,+ bytestring >=0.10.10.1,+ hspec >=2.7.6,+ hspec-expectations-json >=1.0.2.1,+ semigroupoids >=5.3.4,+ text >=1.2.4.0,+ yaml >=0.11.5.0,+ yaml-marked++ if impl(ghc >=9.8)+ ghc-options: -Wno-missing-role-annotations++ if impl(ghc >=9.2)+ ghc-options: -Wno-missing-kind-signatures++ if impl(ghc >=8.10)+ ghc-options:+ -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module