type-digits-0.1: Type/Digits.hs

{-# LANGUAGE TypeFamilies, EmptyDataDecls, TemplateHaskell,
  ScopedTypeVariables, QuasiQuotes #-}

{- |

Module      :  Type.Digits
Copyright   :  (c) The University of Kansas 2011
License     :  BSD3

Maintainer  :  nicolas.frisby@gmail.com
Stability   :  experimental
Portability :  see LANGUAGE pragmas (... GHC)

Type-level numerals built from type-level digits of an arbitrary radix.

-}
module Type.Digits
  (module Type.Digits.Aux,
   digit, toType, toType_, toDigits, toDigits_,
   flexible, fixed, flexible', fixed',
   exactly) where

import Type.Spine
import Type.Spine.Stage0 (kTypeG)
import Type.Spine.TH (liftNameG)

import Data.Proxy.TH (qProxy)

import Type.Digits.Aux

import Language.Haskell.TH



-- declares each digit and its 'Spine' instance
concat `fmap` sequence [ do
 n <- return $ mkName n
 let k2 = kTypeG $ ArrowK StarK StarK
 x <- dataD (return []) n [PlainTV (mkName "x")] [] []
 (:[x]) `fmap` tySynInstD ''Spine [k2 `appT` conT n]
           (conT ''TypeName `appT` (k2 `appT` conT n))
 | n <- digitNames]

-- | Convert a number to the name of the corresponding digit -- error if the
-- argument is out of range.
digit :: Num a => a -> Name
digit r = $(caseE [| r |] $ [
  match (litP (IntegerL k))
          (normalB $ liftNameG $ mkName n) []
 | (k, n) <- zip [0..] digitNames]
            ++ [match wildP (normalB $ [| error $ "Type.Digits.digit: not (0 <= " ++ show r ++ " < " ++ show radix ++ ")" |]) []])



-- | Give a list of digit names, and a base type, yields a type.
toType :: [Name] -> Type -> Type
toType = foldr (\n acc -> AppT (ConT n) . acc) id

-- | @toType_ = ($ TupleT 0) . toType@.
toType_ :: [Name] -> Type
toType_ = ($ TupleT 0) . toType

-- | @toDigits f = toType . f@
toDigits :: (a -> [Name]) -> a -> Type -> Type
toDigits f = toType . f

-- | @toDigits_ = (($ TupleT 0) .) . toDigits@.
toDigits_ :: (a -> [Name]) -> a -> Type
toDigits_ = (($ TupleT 0) .) . toDigits

-- | @flexible' = flexible . fromEnum@
flexible' :: Enum a => a -> [Name]
flexible' = flexible . fromEnum

-- | @fixed' = fixed . fromEnum@
fixed' :: Enum a => a -> [Name]
fixed' = fixed . fromEnum

-- | Converts an @Integral@ to a type-level numeral using as many digits as it
-- takes that particular number.
flexible :: Integral a => a -> [Name]
flexible
  | 0 == radix = digit' -- NB guard against @/0@ -- e.g. number of elements in @a@ = radix
  | otherwise = w where
  digit' = (:[]) . digit
  w n = k $ digit' r where
    (q, r) = quotRem n radix
    k | 0 == q = id
      | otherwise = (w q ++)

-- | Converts a @Bounded@ @Integral@ to a type-level numeral using exactly the
-- number of digits it takes to represent each value of that type uniquely.
fixed :: forall a. (Bounded a, Integral a) => a -> [Name]
fixed = exactly (ceiling $ width [qProxy|a|]) . flexible


{-
packToDigits :: forall a. (Bounded a, Integral a) => [a] -> [Name]
packToDigits
  | ce == fl = concatMap fixed
  | otherwise = undefined where
  p = [qProxy|a|]; w :: Float; w = width p; ce = ceiling w; fl = floor w

  leftover = product (replicate ce radix) - spanT p
  leftover' = spanT p - product (replicate fl radix)
-}

width :: (Bounded a, Integral a, Floating b) => [qProxy|a|] -> b
width = width' . spanT

width' :: Floating a => Integer -> a
width' = logBase radix . fromInteger

spanT :: forall a. (Bounded a, Integral a) => [qProxy|a|] -> Integer
spanT _ = 1 + toInteger (maxBound :: a) - toInteger (minBound :: a)

spanT' :: forall a. (Bounded a, Enum a) => [qProxy|a|] -> Integer
spanT' _ = 1 + toInteger (fromEnum (maxBound :: a) - fromEnum (minBound :: a))

-- | Pads its second argument so that the resulting length is its first
-- argument; fails if the second argument is already larger.
exactly :: Int -> [Name] -> [Name]
exactly k l
  | n > k = error "Base: argument to `exactly' has too many elements"
  | otherwise = replicate (k - n) (digit 0) ++ l
  where n = length l