├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .hlint.yaml ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── Setup.lhs ├── cabal.haskell-ci ├── cabal.project ├── scripts └── travis_long ├── src └── Data │ ├── Proxy │ └── TH.hs │ └── Tagged.hs ├── stack-7.8.yaml ├── stack.yaml └── tagged.cabal /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--config=cabal.haskell-ci' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20241202 12 | # 13 | # REGENDATA ("0.19.20241202",["github","--config=cabal.haskell-ci","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.0.20241128 32 | compilerKind: ghc 33 | compilerVersion: 9.12.0.20241128 34 | setup-method: ghcup-prerelease 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | - compiler: ghc-8.2.2 87 | compilerKind: ghc 88 | compilerVersion: 8.2.2 89 | setup-method: ghcup 90 | allow-failure: false 91 | - compiler: ghc-8.0.2 92 | compilerKind: ghc 93 | compilerVersion: 8.0.2 94 | setup-method: ghcup 95 | allow-failure: false 96 | fail-fast: false 97 | steps: 98 | - name: apt-get install 99 | run: | 100 | apt-get update 101 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 102 | - name: Install GHCup 103 | run: | 104 | mkdir -p "$HOME/.ghcup/bin" 105 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 106 | chmod a+x "$HOME/.ghcup/bin/ghcup" 107 | - name: Install cabal-install 108 | run: | 109 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 110 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 111 | - name: Install GHC (GHCup) 112 | if: matrix.setup-method == 'ghcup' 113 | run: | 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 116 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 117 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 121 | env: 122 | HCKIND: ${{ matrix.compilerKind }} 123 | HCNAME: ${{ matrix.compiler }} 124 | HCVER: ${{ matrix.compilerVersion }} 125 | - name: Install GHC (GHCup prerelease) 126 | if: matrix.setup-method == 'ghcup-prerelease' 127 | run: | 128 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 129 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 130 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 131 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 132 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 133 | echo "HC=$HC" >> "$GITHUB_ENV" 134 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 135 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 136 | env: 137 | HCKIND: ${{ matrix.compilerKind }} 138 | HCNAME: ${{ matrix.compiler }} 139 | HCVER: ${{ matrix.compilerVersion }} 140 | - name: Set PATH and environment variables 141 | run: | 142 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 143 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 144 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 145 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 146 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 147 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 148 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 149 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 150 | if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 151 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 152 | env: 153 | HCKIND: ${{ matrix.compilerKind }} 154 | HCNAME: ${{ matrix.compiler }} 155 | HCVER: ${{ matrix.compilerVersion }} 156 | - name: env 157 | run: | 158 | env 159 | - name: write cabal config 160 | run: | 161 | mkdir -p $CABAL_DIR 162 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 207 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 208 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 209 | rm -f cabal-plan.xz 210 | chmod a+x $HOME/.cabal/bin/cabal-plan 211 | cabal-plan --version 212 | - name: checkout 213 | uses: actions/checkout@v4 214 | with: 215 | path: source 216 | - name: initial cabal.project for sdist 217 | run: | 218 | touch cabal.project 219 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 220 | cat cabal.project 221 | - name: sdist 222 | run: | 223 | mkdir -p sdist 224 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 225 | - name: unpack 226 | run: | 227 | mkdir -p unpacked 228 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 229 | - name: generate cabal.project 230 | run: | 231 | PKGDIR_tagged="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/tagged-[0-9.]*')" 232 | echo "PKGDIR_tagged=${PKGDIR_tagged}" >> "$GITHUB_ENV" 233 | rm -f cabal.project cabal.project.local 234 | touch cabal.project 235 | touch cabal.project.local 236 | echo "packages: ${PKGDIR_tagged}" >> cabal.project 237 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package tagged" >> cabal.project ; fi 238 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 239 | cat >> cabal.project <> cabal.project 243 | fi 244 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(tagged)$/; }' >> cabal.project.local 245 | cat cabal.project 246 | cat cabal.project.local 247 | - name: dump install plan 248 | run: | 249 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 250 | cabal-plan 251 | - name: restore cache 252 | uses: actions/cache/restore@v4 253 | with: 254 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 255 | path: ~/.cabal/store 256 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 257 | - name: install dependencies 258 | run: | 259 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 260 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 261 | - name: build 262 | run: | 263 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 264 | - name: cabal check 265 | run: | 266 | cd ${PKGDIR_tagged} || false 267 | ${CABAL} -vnormal check 268 | - name: haddock 269 | run: | 270 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 271 | - name: save cache 272 | if: always() 273 | uses: actions/cache/save@v4 274 | with: 275 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 276 | path: ~/.cabal/store 277 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .hsenv/ 4 | docs 5 | wiki 6 | TAGS 7 | tags 8 | wip 9 | .DS_Store 10 | .*.swp 11 | .*.swo 12 | *.o 13 | *.hi 14 | *~ 15 | *# 16 | .stack-work/ 17 | cabal-dev 18 | *.chi 19 | *.chs.h 20 | *.dyn_o 21 | *.dyn_hi 22 | .hpc 23 | .hsenv 24 | .cabal-sandbox/ 25 | cabal.sandbox.config 26 | *.prof 27 | *.aux 28 | *.hp 29 | *.eventlog 30 | cabal.project.local 31 | cabal.project.local~ 32 | .HTF/ 33 | .ghc.environment.* 34 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [--cpp-define=HLINT, --cpp-ansi] 2 | 3 | - ignore: {name: Use camelCase} 4 | - ignore: {name: Eta reduce} 5 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | 0.8.9 [2024.12.03] 2 | ------------------ 3 | * Allow building with GHC 9.12. 4 | * Drop support for GHC 7.10 and earlier. 5 | 6 | 0.8.8 [2023.08.08] 7 | ------------------ 8 | * Allow building with GHC 9.8. 9 | 10 | 0.8.7 [2023.02.18] 11 | ------------------ 12 | * Define `Foldable1` and `Bifoldable1` instances for `Tagged`. These instances 13 | were originally defined in the `semigroupoids` library, and they have now 14 | been migrated to `tagged` as a side effect of adapting to 15 | [this Core Libraries Proposal](https://github.com/haskell/core-libraries-committee/issues/9), 16 | which adds `Foldable1` and `Bifoldable1` to `base`. 17 | 18 | 0.8.6.1 [2020.12.28] 19 | -------------------- 20 | * Mark all modules as explicitly Safe or Trustworthy. 21 | 22 | 0.8.6 [2018.07.02] 23 | ------------------ 24 | * Make the `Read(1)` instances for `Proxy` ignore the precedence argument, 25 | mirroring similar changes to `base` 26 | [here](http://git.haskell.org/ghc.git/commitdiff/8fd959998e900dffdb7f752fcd42df7aaedeae6e). 27 | * Fix a bug in the `Floating` instance for `Tagged` in which `logBase` was 28 | defined in terms of `(**)`. 29 | * Avoid incurring some dependencies when using recent GHCs. 30 | 31 | 0.8.5 32 | ----- 33 | * Support `Data.Bifoldable`/`Data.Bitraversable` in `base` for GHC 8.1+. 34 | * Backport the `Eq1`, `Ord1`, `Read1`, and `Show1` instances for `Proxy` from `base-4.9` 35 | * Add `Eq1`/`2`, `Ord1`/`2`, `Read1`/`2`, and `Show1`/`2` instances for `Tagged` 36 | 37 | 0.8.4 38 | ----- 39 | * Backport the `Alternative`, `MonadPlus`, and `MonadZip` instances for `Proxy` from `base-4.9` 40 | * Add `Bits`, `FiniteBits`, `IsString`, and `Storable` instances for `Tagged` 41 | 42 | 0.8.3 43 | ----- 44 | * Manual `Generic1` support to work around a bug in GHC 7.6 45 | * Invert the dependency to supply the `Semigroup` instance ourselves when building on GHC 8 46 | 47 | 0.8.2 48 | ------- 49 | * `deepseq` support. 50 | * Widened `template-haskell` dependency bounds. 51 | 52 | 0.8.1 53 | ----- 54 | * Add `KProxy` to the backwards compatibility `Data.Proxy` module. 55 | * Add a `Generic` instance to `Proxy`. 56 | 57 | 0.8.0.1 58 | ------- 59 | * Fix builds on GHC 7.4. 60 | 61 | 0.8 62 | --- 63 | * Added `Data.Proxy.TH`, based on the code from `Frames` by Anthony Cowley. 64 | * Removed `reproxy` from `Data.Proxy`. This is a bad API decision, but it isn't present in GHC's `Data.Proxy`, and this makes the API more stable. 65 | 66 | 0.7.3 67 | --- 68 | * Support `Data.Bifunctor` in `base` for GHC 7.9+. 69 | 70 | 0.7.2 71 | ----- 72 | * Fixed warning on GHC 7.8 73 | 74 | 0.7.1 75 | ----- 76 | * Added `tagWith`. 77 | 78 | 0.7 79 | --- 80 | * `Data.Proxy` has moved into base as of GHC 7.7 for use in the new `Data.Typeable`. We no longer export 81 | it for GHC >= 7.7. The most notable change in the module from the migration into base is the loss of 82 | the `reproxy` function. 83 | 84 | 0.6.2 85 | ----- 86 | * Allowed polymorphic arguments where possible. 87 | 88 | 0.6.1 89 | ----- 90 | * Needlessly claim that this entirely pure package is `Trustworthy`! 91 | 92 | 0.6 93 | --- 94 | * On GHC 7.7, we now still export the instances we used to for `Data.Proxy.Proxy` as orphans if need be. 95 | 96 | 0.5 97 | --- 98 | * On GHC 7.7 we now simply export `Data.Typeable.Proxy` rather than make our own type. We still re-export it. 99 | 100 | 0.4.5 101 | ----- 102 | * Added `witness` 103 | 104 | 0.4.4 105 | ----- 106 | * Actually working polymorphic kind support 107 | 108 | 0.4.3 109 | ----- 110 | * Added polymorphic kind support 111 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009-2015 Edward Kmett 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Edward Kmett nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | tagged 2 | ====== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/tagged.svg)](https://hackage.haskell.org/package/tagged) [![Build Status](https://github.com/ekmett/tagged/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/tagged/actions?query=workflow%3AHaskell-CI) 5 | 6 | Values carrying an extra [phantom type](https://wiki.haskell.org/Phantom_type) tag. 7 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | -- irc-channels: irc.freenode.org#haskell-lens 5 | -- irc-if-in-origin-repo: True 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /scripts/travis_long: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | $* & 4 | pidA=$! 5 | minutes=0 6 | 7 | while true; do sleep 60; ((minutes++)); echo -e "\033[0;32m$minutes minute(s) elapsed.\033[0m"; done & 8 | pidB=$! 9 | 10 | wait $pidA 11 | exitCode=$? 12 | 13 | echo -e "\033[0;32m$* finished.\033[0m" 14 | 15 | kill -9 $pidB 16 | 17 | exit $exitCode 18 | -------------------------------------------------------------------------------- /src/Data/Proxy/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskellQuotes #-} 3 | #ifndef MIN_VERSION_template_haskell 4 | #define MIN_VERSION_template_haskell(x,y,z) 1 5 | #endif 6 | -- template-haskell is only safe since GHC-8.2 7 | #if __GLASGOW_HASKELL__ >= 802 8 | {-# LANGUAGE Safe #-} 9 | #else 10 | {-# LANGUAGE Trustworthy #-} 11 | #endif 12 | module Data.Proxy.TH 13 | ( pr 14 | , pr1 15 | ) where 16 | 17 | import Data.Char 18 | import Data.Proxy (Proxy(..)) 19 | import Language.Haskell.TH 20 | import Language.Haskell.TH.Quote 21 | 22 | proxy_d, proxy_tc :: Name 23 | proxy_d = 'Proxy 24 | proxy_tc = ''Proxy 25 | 26 | proxyTypeQ :: TypeQ -> TypeQ 27 | proxyTypeQ t = appT (conT proxy_tc) t 28 | 29 | proxyExpQ :: TypeQ -> ExpQ 30 | proxyExpQ t = sigE (conE proxy_d) (proxyTypeQ t) 31 | 32 | proxyPatQ :: TypeQ -> PatQ 33 | proxyPatQ t = sigP (conP proxy_d []) (proxyTypeQ t) 34 | 35 | -- | A proxy value quasiquoter. @[pr|T|]@ will splice an expression 36 | -- @Proxy::Proxy T@, while @[pr|A,B,C|]@ will splice in a value of 37 | -- @Proxy :: Proxy [A,B,C]@. 38 | 39 | -- TODO: parse a richer syntax for the types involved here so we can include spaces, applications, etc. 40 | pr :: QuasiQuoter 41 | pr = QuasiQuoter (mkProxy proxyExpQ) (mkProxy proxyPatQ) (mkProxy proxyTypeQ) undefined where 42 | mkProxy :: (TypeQ -> r) -> String -> r 43 | mkProxy p s = case ts of 44 | [h@(t:_)] 45 | | isUpper t -> p $ conT $ mkName h 46 | | otherwise -> p $ varT $ mkName h 47 | _ -> p $ mkList <$> cons 48 | where 49 | ts = map strip $ splitOn ',' s 50 | cons = mapM (conT . mkName) ts 51 | mkList = foldr (AppT . AppT PromotedConsT) PromotedNilT 52 | 53 | -- | Like 'pr', but takes a single type, which is used to produce a 54 | -- 'Proxy' for a single-element list containing only that type. This 55 | -- is useful for passing a single type to a function that wants a list 56 | -- of types. 57 | 58 | -- TODO: parse a richer syntax for the types involved here so we can include spaces, applications, etc. 59 | pr1 :: QuasiQuoter 60 | pr1 = QuasiQuoter (mkProxy proxyExpQ) (mkProxy proxyPatQ) (mkProxy proxyTypeQ) undefined where 61 | sing x = AppT (AppT PromotedConsT x) PromotedNilT 62 | mkProxy p s = case s of 63 | t:_ 64 | | isUpper t -> p (fmap sing (conT $ mkName s)) 65 | | otherwise -> p (fmap sing (varT $ mkName s)) 66 | _ -> error "Empty string passed to pr1" 67 | 68 | -- | Split on a delimiter. 69 | splitOn :: Eq a => a -> [a] -> [[a]] 70 | splitOn d = go where 71 | go [] = [] 72 | go xs = case t of 73 | [] -> [h] 74 | (_:t') -> h : go t' 75 | where (h,t) = break (== d) xs 76 | 77 | -- | Remove white space from both ends of a 'String'. 78 | strip :: String -> String 79 | strip = takeWhile (not . isSpace) . dropWhile isSpace 80 | -------------------------------------------------------------------------------- /src/Data/Tagged.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE Safe #-} 5 | 6 | {-# OPTIONS_GHC -Wno-deprecations #-} 7 | ---------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Tagged 10 | -- Copyright : 2009-2015 Edward Kmett 11 | -- License : BSD3 12 | -- 13 | -- Maintainer : Edward Kmett 14 | -- Stability : experimental 15 | -- Portability : portable 16 | -- 17 | ------------------------------------------------------------------------------- 18 | 19 | module Data.Tagged 20 | ( 21 | -- * Tagged values 22 | Tagged(..) 23 | , retag 24 | , untag 25 | , tagSelf 26 | , untagSelf 27 | , asTaggedTypeOf 28 | , witness 29 | -- * Conversion 30 | , proxy 31 | , unproxy 32 | , tagWith 33 | -- * Proxy methods GHC dropped 34 | , reproxy 35 | ) where 36 | 37 | #if !(MIN_VERSION_base(4,18,0)) 38 | import Control.Applicative (liftA2) 39 | #endif 40 | import Data.Bits 41 | import Data.Foldable (Foldable(..)) 42 | #ifdef MIN_VERSION_deepseq 43 | import Control.DeepSeq (NFData(..)) 44 | #endif 45 | import Data.Functor.Classes ( Eq1(..), Ord1(..), Read1(..), Show1(..) 46 | , Eq2(..), Ord2(..), Read2(..), Show2(..) 47 | ) 48 | import Control.Monad (liftM) 49 | import Data.Bifunctor 50 | #if MIN_VERSION_base(4,10,0) 51 | import Data.Bifoldable (Bifoldable(..)) 52 | import Data.Bitraversable (Bitraversable(..)) 53 | #endif 54 | #if MIN_VERSION_base(4,18,0) 55 | import Data.Foldable1 (Foldable1(..)) 56 | import Data.Bifoldable1 (Bifoldable1(..)) 57 | #endif 58 | #ifdef __GLASGOW_HASKELL__ 59 | import Data.Data 60 | #endif 61 | import Data.Ix (Ix(..)) 62 | import Data.Semigroup (Semigroup(..)) 63 | import Data.String (IsString(..)) 64 | import Foreign.Ptr (castPtr) 65 | import Foreign.Storable (Storable(..)) 66 | import GHC.Generics (Generic, Generic1) 67 | 68 | -- | A @'Tagged' s b@ value is a value @b@ with an attached phantom type @s@. 69 | -- This can be used in place of the more traditional but less safe idiom of 70 | -- passing in an undefined value with the type, because unlike an @(s -> b)@, 71 | -- a @'Tagged' s b@ can't try to use the argument @s@ as a real value. 72 | -- 73 | -- Moreover, you don't have to rely on the compiler to inline away the extra 74 | -- argument, because the newtype is \"free\" 75 | -- 76 | -- 'Tagged' has kind @k -> * -> *@ if the compiler supports @PolyKinds@, therefore 77 | -- there is an extra @k@ showing in the instance haddocks that may cause confusion. 78 | newtype Tagged s b = Tagged { unTagged :: b } 79 | deriving (Eq, Ord, Ix, Bounded, Generic, Generic1) 80 | 81 | #ifdef __GLASGOW_HASKELL__ 82 | instance (Data s, Data b) => Data (Tagged s b) where 83 | gfoldl f z (Tagged b) = z Tagged `f` b 84 | toConstr _ = taggedConstr 85 | gunfold k z c = case constrIndex c of 86 | 1 -> k (z Tagged) 87 | _ -> error "gunfold" 88 | dataTypeOf _ = taggedDataType 89 | dataCast1 f = gcast1 f 90 | dataCast2 f = gcast2 f 91 | 92 | taggedConstr :: Constr 93 | taggedConstr = mkConstr taggedDataType "Tagged" [] Prefix 94 | {-# INLINE taggedConstr #-} 95 | 96 | taggedDataType :: DataType 97 | taggedDataType = mkDataType "Data.Tagged.Tagged" [taggedConstr] 98 | {-# INLINE taggedDataType #-} 99 | #endif 100 | 101 | instance Show b => Show (Tagged s b) where 102 | showsPrec n (Tagged b) = showParen (n > 10) $ 103 | showString "Tagged " . 104 | showsPrec 11 b 105 | 106 | instance Read b => Read (Tagged s b) where 107 | readsPrec d = readParen (d > 10) $ \r -> 108 | [(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- readsPrec 11 s] 109 | 110 | instance Semigroup a => Semigroup (Tagged s a) where 111 | Tagged a <> Tagged b = Tagged (a <> b) 112 | stimes n (Tagged a) = Tagged (stimes n a) 113 | 114 | instance (Semigroup a, Monoid a) => Monoid (Tagged s a) where 115 | mempty = Tagged mempty 116 | mappend = (<>) 117 | 118 | instance Functor (Tagged s) where 119 | fmap f (Tagged x) = Tagged (f x) 120 | {-# INLINE fmap #-} 121 | 122 | -- this instance is provided by the bifunctors package for GHC<7.9 123 | instance Bifunctor Tagged where 124 | bimap _ g (Tagged b) = Tagged (g b) 125 | {-# INLINE bimap #-} 126 | 127 | #if MIN_VERSION_base(4,10,0) 128 | -- these instances are provided by the bifunctors package for GHC<8.1 129 | instance Bifoldable Tagged where 130 | bifoldMap _ g (Tagged b) = g b 131 | {-# INLINE bifoldMap #-} 132 | 133 | instance Bitraversable Tagged where 134 | bitraverse _ g (Tagged b) = Tagged <$> g b 135 | {-# INLINE bitraverse #-} 136 | #endif 137 | 138 | #if MIN_VERSION_base(4,18,0) 139 | instance Foldable1 (Tagged a) where 140 | foldMap1 f (Tagged a) = f a 141 | {-# INLINE foldMap1 #-} 142 | 143 | instance Bifoldable1 Tagged where 144 | bifoldMap1 _ g (Tagged b) = g b 145 | {-# INLINE bifoldMap1 #-} 146 | #endif 147 | 148 | #ifdef MIN_VERSION_deepseq 149 | instance NFData b => NFData (Tagged s b) where 150 | rnf (Tagged b) = rnf b 151 | #endif 152 | 153 | instance Eq1 (Tagged s) where 154 | liftEq eq (Tagged a) (Tagged b) = eq a b 155 | 156 | instance Ord1 (Tagged s) where 157 | liftCompare cmp (Tagged a) (Tagged b) = cmp a b 158 | 159 | instance Read1 (Tagged s) where 160 | liftReadsPrec rp _ d = readParen (d > 10) $ \r -> 161 | [(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- rp 11 s] 162 | 163 | instance Show1 (Tagged s) where 164 | liftShowsPrec sp _ n (Tagged b) = showParen (n > 10) $ 165 | showString "Tagged " . 166 | sp 11 b 167 | 168 | instance Eq2 Tagged where 169 | liftEq2 _ eq (Tagged a) (Tagged b) = eq a b 170 | 171 | instance Ord2 Tagged where 172 | liftCompare2 _ cmp (Tagged a) (Tagged b) = cmp a b 173 | 174 | instance Read2 Tagged where 175 | liftReadsPrec2 _ _ rp _ d = readParen (d > 10) $ \r -> 176 | [(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- rp 11 s] 177 | 178 | instance Show2 Tagged where 179 | liftShowsPrec2 _ _ sp _ n (Tagged b) = showParen (n > 10) $ 180 | showString "Tagged " . 181 | sp 11 b 182 | 183 | instance Applicative (Tagged s) where 184 | pure = Tagged 185 | {-# INLINE pure #-} 186 | Tagged f <*> Tagged x = Tagged (f x) 187 | {-# INLINE (<*>) #-} 188 | _ *> n = n 189 | {-# INLINE (*>) #-} 190 | 191 | instance Monad (Tagged s) where 192 | return = pure 193 | {-# INLINE return #-} 194 | Tagged m >>= k = k m 195 | {-# INLINE (>>=) #-} 196 | (>>) = (*>) 197 | {-# INLINE (>>) #-} 198 | 199 | instance Foldable (Tagged s) where 200 | foldMap f (Tagged x) = f x 201 | {-# INLINE foldMap #-} 202 | fold (Tagged x) = x 203 | {-# INLINE fold #-} 204 | foldr f z (Tagged x) = f x z 205 | {-# INLINE foldr #-} 206 | foldl f z (Tagged x) = f z x 207 | {-# INLINE foldl #-} 208 | foldl1 _ (Tagged x) = x 209 | {-# INLINE foldl1 #-} 210 | foldr1 _ (Tagged x) = x 211 | {-# INLINE foldr1 #-} 212 | 213 | instance Traversable (Tagged s) where 214 | traverse f (Tagged x) = Tagged <$> f x 215 | {-# INLINE traverse #-} 216 | sequenceA (Tagged x) = Tagged <$> x 217 | {-# INLINE sequenceA #-} 218 | mapM f (Tagged x) = liftM Tagged (f x) 219 | {-# INLINE mapM #-} 220 | sequence (Tagged x) = liftM Tagged x 221 | {-# INLINE sequence #-} 222 | 223 | instance Enum a => Enum (Tagged s a) where 224 | succ = fmap succ 225 | pred = fmap pred 226 | toEnum = Tagged . toEnum 227 | fromEnum (Tagged x) = fromEnum x 228 | enumFrom (Tagged x) = map Tagged (enumFrom x) 229 | enumFromThen (Tagged x) (Tagged y) = map Tagged (enumFromThen x y) 230 | enumFromTo (Tagged x) (Tagged y) = map Tagged (enumFromTo x y) 231 | enumFromThenTo (Tagged x) (Tagged y) (Tagged z) = 232 | map Tagged (enumFromThenTo x y z) 233 | 234 | instance Num a => Num (Tagged s a) where 235 | (+) = liftA2 (+) 236 | (-) = liftA2 (-) 237 | (*) = liftA2 (*) 238 | negate = fmap negate 239 | abs = fmap abs 240 | signum = fmap signum 241 | fromInteger = Tagged . fromInteger 242 | 243 | instance Real a => Real (Tagged s a) where 244 | toRational (Tagged x) = toRational x 245 | 246 | instance Integral a => Integral (Tagged s a) where 247 | quot = liftA2 quot 248 | rem = liftA2 rem 249 | div = liftA2 div 250 | mod = liftA2 mod 251 | quotRem (Tagged x) (Tagged y) = (Tagged a, Tagged b) where 252 | (a, b) = quotRem x y 253 | divMod (Tagged x) (Tagged y) = (Tagged a, Tagged b) where 254 | (a, b) = divMod x y 255 | toInteger (Tagged x) = toInteger x 256 | 257 | instance Fractional a => Fractional (Tagged s a) where 258 | (/) = liftA2 (/) 259 | recip = fmap recip 260 | fromRational = Tagged . fromRational 261 | 262 | instance Floating a => Floating (Tagged s a) where 263 | pi = Tagged pi 264 | exp = fmap exp 265 | log = fmap log 266 | sqrt = fmap sqrt 267 | sin = fmap sin 268 | cos = fmap cos 269 | tan = fmap tan 270 | asin = fmap asin 271 | acos = fmap acos 272 | atan = fmap atan 273 | sinh = fmap sinh 274 | cosh = fmap cosh 275 | tanh = fmap tanh 276 | asinh = fmap asinh 277 | acosh = fmap acosh 278 | atanh = fmap atanh 279 | (**) = liftA2 (**) 280 | logBase = liftA2 logBase 281 | 282 | instance RealFrac a => RealFrac (Tagged s a) where 283 | properFraction (Tagged x) = (a, Tagged b) where 284 | (a, b) = properFraction x 285 | truncate (Tagged x) = truncate x 286 | round (Tagged x) = round x 287 | ceiling (Tagged x) = ceiling x 288 | floor (Tagged x) = floor x 289 | 290 | instance RealFloat a => RealFloat (Tagged s a) where 291 | floatRadix (Tagged x) = floatRadix x 292 | floatDigits (Tagged x) = floatDigits x 293 | floatRange (Tagged x) = floatRange x 294 | decodeFloat (Tagged x) = decodeFloat x 295 | encodeFloat m n = Tagged (encodeFloat m n) 296 | exponent (Tagged x) = exponent x 297 | significand = fmap significand 298 | scaleFloat n = fmap (scaleFloat n) 299 | isNaN (Tagged x) = isNaN x 300 | isInfinite (Tagged x) = isInfinite x 301 | isDenormalized (Tagged x) = isDenormalized x 302 | isNegativeZero (Tagged x) = isNegativeZero x 303 | isIEEE (Tagged x) = isIEEE x 304 | atan2 = liftA2 atan2 305 | 306 | instance Bits a => Bits (Tagged s a) where 307 | Tagged a .&. Tagged b = Tagged (a .&. b) 308 | Tagged a .|. Tagged b = Tagged (a .|. b) 309 | xor (Tagged a) (Tagged b) = Tagged (xor a b) 310 | complement (Tagged a) = Tagged (complement a) 311 | shift (Tagged a) i = Tagged (shift a i) 312 | shiftL (Tagged a) i = Tagged (shiftL a i) 313 | shiftR (Tagged a) i = Tagged (shiftR a i) 314 | rotate (Tagged a) i = Tagged (rotate a i) 315 | rotateL (Tagged a) i = Tagged (rotateL a i) 316 | rotateR (Tagged a) i = Tagged (rotateR a i) 317 | bit i = Tagged (bit i) 318 | setBit (Tagged a) i = Tagged (setBit a i) 319 | clearBit (Tagged a) i = Tagged (clearBit a i) 320 | complementBit (Tagged a) i = Tagged (complementBit a i) 321 | testBit (Tagged a) i = testBit a i 322 | isSigned (Tagged a) = isSigned a 323 | bitSize (Tagged a) = bitSize a -- deprecated, but still required :( 324 | unsafeShiftL (Tagged a) i = Tagged (unsafeShiftL a i) 325 | unsafeShiftR (Tagged a) i = Tagged (unsafeShiftR a i) 326 | popCount (Tagged a) = popCount a 327 | bitSizeMaybe (Tagged a) = bitSizeMaybe a 328 | zeroBits = Tagged zeroBits 329 | 330 | instance FiniteBits a => FiniteBits (Tagged s a) where 331 | finiteBitSize (Tagged a) = finiteBitSize a 332 | countLeadingZeros (Tagged a) = countLeadingZeros a 333 | countTrailingZeros (Tagged a) = countTrailingZeros a 334 | 335 | instance IsString a => IsString (Tagged s a) where 336 | fromString = Tagged . fromString 337 | 338 | instance Storable a => Storable (Tagged s a) where 339 | sizeOf t = sizeOf a 340 | where 341 | Tagged a = Tagged undefined `asTypeOf` t 342 | alignment t = alignment a 343 | where 344 | Tagged a = Tagged undefined `asTypeOf` t 345 | peek ptr = Tagged <$> peek (castPtr ptr) 346 | poke ptr (Tagged a) = poke (castPtr ptr) a 347 | peekElemOff ptr i = Tagged <$> peekElemOff (castPtr ptr) i 348 | pokeElemOff ptr i (Tagged a) = pokeElemOff (castPtr ptr) i a 349 | peekByteOff ptr i = Tagged <$> peekByteOff (castPtr ptr) i 350 | pokeByteOff ptr i (Tagged a) = pokeByteOff (castPtr ptr) i a 351 | 352 | -- | Some times you need to change the tag you have lying around. 353 | -- Idiomatic usage is to make a new combinator for the relationship between the 354 | -- tags that you want to enforce, and define that combinator using 'retag'. 355 | -- 356 | -- @ 357 | -- data Succ n 358 | -- retagSucc :: 'Tagged' n a -> 'Tagged' (Succ n) a 359 | -- retagSucc = 'retag' 360 | -- @ 361 | retag :: Tagged s b -> Tagged t b 362 | retag = Tagged . unTagged 363 | {-# INLINE retag #-} 364 | 365 | -- | Alias for 'unTagged' 366 | untag :: Tagged s b -> b 367 | untag = unTagged 368 | 369 | -- | Tag a value with its own type. 370 | tagSelf :: a -> Tagged a a 371 | tagSelf = Tagged 372 | {-# INLINE tagSelf #-} 373 | 374 | -- | 'asTaggedTypeOf' is a type-restricted version of 'const'. It is usually used as an infix operator, and its typing forces its first argument (which is usually overloaded) to have the same type as the tag of the second. 375 | asTaggedTypeOf :: s -> tagged s b -> s 376 | asTaggedTypeOf = const 377 | {-# INLINE asTaggedTypeOf #-} 378 | 379 | witness :: Tagged a b -> a -> b 380 | witness (Tagged b) _ = b 381 | {-# INLINE witness #-} 382 | 383 | -- | 'untagSelf' is a type-restricted version of 'untag'. 384 | untagSelf :: Tagged a a -> a 385 | untagSelf (Tagged x) = x 386 | {-# INLINE untagSelf #-} 387 | 388 | -- | Convert from a 'Tagged' representation to a representation 389 | -- based on a 'Proxy'. 390 | proxy :: Tagged s a -> proxy s -> a 391 | proxy (Tagged x) _ = x 392 | {-# INLINE proxy #-} 393 | 394 | -- | Convert from a representation based on a 'Proxy' to a 'Tagged' 395 | -- representation. 396 | unproxy :: (Proxy s -> a) -> Tagged s a 397 | unproxy f = Tagged (f Proxy) 398 | {-# INLINE unproxy #-} 399 | 400 | -- | Another way to convert a proxy to a tag. 401 | tagWith :: proxy s -> a -> Tagged s a 402 | tagWith _ = Tagged 403 | {-# INLINE tagWith #-} 404 | 405 | -- | Some times you need to change the proxy you have lying around. 406 | -- Idiomatic usage is to make a new combinator for the relationship 407 | -- between the proxies that you want to enforce, and define that 408 | -- combinator using 'reproxy'. 409 | -- 410 | -- @ 411 | -- data Succ n 412 | -- reproxySucc :: proxy n -> 'Proxy' (Succ n) 413 | -- reproxySucc = 'reproxy' 414 | -- @ 415 | reproxy :: proxy a -> Proxy b 416 | reproxy _ = Proxy 417 | -------------------------------------------------------------------------------- /stack-7.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-2.21 2 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2016-07-19 2 | -------------------------------------------------------------------------------- /tagged.cabal: -------------------------------------------------------------------------------- 1 | name: tagged 2 | version: 0.8.9 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Edward A. Kmett 6 | maintainer: Edward A. Kmett 7 | stability: experimental 8 | category: Data, Phantom Types 9 | synopsis: Haskell 98 phantom types to avoid unsafely passing dummy arguments 10 | homepage: http://github.com/ekmett/tagged 11 | bug-reports: http://github.com/ekmett/tagged/issues 12 | copyright: 2009-2015 Edward A. Kmett 13 | description: Haskell 98 phantom types to avoid unsafely passing dummy arguments. 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | extra-source-files: .hlint.yaml CHANGELOG.markdown README.markdown 17 | tested-with: 18 | GHC == 8.0.2 19 | GHC == 8.2.2 20 | GHC == 8.4.4 21 | GHC == 8.6.5 22 | GHC == 8.8.4 23 | GHC == 8.10.7 24 | GHC == 9.0.2 25 | GHC == 9.2.8 26 | GHC == 9.4.8 27 | GHC == 9.6.6 28 | GHC == 9.8.4 29 | GHC == 9.10.1 30 | GHC == 9.12.1 31 | 32 | source-repository head 33 | type: git 34 | location: https://github.com/ekmett/tagged.git 35 | 36 | flag deepseq 37 | description: 38 | You can disable the use of the `deepseq` package using `-f-deepseq`. 39 | . 40 | Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. 41 | default: True 42 | manual: True 43 | 44 | library 45 | default-language: Haskell98 46 | other-extensions: CPP 47 | build-depends: 48 | base >= 4.9 && < 5, 49 | template-haskell >= 2.11 && < 2.24 50 | ghc-options: -Wall 51 | hs-source-dirs: src 52 | exposed-modules: 53 | Data.Proxy.TH 54 | Data.Tagged 55 | 56 | if impl(ghc >= 9.0) 57 | -- these flags may abort compilation with GHC-8.10 58 | -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 59 | ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode 60 | 61 | if flag(deepseq) 62 | build-depends: deepseq >= 1.1 && < 1.6 63 | --------------------------------------------------------------------------------