type-digits-0.2: 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
  (digitStrings, radix,
   Digit,
   digit, toType, toType_, toDigits, toDigits_,
   flexible, fixed, flexible', fixed',
   exactly,
   digitNames, digitTypes, digitStopName, digitStopType) where

import Type.Spine
import Type.Spine.TH (liftNameG_d)

import Type.Digits.Stage0
import Type.Digits.Stage1
import Type.Digits.Aux

import Language.Haskell.TH



fmap concat $ mapM spineType_pro $ 'DigitStop : digitNames


-- | Convert a number to the name of the corresponding digit -- error if the
-- argument is out of range.
digit :: (Show a, Eq a, Num a) => a -> Name
digit r = $(caseE [| r |] $ [
  match (litP (IntegerL k))
          (normalB $ liftNameG_d $ mkName n) []
 | (k, n) <- zip [0..] digitStrings]
            ++ [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 (PromotedT n) . acc) id

-- | @toType_ = ($ PromotedT 'DigitStop) . toType@.
toType_ :: [Name] -> Type
toType_ = ($ PromotedT 'DigitStop) . toType

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

-- | @toDigits_ = (($ PromotedT 'DigitStop) .) . toDigits@.
toDigits_ :: (a -> [Name]) -> a -> Type
toDigits_ = (($ PromotedT 'DigitStop) .) . 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 :: (Show a, Eq a, 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, Show a, Eq a, Integral a) => a -> [Name]
fixed = exactly (ceiling $ width (Proxy :: Proxy a)) . flexible


{-
packToDigits :: forall a. (Bounded a, Integral a) => [a] -> [Name]
packToDigits
  | ce == fl = concatMap fixed
  | otherwise = undefined where
  p = Proxy :: Proxy 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) => Proxy a -> b
width = width' . spanT

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

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

spanT' :: forall a. (Bounded a, Enum a) => Proxy 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