Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 229 lines (173 sloc) 6.824 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-} -- for compiling instances of (==)
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
{-| This module is an internal GHC module. It declares the constants used
in the implementation of type-level natural numbers. The programmer interface
for working with type-level naturals should be defined in a separate library.

/Since: 4.6.0.0/
-}

module GHC.TypeLits
  ( -- * Kinds
    Nat, Symbol

    -- * Linking type and value level
  , KnownNat, natVal
  , KnownSymbol, symbolVal
  , SomeNat(..), SomeSymbol(..)
  , someNatVal, someSymbolVal
  , sameNat, sameSymbol


    -- * Functions on type literals
  , type (<=), type (<=?), type (+), type (*), type (^), type (-)
  , CmpNat, CmpSymbol

  ) where

import GHC.Base(Eq(..), Ord(..), Bool(True,False), Ordering(..), otherwise)
import GHC.Num(Integer)
import GHC.Base(String)
import GHC.Show(Show(..))
import GHC.Read(Read(..))
import GHC.Prim(magicDict)
import Data.Maybe(Maybe(..))
import Data.Proxy(Proxy(..))
import Data.Type.Equality(type (==), (:~:)(Refl))
import Unsafe.Coerce(unsafeCoerce)

-- | (Kind) This is the kind of type-level natural numbers.
data Nat

-- | (Kind) This is the kind of type-level symbols.
data Symbol


--------------------------------------------------------------------------------

-- | This class gives the integer associated with a type-level natural.
-- There are instances of the class for every concrete literal: 0, 1, 2, etc.
--
-- /Since: 4.7.0.0/
class KnownNat (n :: Nat) where
  natSing :: SNat n

-- | This class gives the string associated with a type-level symbol.
-- There are instances of the class for every concrete literal: "hello", etc.
--
-- /Since: 4.7.0.0/
class KnownSymbol (n :: Symbol) where
  symbolSing :: SSymbol n

-- | /Since: 4.7.0.0/
natVal :: forall n proxy. KnownNat n => proxy n -> Integer
natVal _ = case natSing :: SNat n of
             SNat x -> x

-- | /Since: 4.7.0.0/
symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String
symbolVal _ = case symbolSing :: SSymbol n of
                SSymbol x -> x



-- | This type represents unknown type-level natural numbers.
data SomeNat = forall n. KnownNat n => SomeNat (Proxy n)
                  -- ^ /Since: 4.7.0.0/

-- | This type represents unknown type-level symbols.
data SomeSymbol = forall n. KnownSymbol n => SomeSymbol (Proxy n)
                  -- ^ /Since: 4.7.0.0/

-- | Convert an integer into an unknown type-level natural.
--
-- /Since: 4.7.0.0/
someNatVal :: Integer -> Maybe SomeNat
someNatVal n
  | n >= 0 = Just (withSNat SomeNat (SNat n) Proxy)
  | otherwise = Nothing

-- | Convert a string into an unknown type-level symbol.
--
-- /Since: 4.7.0.0/
someSymbolVal :: String -> SomeSymbol
someSymbolVal n = withSSymbol SomeSymbol (SSymbol n) Proxy



instance Eq SomeNat where
  SomeNat x == SomeNat y = natVal x == natVal y

instance Ord SomeNat where
  compare (SomeNat x) (SomeNat y) = compare (natVal x) (natVal y)

instance Show SomeNat where
  showsPrec p (SomeNat x) = showsPrec p (natVal x)

instance Read SomeNat where
  readsPrec p xs = do (a,ys) <- readsPrec p xs
                      case someNatVal a of
                        Nothing -> []
                        Just n -> [(n,ys)]


instance Eq SomeSymbol where
  SomeSymbol x == SomeSymbol y = symbolVal x == symbolVal y

instance Ord SomeSymbol where
  compare (SomeSymbol x) (SomeSymbol y) = compare (symbolVal x) (symbolVal y)

instance Show SomeSymbol where
  showsPrec p (SomeSymbol x) = showsPrec p (symbolVal x)

instance Read SomeSymbol where
  readsPrec p xs = [ (someSymbolVal a, ys) | (a,ys) <- readsPrec p xs ]

type family EqNat (a :: Nat) (b :: Nat) where
  EqNat a a = True
  EqNat a b = False
type instance a == b = EqNat a b

type family EqSymbol (a :: Symbol) (b :: Symbol) where
  EqSymbol a a = True
  EqSymbol a b = False
type instance a == b = EqSymbol a b

--------------------------------------------------------------------------------

infix 4 <=?, <=
infixl 6 +, -
infixl 7 *
infixr 8 ^

-- | Comparison of type-level naturals, as a constraint.
type x <= y = (x <=? y) ~ True

-- | Comparison of type-level symbols, as a function.
--
-- /Since: 4.7.0.0/
type family CmpSymbol (m :: Symbol) (n :: Symbol) :: Ordering

-- | Comparison of type-level naturals, as a function.
--
-- /Since: 4.7.0.0/
type family CmpNat (m :: Nat) (n :: Nat) :: Ordering

{- | Comparison of type-level naturals, as a function.
NOTE: The functionality for this function should be subsumed
by 'CmpNat', so this might go away in the future.
Please let us know, if you encounter discrepancies between the two. -}
type family (m :: Nat) <=? (n :: Nat) :: Bool

-- | Addition of type-level naturals.
type family (m :: Nat) + (n :: Nat) :: Nat

-- | Multiplication of type-level naturals.
type family (m :: Nat) * (n :: Nat) :: Nat

-- | Exponentiation of type-level naturals.
type family (m :: Nat) ^ (n :: Nat) :: Nat

-- | Subtraction of type-level naturals.
--
-- /Since: 4.7.0.0/
type family (m :: Nat) - (n :: Nat) :: Nat


--------------------------------------------------------------------------------

-- | We either get evidence that this function was instantiated with the
-- same type-level numbers, or 'Nothing'.
--
-- /Since: 4.7.0.0/
sameNat :: (KnownNat a, KnownNat b) =>
           Proxy a -> Proxy b -> Maybe (a :~: b)
sameNat x y
  | natVal x == natVal y = Just (unsafeCoerce Refl)
  | otherwise = Nothing

-- | We either get evidence that this function was instantiated with the
-- same type-level symbols, or 'Nothing'.
--
-- /Since: 4.7.0.0/
sameSymbol :: (KnownSymbol a, KnownSymbol b) =>
              Proxy a -> Proxy b -> Maybe (a :~: b)
sameSymbol x y
  | symbolVal x == symbolVal y = Just (unsafeCoerce Refl)
  | otherwise = Nothing

--------------------------------------------------------------------------------
-- PRIVATE:

newtype SNat (n :: Nat) = SNat Integer
newtype SSymbol (s :: Symbol) = SSymbol String

data WrapN a b = WrapN (KnownNat a => Proxy a -> b)
data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b)

-- See Note [magicDictId magic] in "basicType/MkId.hs"
withSNat :: (KnownNat a => Proxy a -> b)
         -> SNat a -> Proxy a -> b
withSNat f x y = magicDict (WrapN f) x y

-- See Note [magicDictId magic] in "basicType/MkId.hs"
withSSymbol :: (KnownSymbol a => Proxy a -> b)
            -> SSymbol a -> Proxy a -> b
withSSymbol f x y = magicDict (WrapS f) x y


Something went wrong with that request. Please try again.