Skip to content

Commit 4959d84

Browse files
Merge pull request #15 from input-output-hk/jonathanknowles/bech32-th
Introduce Template Haskell companion library.
2 parents b719f97 + f156577 commit 4959d84

17 files changed

Lines changed: 476 additions & 13 deletions

File tree

.travis.yml

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -20,8 +20,9 @@ install:
2020

2121
script:
2222
- cabal-3.0 configure --enable-tests
23-
- cabal-3.0 build
24-
- cabal-3.0 test --test-show-details=streaming
25-
- cabal-3.0 check
26-
- cabal-3.0 haddock
27-
- cabal-3.0 sdist
23+
- (cd bech32 && cabal-3.0 check)
24+
- (cd bech32-th && cabal-3.0 check)
25+
- cabal-3.0 build all
26+
- cabal-3.0 test all --test-show-details=streaming
27+
- cabal-3.0 haddock all
28+
- cabal-3.0 sdist all

README.md

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -82,5 +82,7 @@ Just "Lorem ipsum dolor sit amet!"
8282
If you find a bug or you'd like to propose a feature, please feel free to raise
8383
an issue on our [issue tracker](https://github.com/input-output-hk/bech32/issues).
8484

85-
Pull requests are welcome! When creating a pull request, please make sure that
86-
your code adheres to our [coding standards](https://github.com/input-output-hk/cardano-wallet/wiki/Coding-Standards).
85+
Pull requests are welcome!
86+
87+
When creating a pull request, please make sure that your code adheres to our
88+
[coding standards](https://github.com/input-output-hk/cardano-wallet/wiki/Coding-Standards).

bech32-th/ChangeLog.md

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
# ChangeLog for `bech32-th`
2+
3+
## 1.0.2 -- 2020-02-19
4+
5+
+ Initial release adapted from https://github.com/input-output-hk/cardano-wallet
File renamed without changes.

bech32-th/bech32-th.cabal

Lines changed: 78 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,78 @@
1+
name: bech32-th
2+
version: 1.0.2
3+
synopsis: Template Haskell extensions to the Bech32 library.
4+
description: Template Haskell extensions to the Bech32 library, including
5+
quasi-quoters for compile-time checking of Bech32 string
6+
literals.
7+
author: IOHK Engineering Team
8+
maintainer: operations@iohk.io, erikd@mega-nerd.com, jonathan.knowles@iohk.io
9+
copyright: 2020 IOHK
10+
license: Apache-2.0
11+
license-file: LICENSE
12+
homepage: https://github.com/input-output-hk/bech32
13+
bug-reports: https://github.com/input-output-hk/bech32/issues
14+
category: Web
15+
build-type: Simple
16+
extra-source-files: ChangeLog.md
17+
cabal-version: >=1.10
18+
19+
source-repository head
20+
type: git
21+
location: https://github.com/input-output-hk/bech32.git
22+
23+
flag werror
24+
description: Enable `-Werror`
25+
default: False
26+
manual: True
27+
28+
library
29+
default-language:
30+
Haskell2010
31+
default-extensions:
32+
NoImplicitPrelude
33+
OverloadedStrings
34+
ghc-options:
35+
-Wall
36+
-Wcompat
37+
-fwarn-redundant-constraints
38+
if (flag(werror))
39+
ghc-options:
40+
-Werror
41+
build-depends:
42+
base
43+
, bech32 >= 1.0.2
44+
, template-haskell
45+
, text
46+
hs-source-dirs:
47+
src
48+
exposed-modules:
49+
Codec.Binary.Bech32.TH
50+
51+
test-suite bech32-th-test
52+
default-language:
53+
Haskell2010
54+
default-extensions:
55+
NoImplicitPrelude
56+
OverloadedStrings
57+
type:
58+
exitcode-stdio-1.0
59+
hs-source-dirs:
60+
test
61+
ghc-options:
62+
-threaded -rtsopts -with-rtsopts=-N
63+
-Wall
64+
if (flag(werror))
65+
ghc-options:
66+
-Werror
67+
build-depends:
68+
base < 4.14
69+
, bech32
70+
, bech32-th
71+
, hspec
72+
, template-haskell
73+
build-tools:
74+
hspec-discover
75+
main-is:
76+
Main.hs
77+
other-modules:
78+
Codec.Binary.Bech32.THSpec
Lines changed: 74 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,74 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
3+
-- |
4+
-- Copyright: © 2020 IOHK
5+
-- License: Apache-2.0
6+
--
7+
-- This module contains Template-Haskell-specific extensions to the
8+
-- [Bech32 library](https://github.com/input-output-hk/bech32).
9+
10+
module Codec.Binary.Bech32.TH
11+
(
12+
-- ** Quasi-Quotation Support
13+
humanReadablePart
14+
) where
15+
16+
import Prelude
17+
18+
import Codec.Binary.Bech32
19+
( HumanReadablePart, humanReadablePartFromText, humanReadablePartToText )
20+
import Control.Exception
21+
( throw )
22+
import Data.Text
23+
( Text )
24+
import Language.Haskell.TH.Quote
25+
( QuasiQuoter (..) )
26+
import Language.Haskell.TH.Syntax
27+
( Exp, Q )
28+
29+
import qualified Data.Text as T
30+
31+
-- | A quasiquoter for Bech32 human-readable prefixes.
32+
--
33+
-- This quasiquoter makes it possible to construct values of type
34+
-- 'HumanReadablePart' at compile time, using string literals.
35+
--
36+
-- Failure to parse a string literal will result in a __compile-time error__.
37+
--
38+
-- See 'Codec.Binary.Bech32.HumanReadablePartError' for the set of possible
39+
-- errors that can be raised.
40+
--
41+
-- Example:
42+
--
43+
-- >>> :set -XQuasiQuotes
44+
-- >>> import Codec.Binary.Bech32
45+
-- >>> import Codec.Binary.Bech32.TH
46+
-- >>> let addrPrefix = [humanReadablePart|addr|]
47+
-- >>> addrPrefix
48+
-- HumanReadablePart "addr"
49+
-- >>> :t addrPrefix
50+
-- addrPrefix :: HumanReadablePart
51+
--
52+
humanReadablePart :: QuasiQuoter
53+
humanReadablePart = QuasiQuoter
54+
{ quoteExp = quoteHumanReadablePart
55+
, quotePat = notHandled "patterns"
56+
, quoteType = notHandled "types"
57+
, quoteDec = notHandled "declarations"
58+
}
59+
where
60+
notHandled things =
61+
error $ things <>
62+
" are not handled by the Bech32 humanReadablePart quasiquoter."
63+
64+
quoteHumanReadablePart :: String -> Q Exp
65+
quoteHumanReadablePart = quote
66+
. T.unpack
67+
. humanReadablePartToText
68+
. unsafeHumanReadablePart
69+
. T.pack
70+
where
71+
quote t = [| unsafeHumanReadablePart t |]
72+
73+
unsafeHumanReadablePart :: Text -> HumanReadablePart
74+
unsafeHumanReadablePart = either throw id . humanReadablePartFromText
Lines changed: 92 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,92 @@
1+
module Codec.Binary.Bech32.THSpec
2+
( spec
3+
) where
4+
5+
import Prelude
6+
7+
import Codec.Binary.Bech32
8+
( CharPosition (..)
9+
, HumanReadablePartError (..)
10+
, humanReadableCharMaxBound
11+
, humanReadableCharMinBound
12+
, humanReadablePartMaxLength
13+
, humanReadablePartMinLength
14+
)
15+
import Codec.Binary.Bech32.TH
16+
( humanReadablePart )
17+
import Control.Monad
18+
( forM_ )
19+
import Language.Haskell.TH.Quote
20+
( QuasiQuoter (quoteExp) )
21+
import Language.Haskell.TH.Syntax
22+
( Exp (..), runQ )
23+
import Test.Hspec
24+
( Spec, describe, it, shouldSatisfy, shouldThrow )
25+
26+
spec :: Spec
27+
spec =
28+
describe "Quasi-Quotations" $
29+
30+
describe "Human-Readable Prefixes" $ do
31+
let mkHumanReadablePartExp = runQ . quoteExp humanReadablePart
32+
33+
describe "Parsing valid human-readable prefixes should succeed." $
34+
forM_ validHumanReadableParts $ \hrp ->
35+
it (show hrp) $
36+
mkHumanReadablePartExp hrp >>=
37+
(`shouldSatisfy` isAppE)
38+
39+
describe "Parsing invalid human-readable prefixes should fail." $
40+
forM_ invalidHumanReadableParts $ \(hrp, expectedError) ->
41+
it (show hrp) $
42+
mkHumanReadablePartExp hrp
43+
`shouldThrow` (== expectedError)
44+
45+
-- | Matches only function application expressions.
46+
--
47+
isAppE :: Exp -> Bool
48+
isAppE AppE {} = True
49+
isAppE _ = False
50+
51+
-- | A selection of valid human-readable prefixes, that when parsed with the
52+
-- 'humanReadablePart' quasiquoter should not result in an exception.
53+
--
54+
-- Note that this is not by any means intended to be an exhaustive list.
55+
-- The underlying parsing logic, provided by `humanReadablePartFromText`,
56+
-- is already tested in the `bech32` package.
57+
--
58+
validHumanReadableParts :: [String]
59+
validHumanReadableParts =
60+
[ replicate humanReadablePartMinLength humanReadableCharMinBound
61+
, replicate humanReadablePartMaxLength humanReadableCharMaxBound
62+
, "addr"
63+
]
64+
65+
-- | A selection of invalid human-readable prefixes, along with the errors that
66+
-- we expect to see if we attempt to parse them with the 'humanReadablePart'
67+
-- quasi-quoter.
68+
--
69+
-- Note that this is not by any means intended to be an exhaustive list.
70+
-- The underlying parsing logic, provided by `humanReadablePartFromText`,
71+
-- is already tested in the `bech32` package.
72+
--
73+
invalidHumanReadableParts :: [(String, HumanReadablePartError)]
74+
invalidHumanReadableParts =
75+
[ ( replicate (pred minLen) minChar
76+
, HumanReadablePartTooShort
77+
)
78+
, ( replicate (succ maxLen) maxChar
79+
, HumanReadablePartTooLong
80+
)
81+
, ( replicate (succ minLen) (pred minChar)
82+
, HumanReadablePartContainsInvalidChars (CharPosition <$> [0 .. minLen])
83+
)
84+
, ( replicate (succ minLen) (succ maxChar)
85+
, HumanReadablePartContainsInvalidChars (CharPosition <$> [0 .. minLen])
86+
)
87+
]
88+
where
89+
minChar = humanReadableCharMinBound
90+
maxChar = humanReadableCharMaxBound
91+
minLen = humanReadablePartMinLength
92+
maxLen = humanReadablePartMaxLength
File renamed without changes.
Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,8 @@
11
# ChangeLog for `bech32`
22

3-
## 1.0.0 -- 2019-09-27
3+
## 1.0.2 -- 2020-02-19
44

5-
+ Initial release pulled from https://github.com/input-output-hk/cardano-wallet
5+
+ Added support for the `bech32-th` extension library.
66

77
## 1.0.1 -- 2020-02-13
88

@@ -12,3 +12,7 @@
1212
interface.
1313
+ Exposed the `Word5` type within the public interface.
1414
+ Exposed the `CharPosition` type within the public interface.
15+
16+
## 1.0.0 -- 2019-09-27
17+
18+
+ Initial release pulled from https://github.com/input-output-hk/cardano-wallet

0 commit comments

Comments
 (0)