├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── ifcxt.cabal ├── src ├── IfCxt.hs └── IfCxt │ └── Examples.hs ├── stack.yaml └── test └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | .stack-work/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # explicitly request container-based infrastructure 4 | sudo: false 5 | 6 | matrix: 7 | include: 8 | - env: CABALVER=1.22 GHCVER=7.10.3 9 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3],sources: [hvr-ghc]}} 10 | - env: CABALVER=1.24 GHCVER=8.0.2 11 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2],sources: [hvr-ghc]}} 12 | - env: CABALVER=2.0 GHCVER=8.2.2 13 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2],sources: [hvr-ghc]}} 14 | - env: CABALVER=head GHCVER=head 15 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 16 | 17 | allow_failures: 18 | - env: CABALVER=head GHCVER=head 19 | - env: CABALVER=2.0 GHCVER=8.2.2 20 | 21 | before_install: 22 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 23 | 24 | install: 25 | - travis_retry cabal update 26 | - cabal install --only-dependencies --enable-tests --force-reinstalls 27 | 28 | script: 29 | - cabal configure --enable-tests 30 | #--enable-library-coverage || cabal configure --enable-tests --enable-coverage 31 | - cabal build 32 | - cabal test 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Mike Izbicki 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 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 Mike Izbicki 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.md: -------------------------------------------------------------------------------- 1 | # IfCxt 2 | 3 | This package introduces the function: 4 | ``` 5 | ifCxt :: IfCxt cxt => proxy cxt -> (cxt => a) -> a -> a 6 | ``` 7 | This function acts like an `if` statement where the `proxy cxt` parameter is the condition. 8 | If the type checker can satisfy the `cxt` constraint, then the second argument `cxt => a` is returned; 9 | otherwise, the third argument `a` is returned. 10 | 11 | Before seeing more details about how `ifCxt` is implemented, 12 | let's look at three examples of how to use it. 13 | 14 | ### Example 1: show every type 15 | 16 | The `cxtShow` function below is polymorphic over the type `a`. 17 | If `a` is an instance of `Show`, then `cxtShow a` evaluates to `show a`; 18 | but if `a` is not an instance of `Show`, `cxtShow a` evaluates to `<>`. 19 | 20 | ``` 21 | cxtShow :: forall a. IfCxt (Show a) => a -> String 22 | cxtShow a = ifCxt (Proxy::Proxy (Show a)) 23 | (show a) 24 | "<>" 25 | ``` 26 | In ghci: 27 | 28 | ``` 29 | ghci> cxtShow (1 :: Int) 30 | "1" 31 | ``` 32 | ``` 33 | ghci> cxtShow (id :: a -> a) 34 | "<>" 35 | ``` 36 | 37 | ### Example 2: make your code asymptotically efficient 38 | 39 | The `nub` function removes duplicate elements from lists. 40 | It can be defined as: 41 | 42 | ``` 43 | nub :: Eq a => [a] -> [a] 44 | nub [] = [] 45 | nub (x:xs) = x : nub (filter (x/=) xs) 46 | ``` 47 | This function takes time O(n^2). 48 | But if we also have an `Ord` constraint, we can define a much more efficient version that takes time O(n log n): 49 | 50 | ``` 51 | nubOrd :: Ord a => [a] -> [a] 52 | nubOrd = go . sort 53 | where 54 | go (x1:x2:xs) 55 | | x1==x2 = go (x2:xs) 56 | | otherwise = x1 : go (x2:xs) 57 | go [x] = [x] 58 | go [] = [] 59 | ``` 60 | Now, we can use the `ifCxt` function to define a version of `nub` that will automatically select the most efficient implementation for whatever type we happen to run it on: 61 | 62 | ``` 63 | cxtNub :: forall a. (Eq a, IfCxt (Ord a)) => [a] -> [a] 64 | cxtNub = ifCxt (Proxy::Proxy (Ord a)) nubOrd nub 65 | ``` 66 | 67 | ### Example 3: make your code numerically stable 68 | 69 | The simplest way to sum a list of numbers is: 70 | ``` 71 | sumSimple :: Num a => [a] -> a 72 | sumSimple = foldl' (+) 0 73 | ``` 74 | This method has numerical stability issues on floating point representations. 75 | [Kahan summation](https://en.wikipedia.org/wiki/Kahan_summation_algorithm) is a more accurate technique shown below: 76 | ``` 77 | sumKahan :: Num a => [a] -> a 78 | sumKahan = snd . foldl' go (0,0) 79 | where 80 | go (c,t) i = ((t'-t)-y,t') 81 | where 82 | y = i-c 83 | t' = t+y 84 | ``` 85 | Because Kahan summation does a lot more work than simple summation, we would prefer not to run it on non-floating point types. 86 | The `sumCxt` function below accomplishes this: 87 | ``` 88 | cxtSum :: forall a. (Num a, IfCxt (Floating a)) => [a] -> a 89 | cxtSum = ifCxt (Proxy::Proxy (Floating a)) sumKahan sumSimple 90 | ``` 91 | Notice that the `ifCxt` function is conditioning on the `Floating a` constraint, 92 | which isn't actually *used* by the `sumKahan` function. 93 | 94 | ## How it works 95 | 96 | The magic of the technique is in the `IfCxt` class: 97 | ``` 98 | class IfCxt (cxt :: Constraint) where 99 | ifCxt :: proxy cxt -> (cxt => a) -> a -> a 100 | ``` 101 | (Notice that making a constraint an instance of a class requires the`ConstraintKinds` extension, 102 | and the higher order `(cxt => a)` parameter requires the `RankNTypes` extension.) 103 | 104 | There is a "global" instance defined as: 105 | ``` 106 | instance {-# OVERLAPPABLE #-} IfCxt cxt where ifCxt _ t f = f 107 | ``` 108 | What this says is that if no more specific instance is available, then the "global" `ifCxt` function will be used, which always returns the `f` (false) parameter. 109 | 110 | Then for every instance of every other class, we need to define an overlapping `IfCxt` instance that always returns the `t` (true) parameter. 111 | For example, for `Show Int`, we define: 112 | ``` 113 | instance {-# OVERLAPS #-} IfCxt (Show Int) where ifCxt _ t f = t 114 | ``` 115 | 116 | This is a lot of boilerplate, so the template haskell function `mkIfCxtInstances` can be used to define these instances automatically. 117 | Unfortunately, due to a [bug in template haskell](https://ghc.haskell.org/trac/ghc/ticket/9699) we cannot enumerate all the classes currently in scope. 118 | So you must manually call `mkIfCxtInstances` on each class you want `ifCxt` to work with. 119 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ifcxt.cabal: -------------------------------------------------------------------------------- 1 | -- Initial ifcxt.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: ifcxt 5 | version: 0.1.1 6 | synopsis: put if statements within type constraints 7 | description: 8 | 9 | This package introduces the @ifCxt@ function, 10 | which lets your write if statements that depend on a polymorphic variable's class instances. 11 | For example, we can make a version of 'show' that can be called on any type: 12 | 13 | . 14 | 15 | > cxtShow :: forall a. IfCxt (Show a) => a -> String 16 | > cxtShow a = ifCxt (Proxy::Proxy (Show a)) 17 | > (show a) 18 | > "<>" 19 | 20 | Running this function in ghci, we get: 21 | 22 | . 23 | 24 | >>> cxtShow (1 :: Int) 25 | "1" 26 | 27 | . 28 | 29 | >>> cxtShow (id :: a -> a) 30 | "<>" 31 | 32 | . 33 | 34 | See the project webpage http://github.com/mikeizbicki/ifcxt for more details. 35 | 36 | homepage: http://github.com/mikeizbicki/ifcxt 37 | license: BSD3 38 | license-file: LICENSE 39 | author: Mike Izbicki 40 | maintainer: mike@izbicki.me 41 | -- copyright: 42 | category: Control 43 | build-type: Simple 44 | -- extra-source-files: 45 | cabal-version: >=1.10 46 | 47 | source-repository head 48 | type: git 49 | location: http://github.com/mikeizbicki/ifcxt 50 | 51 | library 52 | exposed-modules: IfCxt, IfCxt.Examples 53 | -- other-modules: 54 | default-extensions: 55 | ConstraintKinds, 56 | CPP, 57 | Rank2Types, 58 | FlexibleInstances, 59 | FlexibleContexts, 60 | TemplateHaskell 61 | build-depends: base >=4.8, template-haskell >=2.10 62 | hs-source-dirs: src 63 | default-language: Haskell2010 64 | 65 | test-suite test 66 | default-language: Haskell2010 67 | type: exitcode-stdio-1.0 68 | hs-source-dirs: test 69 | main-is: Main.hs 70 | build-depends: base >= 4.8 71 | , ifcxt 72 | , QuickCheck 73 | , tasty >= 0.7 74 | , tasty-quickcheck 75 | -------------------------------------------------------------------------------- /src/IfCxt.hs: -------------------------------------------------------------------------------- 1 | module IfCxt 2 | ( IfCxt (..) 3 | , mkIfCxtInstances 4 | ) 5 | where 6 | 7 | import Control.Monad 8 | import Data.Proxy 9 | import Language.Haskell.TH.Syntax 10 | 11 | -- | This class lets a polymorphic function behave differently depending on the constraints of the polymorphic variable. 12 | -- For example, we can use it to write the following improved version of the "show" function: 13 | -- 14 | -- > ifShow :: forall a. IfCxt (Show a) => a -> String 15 | -- > ifShow = ifCxt (Proxy::Proxy (Show a)) 16 | -- > show 17 | -- > (const "<>") 18 | -- 19 | -- In ghci, we can run: 20 | -- 21 | -- >>> ifShow (1 :: Int) 22 | -- "1" 23 | -- >>> ifShow (id :: a -> a) 24 | -- "<>" 25 | -- 26 | -- The "IfCxt.Examples" module contains more examples. 27 | class IfCxt cxt where 28 | ifCxt :: proxy cxt -> (cxt => a) -> a -> a 29 | 30 | instance {-# OVERLAPPABLE #-} IfCxt cxt where ifCxt _ t f = f 31 | 32 | -- | Derives all possible instances of "IfCxt" for the given one parameter type class. 33 | mkIfCxtInstances :: Name -> Q [Dec] 34 | mkIfCxtInstances n = do 35 | info <- reify ''IfCxt 36 | let instancesOfIfCxt = case info of 37 | #if MIN_VERSION_template_haskell(2,11,0) 38 | ClassI _ xs -> map (\(InstanceD _ _ (AppT _ t) _) -> t) xs 39 | #else 40 | ClassI _ xs -> map (\(InstanceD _ (AppT _ t) _) -> t) xs 41 | #endif 42 | 43 | isInstanceOfIfCxt t = t `elem` instancesOfIfCxt 44 | 45 | info <- reify n 46 | case info of 47 | #if MIN_VERSION_template_haskell(2,11,0) 48 | ClassI _ xs -> fmap concat $ forM xs $ \(InstanceD _ cxt (AppT classt t) ys) -> return $ 49 | #else 50 | ClassI _ xs -> fmap concat $ forM xs $ \(InstanceD cxt (AppT classt t) ys) -> return $ 51 | #endif 52 | if isInstanceOfIfCxt (AppT classt t) 53 | then [] 54 | else mkInstance cxt classt t n 55 | otherwise -> fail $ show n ++ " is not a class name." 56 | 57 | mkInstance :: Cxt -> Type -> Type -> Name -> [Dec] 58 | mkInstance cxt classt t n = [ 59 | InstanceD 60 | #if MIN_VERSION_template_haskell(2,11,0) 61 | Nothing 62 | #endif 63 | (map relaxCxt cxt) 64 | (relaxCxt (AppT (ConT n) t)) 65 | [ FunD 'ifCxt 66 | [ Clause 67 | [ VarP $ mkName "proxy" 68 | , VarP $ mkName "t" 69 | , VarP $ mkName "f" 70 | ] 71 | (NormalB (mkIfCxtFun cxt)) 72 | [] 73 | ] 74 | ] 75 | ] 76 | 77 | -- | "Relax" constraints by wrapping in "IfCxt". 78 | relaxCxt :: Type -> Type 79 | relaxCxt t@(AppT (ConT c) _) | c == ''IfCxt = t 80 | relaxCxt t = AppT (ConT ''IfCxt) t 81 | 82 | -- | Creates an implementation of "ifCxt". If our instance has no extra 83 | -- constraints, e.g. deriving "IfCxt (Show Bool)" from "Show Bool", we simply 84 | -- return the first argument. 85 | -- 86 | -- If we have extra constraints, e.g. deriving 87 | -- "IfCxt (Show a) => IfCxt(Show [a])" from "Show a => Show [a]", we call 88 | -- "ifCxt" recursively to bring those instances in scope. We only return the 89 | -- first argument if all constraints are satisfied. 90 | mkIfCxtFun :: Cxt -> Exp 91 | mkIfCxtFun [] = VarE $ mkName "t" 92 | mkIfCxtFun (c:cs) = AppE (AppE (AppE (VarE 'ifCxt) 93 | proxy) 94 | (mkIfCxtFun cs)) 95 | (VarE $ mkName "f") 96 | where proxy = SigE (ConE 'Proxy) 97 | (AppT (ConT ''Proxy) c) 98 | -------------------------------------------------------------------------------- /src/IfCxt/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures, ScopedTypeVariables, MultiParamTypeClasses #-} 2 | -- | Some motivating examples for the "IfCxt" module. 3 | module IfCxt.Examples 4 | ( cxtShow 5 | , cxtShowTypeable 6 | , cxtNub 7 | , Magic 8 | , magic 9 | ) 10 | where 11 | 12 | import IfCxt 13 | import Data.List 14 | import Data.Typeable 15 | 16 | mkIfCxtInstances ''Ord 17 | mkIfCxtInstances ''Show 18 | mkIfCxtInstances ''Typeable 19 | 20 | -- | A version of "show" that can be called on any type. 21 | -- If the type is not an instance of "Show", then @<>@ gets displayed. 22 | cxtShow :: forall a. IfCxt (Show a) => a -> String 23 | cxtShow a = ifCxt (Proxy::Proxy (Show a)) 24 | (show a) 25 | "<>" 26 | 27 | -- | Like "cxtShow" above, but if @a@ is not an instance of "Show" then we print out the type. 28 | cxtShowTypeable :: forall a. 29 | ( IfCxt (Show a) 30 | , IfCxt (Typeable a) 31 | ) => a -> String 32 | cxtShowTypeable = ifCxt (Proxy::Proxy (Show a)) 33 | show 34 | ( ifCxt (Proxy::Proxy (Typeable a)) 35 | (\a -> "<<"++show (typeOf a) ++">>") 36 | (const "<>") 37 | ) 38 | 39 | -- | A version of "nub" that is maximally efficient for the given type. 40 | -- If we only have an "Eq" constraint, then "cxtNub" takes time @O(n^2)@, 41 | -- but if we also have an "Ord" constraint, then "cxtNub" only takes time @O(n*log n)@. 42 | -- If the type @a@ does have an "Ord" constraint, then the order of the elements may change. 43 | cxtNub :: forall a. (Eq a, IfCxt (Ord a)) => [a] -> [a] 44 | cxtNub = ifCxt (Proxy::Proxy (Ord a)) nubOrd nub 45 | where 46 | nubOrd :: Ord a => [a] -> [a] 47 | nubOrd = go . sort 48 | where 49 | go (x1:x2:xs) 50 | | x1==x2 = go (x2:xs) 51 | | otherwise = x1 : go (x2:xs) 52 | go [x] = [x] 53 | go [] = [] 54 | 55 | -- | A version of "sum" that uses the numerically stable Kahan summation technique on floating point values. 56 | cxtSum :: forall a. (Num a, IfCxt (Floating a)) => [a] -> a 57 | cxtSum = ifCxt (Proxy::Proxy (Floating a)) sumKahan sumSimple 58 | where 59 | sumSimple :: Num b => [b] -> b 60 | sumSimple = foldl' (+) 0 61 | 62 | sumKahan :: Num b => [b] -> b 63 | sumKahan = snd . foldl' go (0,0) 64 | where 65 | go (c,t) i = ((t'-t)-y,t') 66 | where 67 | y = i-c 68 | t' = t+y 69 | 70 | class Magic 71 | 72 | -- | This function behaves differently depending on whether there exists a 'Magic' instance or not. 73 | magic :: Int 74 | magic = ifCxt (Proxy::Proxy Magic) 1 2 75 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | resolver: lts-3.3 6 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, FlexibleInstances, FlexibleContexts, KindSignatures, ScopedTypeVariables, TemplateHaskell, ConstraintKinds #-} 2 | 3 | module Main where 4 | 5 | import Data.Maybe 6 | import Data.Typeable 7 | import IfCxt 8 | import Test.Tasty (defaultMain, testGroup, localOption) 9 | import Test.Tasty.QuickCheck 10 | 11 | mkIfCxtInstances ''Ord 12 | 13 | main = defaultMain $ testGroup "All tests" [ 14 | testProperty "Find Ord for Int" findOrdInt 15 | , testProperty "Find Ord for [Int]" findOrdListInt 16 | , testProperty "No Ord for (Int -> Int)" notFoundOrdFuncInt 17 | , testProperty "No Ord for [Int -> Int]" notFoundOrdListFuncInt 18 | , testProperty "Get Ord for Int" haveOrdInt 19 | , testProperty "Get Ord for [Int]" haveOrdListInt 20 | , testProperty "Can't get Ord for (Int -> Int)" noOrdFuncInt 21 | , testProperty "Can't get Ord for [Int -> Int]" noOrdListFuncInt 22 | , testProperty "Can use Ord for Int" usableOrdInt 23 | , testProperty "Can use Ord for [Int]" usableOrdListInt 24 | , testProperty "Can use Ord for (Int -> Int)" unusableOrdFuncInt 25 | , testProperty "Can use Ord for [Int -> Int]" unusableOrdListFuncInt 26 | ] 27 | 28 | -- Tests 29 | 30 | findOrdInt = ifCxt (Proxy :: Proxy (Ord Int)) True False 31 | findOrdListInt = ifCxt (Proxy :: Proxy (Ord [Int])) True False 32 | notFoundOrdFuncInt = ifCxt (Proxy :: Proxy (Ord (Int -> Int))) False True 33 | notFoundOrdListFuncInt = ifCxt (Proxy :: Proxy (Ord [Int -> Int])) False True 34 | 35 | haveOrdInt = isJust $ getLTE (Proxy :: Proxy (Ord Int)) 36 | haveOrdListInt = isJust $ getLTE (Proxy :: Proxy (Ord [Int])) 37 | noOrdFuncInt = isNothing $ getLTE (Proxy :: Proxy (Ord (Int -> Int))) 38 | noOrdListFuncInt = isNothing $ getLTE (Proxy :: Proxy (Ord [Int -> Int])) 39 | 40 | usableOrdInt (x :: Int) y = usableLTE x y 41 | usableOrdListInt (x :: [Int]) y = usableLTE x y 42 | unusableOrdFuncInt (x :: Int) y = unusableLTE (+x) (*y) 43 | unusableOrdListFuncInt = unusableLTE ([] :: [Int -> Int]) [] 44 | 45 | -- Helpers 46 | 47 | getLTE :: forall proxy a. IfCxt (Ord a) => proxy (Ord a) -> Maybe (a -> a -> Bool) 48 | getLTE _ = ifCxt (Proxy :: Proxy (Ord a)) 49 | (Just (<=)) 50 | Nothing 51 | 52 | useLTE :: (IfCxt (Ord a)) => a -> a -> Maybe Bool 53 | useLTE x y = getLTE (Proxy :: Proxy (Ord a)) <*> pure x <*> pure y 54 | 55 | usableLTE :: (IfCxt (Ord a), Ord a) => a -> a -> Bool 56 | usableLTE x y = useLTE x y == Just (x <= y) 57 | 58 | unusableLTE :: (IfCxt (Ord a)) => a -> a -> Bool 59 | unusableLTE x y = useLTE x y == Nothing 60 | --------------------------------------------------------------------------------