git.iko.soy/typeable/hjsonpointer
on master help sign in
swap
75ed0d022 ahead, 0 behind
.travis.yml+79−59
since splitsnapshots
unifiedsplit
@@ -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
2#
2#
3+# runghc make_travis_yml_2.hs 'hjsonpointer.cabal'
4+#
5+# For more information, see https://github.com/hvr/multi-ghc-travis
6+
3−# Manually modified to remove cabal check. I don't want a description field.
7+# NOTE: After generating comment out `cabal check`, it requires a description field.
4
8
5language: c
9language: c
6sudo: false
10sudo: false
7
11
12+git:
13+ submodules: false # whether to recursively clone submodules
14+
8cache:
15cache:
9 directories:
16 directories:
10− - $HOME/.cabsnap
11 - $HOME/.cabal/packages
17 - $HOME/.cabal/packages
18+ - $HOME/.cabal/store
12
19
13before_cache:
20before_cache:
14 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
21 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
22+ # remove files that are regenerated by 'cabal update'
15− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
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
16
30
17matrix:
31matrix:
18 include:
32 include:
19− - env: CABALVER=1.18 GHCVER=7.8.4
33+ - compiler: "ghc-8.0.2"
20− compiler: ": #GHC 7.8.4"
34+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
21− addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
35+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
22− - env: CABALVER=1.22 GHCVER=7.10.2
36+ - compiler: "ghc-8.2.2"
23− compiler: ": #GHC 7.10.2"
37+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
24− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
38+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
25− - env: CABALVER=1.24 GHCVER=8.0.1
39+ - compiler: "ghc-8.4.1"
26− compiler: ": #GHC 8.0.1"
40+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
27− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
41+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}
28
42
29before_install:
43before_install:
44+ - HC=${CC}
45+ - HCPKG=${HC/ghc/ghc-pkg}
30− - unset CC
46+ - unset CC
47+ - ROOTDIR=$(pwd)
48+ - mkdir -p $HOME/.local/bin
31− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
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
32
52
33install:
53install:
34− - cabal --version
54+ - cabal --version
35− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
55+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
36− - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
56+ - BENCH=${BENCH---enable-benchmarks}
37− then
57+ - TEST=${TEST---enable-tests}
38− zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
58+ - HADDOCK=${HADDOCK-true}
39− $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
59+ - INSTALLED=${INSTALLED-true}
40− fi
60+ - GHCHEAD=${GHCHEAD-false}
41− - travis_retry cabal update -v
61+ - travis_retry cabal update -v
42− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
62+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
43− - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
63+ - rm -fv cabal.project cabal.project.local
44− - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
64+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
45−
65+ - "printf 'packages: \".\"\\n' > cabal.project"
46−# check whether current requested install-plan matches cached package-db snapshot
66+ - cat cabal.project
47− - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
67+ - if [ -f "./configure.ac" ]; then
48− then
68+ (cd "." && autoreconf -i);
49− echo "cabal build-cache HIT";
69+ fi
50− rm -rfv .ghc;
70+ - rm -f cabal.project.freeze
51− cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
71+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
52− cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
72+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
53− else
73+ - rm -rf .ghc.environment.* "."/dist
54− echo "cabal build-cache MISS";
74+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
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
68
75
69# Here starts the actual work to be performed for the package under test;
76# Here starts the actual work to be performed for the package under test;
70# any command which exits with a non-zero exit code causes the build to fail.
77# any command which exits with a non-zero exit code causes the build to fail.
71script:
78script:
72− - if [ -f configure.ac ]; then autoreconf -i; fi
79+ # test that source-distributions can be generated
73− - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
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
74− - cabal build # this builds all libraries and executables (including tests/benchmarks)
86+ # this builds all libraries and executables (without tests/benchmarks)
75− - cabal test
87+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
76− - cabal sdist # tests that a source-distribution can be generated
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)
77
98
78−# Check that the resulting source distribution can be built & installed.
99+ # haddock
79−# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
100+ - rm -rf ./dist-newstyle
80−# `cabal install --force-reinstalls dist/*-*.tar.gz`
101+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
81− - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
82− (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
83
102
103+# REGENDATA ["hjsonpointer.cabal"]
84# EOF
104# EOF
Example.hs+14−15
@@ -1,27 +1,26 @@
1−{-# LANGUAGE OverloadedStrings #-}
2
1
3module Example where
2module Example where
4
3
5−import Control.Monad (unless)
4+import Control.Monad (unless)
6import Data.Aeson
5import Data.Aeson
7−import qualified Data.Aeson.Pointer as P
6+import qualified JSONPointer as JP
8
7
9main :: IO ()
8main :: IO ()
10main = do
9main = do
11− -- JSON Pointers must either be empty or start with a /.
10+ -- JSON Pointers must either be empty or start with a /.
12− pntr1 <- case P.unescape "/foo/0" of
11+ pntr1 <- case JP.unescape "/foo/0" of
13− Left _ -> error "Failed to construct JSON Pointer."
12+ Left _ -> error "Failed to construct JSON Pointer."
14− Right pntr -> return pntr
13+ Right pntr -> return pntr
15
14
16− -- We can also write JSON Pointers in Haskell.
15+ -- We can also write JSON Pointers in Haskell.
17− let pntr2 = P.Pointer [P.Token "/"]
16+ let pntr2 = JP.Pointer [JP.Token "/"]
18− -- When we do this we don't have to escape / or ~ characters
17+ -- 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
18+ -- (as ~1 and ~0 respectively) like we do in an escaped JSON
20− -- Pointer string.
19+ -- Pointer string.
21− unless (P.unescape "/~1" == Right pntr2) (error "ohno!")
20+ unless (JP.unescape "/~1" == Right pntr2) (error "ohno!")
22
21
23− print (P.resolve pntr1 document)
22+ print (JP.resolve pntr1 document)
24− print (P.resolve pntr2 document)
23+ print (JP.resolve pntr2 document)
25
24
26 where
25 where
27 document :: Value
26 document :: Value
MIT-LICENSE.txt+1−1
@@ -1,5 +1,5 @@
1The MIT License (MIT)
1The MIT License (MIT)
2−Copyright (c) 2015 Ian Grant Jeffries
2+Copyright (c) 2016 Ian Grant Jeffries
3
3
4Permission is hereby granted, free of charge, to any person obtaining a copy
4Permission is hereby granted, free of charge, to any person obtaining a copy
5of this software and associated documentation files (the "Software"), to deal
5of this software and associated documentation files (the "Software"), to deal
README.md+17−19
@@ -7,30 +7,28 @@
7# Example
7# Example
8
8
9```haskell
9```haskell
10−{-# LANGUAGE OverloadedStrings #-}
10+module Example where
11
11
12−module Main where
13−
14−import Control.Monad (unless)
12+import Control.Monad (unless)
15import Data.Aeson
13import Data.Aeson
16−import qualified Data.Aeson.Pointer as P
14+import qualified JSONPointer as JP
17
15
18main :: IO ()
16main :: IO ()
19main = do
17main = do
20− -- JSON Pointers must either be empty or start with a /.
18+ -- JSON Pointers must either be empty or start with a /.
21− pntr1 <- case P.unescape "/foo/0" of
19+ pntr1 <- case JP.unescape "/foo/0" of
22− Left _ -> error "Failed to construct JSON Pointer."
20+ Left _ -> error "Failed to construct JSON Pointer."
23− Right pntr -> pure pntr
21+ Right pntr -> return pntr
24−
22+
25− -- We can also write JSON Pointers in Haskell.
23+ -- We can also write JSON Pointers in Haskell.
26− let pntr2 = P.Pointer [P.Token "/"]
24+ let pntr2 = JP.Pointer [JP.Token "/"]
27− -- When we do this we don't have to escape / or ~ characters
25+ -- 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
26+ -- (as ~1 and ~0 respectively) like we do in an escaped JSON
29− -- Pointer string.
27+ -- Pointer string.
30− unless (P.unescape "/~1" == Right pntr2) (error "ohno!")
28+ unless (JP.unescape "/~1" == Right pntr2) (error "ohno!")
31−
29+
32− print (P.resolve pntr1 document)
30+ print (JP.resolve pntr1 document)
33− print (P.resolve pntr2 document)
31+ print (JP.resolve pntr2 document)
34
32
35 where
33 where
36 document :: Value
34 document :: Value
changelog.md+48
@@ -1,3 +1,51 @@
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+
1# 0.3.0.2
49# 0.3.0.2
2
50
3+ Switch to hspec for tests.
51+ Switch to hspec for tests.
hjsonpointer.cabal+52−48
@@ -1,52 +1,56 @@
1−name: hjsonpointer
1+name: hjsonpointer
2−version: 0.3.0.2
2+version: 1.5.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−tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1
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
13−extra-source-files: changelog.md
14+extra-source-files:
15+ changelog.md
14− README.md
16+ README.md
15
17
16library
18library
17− hs-source-dirs: src
19+ hs-source-dirs:
18− exposed-modules: Data.Aeson.Pointer
20+ src
19− default-language: Haskell2010
21+ default-language: Haskell2010
20− default-extensions: OverloadedStrings
21− other-extensions: GeneralizedNewtypeDeriving
22− ghc-options: -Wall
22+ ghc-options:
23+ -Wall
24+ exposed-modules:
25+ JSONPointer
23− build-depends: aeson >= 0.7 && < 0.12
26+ build-depends:
24− , base >= 4.6 && < 4.10
27+ base >= 4.9 && < 5
25− , QuickCheck >= 2.8 && < 2.10
28+ , aeson >= 0.7
29+ , hashable >= 1.2
26− , unordered-containers >= 0.2 && < 0.3
30+ , unordered-containers >= 0.2
27− , text >= 1.2 && < 1.3
31+ , text >= 1.2
28− , vector >= 0.10 && < 0.12
32+ , vector >= 0.10
29
33
30test-suite unit
34test-suite unit
31− type: exitcode-stdio-1.0
32− hs-source-dirs: test
35+ hs-source-dirs:
36+ test
33− ./
37+ ./
34− main-is: Unit.hs
38+ main-is: Unit.hs
35− other-modules: Example
36− default-language: Haskell2010
39+ default-language: Haskell2010
40+ type: exitcode-stdio-1.0
41+ default-extensions:
42+ OverloadedStrings
37− ghc-options: -Wall
43+ ghc-options:
38− default-extensions: OverloadedStrings
44+ -Wall
45+ -fno-warn-orphans
46+ other-modules: Example
39− build-depends: aeson
47+ build-depends:
48+ aeson
40− , base
49+ , base
41− , hjsonpointer
50+ , hjsonpointer
51+ , hspec >= 2.2
52+ , http-types >= 0.8
42− , QuickCheck
53+ , QuickCheck
43− , unordered-containers
54+ , unordered-containers
44− , text
55+ , text
45− , vector
56+ , vector
46− , hspec >= 2.2 && < 2.3
47− , http-types >= 0.8 && < 0.10
48− , HUnit >= 1.2 && < 1.4
49−
50−source-repository head
51− type: git
52− location: git://github.com/seagreen/hjsonpointer.git
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.hs+66−67
@@ -1,93 +1,92 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE StandaloneDeriving #-}
1
3
2module Main where
4module Main where
3
5
4−import Control.Arrow
5import Data.Aeson
6import Data.Aeson
6−import qualified Data.Aeson.Pointer as P
7+import Data.Bifunctor (first)
8+import Data.Foldable
9+import Data.Monoid
7−import Data.Text (Text)
10+import Data.Text (Text)
8−import qualified Data.Text as T
11+import qualified Data.Text as T
9−import Data.Text.Encoding
12+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
10−import qualified Data.Vector as V
13+import qualified Data.Vector as V
14+import qualified JSONPointer as JP
11−import Network.HTTP.Types.URI (urlDecode)
15+import Network.HTTP.Types.URI (urlDecode)
12
16
13import Test.Hspec
17import Test.Hspec
14−import Test.QuickCheck (property)
18+import Test.QuickCheck (Arbitrary(..), property)
15
19
16−import Test.HUnit hiding (Test)
20+import qualified Example
17
21
18−-- For GHCs before 7.10:
22+deriving instance Arbitrary JP.Pointer
19−import Control.Applicative
20−import Data.Foldable
21−import Data.Monoid
22
23
23−import qualified Example
24+instance Arbitrary JP.Token where
25+ arbitrary = JP.Token . T.pack <$> arbitrary
24
26
25main :: IO ()
27main :: IO ()
26main = hspec $ do
28main = hspec $ do
27− describe "example" $ do
29+ describe "example" $ do
28− it "compiles and runs without errors" Example.main
30+ it "compiles and runs without errors" Example.main
29− describe "pointers" $ do
31+ describe "pointers" $ do
30− it "can be stored as JSON without changing its value" (property roundtrip)
32+ it "can be stored as JSON without changing its value" (property roundtrip)
31− it "can be represented in a JSON string value" jsonString
33+ it "can be represented in a JSON string value" jsonString
32− it "can be represented in a URI fragment identifier" uriFragment
34+ it "can be represented in a URI fragment identifier" uriFragment
33
35
34−roundtrip :: P.Pointer -> Bool
36+roundtrip :: JP.Pointer -> Bool
35roundtrip a = Just a == decode (encode a)
37roundtrip a = Just a == decode (encode a)
36
38
37−jsonString :: Assertion
39+jsonString :: Expectation
38jsonString = traverse_ resolvesTo
40jsonString = traverse_ resolvesTo
39− [ ("" , specExample)
41+ [ ("" , specExample)
40− , ("/foo" , Array $ V.fromList ["bar", "baz"])
42+ , ("/foo" , Array $ V.fromList ["bar", "baz"])
41− , ("/foo/0", String "bar")
43+ , ("/foo/0", String "bar")
42− , ("/" , Number 0)
44+ , ("/" , Number 0)
43− , ("/a~1b" , Number 1)
45+ , ("/a~1b" , Number 1)
44− , ("/c%d" , Number 2)
46+ , ("/c%d" , Number 2)
45− , ("/e^f" , Number 3)
47+ , ("/e^f" , Number 3)
46− , ("/g|h" , Number 4)
48+ , ("/g|h" , Number 4)
47− , ("/i\\j" , Number 5)
49+ , ("/i\\j" , Number 5)
48− , ("/k\"l" , Number 6)
50+ , ("/k\"l" , Number 6)
49− , ("/ " , Number 7)
51+ , ("/ " , Number 7)
50− , ("/m~0n" , Number 8)
52+ , ("/m~0n" , Number 8)
51− ]
53+ ]
52
54
53−uriFragment :: Assertion
55+uriFragment :: Expectation
54uriFragment = traverse_ resolvesTo . fmap (first decodeFragment) $
56uriFragment = traverse_ resolvesTo . fmap (first decodeFragment) $
55− [ ("#" , specExample)
57+ [ ("#" , specExample)
56− , ("#/foo" , Array $ V.fromList ["bar", "baz"])
58+ , ("#/foo" , Array $ V.fromList ["bar", "baz"])
57− , ("#/foo/0", String "bar")
59+ , ("#/foo/0", String "bar")
58− , ("#/" , Number 0)
60+ , ("#/" , Number 0)
59− , ("#/a~1b" , Number 1)
61+ , ("#/a~1b" , Number 1)
60− , ("#/c%25d", Number 2)
62+ , ("#/c%25d", Number 2)
61− , ("#/e%5Ef", Number 3)
63+ , ("#/e%5Ef", Number 3)
62− , ("#/g%7Ch", Number 4)
64+ , ("#/g%7Ch", Number 4)
63− , ("#/i%5Cj", Number 5)
65+ , ("#/i%5Cj", Number 5)
64− , ("#/k%22l", Number 6)
66+ , ("#/k%22l", Number 6)
65− , ("#/%20" , Number 7)
67+ , ("#/%20" , Number 7)
66− , ("#/m~0n" , Number 8)
68+ , ("#/m~0n" , Number 8)
67− ]
69+ ]
68 where
70 where
69 decodeFragment :: Text -> Text
71 decodeFragment :: Text -> Text
70 decodeFragment = T.drop 1 . decodeUtf8 . urlDecode True . encodeUtf8
72 decodeFragment = T.drop 1 . decodeUtf8 . urlDecode True . encodeUtf8
71
73
72−resolvesTo :: (Text, Value) -> Assertion
74+resolvesTo :: (Text, Value) -> Expectation
73resolvesTo (t, expected) =
75resolvesTo (t, expected) =
74− case P.unescape t of
76+ case JP.unescape t of
75− Left e -> assertFailure (show e <> " error for pointer: " <> show t)
77+ Left e -> expectationFailure (show e <> " error for pointer: " <> show t)
76− Right p -> assertEqual
77− ("Resolved value for pointer: " <> show t)
78− (Right expected)
79− (P.resolve p specExample)
78+ Right p -> JP.resolve p specExample `shouldBe` Right expected
80
79
81specExample :: Value
80specExample :: Value
82specExample = object
81specExample = object
83− [ "foo" .= (["bar", "baz"] :: [Text])
82+ [ "foo" .= (["bar", "baz"] :: [Text])
84− , "" .= (0 :: Int)
83+ , "" .= (0 :: Int)
85− , "a/b" .= (1 :: Int)
84+ , "a/b" .= (1 :: Int)
86− , "c%d" .= (2 :: Int)
85+ , "c%d" .= (2 :: Int)
87− , "e^f" .= (3 :: Int)
86+ , "e^f" .= (3 :: Int)
88− , "g|h" .= (4 :: Int)
87+ , "g|h" .= (4 :: Int)
89− , "i\\j" .= (5 :: Int)
88+ , "i\\j" .= (5 :: Int)
90− , "k\"l" .= (6 :: Int)
89+ , "k\"l" .= (6 :: Int)
91− , " " .= (7 :: Int)
90+ , " " .= (7 :: Int)
92− , "m~n" .= (8 :: Int)
91+ , "m~n" .= (8 :: Int)
93− ]
92+ ]