git.iko.soy/typeable/hjsonpointer
on master help sign in
swap
75ed0d024 ahead, 0 behind
12 files changed+493−363
since splitsnapshots
unifiedsplit
.travis.yml+79−59 Example.hs+15−16 MIT-LICENSE.txt+1−1 README.md+17−19 changelog.md+57−1 hjsonpointer.cabal+52−55 shell.nix+9 src/Data/Aeson/Pointer.hs−122 src/JSONPointer.hs+169 stack.yaml+2 test/Unit.hs+92 tests/Unit.hs−90
.travis.yml+79−59
@@ -1,84 +1,104 @@
1−# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
1+# This Travis job script has been generated by a script via
22#
3−# Manually modified to remove cabal check. I don't want a description field.
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.
48
59language: c
610sudo: false
711
12+git:
13+ submodules: false # whether to recursively clone submodules
14+
815cache:
916 directories:
10− - $HOME/.cabsnap
1117 - $HOME/.cabal/packages
18+ - $HOME/.cabal/store
1219
1320before_cache:
1421 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
15− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
22+ # remove files that are regenerated by 'cabal update'
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
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
1630
1731matrix:
1832 include:
19− - env: CABALVER=1.18 GHCVER=7.8.4
20− compiler: ": #GHC 7.8.4"
21− addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
22− - env: CABALVER=1.22 GHCVER=7.10.2
23− compiler: ": #GHC 7.10.2"
24− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
25− - env: CABALVER=1.24 GHCVER=8.0.1
26− compiler: ": #GHC 8.0.1"
27− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
33+ - compiler: "ghc-8.0.2"
34+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
35+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
36+ - compiler: "ghc-8.2.2"
37+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
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]}}
2842
2943before_install:
30− - unset CC
31− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
44+ - HC=${CC}
45+ - HCPKG=${HC/ghc/ghc-pkg}
46+ - 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"
50+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
51+ - echo $HCNUMVER
3252
3353install:
34− - cabal --version
35− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
36− - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
37− then
38− zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
39− $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
40− fi
41− - travis_retry cabal update -v
42− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
43− - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
44− - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
45−
46−# check whether current requested install-plan matches cached package-db snapshot
47− - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
48− then
49− echo "cabal build-cache HIT";
50− rm -rfv .ghc;
51− cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
52− cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
53− else
54− echo "cabal build-cache MISS";
55− rm -rf $HOME/.cabsnap;
56− mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
57− cabal install --only-dependencies --enable-tests --enable-benchmarks;
58− fi
59−
60−# snapshot package-db on cache miss
61− - if [ ! -d $HOME/.cabsnap ];
62− then
63− echo "snapshotting package-db to build-cache";
64− mkdir $HOME/.cabsnap;
65− cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
66− cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
67− fi
54+ - cabal --version
55+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
56+ - BENCH=${BENCH---enable-benchmarks}
57+ - TEST=${TEST---enable-tests}
58+ - HADDOCK=${HADDOCK-true}
59+ - INSTALLED=${INSTALLED-true}
60+ - GHCHEAD=${GHCHEAD-false}
61+ - travis_retry cabal update -v
62+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
63+ - rm -fv cabal.project cabal.project.local
64+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
65+ - "printf 'packages: \".\"\\n' > cabal.project"
66+ - cat cabal.project
67+ - if [ -f "./configure.ac" ]; then
68+ (cd "." && autoreconf -i);
69+ fi
70+ - rm -f cabal.project.freeze
71+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
72+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
73+ - rm -rf .ghc.environment.* "."/dist
74+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
6875
6976# Here starts the actual work to be performed for the package under test;
7077# any command which exits with a non-zero exit code causes the build to fail.
7178script:
72− - if [ -f configure.ac ]; then autoreconf -i; fi
73− - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
74− - cabal build # this builds all libraries and executables (including tests/benchmarks)
75− - cabal test
76− - cabal sdist # tests that a source-distribution can be generated
79+ # test that source-distributions can be generated
80+ - (cd "." && cabal sdist)
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)
87+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
88+
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)
7798
78−# Check that the resulting source distribution can be built & installed.
79−# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
80−# `cabal install --force-reinstalls dist/*-*.tar.gz`
81− - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
82− (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
99+ # haddock
100+ - rm -rf ./dist-newstyle
101+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
83102
103+# REGENDATA ["hjsonpointer.cabal"]
84104# EOF
Example.hs+15−16
@@ -1,27 +1,26 @@
1−{-# LANGUAGE OverloadedStrings #-}
21
3−module Main where
2+module Example where
43
5−import Control.Monad (unless)
4+import Control.Monad (unless)
65import Data.Aeson
7−import qualified Data.Aeson.Pointer as P
6+import qualified JSONPointer as JP
87
98main :: IO ()
109main = do
11− -- JSON Pointers must either be empty or start with a /.
12− pntr1 <- case P.unescape "/foo/0" of
13− Left _ -> error "Failed to construct JSON Pointer."
14− Right pntr -> return pntr
10+ -- JSON Pointers must either be empty or start with a /.
11+ pntr1 <- case JP.unescape "/foo/0" of
12+ Left _ -> error "Failed to construct JSON Pointer."
13+ Right pntr -> return pntr
1514
16− -- We can also write JSON Pointers in Haskell.
17− let pntr2 = P.Pointer [P.Token "/"]
18− -- When we do this we don't have to escape / or ~ characters
19− -- (as ~1 and ~0 respectively) like we do in an escaped JSON
20− -- Pointer string.
21− unless (P.unescape "/~1" == Right pntr2) (error "ohno!")
15+ -- We can also write JSON Pointers in Haskell.
16+ let pntr2 = JP.Pointer [JP.Token "/"]
17+ -- 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+ -- Pointer string.
20+ unless (JP.unescape "/~1" == Right pntr2) (error "ohno!")
2221
23− print (P.resolve pntr1 document)
24− print (P.resolve pntr2 document)
22+ print (JP.resolve pntr1 document)
23+ print (JP.resolve pntr2 document)
2524
2625 where
2726 document :: Value
MIT-LICENSE.txt+1−1
@@ -1,5 +1,5 @@
11The MIT License (MIT)
2−Copyright (c) 2015 Ian Grant Jeffries
2+Copyright (c) 2016 Ian Grant Jeffries
33
44Permission is hereby granted, free of charge, to any person obtaining a copy
55of this software and associated documentation files (the "Software"), to deal
README.md+17−19
@@ -7,30 +7,28 @@
77# Example
88
99```haskell
10−{-# LANGUAGE OverloadedStrings #-}
10+module Example where
1111
12−module Main where
13−
14−import Control.Monad (unless)
12+import Control.Monad (unless)
1513import Data.Aeson
16−import qualified Data.Aeson.Pointer as P
14+import qualified JSONPointer as JP
1715
1816main :: IO ()
1917main = do
20− -- JSON Pointers must either be empty or start with a /.
21− pntr1 <- case P.unescape "/foo/0" of
22− Left _ -> error "Failed to construct JSON Pointer."
23− Right pntr -> pure pntr
24−
25− -- We can also write JSON Pointers in Haskell.
26− let pntr2 = P.Pointer [P.Token "/"]
27− -- When we do this we don't have to escape / or ~ characters
28− -- (as ~1 and ~0 respectively) like we do in an escaped JSON
29− -- Pointer string.
30− unless (P.unescape "/~1" == Right pntr2) (error "ohno!")
31−
32− print (P.resolve pntr1 document)
33− print (P.resolve pntr2 document)
18+ -- JSON Pointers must either be empty or start with a /.
19+ pntr1 <- case JP.unescape "/foo/0" of
20+ Left _ -> error "Failed to construct JSON Pointer."
21+ Right pntr -> return pntr
22+
23+ -- We can also write JSON Pointers in Haskell.
24+ let pntr2 = JP.Pointer [JP.Token "/"]
25+ -- 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
27+ -- Pointer string.
28+ unless (JP.unescape "/~1" == Right pntr2) (error "ohno!")
29+
30+ print (JP.resolve pntr1 document)
31+ print (JP.resolve pntr2 document)
3432
3533 where
3634 document :: Value
changelog.md+57−1
@@ -1,4 +1,60 @@
1−# 0.3
1+# 1.5.0
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
258
359+ Rewrite.
460
hjsonpointer.cabal+52−55
@@ -1,59 +1,56 @@
1−name: hjsonpointer
2−version: 0.3.0.1
3−synopsis: JSON Pointer library
4−homepage: https://github.com/seagreen/hjsonpointer
5−license: MIT
6−license-file: MIT-LICENSE.txt
7−author: Ian Grant Jeffries
8−maintainer: ian@housejeffries.com
9−category: Data
10−build-type: Simple
11−cabal-version: >=1.10
12−tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1
13−extra-source-files: changelog.md
14− README.md
1+name: hjsonpointer
2+version: 1.5.0
3+synopsis: JSON Pointer library
4+homepage: https://github.com/seagreen/hjsonpointer
5+license: MIT
6+license-file: MIT-LICENSE.txt
7+author: Ian Grant Jeffries
8+maintainer: ian@housejeffries.com
9+category: Data
10+build-type: Simple
11+cabal-version: >=1.10
12+-- Rerun multi-ghc-travis (executable make-travis-yml-2) after changing:
13+Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1
14+extra-source-files:
15+ changelog.md
16+ README.md
1517
1618library
17− hs-source-dirs: src
18− exposed-modules: Data.Aeson.Pointer
19− default-language: Haskell2010
20− default-extensions: OverloadedStrings
21− other-extensions: GeneralizedNewtypeDeriving
22− ghc-options: -Wall
23− build-depends: aeson >= 0.7 && < 0.12
24− , base >= 4.6 && < 4.10
25− , QuickCheck >= 2.8 && < 2.9
26− , unordered-containers >= 0.2 && < 0.3
27− , text >= 1.2 && < 1.3
28− , vector >= 0.10 && < 0.12
19+ hs-source-dirs:
20+ src
21+ default-language: Haskell2010
22+ ghc-options:
23+ -Wall
24+ exposed-modules:
25+ JSONPointer
26+ build-depends:
27+ base >= 4.9 && < 5
28+ , aeson >= 0.7
29+ , hashable >= 1.2
30+ , unordered-containers >= 0.2
31+ , text >= 1.2
32+ , vector >= 0.10
2933
3034test-suite unit
31− type: exitcode-stdio-1.0
32− hs-source-dirs: tests
33− main-is: Unit.hs
34− default-language: Haskell2010
35− ghc-options: -Wall
36− default-extensions: OverloadedStrings
37− build-depends: aeson
38− , base
39− , hjsonpointer
40− , unordered-containers
41− , text
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
35+ hs-source-dirs:
36+ test
37+ ./
38+ main-is: Unit.hs
39+ default-language: Haskell2010
40+ type: exitcode-stdio-1.0
41+ default-extensions:
42+ OverloadedStrings
43+ ghc-options:
44+ -Wall
45+ -fno-warn-orphans
46+ other-modules: Example
47+ build-depends:
48+ aeson
49+ , base
50+ , hjsonpointer
51+ , hspec >= 2.2
52+ , http-types >= 0.8
53+ , QuickCheck
54+ , unordered-containers
55+ , text
56+ , vector
shell.nixnew file+9
@@ -0,0 +1,9 @@
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.hsdeleted−122
@@ -1,122 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−
3−module Data.Aeson.Pointer where
4−
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.hsnew file+169
@@ -0,0 +1,169 @@
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.yamlnew file+2
@@ -0,0 +1,2 @@
1+resolver: lts-12.10
2+pvp-bounds: upper-revision
test/Unit.hsnew file+92
@@ -0,0 +1,92 @@
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.hsdeleted−90
@@ -1,90 +0,0 @@
1−
2−module Main where
3−
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− ]