master..59434d8 · typeable/hjsonpointer

git.iko.soy/typeable/hjsonpointer

on 59434d8 help sign in

.travis.yml+56−79

since splitsnapshots

unifiedsplit

@@ -1,104 +1,81 @@

1−# This Travis job script has been generated by a script via

1+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis

3−# runghc make_travis_yml_2.hs 'hjsonpointer.cabal'

4−#

5−# For more information, see https://github.com/hvr/multi-ghc-travis

6−

7−# NOTE: After generating comment out `cabal check`, it requires a description field.

3+# Manually modified to remove cabal check. I don't want a description field.

9language: c

5language: c

10sudo: false

6sudo: false

12−git:

13− submodules: false # whether to recursively clone submodules

14−

15cache:

8cache:

16 directories:

9 directories:

10+ - $HOME/.cabsnap

17 - $HOME/.cabal/packages

11 - $HOME/.cabal/packages

18− - $HOME/.cabal/store

20before_cache:

13before_cache:

21 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

14 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

22− # remove files that are regenerated by 'cabal update'

23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

15+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

24− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

25− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

26− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

27− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

28−

29− - rm -rfv $HOME/.cabal/packages/head.hackage

31matrix:

17matrix:

32 include:

18 include:

33− - compiler: "ghc-8.0.2"

19+ - env: CABALVER=1.18 GHCVER=7.8.4

34− # env: TEST=--disable-tests BENCH=--disable-benchmarks

20+ compiler: ": #GHC 7.8.4"

35− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}

21+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}

36− - compiler: "ghc-8.2.2"

22+ - env: CABALVER=1.22 GHCVER=7.10.2

37− # env: TEST=--disable-tests BENCH=--disable-benchmarks

23+ compiler: ": #GHC 7.10.2"

38− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}

39− - compiler: "ghc-8.4.1"

40− # env: TEST=--disable-tests BENCH=--disable-benchmarks

41− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}

24+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}

43before_install:

26before_install:

44− - HC=${CC}

45− - HCPKG=${HC/ghc/ghc-pkg}

46− - unset CC

27+ - unset CC

47− - ROOTDIR=$(pwd)

48− - mkdir -p $HOME/.local/bin

49− - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"

28+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

50− - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))

51− - echo $HCNUMVER

53install:

30install:

54− - cabal --version

31+ - cabal --version

55− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

32+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

56− - BENCH=${BENCH---enable-benchmarks}

33+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];

57− - TEST=${TEST---enable-tests}

34+ then

58− - HADDOCK=${HADDOCK-true}

35+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >

59− - INSTALLED=${INSTALLED-true}

36+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;

60− - GHCHEAD=${GHCHEAD-false}

37+ fi

61− - travis_retry cabal update -v

38+ - travis_retry cabal update -v

62− - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"

39+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

63− - rm -fv cabal.project cabal.project.local

40+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt

64− - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'

41+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt

65− - "printf 'packages: \".\"\\n' > cabal.project"

42+

66− - cat cabal.project

43+# check whether current requested install-plan matches cached package-db snapshot

67− - if [ -f "./configure.ac" ]; then

44+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;

68− (cd "." && autoreconf -i);

45+ then

69− fi

46+ echo "cabal build-cache HIT";

70− - rm -f cabal.project.freeze

47+ rm -rfv .ghc;

71− - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

48+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;

72− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

49+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;

73− - rm -rf .ghc.environment.* "."/dist

50+ else

74− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

51+ echo "cabal build-cache MISS";

52+ rm -rf $HOME/.cabsnap;

53+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;

54+ cabal install --only-dependencies --enable-tests --enable-benchmarks;

55+ fi

56+

57+# snapshot package-db on cache miss

58+ - if [ ! -d $HOME/.cabsnap ];

59+ then

60+ echo "snapshotting package-db to build-cache";

61+ mkdir $HOME/.cabsnap;

62+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;

63+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

64+ fi

76# Here starts the actual work to be performed for the package under test;

66# Here starts the actual work to be performed for the package under test;

77# any command which exits with a non-zero exit code causes the build to fail.

67# any command which exits with a non-zero exit code causes the build to fail.

78script:

68script:

