Merge pull request #15 from input-output-hk/jonathanknowles/bech32-th

Introduce Template Haskell companion library.

.travis.yml

@@ -20,8 +20,9 @@ install:
 
 script:
  - cabal-3.0 configure --enable-tests
- - cabal-3.0 build
- - cabal-3.0 test --test-show-details=streaming
- - cabal-3.0 check
- - cabal-3.0 haddock
- - cabal-3.0 sdist
+ - (cd bech32    && cabal-3.0 check)
+ - (cd bech32-th && cabal-3.0 check)
+ - cabal-3.0 build all
+ - cabal-3.0 test all --test-show-details=streaming
+ - cabal-3.0 haddock all
+ - cabal-3.0 sdist all

README.md

@@ -82,5 +82,7 @@ Just "Lorem ipsum dolor sit amet!"
 If you find a bug or you'd like to propose a feature, please feel free to raise
 an issue on our [issue tracker](https://github.com/input-output-hk/bech32/issues).
 
-Pull requests are welcome! When creating a pull request, please make sure that
-your code adheres to our [coding standards](https://github.com/input-output-hk/cardano-wallet/wiki/Coding-Standards).
+Pull requests are welcome!
+
+When creating a pull request, please make sure that your code adheres to our
+[coding standards](https://github.com/input-output-hk/cardano-wallet/wiki/Coding-Standards).

bech32-th/ChangeLog.md

@@ -0,0 +1,5 @@
+# ChangeLog for `bech32-th`
+
+## 1.0.2 -- 2020-02-19
+
++ Initial release adapted from https://github.com/input-output-hk/cardano-wallet

bech32-th/bech32-th.cabal

@@ -0,0 +1,78 @@
+name:               bech32-th
+version:            1.0.2
+synopsis:           Template Haskell extensions to the Bech32 library.
+description:        Template Haskell extensions to the Bech32 library, including
+                    quasi-quoters for compile-time checking of Bech32 string
+                    literals.
+author:             IOHK Engineering Team
+maintainer:         [email protected], [email protected], [email protected]
+copyright:          2020 IOHK
+license:            Apache-2.0
+license-file:       LICENSE
+homepage:           https://github.com/input-output-hk/bech32
+bug-reports:        https://github.com/input-output-hk/bech32/issues
+category:           Web
+build-type:         Simple
+extra-source-files: ChangeLog.md
+cabal-version:      >=1.10
+
+source-repository head
+  type:     git
+  location: https://github.com/input-output-hk/bech32.git
+
+flag werror
+    description: Enable `-Werror`
+    default: False
+    manual: True
+
+library
+  default-language:
+      Haskell2010
+  default-extensions:
+      NoImplicitPrelude
+      OverloadedStrings
+  ghc-options:
+      -Wall
+      -Wcompat
+      -fwarn-redundant-constraints
+  if (flag(werror))
+    ghc-options:
+      -Werror
+  build-depends:
+      base
+    , bech32 >= 1.0.2
+    , template-haskell
+    , text
+  hs-source-dirs:
+      src
+  exposed-modules:
+      Codec.Binary.Bech32.TH
+
+test-suite bech32-th-test
+  default-language:
+      Haskell2010
+  default-extensions:
+      NoImplicitPrelude
+      OverloadedStrings
+  type:
+      exitcode-stdio-1.0
+  hs-source-dirs:
+      test
+  ghc-options:
+      -threaded -rtsopts -with-rtsopts=-N
+      -Wall
+  if (flag(werror))
+    ghc-options:
+      -Werror
+  build-depends:
+      base < 4.14
+    , bech32
+    , bech32-th
+    , hspec
+    , template-haskell
+  build-tools:
+      hspec-discover
+  main-is:
+      Main.hs
+  other-modules:
+      Codec.Binary.Bech32.THSpec

bech32-th/src/Codec/Binary/Bech32/TH.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Copyright: © 2020 IOHK
+-- License: Apache-2.0
+--
+-- This module contains Template-Haskell-specific extensions to the
+-- [Bech32 library](https://github.com/input-output-hk/bech32).
+
+module Codec.Binary.Bech32.TH
+    (
+      -- ** Quasi-Quotation Support
+      humanReadablePart
+    ) where
+
+import Prelude
+
+import Codec.Binary.Bech32
+    ( HumanReadablePart, humanReadablePartFromText, humanReadablePartToText )
+import Control.Exception
+    ( throw )
+import Data.Text
+    ( Text )
+import Language.Haskell.TH.Quote
+    ( QuasiQuoter (..) )
+import Language.Haskell.TH.Syntax
+    ( Exp, Q )
+
+import qualified Data.Text as T
+
+-- | A quasiquoter for Bech32 human-readable prefixes.
+--
+-- This quasiquoter makes it possible to construct values of type
+-- 'HumanReadablePart' at compile time, using string literals.
+--
+-- Failure to parse a string literal will result in a __compile-time error__.
+--
+-- See 'Codec.Binary.Bech32.HumanReadablePartError' for the set of possible
+-- errors that can be raised.
+--
+-- Example:
+--
+-- >>> :set -XQuasiQuotes
+-- >>> import Codec.Binary.Bech32
+-- >>> import Codec.Binary.Bech32.TH
+-- >>> let addrPrefix = [humanReadablePart|addr|]
+-- >>> addrPrefix
+-- HumanReadablePart "addr"
+-- >>> :t addrPrefix
+-- addrPrefix :: HumanReadablePart
+--
+humanReadablePart :: QuasiQuoter
+humanReadablePart = QuasiQuoter
+    { quoteExp  = quoteHumanReadablePart
+    , quotePat  = notHandled "patterns"
+    , quoteType = notHandled "types"
+    , quoteDec  = notHandled "declarations"
+    }
+  where
+    notHandled things =
+      error $ things <>
+          " are not handled by the Bech32 humanReadablePart quasiquoter."
+
+quoteHumanReadablePart :: String -> Q Exp
+quoteHumanReadablePart = quote
+    . T.unpack
+    . humanReadablePartToText
+    . unsafeHumanReadablePart
+    . T.pack
+  where
+    quote t = [| unsafeHumanReadablePart t |]
+
+unsafeHumanReadablePart :: Text -> HumanReadablePart
+unsafeHumanReadablePart = either throw id . humanReadablePartFromText

bech32-th/test/Codec/Binary/Bech32/THSpec.hs

@@ -0,0 +1,92 @@
+module Codec.Binary.Bech32.THSpec
+    ( spec
+    ) where
+
+import Prelude
+
+import Codec.Binary.Bech32
+    ( CharPosition (..)
+    , HumanReadablePartError (..)
+    , humanReadableCharMaxBound
+    , humanReadableCharMinBound
+    , humanReadablePartMaxLength
+    , humanReadablePartMinLength
+    )
+import Codec.Binary.Bech32.TH
+    ( humanReadablePart )
+import Control.Monad
+    ( forM_ )
+import Language.Haskell.TH.Quote
+    ( QuasiQuoter (quoteExp) )
+import Language.Haskell.TH.Syntax
+    ( Exp (..), runQ )
+import Test.Hspec
+    ( Spec, describe, it, shouldSatisfy, shouldThrow )
+
+spec :: Spec
+spec =
+    describe "Quasi-Quotations" $
+
+        describe "Human-Readable Prefixes" $ do
+            let mkHumanReadablePartExp = runQ . quoteExp humanReadablePart
+
+            describe "Parsing valid human-readable prefixes should succeed." $
+                forM_ validHumanReadableParts $ \hrp ->
+                    it (show hrp) $
+                        mkHumanReadablePartExp hrp >>=
+                            (`shouldSatisfy` isAppE)
+
+            describe "Parsing invalid human-readable prefixes should fail." $
+                forM_ invalidHumanReadableParts $ \(hrp, expectedError) ->
+                    it (show hrp) $
+                        mkHumanReadablePartExp hrp
+                            `shouldThrow` (== expectedError)
+
+-- | Matches only function application expressions.
+--
+isAppE :: Exp -> Bool
+isAppE AppE {} = True
+isAppE _       = False
+
+-- | A selection of valid human-readable prefixes, that when parsed with the
+--   'humanReadablePart' quasiquoter should not result in an exception.
+--
+-- Note that this is not by any means intended to be an exhaustive list.
+-- The underlying parsing logic, provided by `humanReadablePartFromText`,
+-- is already tested in the `bech32` package.
+--
+validHumanReadableParts :: [String]
+validHumanReadableParts =
+    [ replicate humanReadablePartMinLength humanReadableCharMinBound
+    , replicate humanReadablePartMaxLength humanReadableCharMaxBound
+    , "addr"
+    ]
+
+-- | A selection of invalid human-readable prefixes, along with the errors that
+--   we expect to see if we attempt to parse them with the 'humanReadablePart'
+--   quasi-quoter.
+--
+-- Note that this is not by any means intended to be an exhaustive list.
+-- The underlying parsing logic, provided by `humanReadablePartFromText`,
+-- is already tested in the `bech32` package.
+--
+invalidHumanReadableParts :: [(String, HumanReadablePartError)]
+invalidHumanReadableParts =
+    [ ( replicate (pred minLen) minChar
+      , HumanReadablePartTooShort
+      )
+    , ( replicate (succ maxLen) maxChar
+      , HumanReadablePartTooLong
+      )
+    , ( replicate (succ minLen) (pred minChar)
+      , HumanReadablePartContainsInvalidChars (CharPosition <$> [0 .. minLen])
+      )
+    , ( replicate (succ minLen) (succ maxChar)
+      , HumanReadablePartContainsInvalidChars (CharPosition <$> [0 .. minLen])
+      )
+    ]
+  where
+    minChar = humanReadableCharMinBound
+    maxChar = humanReadableCharMaxBound
+    minLen = humanReadablePartMinLength
+    maxLen = humanReadablePartMaxLength

ChangeLog.md → bech32/ChangeLog.md

@@ -1,8 +1,8 @@
 # ChangeLog for `bech32`
 
-## 1.0.0 -- 2019-09-27
+## 1.0.2 -- 2020-02-19
 
-+ Initial release pulled from https://github.com/input-output-hk/cardano-wallet
++ Added support for the `bech32-th` extension library.
 
 ## 1.0.1 -- 2020-02-13
 
@@ -12,3 +12,7 @@
   interface.
 + Exposed the `Word5` type within the public interface.
 + Exposed the `CharPosition` type within the public interface.
+
+## 1.0.0 -- 2019-09-27
+
++ Initial release pulled from https://github.com/input-output-hk/cardano-wallet