module Network.ONCRPC.XDR.Array
( KnownNat
, KnownOrdering
, LengthArray
, FixedLengthArray
, fixedLengthArrayLength
, BoundedLengthArray
, boundedLengthArrayBound
, unLengthArray
, unsafeLengthArray
, lengthArray
, lengthArray'
, boundLengthArray
, boundLengthArrayFromList
, padLengthArray
, constLengthArray
, emptyFixedLengthArray
, emptyBoundedLengthArray
, expandBoundedLengthArray
, boundFixedLengthArray
, appendLengthArray
, fromLengthList
) where
import Prelude hiding (length, take, drop, replicate)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import Data.Maybe (fromMaybe, fromJust)
import Data.Monoid (Monoid, (<>))
import Data.Proxy (Proxy(..))
import Data.String (IsString(..))
import qualified Data.Vector as V
import Data.Word (Word8)
import GHC.TypeLits (Nat, KnownNat, natVal, type (+), type CmpNat)
class HasLength a where
length :: a -> Int
compareLength :: a -> Int -> Ordering
compareLength = compare . length
class (Monoid a, HasLength a) => Array a where
type Elem a :: *
take :: Int -> a -> a
replicate :: Int -> Elem a -> a
fromList :: [Elem a] -> a
instance HasLength [a] where
length = List.length
compareLength [] n = compare 0 n
compareLength (_:l) n = compareLength l (n 1)
instance Array [a] where
type Elem [a] = a
take = List.take
replicate = List.replicate
fromList = id
instance HasLength (V.Vector a) where
length = V.length
instance Array (V.Vector a) where
type Elem (V.Vector a) = a
take = V.take
replicate = V.replicate
fromList = V.fromList
instance HasLength BS.ByteString where
length = BS.length
instance Array BS.ByteString where
type Elem BS.ByteString = Word8
take = BS.take
replicate = BS.replicate
fromList = BS.pack
instance HasLength BSL.ByteString where
length = fromIntegral . BSL.length
compareLength b n
| BSL.null b' = LT
| BSL.null (BSL.tail b') = EQ
| otherwise = GT
where b' = BSL.drop (fromIntegral n 1) b
instance Array BSL.ByteString where
type Elem BSL.ByteString = Word8
take = BSL.take . fromIntegral
replicate = BSL.replicate . fromIntegral
fromList = BSL.pack
class KnownOrdering (o :: Ordering) where
orderingVal :: proxy o -> Ordering
instance KnownOrdering 'LT where orderingVal _ = LT
instance KnownOrdering 'EQ where orderingVal _ = EQ
instance KnownOrdering 'GT where orderingVal _ = GT
newtype LengthArray (o :: Ordering) (n :: Nat) a = LengthArray{ unLengthArray :: a }
deriving (Eq, Ord, Show)
instance HasLength a => HasLength (LengthArray o n a) where
length = length . unLengthArray
compareLength = compareLength . unLengthArray
type FixedLengthArray n a = LengthArray 'EQ n a
type BoundedLengthArray n a = LengthArray 'LT (n + 1) a
lengthArrayOrdering :: forall o n a . KnownOrdering o => LengthArray o n a -> Ordering
lengthArrayOrdering _ = orderingVal (Proxy :: Proxy o)
lengthArrayBound :: forall o n a . KnownNat n => LengthArray o n a -> Int
lengthArrayBound _ = fromInteger $ natVal (Proxy :: Proxy n)
orderingOp :: Ordering -> Char
orderingOp LT = '<'
orderingOp EQ = '='
orderingOp GT = '>'
describeLengthArray :: (KnownOrdering o, KnownNat n) => LengthArray o n a -> String
describeLengthArray a = orderingOp (lengthArrayOrdering a) : show (lengthArrayBound a)
fixedLengthArrayLength :: KnownNat n => LengthArray 'EQ n a -> Int
fixedLengthArrayLength = lengthArrayBound
boundedLengthArrayBound :: KnownNat n => LengthArray 'LT n a -> Int
boundedLengthArrayBound = subtract 1 . lengthArrayBound
unsafeLengthArray :: a -> LengthArray o n a
unsafeLengthArray = LengthArray
checkLengthArray :: (KnownOrdering o, KnownNat n, HasLength a) => LengthArray o n a -> Bool
checkLengthArray l@(LengthArray a) = compareLength a (lengthArrayBound l) == lengthArrayOrdering l
lengthArray :: forall o n a . (KnownOrdering o, KnownNat n, HasLength a) => a -> Maybe (LengthArray o n a)
lengthArray a
| checkLengthArray l = Just l
| otherwise = Nothing
where l = LengthArray a :: LengthArray o n a
lengthArray' :: forall o n a . (KnownOrdering o, KnownNat n, HasLength a) => a -> LengthArray o n a
lengthArray' a = fromMaybe (error $ "lengthArray': fails check " ++ describeLengthArray (fromJust la)) la
where la = lengthArray a
boundLengthArray :: (KnownNat n, Array a) => a -> LengthArray 'LT n a
boundLengthArray a = l where
l = LengthArray $ take (boundedLengthArrayBound l) a
boundLengthArrayFromList :: (KnownNat n, Array a) => [Elem a] -> LengthArray 'LT n a
boundLengthArrayFromList a = l where
l = LengthArray $ fromList $ take (boundedLengthArrayBound l) a
padLengthArray :: (KnownNat n, Array a) => a -> Elem a -> LengthArray 'EQ n a
padLengthArray a p = l where
a' = case compareLength a n of
LT -> a <> replicate (n length a) p
EQ -> a
GT -> take n a
n = fixedLengthArrayLength l
l = LengthArray a'
constLengthArray :: (KnownNat n, Array a) => Elem a -> LengthArray 'EQ n a
constLengthArray p = l where
l = LengthArray $ replicate (fixedLengthArrayLength l) p
instance (KnownOrdering o, KnownNat n, IsString a, HasLength a) => IsString (LengthArray o n a) where
fromString s = fromMaybe
(error $ "String " ++ show s ++ " fails LengthArray check " ++ describeLengthArray (fromJust ls))
ls
where ls = lengthArray $ fromString s
emptyFixedLengthArray :: Array a => LengthArray 'EQ 0 a
emptyFixedLengthArray = LengthArray mempty
emptyBoundedLengthArray :: (CmpNat 0 n ~ 'LT, Array a) => LengthArray 'LT n a
emptyBoundedLengthArray = LengthArray mempty
expandBoundedLengthArray :: (CmpNat n m ~ 'LT) => LengthArray 'LT n a -> LengthArray 'LT m a
expandBoundedLengthArray = LengthArray . unLengthArray
boundFixedLengthArray :: (CmpNat n m ~ 'LT) => LengthArray 'EQ n a -> LengthArray 'LT m a
boundFixedLengthArray = LengthArray . unLengthArray
appendLengthArray :: Monoid a => LengthArray o n a -> LengthArray o m a -> LengthArray o (n + m) a
appendLengthArray (LengthArray a) (LengthArray b) = LengthArray $ mappend a b
fromLengthList :: Array a => LengthArray o n [Elem a] -> LengthArray o n a
fromLengthList = LengthArray . fromList . unLengthArray