79− # test that source-distributions can be generated

69+ - if [ -f configure.ac ]; then autoreconf -i; fi

80− - (cd "." && cabal sdist)

70+ - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging

81− - mv "."/dist/hjsonpointer-*.tar.gz ${DISTDIR}/

82− - cd ${DISTDIR} || false

83− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;

84− - "printf 'packages: hjsonpointer-*/*.cabal\\n' > cabal.project"

85− - cat cabal.project

86− # this builds all libraries and executables (without tests/benchmarks)

71+ - cabal build # this builds all libraries and executables (including tests/benchmarks)

87− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all

72+ - cabal test

88−

73+ - cabal sdist # tests that a source-distribution can be generated

89− # Build with installed constraints for packages in global-db

90− - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/$[a-zA-Z0-9-]\{1,\}$ */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi

91−

92− # build & run tests, build benchmarks

93− - cabal new-build -w ${HC} ${TEST} ${BENCH} all

94− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi

95−

96− # cabal check

97− # - (cd hjsonpointer-* && cabal check)

99− # haddock

75+# Check that the resulting source distribution can be built & installed.

100− - rm -rf ./dist-newstyle

76+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:

101− - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi

77+# `cabal install --force-reinstalls dist/*-*.tar.gz`

78+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&

79+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")

102

103−# REGENDATA ["hjsonpointer.cabal"]

104# EOF

81# EOF

Example.hs+16−15

@@ -1,26 +1,27 @@

