diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,152 @@ +## yaml-marked + +[![Hackage](https://img.shields.io/hackage/v/yaml-marked.svg?style=flat)](https://hackage.haskell.org/package/yaml-marked) +[![Stackage Nightly](http://stackage.org/package/yaml-marked/badge/nightly)](http://stackage.org/nightly/package/yaml-marked) +[![Stackage LTS](http://stackage.org/package/yaml-marked/badge/lts)](http://stackage.org/lts/package/yaml-marked) +[![CI](https://github.com/pbrisbin/yaml-marked/actions/workflows/ci.yml/badge.svg)](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 + + + +### 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 + -- +``` + + + +## Development & Tests + +```console +stack build --fast --pedantic --test --file-watch +``` + +--- + +[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,152 @@ +## yaml-marked + +[![Hackage](https://img.shields.io/hackage/v/yaml-marked.svg?style=flat)](https://hackage.haskell.org/package/yaml-marked) +[![Stackage Nightly](http://stackage.org/package/yaml-marked/badge/nightly)](http://stackage.org/nightly/package/yaml-marked) +[![Stackage LTS](http://stackage.org/package/yaml-marked/badge/lts)](http://stackage.org/lts/package/yaml-marked) +[![CI](https://github.com/pbrisbin/yaml-marked/actions/workflows/ci.yml/badge.svg)](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 + + + +### 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 + -- +``` + + + +## Development & Tests + +```console +stack build --fast --pedantic --test --file-watch +``` + +--- + +[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md) diff --git a/src/Data/Aeson/Compat.hs b/src/Data/Aeson/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Compat.hs @@ -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 diff --git a/src/Data/Aeson/Compat/Key.hs b/src/Data/Aeson/Compat/Key.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Compat/Key.hs @@ -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 diff --git a/src/Data/Aeson/Compat/KeyMap.hs b/src/Data/Aeson/Compat/KeyMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Compat/KeyMap.hs @@ -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 diff --git a/src/Data/Yaml/Marked.hs b/src/Data/Yaml/Marked.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Marked.hs @@ -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 diff --git a/src/Data/Yaml/Marked/Decode.hs b/src/Data/Yaml/Marked/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Marked/Decode.hs @@ -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 diff --git a/src/Data/Yaml/Marked/Internal.hs b/src/Data/Yaml/Marked/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Marked/Internal.hs @@ -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 + ] diff --git a/src/Data/Yaml/Marked/Parse.hs b/src/Data/Yaml/Marked/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Marked/Parse.hs @@ -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 diff --git a/src/Data/Yaml/Marked/Replace.hs b/src/Data/Yaml/Marked/Replace.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Marked/Replace.hs @@ -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 diff --git a/src/Data/Yaml/Marked/Value.hs b/src/Data/Yaml/Marked/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Marked/Value.hs @@ -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 diff --git a/test/Data/Yaml/Marked/DecodeSpec.hs b/test/Data/Yaml/Marked/DecodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Yaml/Marked/DecodeSpec.hs @@ -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 "" exampleYaml + `shouldReturn` Marked + { markedItem = + StackYaml + { resolver = + Marked + { markedItem = "lts-20.11" + , markedPath = "" + , markedLocationStart = Location 10 0 10 + , markedLocationEnd = Location 19 0 19 + } + , extraDeps = + Marked + { markedItem = + [ Marked + { markedItem = Plain "../local-package" + , markedPath = "" + , markedLocationStart = Location 45 3 3 + , markedLocationEnd = Location 61 3 19 + } + , Marked + { markedItem = Plain "hackage-dep-1.0" + , markedPath = "" + , markedLocationStart = Location 87 6 3 + , markedLocationEnd = Location 102 6 18 + } + , Marked + { markedItem = + Git $ + GitCommit + { git = + Marked + { markedItem = "foo" + , markedPath = "" + , markedLocationStart = Location 125 9 8 + , markedLocationEnd = Location 128 9 11 + } + , commit = + Marked + { markedItem = "abc" + , markedPath = "" + , markedLocationStart = Location 140 10 11 + , markedLocationEnd = Location 143 10 14 + } + } + , markedPath = "" + , markedLocationStart = Location 120 9 3 + , markedLocationEnd = Location 143 10 14 + } + , Marked + { markedItem = Plain "foo-0.0.0" + , markedPath = "" + , markedLocationStart = Location 159 13 3 + , markedLocationEnd = Location 168 13 12 + } + ] + , markedPath = "" + , markedLocationStart = Location 43 3 1 + , markedLocationEnd = Location 168 13 12 + } + , someSetting = + Marked + { markedItem = True + , markedPath = "" + , markedLocationStart = Location 184 15 14 + , markedLocationEnd = Location 187 15 17 + } + } + , markedPath = "" + , markedLocationStart = Location 0 0 0 + , markedLocationEnd = Location 187 15 17 + } diff --git a/test/Data/Yaml/Marked/InternalSpec.hs b/test/Data/Yaml/Marked/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Yaml/Marked/InternalSpec.hs @@ -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 "" 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 "" 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 "" 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 diff --git a/test/Data/Yaml/Marked/ReplaceSpec.hs b/test/Data/Yaml/Marked/ReplaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Yaml/Marked/ReplaceSpec.hs @@ -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 "" 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" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} diff --git a/yaml-marked.cabal b/yaml-marked.cabal new file mode 100644 --- /dev/null +++ b/yaml-marked.cabal @@ -0,0 +1,168 @@ +cabal-version: 1.18 +name: yaml-marked +version: 0.1.0.0 +license: MIT +license-file: LICENSE +maintainer: Pat Brisbin +author: Pat Brisbin +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