/RepLib/Generics/RepLib/Vec.hs

  1{-# LANGUAGE TemplateHaskell, ScopedTypeVariables,
  2    FlexibleInstances, FlexibleContexts,
  3    UndecidableInstances, MultiParamTypeClasses,
  4    TypeFamilies, EmptyDataDecls, TypeOperators, GADTs, MagicHash #-}
  5{-# OPTIONS_GHC -fno-warn-orphans #-}
  6
  7-- | A definition of length-indexed vectors plus their representations
  8module Generics.RepLib.Vec (
  9       Z,rZ,rZ1,S,rS,rS1,
 10       SNat(..),toSNat,
 11       Vec(..),rVec,rVec1
 12       )
 13where
 14
 15import Generics.RepLib
 16import GHC.Base (unsafeCoerce#)
 17
 18-- | Natural numbers
 19data Z
 20data S n
 21
 22$(derive [''Z, ''S])
 23
 24-- | Singleton GADT for natural numbers
 25data SNat a where
 26  SZ :: SNat Z
 27  SS :: Rep n => SNat n -> SNat (S n)
 28
 29-- | Convert a representation of a natural number into a singleton
 30-- WARNING: Only call this on *numbers*
 31-- It demonstrates a deficiency of reps for void/abstract datatypes
 32toSNat :: forall n. R n -> (SNat n)
 33toSNat r =
 34  case gcast (SZ :: SNat n) of
 35    Just sz -> sz
 36    Nothing -> case gcast (SS (toSNat rm)) of
 37
 38toSNat r@(Data (DT "Generics.RepLib.Vec.Z" MNil) []) =
 39    case gcastR r rZ SZ of
 40      Just sz -> sz
 41      Nothing -> error "BUG"
 42toSNat r@(Data (DT "Generics.RepLib.Vec.S" (rm :+: MNil)) []) =
 43    case gcastR r (rS (toSNat rm)) of
 44       Just i -> i
 45       Nothing -> error "impossible"
 46--       (unsafeCoerce# (SS (toSNat rm)) :: SNat n)
 47toSNat _ = error "BUG: toSNat can only be called with the representation of a natural number"
 48
 49
 50-- | a tuple of n values of type a
 51type family Tup a n :: *
 52type instance Tup a Z = Nil
 53type instance Tup a (S m) = a :*: (Tup a m)
 54
 55-- | a vector of n values of type a
 56data Vec a n where
 57 VNil  :: Vec a Z
 58 VCons :: Rep n => a -> Vec a n -> Vec a (S n)
 59
 60gTo :: forall a n . Rep n => SNat n -> (Tup a n) -> (Vec a n)
 61gTo s = case s of
 62  SZ -> \Nil -> VNil
 63  SS sm -> \(a :*: l ) -> VCons a (gTo sm l)
 64gFrom :: forall a n. Rep n => SNat n -> (Vec a n) -> Maybe (Tup a n)
 65gFrom SZ = \ VNil -> Just Nil
 66gFrom (SS sm) = \ (VCons a tl) -> do
 67     tl' <- gFrom sm tl
 68     return (a :*: tl')
 69
 70gMTup :: forall a n. (Rep a, Rep n) => R a -> SNat n -> MTup R (Tup a n)
 71gMTup ra SZ = MNil
 72gMTup ra (SS sm) = ra :+: gMTup ra sm
 73
 74vecEmb :: forall a n . Rep n => SNat n -> Emb (Tup a n) (Vec a n)
 75vecEmb sn =   (Emb { to = gTo sn,
 76                    from = gFrom sn,
 77                    labels = Nothing,
 78                    name = "",
 79                    fixity = Nonfix })
 80
 81-- | Rep of the vector type
 82rVec :: forall a n. (Rep a, Rep n) => R (Vec a n)
 83rVec =
 84  Data (DT "Generics.RepLib.Vec.Vec" ((rep :: R a) :+: (rep :: R n) :+: MNil))
 85       [ Con (vecEmb sn)
 86             (gMTup (rep :: R a) sn) ]  where
 87     sn :: SNat n
 88     sn = toSNat rep
 89
 90gMTup1 :: forall a n ctx. (Rep a, Rep n, Sat (ctx a)) => R a -> SNat n -> MTup ctx (Tup a n)
 91gMTup1 ra SZ = MNil
 92gMTup1 ra (SS sm) = dict :+: gMTup1 ra sm
 93
 94rVec1 :: forall a n ctx. (Rep a, Rep n, Sat (ctx a)) => R1 ctx (Vec a n)
 95rVec1 =
 96  Data1 (DT "Generics.RepLib.Vec.Vec" ((rep :: R a) :+: (rep :: R n) :+: MNil))
 97       [ Con (vecEmb sn)
 98             (gMTup1 (rep :: R a) sn) ]  where
 99     sn :: SNat n
100     sn = toSNat rep
101
102
103instance (Rep a, Rep n) => Rep (Vec a n) where
104     rep  = rVec
105instance (Rep a, Rep n, Sat (ctx a)) => Rep1 ctx (Vec a n) where
106     rep1 = rVec1