1+{-# LANGUAGE OverloadedStrings #-}

2−module Example where

3+module Main where

4−import Control.Monad (unless)

5+import Control.Monad (unless)

5import Data.Aeson

6import Data.Aeson

6−import qualified JSONPointer as JP

7+import qualified Data.Aeson.Pointer as P

8main :: IO ()

9main :: IO ()

9main = do

10main = do

10− -- JSON Pointers must either be empty or start with a /.

11+ -- JSON Pointers must either be empty or start with a /.

11− pntr1 <- case JP.unescape "/foo/0" of

12+ pntr1 <- case P.unescape "/foo/0" of

12− Left _ -> error "Failed to construct JSON Pointer."

13+ Left _ -> error "Failed to construct JSON Pointer."

13− Right pntr -> return pntr

14+ Right pntr -> return pntr

15− -- We can also write JSON Pointers in Haskell.

16+ -- We can also write JSON Pointers in Haskell.

16− let pntr2 = JP.Pointer [JP.Token "/"]

17+ let pntr2 = P.Pointer [P.Token "/"]

17− -- When we do this we don't have to escape / or ~ characters

18+ -- When we do this we don't have to escape / or ~ characters

18− -- (as ~1 and ~0 respectively) like we do in an escaped JSON

19+ -- (as ~1 and ~0 respectively) like we do in an escaped JSON

19− -- Pointer string.

20+ -- Pointer string.

20− unless (JP.unescape "/~1" == Right pntr2) (error "ohno!")

21+ unless (P.unescape "/~1" == Right pntr2) (error "ohno!")

22− print (JP.resolve pntr1 document)

23+ print (P.resolve pntr1 document)

23− print (JP.resolve pntr2 document)

24+ print (P.resolve pntr2 document)

25 where

26 where

26 document :: Value

27 document :: Value

MIT-LICENSE.txt+1−1

@@ -1,5 +1,5 @@

1The MIT License (MIT)

4Permission is hereby granted, free of charge, to any person obtaining a copy

5of this software and associated documentation files (the "Software"), to deal

README.md+19−17

@@ -7,28 +7,30 @@

7# Example

9```haskell

10−module Example where

10+{-# LANGUAGE OverloadedStrings #-}

12+module Main where

13+

12−import Control.Monad (unless)

14+import Control.Monad (unless)

13import Data.Aeson

15import Data.Aeson

14−import qualified JSONPointer as JP

16+import qualified Data.Aeson.Pointer as P

16main :: IO ()

18main :: IO ()

17main = do

19main = do

18− -- JSON Pointers must either be empty or start with a /.

20+ -- JSON Pointers must either be empty or start with a /.

19− pntr1 <- case JP.unescape "/foo/0" of

21+ pntr1 <- case P.unescape "/foo/0" of

20− Left _ -> error "Failed to construct JSON Pointer."

22+ Left _ -> error "Failed to construct JSON Pointer."

21− Right pntr -> return pntr

23+ Right pntr -> pure pntr

22−

24+

23− -- We can also write JSON Pointers in Haskell.

25+ -- We can also write JSON Pointers in Haskell.

24− let pntr2 = JP.Pointer [JP.Token "/"]

26+ let pntr2 = P.Pointer [P.Token "/"]

25− -- When we do this we don't have to escape / or ~ characters

27+ -- When we do this we don't have to escape / or ~ characters

26− -- (as ~1 and ~0 respectively) like we do in an escaped JSON

28+ -- (as ~1 and ~0 respectively) like we do in an escaped JSON

27− -- Pointer string.

29+ -- Pointer string.

28− unless (JP.unescape "/~1" == Right pntr2) (error "ohno!")

30+ unless (P.unescape "/~1" == Right pntr2) (error "ohno!")

29−

31+

30− print (JP.resolve pntr1 document)

32+ print (P.resolve pntr1 document)

31− print (JP.resolve pntr2 document)

33+ print (P.resolve pntr2 document)

33 where

35 where

34 document :: Value

36 document :: Value

changelog.md+1−57

@@ -1,60 +1,4 @@

1−# 1.5.0

1+# 0.3

2−

3−+ Drop QuickCheck dependency (thanks @mmhat !).

4−

5−# 1.4.0

6−

7−+ Enable GHC 8.4 (thanks @4e6 !).

8−+ Drop GHC 7.10.

9−

10−# 1.3.0

11−

12−+ Test with GHC 8.2. Drop GHC 7.8.

13−

14−# 1.2.0

15−

16−+ Track upper bounds in a Hackage revision instead of source code.

17−

18−# 1.1.1

19−

20−+ Bump aeson.

21−

22−# 1.1.0.2

23−

24−+ Raise test dep upper bounds.

25−

26−# 1.1.0.1

27−

28−+ Bump `vector`.

29−

30−# 1.1.0.0

31−

32−+ Rename the module to `JSONPointer`.

33−+ Bump aeson.

34−+ Derive `Semigroup` for `Pointer`.

35−+ Reorganize code.

36−

37−# 1.0.0.2

38−

39−+ Bump hspec.

40−

41−# 1.0.0.1

42−

43−+ Remove HUnit dep.

44−

45−# 1.0.0.0

46−

47−+ Bump aeson.

48−

49−# 0.3.0.2

50−

51−+ Switch to hspec for tests.

52−

53−# 0.3.0.1

54−

55−+ Enable GHC 8.

56−

57−# 0.3.0.0

59+ Rewrite.

3+ Rewrite.

hjsonpointer.cabal+55−52

@@ -1,56 +1,59 @@

1−name: hjsonpointer

1+name: hjsonpointer

2−version: 1.5.0

2+version: 0.3.0.0

3−synopsis: JSON Pointer library

3+synopsis: JSON Pointer library

4−homepage: https://github.com/seagreen/hjsonpointer

4+homepage: https://github.com/seagreen/hjsonpointer

5−license: MIT

5+license: MIT

6−license-file: MIT-LICENSE.txt

6+license-file: MIT-LICENSE.txt

7−author: Ian Grant Jeffries

7+author: Ian Grant Jeffries

8−maintainer: ian@housejeffries.com

8+maintainer: ian@housejeffries.com

9−category: Data

9+category: Data

10−build-type: Simple

10+build-type: Simple

11−cabal-version: >=1.10

11+cabal-version: >=1.10

12−-- Rerun multi-ghc-travis (executable make-travis-yml-2) after changing:

12+tested-with: GHC == 7.8.4, GHC == 7.10.3

13−Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1

14−extra-source-files:

13+extra-source-files: changelog.md

15− changelog.md

16− README.md

14+ README.md

18library

16library

19− hs-source-dirs:

17+ hs-source-dirs: src

20− src

18+ exposed-modules: Data.Aeson.Pointer

21− default-language: Haskell2010

19+ default-language: Haskell2010

20+ default-extensions: OverloadedStrings

21+ other-extensions: GeneralizedNewtypeDeriving

22− ghc-options:

22+ ghc-options: -Wall

23− -Wall

24− exposed-modules:

25− JSONPointer

26− build-depends:

23+ build-depends: aeson >= 0.7 && < 0.12

27− base >= 4.9 && < 5

24+ , base >= 4.6 && < 4.9

28− , aeson >= 0.7

25+ , QuickCheck >= 2.8 && < 2.9

29− , hashable >= 1.2

30− , unordered-containers >= 0.2

26+ , unordered-containers >= 0.2 && < 0.3

31− , text >= 1.2

27+ , text >= 1.2 && < 1.3

32− , vector >= 0.10

28+ , vector >= 0.10 && < 0.12

34test-suite unit

30test-suite unit

35− hs-source-dirs:

36− test

37− ./

38− main-is: Unit.hs

39− default-language: Haskell2010

40− type: exitcode-stdio-1.0

31+ type: exitcode-stdio-1.0

32+ hs-source-dirs: tests

33+ main-is: Unit.hs

34+ default-language: Haskell2010

35+ ghc-options: -Wall

41− default-extensions:

36+ default-extensions: OverloadedStrings

42− OverloadedStrings

43− ghc-options:

44− -Wall

45− -fno-warn-orphans

46− other-modules: Example

47− build-depends:

37+ build-depends: aeson

48− aeson

49− , base

38+ , base

50− , hjsonpointer

39+ , hjsonpointer

51− , hspec >= 2.2

52− , http-types >= 0.8

53− , QuickCheck

54− , unordered-containers

40+ , unordered-containers

55− , text

41+ , text

56− , vector

42+ , vector

43+ , http-types >= 0.8 && < 0.10

44+ , HUnit >= 1.2 && < 1.4

45+ , test-framework >= 0.8 && < 0.9

46+ , test-framework-hunit >= 0.3 && < 0.4

47+ , test-framework-quickcheck2 >= 0.3 && < 0.4

48+

49+executable example

50+ main-is: Example.hs

51+ default-language: Haskell2010

52+ ghc-options: -Wall

53+ build-depends: aeson

54+ , base

55+ , hjsonpointer

56+

57+source-repository head

58+ type: git

59+ location: git://github.com/seagreen/hjsonpointer.git

shell.nixdeleted−9

@@ -1,9 +0,0 @@

1−{ghc}:

2−with (import <nixpkgs> {});

3−

4−haskell.lib.buildStackProject {

5− name = "none";

6− inherit ghc;

7− buildInputs = [

8− ];

9−}

src/Data/Aeson/Pointer.hsnew file+122

@@ -0,0 +1,122 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+module Data.Aeson.Pointer where

5+import Control.Monad (when)

6+import Data.Aeson

7+import qualified Data.HashMap.Strict as H

8+import Data.Text (Text)

9+import qualified Data.Text as T

10+import qualified Data.Vector as V

11+import Test.QuickCheck

12+import Text.Read (readMaybe)

13+

14+-- For GHCs before 7.10:

15+import Control.Applicative

16+import Data.Monoid

17+import Data.Traversable

18+

19+newtype Pointer

20+ = Pointer { _unPointer :: [Token] }

21+ deriving (Eq, Show, Monoid, Arbitrary)

22+

23+instance FromJSON Pointer where

24+ parseJSON = withText "JSON Pointer" $ \t ->

25+ case unescape t of

26+ Left e -> fail (show e)

27+ Right p -> pure p

28+

29+instance ToJSON Pointer where

30+ toJSON = String . escape

31+

32+-- | We don't try to distinguish between integer tokens and string

33+-- tokens since all tokens start as strings, and all tokens can

34+-- be used to resolve JSON objects.

35+newtype Token = Token { _unToken :: Text } deriving (Eq, Show)

36+

37+instance Arbitrary Token where

38+ arbitrary = Token . T.pack <$> arbitrary

39+

40+escape :: Pointer -> Text

41+escape (Pointer []) = ""

42+escape (Pointer ts) =

43+ T.cons '/'

44+ . T.intercalate "/"

45+ . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)

46+ $ ts

47+

48+-- * Unescaping

49+

50+data FormatError

51+ = InvalidFirstChar

52+ -- ^ JSON Pointers must either be empty or start with a @/@.

53+ | UnescapedTilde

54+ deriving (Eq, Show)

55+

56+

57+-- | JSON Pointers must either be empty or start with a @/@. This means

58+-- that if you're turning a URI Fragment into a JSON Pointer you must

59+-- drop the initial @#@.

60+--

61+-- Note that the unescaping happening here is not the same as URI

62+-- decoding. If you are turning a URI fragment into a JSON Pointer you

63+-- must URI decode the 'Text' before using it as an argument to this

64+-- function. There's an example of how to do this in the tests using

65+-- "Network.HTTP.Types.URI.urlDecode" from http-types.

66+unescape :: Text -> Either FormatError Pointer

67+unescape txt =

68+ case T.splitOn "/" txt of

69+ [] -> Right (Pointer [])

70+ "":xs -> Pointer <$> traverse f xs

71+ _ -> Left InvalidFirstChar

72+ where

73+ f :: Text -> Either FormatError Token

74+ f t = case unescapeToken t of

75+ Nothing -> Left UnescapedTilde

76+ Just tok -> Right tok

77+

78+-- | For internal use by 'unescape'.

79+unescapeToken :: Text -> Maybe Token

80+unescapeToken t

81+ | not (isValid t) = Nothing

82+ | otherwise = Just . Token . replace $ t

83+ where

84+ -- All tildes must be followed by 0s or 1s.

85+ isValid :: Text -> Bool

86+ isValid x = all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes

87+ where

88+ afterTildes :: [Text]

89+ afterTildes = drop 1 $ T.splitOn "~" x

90+

91+ replace :: Text -> Text

92+ replace = T.replace "~0" "~" . T.replace "~1" "/"

93+

94+-- * Resolution

95+

96+data ResolutionError

97+ = ObjectLookupFailed

98+ | ArrayIndexInvalid

99+ | ArrayElemNotFound

100+ | ExpectedObjectOrArray

101+ deriving (Eq, Show)

102+

103+resolve :: Pointer -> Value -> Either ResolutionError Value

104+resolve (Pointer []) v = Right v

105+resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)

106+

107+-- | For internal use (or specialized applications that don't want to

108+-- resolve an entire pointer at once).

109+resolveToken :: Token -> Value -> Either ResolutionError Value

110+resolveToken tok (Array vs) =

111+ case readMaybe . T.unpack . _unToken $ tok of

112+ Nothing -> Left ArrayIndexInvalid

113+ Just n -> do

114+ when (n < 0) (Left ArrayIndexInvalid)

115+ case vs V.!? n of

116+ Nothing -> Left ArrayElemNotFound

117+ Just res -> Right res

118+resolveToken tok (Object h) =

119+ case H.lookup (_unToken tok) h of

120+ Nothing -> Left ObjectLookupFailed

121+ Just res -> Right res

122+resolveToken _ _ = Left ExpectedObjectOrArray

src/JSONPointer.hsdeleted−169

@@ -1,169 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3−{-# LANGUAGE OverloadedStrings #-}

4−

5−module JSONPointer where

6−

7−import Control.Monad (when)

8−import Data.Aeson

9−import qualified Data.Hashable as HA

10−import qualified Data.HashMap.Strict as HM

11−import Data.Semigroup (Semigroup)

12−import Data.Text (Text)

13−import qualified Data.Text as T

14−import qualified Data.Vector as V

15−import GHC.Generics (Generic)

16−import Text.Read (readMaybe)

17−

18−--------------------------------------------------

19−-- * Resolution

20−--------------------------------------------------

21−

22−data ResolutionError

23− = ObjectLookupFailed

24− | ArrayIndexInvalid

25− | ArrayElemNotFound

26− | ExpectedObjectOrArray

27− deriving (Eq, Show)

28−

29−resolve :: Pointer -> Value -> Either ResolutionError Value

30−resolve (Pointer []) v = Right v

31−resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)

32−

33−--------------------------------------------------

34−-- * Main types and escaping

35−--------------------------------------------------

36−

37−newtype Pointer

38− = Pointer { _unPointer :: [Token] }

39− deriving (Eq, Show, Semigroup, Monoid, Generic)

40−

41−instance HA.Hashable Pointer

42−

43−instance FromJSON Pointer where

44− parseJSON = withText "JSON Pointer" $ \t ->

45− case unescape t of

46− Left e -> fail (show e)

47− Right p -> pure p

48−

49−instance ToJSON Pointer where

50− toJSON = String . escape

51−

52−-- | We don't try to distinguish between integer tokens and string

53−-- tokens since all tokens start as strings, and all tokens can

54−-- be used to resolve JSON objects.

55−--

56−-- Since these are unescaped you can write @"/"@ and @"~"@ normally.

57−-- (e.g. if you're referencing a key such as @"abc/123"@, go ahead

58−-- and write that exactly.

59−newtype Token

60− = Token { _unToken :: Text }

61− deriving (Eq, Show, Generic)

62−

63−instance HA.Hashable Token

64−

65−-- | This escapes @"/"@ (because it's the token separator character).

66−--

67−-- It also escapes @"~"@ (because it's the escape character).

68−escape :: Pointer -> Text

69−escape (Pointer []) = ""

70−escape (Pointer ts) =

71− T.cons '/'

72− . T.intercalate "/"

73− . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)

74− $ ts

75−

76−data FormatError

77− = InvalidFirstChar

78− -- ^ JSON Pointers must either be empty or start with a @/@.

79− | UnescapedTilde

80− deriving (Eq, Show)

81−

82−-- | JSON Pointers must either be empty or start with a @/@. This means

83−-- that if you're turning a URI Fragment into a JSON Pointer you must

84−-- drop the initial @#@.

85−--

86−-- Note that the unescaping happening here is not the same as URI

87−-- decoding. If you are turning a URI fragment into a JSON Pointer you

88−-- must URI decode the 'Text' before using it as an argument to this

89−-- function. There's an example of how to do this in the tests using

90−-- "Network.HTTP.Types.URI.urlDecode" from http-types.

91−unescape :: Text -> Either FormatError Pointer

92−unescape txt =

93− case T.splitOn "/" txt of

94− [] -> Right (Pointer [])

95− "":xs -> Pointer <$> traverse f xs

96− _ -> Left InvalidFirstChar

97− where

98− f :: Text -> Either FormatError Token

99− f t = case unescapeToken t of

100− Nothing -> Left UnescapedTilde

101− Just tok -> Right tok

102−

103−--------------------------------------------------

104−-- * Wrapper Types

105−--

106−-- $ These aren't used by the rest of the library

107−-- (as explained in the docs for 'Token').

108−--

109−-- However, they might be useful if you need to distinguish JSON Pointer

110−-- tokens from plain 'Text' or 'Int' without losing information by

111−-- converting to 'Token'.

112−--------------------------------------------------

113−

114−-- | A glorified @type@ alias. If you need to do JSON Pointer operations

115−-- you're looking for 'Token' instead.

116−--

117−-- NOTE: Unlike 'Token' this is escaped.

118−newtype Key

119− = Key { _unKey :: Text }

120− deriving (Eq, Show, Generic)

121−

122−instance HA.Hashable Key

123−

124−-- | A glorified @type@ alias. If you need to do JSON Pointer operations

125−-- you're looking for 'Token' instead.

126−newtype Index

127− = Index { _unIndex :: Int }

128− deriving (Eq, Show, Generic)

129−

130−instance HA.Hashable Index

131−

132−--------------------------------------------------

133−-- * Internals

134−--------------------------------------------------

135−

136−-- | For internal use (by 'unescape').

137−unescapeToken :: Text -> Maybe Token

138−unescapeToken t

139− | not (isValid t) = Nothing

140− | otherwise = Just . Token . replace $ t

141− where

142− -- All tildes must be followed by 0s or 1s.

143− isValid :: Text -> Bool

144− isValid x = all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes

145− where

146− afterTildes :: [Text]

147− afterTildes = drop 1 $ T.splitOn "~" x

148−

149− replace :: Text -> Text

150− replace = T.replace "~0" "~" . T.replace "~1" "/"

151−

152−-- | For internal use (by 'resolve').

153−--

154−-- Might also be useful for specialized applications that don't

155−-- want to resolve an entire pointer at once.

156−resolveToken :: Token -> Value -> Either ResolutionError Value

157−resolveToken tok (Array vs) =

158− case readMaybe . T.unpack . _unToken $ tok of

159− Nothing -> Left ArrayIndexInvalid

160− Just n -> do

161− when (n < 0) (Left ArrayIndexInvalid)

162− case vs V.!? n of

163− Nothing -> Left ArrayElemNotFound

164− Just res -> Right res

165−resolveToken tok (Object h) =

166− case HM.lookup (_unToken tok) h of

167− Nothing -> Left ObjectLookupFailed

168− Just res -> Right res

169−resolveToken _ _ = Left ExpectedObjectOrArray

stack.yamldeleted−2

@@ -1,2 +0,0 @@

1−resolver: lts-12.10

2−pvp-bounds: upper-revision

test/Unit.hsdeleted−92

@@ -1,92 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE StandaloneDeriving #-}

3−

4−module Main where

5−

6−import Data.Aeson

7−import Data.Bifunctor (first)

8−import Data.Foldable

9−import Data.Monoid

10−import Data.Text (Text)

11−import qualified Data.Text as T

12−import Data.Text.Encoding (decodeUtf8, encodeUtf8)

13−import qualified Data.Vector as V

14−import qualified JSONPointer as JP

15−import Network.HTTP.Types.URI (urlDecode)

16−

17−import Test.Hspec

18−import Test.QuickCheck (Arbitrary(..), property)

19−

20−import qualified Example

21−

22−deriving instance Arbitrary JP.Pointer

23−

24−instance Arbitrary JP.Token where

25− arbitrary = JP.Token . T.pack <$> arbitrary

26−

27−main :: IO ()

28−main = hspec $ do

29− describe "example" $ do

30− it "compiles and runs without errors" Example.main

31− describe "pointers" $ do

32− it "can be stored as JSON without changing its value" (property roundtrip)

33− it "can be represented in a JSON string value" jsonString

34− it "can be represented in a URI fragment identifier" uriFragment

35−

36−roundtrip :: JP.Pointer -> Bool

37−roundtrip a = Just a == decode (encode a)

38−

39−jsonString :: Expectation

40−jsonString = traverse_ resolvesTo

41− [ ("" , specExample)

42− , ("/foo" , Array $ V.fromList ["bar", "baz"])

43− , ("/foo/0", String "bar")

44− , ("/" , Number 0)

45− , ("/a~1b" , Number 1)

46− , ("/c%d" , Number 2)

47− , ("/e^f" , Number 3)

48− , ("/g|h" , Number 4)

49− , ("/i\\j" , Number 5)

50− , ("/k\"l" , Number 6)

51− , ("/ " , Number 7)

52− , ("/m~0n" , Number 8)

53− ]

54−

55−uriFragment :: Expectation

56−uriFragment = traverse_ resolvesTo . fmap (first decodeFragment) $

57− [ ("#" , specExample)

58− , ("#/foo" , Array $ V.fromList ["bar", "baz"])

59− , ("#/foo/0", String "bar")

60− , ("#/" , Number 0)

61− , ("#/a~1b" , Number 1)

62− , ("#/c%25d", Number 2)

63− , ("#/e%5Ef", Number 3)

64− , ("#/g%7Ch", Number 4)

65− , ("#/i%5Cj", Number 5)

66− , ("#/k%22l", Number 6)

67− , ("#/%20" , Number 7)

68− , ("#/m~0n" , Number 8)

69− ]

70− where

71− decodeFragment :: Text -> Text

72− decodeFragment = T.drop 1 . decodeUtf8 . urlDecode True . encodeUtf8

73−

74−resolvesTo :: (Text, Value) -> Expectation

75−resolvesTo (t, expected) =

76− case JP.unescape t of

77− Left e -> expectationFailure (show e <> " error for pointer: " <> show t)

78− Right p -> JP.resolve p specExample `shouldBe` Right expected

79−

80−specExample :: Value

81−specExample = object

82− [ "foo" .= (["bar", "baz"] :: [Text])

83− , "" .= (0 :: Int)

84− , "a/b" .= (1 :: Int)

85− , "c%d" .= (2 :: Int)

86− , "e^f" .= (3 :: Int)

87− , "g|h" .= (4 :: Int)

88− , "i\\j" .= (5 :: Int)

89− , "k\"l" .= (6 :: Int)

90− , " " .= (7 :: Int)

91− , "m~n" .= (8 :: Int)

92− ]

tests/Unit.hsnew file+90

@@ -0,0 +1,90 @@

2+module Main where

4+import Control.Arrow

5+import Data.Aeson

6+import qualified Data.Aeson.Pointer as P

7+import Data.Text (Text)

8+import qualified Data.Text as T

9+import Data.Text.Encoding

10+import qualified Data.Vector as V

11+import Network.HTTP.Types.URI (urlDecode)

12+import Test.Framework (defaultMain, testGroup)

13+import Test.Framework.Providers.HUnit (testCase)

14+import Test.Framework.Providers.QuickCheck2 (testProperty)

15+import Test.HUnit hiding (Test)

16+

17+-- For GHCs before 7.10:

18+import Control.Applicative

19+import Data.Foldable

20+import Data.Monoid

21+

22+main :: IO ()

23+main = defaultMain

24+ [ testGroup "unit"

25+ [ testProperty "Storing a Pointer as JSON doesn't change its value" roundtrip

26+ , testCase "Can be represented in a JSON string value" jsonString

27+ , testCase "Can be represented in a URI fragment identifier" uriFragment

28+ ]

29+ ]

30+

31+roundtrip :: P.Pointer -> Bool

32+roundtrip a = Just a == decode (encode a)

33+

34+jsonString :: Assertion

35+jsonString = traverse_ resolvesTo

36+ [ ("" , specExample)

37+ , ("/foo" , Array $ V.fromList ["bar", "baz"])

38+ , ("/foo/0", String "bar")

39+ , ("/" , Number 0)

40+ , ("/a~1b" , Number 1)

41+ , ("/c%d" , Number 2)

42+ , ("/e^f" , Number 3)

43+ , ("/g|h" , Number 4)

44+ , ("/i\\j" , Number 5)

45+ , ("/k\"l" , Number 6)

46+ , ("/ " , Number 7)

47+ , ("/m~0n" , Number 8)

48+ ]

49+

50+uriFragment :: Assertion

51+uriFragment = traverse_ resolvesTo . fmap (first decodeFragment) $

52+ [ ("#" , specExample)

53+ , ("#/foo" , Array $ V.fromList ["bar", "baz"])

54+ , ("#/foo/0", String "bar")

55+ , ("#/" , Number 0)

56+ , ("#/a~1b" , Number 1)

57+ , ("#/c%25d", Number 2)

58+ , ("#/e%5Ef", Number 3)

59+ , ("#/g%7Ch", Number 4)

60+ , ("#/i%5Cj", Number 5)

61+ , ("#/k%22l", Number 6)

62+ , ("#/%20" , Number 7)

63+ , ("#/m~0n" , Number 8)

64+ ]

65+ where

66+ decodeFragment :: Text -> Text

67+ decodeFragment = T.drop 1 . decodeUtf8 . urlDecode True . encodeUtf8

68+

69+resolvesTo :: (Text, Value) -> Assertion

70+resolvesTo (t, expected) =

71+ case P.unescape t of

72+ Left e -> assertFailure (show e <> " error for pointer: " <> show t)

73+ Right p -> assertEqual

74+ ("Resolved value for pointer: " <> show t)

75+ (Right expected)

76+ (P.resolve p specExample)

77+

78+specExample :: Value

79+specExample = object

80+ [ "foo" .= (["bar", "baz"] :: [Text])

81+ , "" .= (0 :: Int)

82+ , "a/b" .= (1 :: Int)

83+ , "c%d" .= (2 :: Int)

84+ , "e^f" .= (3 :: Int)

85+ , "g|h" .= (4 :: Int)

86+ , "i\\j" .= (5 :: Int)

87+ , "k\"l" .= (6 :: Int)

88+ , " " .= (7 :: Int)

89+ , "m~n" .= (8 :: Int)

90+ ]