├── .travis.yml ├── .travis ├── attach-binary.sh ├── install-ghr.sh └── install-stack.sh ├── ChangeLog.md ├── Data └── Functor │ └── Identity │ └── Plugin.hs ├── LICENSE ├── README.md ├── Setup.hs ├── same-same.cabal ├── stack.yaml └── test └── Main.hs /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs '-o' '.travis.yml' 'same-same.cabal' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-head" 32 | env: GHCHEAD=true 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} 34 | 35 | before_install: 36 | - HC=${CC} 37 | - HCPKG=${HC/ghc/ghc-pkg} 38 | - unset CC 39 | - ROOTDIR=$(pwd) 40 | - mkdir -p $HOME/.local/bin 41 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 42 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 43 | - echo $HCNUMVER 44 | 45 | install: 46 | - cabal --version 47 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 48 | - BENCH=${BENCH---enable-benchmarks} 49 | - TEST=${TEST---enable-tests} 50 | - HADDOCK=${HADDOCK-true} 51 | - INSTALLED=${INSTALLED-true} 52 | - GHCHEAD=${GHCHEAD-false} 53 | - travis_retry cabal update -v 54 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 55 | - rm -fv cabal.project cabal.project.local 56 | # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage 57 | - | 58 | if $GHCHEAD; then 59 | sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config 60 | 61 | echo 'repository head.hackage' >> ${HOME}/.cabal/config 62 | echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config 63 | echo ' secure: True' >> ${HOME}/.cabal/config 64 | echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config 65 | echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config 66 | echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config 67 | echo ' key-threshold: 3' >> ${HOME}/.cabal.config 68 | 69 | cabal new-update head.hackage -v 70 | fi 71 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 72 | - "printf 'packages: \".\"\\n' > cabal.project" 73 | - cat cabal.project 74 | - if [ -f "./configure.ac" ]; then 75 | (cd "." && autoreconf -i); 76 | fi 77 | - rm -f cabal.project.freeze 78 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 79 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 80 | - rm -rf "."/.ghc.environment.* "."/dist 81 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 82 | 83 | # Here starts the actual work to be performed for the package under test; 84 | # any command which exits with a non-zero exit code causes the build to fail. 85 | script: 86 | # test that source-distributions can be generated 87 | - (cd "." && cabal sdist) 88 | - mv "."/dist/same-same-*.tar.gz ${DISTDIR}/ 89 | - cd ${DISTDIR} || false 90 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 91 | - "printf 'packages: same-same-*/*.cabal\\n' > cabal.project" 92 | - cat cabal.project 93 | # this builds all libraries and executables (without tests/benchmarks) 94 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 95 | 96 | # Build with installed constraints for packages in global-db 97 | - 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 98 | 99 | # build & run tests, build benchmarks 100 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 101 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi 102 | 103 | # cabal check 104 | - (cd same-same-* && cabal check) 105 | 106 | # haddock 107 | - rm -rf ./dist-newstyle 108 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 109 | 110 | # REGENDATA ["-o",".travis.yml","same-same.cabal"] 111 | # EOF 112 | 113 | -------------------------------------------------------------------------------- /.travis/attach-binary.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -o errexit -o verbose 3 | 4 | if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG" 5 | then 6 | echo 'This is not a release build.' 7 | elif test ! "$GITHUB_TOKEN" 8 | then 9 | echo 'The GITHUB_TOKEN environment variable is not set!' 10 | exit 1 11 | else 12 | echo "Building binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..." 13 | stack build --ghc-options -O2 --pedantic 14 | echo "Attaching binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..." 15 | OWNER="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)" 16 | REPO="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)" 17 | BIN="$(stack path --local-install-root)/bin/$REPO" 18 | BUNDLE_NAME="$REPO-$TRAVIS_TAG-$TRAVIS_OS_NAME.tar.gz" 19 | cp "$BIN" "./$REPO" 20 | chmod +x "./$REPO" 21 | tar -czf "$BUNDLE_NAME" "$REPO" 22 | echo "SHA256:" 23 | shasum -a 256 "$BUNDLE_NAME" 24 | ghr -t "$GITHUB_TOKEN" -u "$OWNER" -r "$REPO" --replace "$(git describe --tags)" "$BUNDLE_NAME" 25 | fi 26 | -------------------------------------------------------------------------------- /.travis/install-ghr.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -o errexit -o verbose 3 | 4 | if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG" 5 | then 6 | echo 'This is not a release build.' 7 | else 8 | if [ "$TRAVIS_OS_NAME" = "linux" ] 9 | then 10 | ARCH="linux" 11 | else 12 | ARCH="darwin" 13 | fi 14 | echo "Installing ghr" 15 | URL="https://github.com/tcnksm/ghr/releases/download/v0.5.4/ghr_v0.5.4_${ARCH}_386.zip" 16 | curl -L ${URL} > ghr.zip 17 | mkdir -p "$HOME/bin" 18 | export PATH="$HOME/bin:$PATH" 19 | unzip ghr.zip -d "$HOME/bin" 20 | rm ghr.zip 21 | fi 22 | -------------------------------------------------------------------------------- /.travis/install-stack.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Adapted from https://github.com/commercialhaskell/stack 4 | 5 | set -eux 6 | 7 | travis_retry() { 8 | cmd=$* 9 | $cmd || (sleep 2 && $cmd) || (sleep 10 && $cmd) 10 | } 11 | 12 | fetch_stack_osx() { 13 | curl -skL https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin; 14 | } 15 | 16 | fetch_stack_linux() { 17 | curl -sL https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'; 18 | } 19 | 20 | # We need stack to generate cabal files with precise bounds, even for cabal 21 | # builds. 22 | mkdir -p ~/.local/bin; 23 | if [ "$(uname)" = "Darwin" ]; then 24 | travis_retry fetch_stack_osx 25 | else 26 | travis_retry fetch_stack_linux 27 | fi 28 | 29 | travis_retry stack --no-terminal setup; 30 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for same-same 2 | 3 | ## 0.1 -- 2018-06-11 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /Data/Functor/Identity/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | module Data.Functor.Identity.Plugin (plugin) where 5 | 6 | import Coercion (mkUnsafeCo) 7 | import Control.Monad (guard, join) 8 | import CoreSyn (Expr (..)) 9 | import Data.Bifunctor (second) 10 | import Data.Foldable (toList) 11 | import Data.Maybe (listToMaybe, catMaybes) 12 | import Data.Traversable (for) 13 | import Module (mkModuleName) 14 | import OccName (mkTcOcc) 15 | import Plugins (Plugin (..), defaultPlugin) 16 | import TcEvidence (EvTerm (..)) 17 | import TcPluginM 18 | import TcRnTypes 19 | import TcType (tcSplitTyConApp, tcSplitTyConApp_maybe, eqType) 20 | import TyCoRep (Type (..)) 21 | import TyCon (TyCon, Role(..)) 22 | import Type (mkPrimEqPred) 23 | 24 | 25 | ------------------------------------------------------------------------------ 26 | -- | The same-same plugin, which generates nominal coercion proofs that `a 27 | -- ~ Identity a`. 28 | plugin :: Plugin 29 | plugin = defaultPlugin 30 | { tcPlugin = const $ Just sameSamePlugin 31 | } 32 | 33 | 34 | sameSamePlugin :: TcPlugin 35 | sameSamePlugin = TcPlugin 36 | { tcPluginInit = lookupIdentityTyCon 37 | , tcPluginSolve = solve 38 | , tcPluginStop = pure $ pure () 39 | } 40 | 41 | 42 | ------------------------------------------------------------------------------ 43 | -- | Finds the 'Data.Functor.Identity' 'TyCon'. 44 | lookupIdentityTyCon :: TcPluginM TyCon 45 | lookupIdentityTyCon = do 46 | Found _ md <- findImportedModule emergeModule Nothing 47 | emergeTcNm <- lookupOrig md $ mkTcOcc "Identity" 48 | tcLookupTyCon emergeTcNm 49 | where 50 | emergeModule = mkModuleName "Data.Functor.Identity" 51 | 52 | 53 | ------------------------------------------------------------------------------ 54 | -- | Given an insoluble constraint of the form @a ~ Identity b@, attempt to 55 | -- build an 'EvTerm' providing a nominal coercion from one to the other. 56 | -- Additionally, return the de-identified type variables from either side 57 | -- allowing us to unify them. 58 | getInsolEv :: TyCon -> Ct -> Maybe (EvTerm, Type, Type) 59 | getInsolEv idTyCon (CIrredCan ev True) = do 60 | let t = ctev_pred ev 61 | (_, ts) = tcSplitTyConApp t 62 | [t1, t2] = drop 2 ts 63 | x1 = lowerIdTower idTyCon t1 64 | x2 = lowerIdTower idTyCon t2 65 | guard $ couldPossiblyUnify x1 x2 66 | pure (EvExpr . Coercion $ mkUnsafeCo Nominal t1 t2, x1, x2) 67 | getInsolEv _ _ = Nothing 68 | 69 | 70 | ------------------------------------------------------------------------------ 71 | -- | Given types 'a' and 'b', emit a @a ~ b@ wanted constraint, in effect 72 | -- asking the unifier to unify these types for us. 73 | unify :: CtLoc -> Type -> Type -> TcPluginM (Maybe Ct) 74 | unify ctloc t1 t2 = do 75 | w <- newWanted ctloc $ mkPrimEqPred t1 t2 76 | pure . listToMaybe . toList $ wc_simple $ mkSimpleWC [w] 77 | 78 | 79 | ------------------------------------------------------------------------------ 80 | -- | Helper function to swizzle together 'getInsolEv' and 'unify'. 81 | buildPluginResults :: TyCon -> Ct -> TcPluginM (Maybe ((EvTerm, Ct), [Ct])) 82 | buildPluginResults idTyCon ct = do 83 | let ctloc = ctev_loc $ cc_ev ct 84 | for (getInsolEv idTyCon ct) $ \(ev, t1, t2) -> do 85 | cts <- toList <$> unify ctloc t1 t2 86 | pure ((ev, ct), cts) 87 | 88 | 89 | ------------------------------------------------------------------------------ 90 | -- | Given a tower of @Identity (Identity (Identity (... a)))@, give back 'a'. 91 | lowerIdTower :: TyCon -> Type -> Type 92 | lowerIdTower idTyCon t = 93 | case tcSplitTyConApp_maybe t of 94 | Just (tyCon, apps) -> 95 | if idTyCon == tyCon 96 | then lowerIdTower idTyCon $ head apps 97 | else t 98 | Nothing -> t 99 | 100 | 101 | ------------------------------------------------------------------------------ 102 | -- | Returns 'True' if at least one of the types is a type variable, or if both 103 | -- types are equal. 104 | couldPossiblyUnify :: Type -> Type -> Bool 105 | couldPossiblyUnify (TyVarTy _) _ = True 106 | couldPossiblyUnify _ (TyVarTy _) = True 107 | couldPossiblyUnify a b = eqType a b 108 | 109 | 110 | solve 111 | :: TyCon 112 | -> [Ct] -- ^ [G]iven constraints 113 | -> [Ct] -- ^ [D]erived constraints 114 | -> [Ct] -- ^ [W]anted constraints 115 | -> TcPluginM TcPluginResult 116 | solve idTyCon _ ds ws = do 117 | z <- fmap (second join . unzip . catMaybes) 118 | . for (ds ++ ws) 119 | $ buildPluginResults idTyCon 120 | pure $ uncurry TcPluginOk z 121 | 122 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Sandy Maguire 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # same-same: ignore the differences between a and Identity a. 2 | 3 | [![Build Status](https://api.travis-ci.org/isovector/same-same.svg?branch=master)](https://travis-ci.org/isovector/same-same) | [Hackage][hackage] 4 | 5 | [hackage]: https://hackage.haskell.org/package/same-same 6 | 7 | 8 | ## Dedication 9 | 10 | > The ego is only an illusion, but a very influential one. Letting the 11 | > ego-illusion become your identity can prevent you from knowing your true self. 12 | > Ego, the false idea of believing that you are what you have or what you do, is 13 | > a backwards way of assessing and living life. 14 | > 15 | > Wayne Dyer 16 | 17 | 18 | ## Synopsis 19 | 20 | I think [higher-kinded data][hkd] is a pretty cool guy. eh reuses datatypes and 21 | doesn't afraid of anything. But working with HKD isn't everything it's cracked 22 | up to be -- it makes deriving instances hard, requires janky type families, and 23 | in general doesn't fill you with any sense of joy. 24 | 25 | [hkd]: http://reasonablypolymorphic.com/blog/higher-kinded-data/ 26 | 27 | Enter `same-same`: a compiler plugin that provides proofs of `a ~ Identity a` 28 | and makes working with HKD a little less shit. Armed with this proof, we're able 29 | to get rid of the HKD type family, and thus regain our derived instances. 30 | 31 | 32 | ## Unsoundness 33 | 34 | This plugin is a teensy little bit **completely unsound** and when used for 35 | evil, is capable of producing `forall a b. a ~ b` proofs. Fortunately, you need 36 | to be actively trying to accomplish such a feat, and so you're probably going to 37 | be a-ok. 38 | 39 | Modules that haven't loaded the plugin are not affected by this "feature." 40 | 41 | 42 | ## Example 43 | 44 | ```haskell 45 | {-# OPTIONS_GHC -fplugin=Data.Functor.Identity.Plugin #-} 46 | 47 | module Test where 48 | 49 | import Data.Functor.Identity 50 | 51 | data X f = X 52 | { foo :: f Int 53 | } 54 | 55 | getFoo :: X Identity -> Int 56 | getFoo = foo 57 | ``` 58 | 59 | 60 | ## Contact 61 | 62 | Please reports bugs and missing features at the [GitHub bugtracker][issues]. This is 63 | also where you can find the [source code][source]. 64 | 65 | `same-same` was written by [Sandy Maguire][me] and is licensed under a 66 | permissive MIT [license][lic]. 67 | 68 | [me]: http://reasonablypolymorphic.me 69 | [lic]: https://github.com/isovector/same-same/blob/LICENSE 70 | [issues]: https://github.com/isovector/same-same/issues 71 | [source]: https://github.com/isovector/same-same 72 | 73 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /same-same.cabal: -------------------------------------------------------------------------------- 1 | name: same-same 2 | version: 0.1.2 3 | synopsis: Ignore the differences between a and Identity a. 4 | description: 5 | This plugin provides nominal(!) proofs that @a ~ Identity a@, allowing 6 | for a more idiomatic approach to higher kinded data. 7 | 8 | homepage: https://github.com/isovector/same-same 9 | license: MIT 10 | license-file: LICENSE 11 | author: Sandy Maguire 12 | maintainer: sandy@sandymaguire.me 13 | copyright: 2018 Sandy Maguire 14 | category: Constraints 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md, README.md 17 | cabal-version: >=1.10 18 | tested-with: GHC ==8.0.1, GHC ==8.0.2, GHC ==8.2.2 19 | 20 | library 21 | exposed-modules: Data.Functor.Identity.Plugin 22 | build-depends: base >=4.9 && <5 23 | build-depends: ghc >=8.0.1 24 | default-language: Haskell2010 25 | 26 | Test-Suite tests 27 | type: exitcode-stdio-1.0 28 | default-language: Haskell2010 29 | hs-Source-Dirs: test 30 | main-is: Main.hs 31 | build-depends: base >=4.9 && <5, same-same 32 | 33 | source-repository head 34 | type: git 35 | location: git://github.com/isovector/same-same.git 36 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: [] 7 | 8 | flags: {} 9 | 10 | extra-package-dbs: [] 11 | 12 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.Functor.Identity.Plugin #-} 2 | 3 | module Main where 4 | 5 | import Data.Functor.Identity 6 | 7 | 8 | data X f = X 9 | { foo :: f String 10 | } 11 | 12 | 13 | myX :: X Identity 14 | myX = X "world" 15 | 16 | 17 | hello :: Show a => Identity a -> IO () 18 | hello = print 19 | 20 | 21 | main :: IO () 22 | main = do 23 | hello "hello" 24 | putStrLn $ foo myX 25 | 26 | --------------------------------------------------------------------------------