diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +## 0.1.0 (2024-05-07) +Initial release. + +* some simple type-level printy helpers diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Ben Orchard (@raehik) + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# type-level-show +Utilities for writing `Show`-like type families i.e. instead of `showsPrec +:: Int -> a -> ShowS`, we have `ShowsPrec :: Natural -> k -> Symbol`. + +Requires at least GHC 9.2 for the type-level `Symbol` manipulation. + +## Why? +[refined-hackage]: https://hackage.haskell.org/package/refined +[rerefined-hackage]: https://hackage.haskell.org/package/rerefined + +[refined][refined-hackage] fills out error messages using `TypeRep`s. My rewrite +[rerefined][rerefined-hackage] allows you to use `Typeable` to fill out a +predicate name, or you can do it yourself. But `TypeRep` is a pain to use, and +it seems strange to do runtime work on type representations. Why can't we just +do it on the type level? + +We _could_, but the problem is nice formatting. `Show` instances handle +precedence, and the base library provides a bunch of handy utilities such as +`showParen :: Bool -> ShowS -> ShowS`. Worse, I couldn't find a `ShowNat :: +Natural -> Symbol` type family on Hoogle, which is a very simple type family +that should certainly be lying around. + +This library intends to provide such utilities, so that rerefined can avoid +`Typeable` altogether. + +Unsure if I'll provide a `ShowType`. Lower priority than the plain utilities. + +## License +Provided under the MIT license. See `LICENSE` for license text. diff --git a/src/TypeLevelShow/Natural.hs b/src/TypeLevelShow/Natural.hs new file mode 100644 --- /dev/null +++ b/src/TypeLevelShow/Natural.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE UndecidableInstances #-} + +module TypeLevelShow.Natural where + +import GHC.TypeLits +import DeFun.Core ( type (~>), type App, type (@@) ) + +type ShowNatBin n = ShowNatBase 2 ShowNatBinaryDigitSym n +type ShowNatOct n = ShowNatBase 8 ShowNatOctalDigitSym n +type ShowNatDec n = ShowNatBase 10 ShowNatDecimalDigitSym n +type ShowNatHexLower n = ShowNatBase 16 ShowNatHexDigitLowerSym n +type ShowNatHexUpper n = ShowNatBase 16 ShowNatHexDigitUpperSym n + +-- | Render a type-level 'Natural' in the given base using the given digit +-- printer. +type family ShowNatBase base showDigit n where + -- | Our algorithm returns the empty 'Symbol' for 0, so handle it here. + ShowNatBase base showDigit 0 = "0" + + ShowNatBase base showDigit n = ShowNatBase' base showDigit "" n + +type ShowNatBase' :: Natural -> (Natural ~> Char) -> Symbol -> Natural -> Symbol +type family ShowNatBase' base showDigit acc n where + ShowNatBase' base showDigit acc 0 = acc + ShowNatBase' base showDigit acc n = ShowNatBase' base showDigit + (ConsSymbol (showDigit @@ (n `Mod` base)) acc) (n `Div` base) + +-- TODO add TypeErrors to invalid usages of these digit printers +-- should be free performance-wise so no harm +-- low priority because they're internals anyway + +type family ShowNatBinaryDigit (d :: Natural) :: Char where + ShowNatBinaryDigit 0 = '0' + ShowNatBinaryDigit 1 = '1' + +type ShowNatBinaryDigitSym :: Natural ~> Char +data ShowNatBinaryDigitSym d +type instance App ShowNatBinaryDigitSym d = ShowNatBinaryDigit d + +type family ShowNatOctalDigit (d :: Natural) :: Char where + ShowNatOctalDigit 0 = '0' + ShowNatOctalDigit 1 = '1' + ShowNatOctalDigit 2 = '2' + ShowNatOctalDigit 3 = '3' + ShowNatOctalDigit 4 = '4' + ShowNatOctalDigit 5 = '5' + ShowNatOctalDigit 6 = '6' + ShowNatOctalDigit 7 = '7' + +type ShowNatOctalDigitSym :: Natural ~> Char +data ShowNatOctalDigitSym d +type instance App ShowNatOctalDigitSym d = ShowNatOctalDigit d + +type family ShowNatDecimalDigit (d :: Natural) :: Char where + ShowNatDecimalDigit 0 = '0' + ShowNatDecimalDigit 1 = '1' + ShowNatDecimalDigit 2 = '2' + ShowNatDecimalDigit 3 = '3' + ShowNatDecimalDigit 4 = '4' + ShowNatDecimalDigit 5 = '5' + ShowNatDecimalDigit 6 = '6' + ShowNatDecimalDigit 7 = '7' + ShowNatDecimalDigit 8 = '8' + ShowNatDecimalDigit 9 = '9' + +type ShowNatDecimalDigitSym :: Natural ~> Char +data ShowNatDecimalDigitSym d +type instance App ShowNatDecimalDigitSym d = ShowNatDecimalDigit d + +type family ShowNatHexDigitLower (d :: Natural) :: Char where + ShowNatHexDigitLower 0 = '0' + ShowNatHexDigitLower 1 = '1' + ShowNatHexDigitLower 2 = '2' + ShowNatHexDigitLower 3 = '3' + ShowNatHexDigitLower 4 = '4' + ShowNatHexDigitLower 5 = '5' + ShowNatHexDigitLower 6 = '6' + ShowNatHexDigitLower 7 = '7' + ShowNatHexDigitLower 8 = '8' + ShowNatHexDigitLower 9 = '9' + ShowNatHexDigitLower 10 = 'a' + ShowNatHexDigitLower 11 = 'b' + ShowNatHexDigitLower 12 = 'c' + ShowNatHexDigitLower 13 = 'd' + ShowNatHexDigitLower 14 = 'e' + ShowNatHexDigitLower 15 = 'f' + +type ShowNatHexDigitLowerSym :: Natural ~> Char +data ShowNatHexDigitLowerSym d +type instance App ShowNatHexDigitLowerSym d = ShowNatHexDigitLower d + +type family ShowNatHexDigitUpper (d :: Natural) :: Char where + ShowNatHexDigitUpper 0 = '0' + ShowNatHexDigitUpper 1 = '1' + ShowNatHexDigitUpper 2 = '2' + ShowNatHexDigitUpper 3 = '3' + ShowNatHexDigitUpper 4 = '4' + ShowNatHexDigitUpper 5 = '5' + ShowNatHexDigitUpper 6 = '6' + ShowNatHexDigitUpper 7 = '7' + ShowNatHexDigitUpper 8 = '8' + ShowNatHexDigitUpper 9 = '9' + ShowNatHexDigitUpper 10 = 'A' + ShowNatHexDigitUpper 11 = 'B' + ShowNatHexDigitUpper 12 = 'C' + ShowNatHexDigitUpper 13 = 'D' + ShowNatHexDigitUpper 14 = 'E' + ShowNatHexDigitUpper 15 = 'F' + +type ShowNatHexDigitUpperSym :: Natural ~> Char +data ShowNatHexDigitUpperSym d +type instance App ShowNatHexDigitUpperSym d = ShowNatHexDigitUpper d diff --git a/src/TypeLevelShow/Utils.hs b/src/TypeLevelShow/Utils.hs new file mode 100644 --- /dev/null +++ b/src/TypeLevelShow/Utils.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE UndecidableInstances #-} + +module TypeLevelShow.Utils where + +import GHC.TypeLits + +-- | Surround the given 'Symbol' with parentheses when the 'Bool' parameter is +-- 'True'. +type ShowParen :: Bool -> Symbol -> Symbol +type family ShowParen b p where + ShowParen False p = p + ShowParen True p = ConsSymbol '(' p `AppendSymbol` ")" + +-- | Surround the given 'Symbol' with parentheses if the given precedence is +-- greater than the given 'Natural'. +-- +-- Type-level relational operations are a pain. This may be easier to use. +type ShowParenIfGt :: Natural -> Natural -> Symbol -> Symbol +type ShowParenIfGt n d p = ShowParen (OrderingGT (CmpNat d n)) p + +type family OrderingGT (a :: Ordering) :: Bool where + OrderingGT LT = False + OrderingGT EQ = False + OrderingGT GT = True + +type ShowChar ch = ConsSymbol ch "" + +type l ++ r = AppendSymbol l r +type l > r = OrderingGT (CmpNat l r) diff --git a/type-level-show.cabal b/type-level-show.cabal new file mode 100644 --- /dev/null +++ b/type-level-show.cabal @@ -0,0 +1,55 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: type-level-show +version: 0.1.0 +synopsis: Utilities for writing Show-like type families +description: Please see README.md. +category: Types, Data +homepage: https://github.com/raehik/type-level-show#readme +bug-reports: https://github.com/raehik/type-level-show/issues +author: Ben Orchard +maintainer: Ben Orchard +license: MIT +license-file: LICENSE +build-type: Simple +tested-with: + GHC==9.8 + , GHC==9.6 + , GHC==9.4 + , GHC==9.2 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/raehik/type-level-show + +library + exposed-modules: + TypeLevelShow.Natural + TypeLevelShow.Utils + other-modules: + Paths_type_level_show + hs-source-dirs: + src + default-extensions: + LambdaCase + NoStarIsType + DerivingVia + DeriveAnyClass + GADTs + RoleAnnotations + DefaultSignatures + TypeFamilies + DataKinds + MagicHash + ghc-options: -Wall -Wno-unticked-promoted-constructors + build-depends: + base >=4.16 && <5 + , defun-core ==0.1.* + default-language: GHC2021