Ticket #1646: ConstrainedType.hs

File ConstrainedType.hs, 39.8 KB (added by guest, 7 years ago)
Line 
1module ConstrainedType where
2
3{-
4The encoding is for UNALIGNED PER
5-}
6
7import Data.Monoid
8import Data.List hiding (groupBy)
9import Data.Bits
10import Data.Char
11import Control.Monad.State
12import Control.Monad.Error
13import qualified Data.ByteString.Lazy as B
14import Language.ASN1 hiding (Optional, BitString, PrintableString, IA5String, ComponentType(Default))
15import Text.PrettyPrint
16import System
17import IO
18
19type BitStream = [Int]
20
21bigIntLength = toInteger . length
22
23newtype IA5String = IA5String {iA5String :: String}
24newtype BitString = BitString {bitString :: BitStream}
25
26instance Show IA5String where
27   show (IA5String x) = show x
28
29newtype IA5Char = IA5Char {iA5Char :: Char}
30
31class List a b | a -> b where
32   nil  :: b
33   cons :: a -> b -> b
34
35instance List IA5Char IA5String where
36   nil = IA5String []
37   cons x y = IA5String ((iA5Char x):(iA5String y))
38
39data AlphabetConstraint :: * -> * where
40   SingleValueAlpha      :: List a b => a -> AlphabetConstraint b
41   RangeAlpha            :: List a b => a -> a -> AlphabetConstraint b
42   UnionAlpha            :: AlphabetConstraint a -> AlphabetConstraint a -> AlphabetConstraint a
43
44newtype PrintableString = PrintableString {unPrintableString :: String}
45
46
47
48-- X.680 (07/2002) Section 47.1 Table 9
49
50class SingleValue a
51
52instance SingleValue BitString
53instance SingleValue IA5String
54instance SingleValue PrintableString
55instance SingleValue Integer
56
57class ContainedSubtype a
58
59instance ContainedSubtype BitString
60instance ContainedSubtype IA5String
61instance ContainedSubtype PrintableString
62instance ContainedSubtype Integer
63
64class ValueRange a
65
66-- BIT STRING cannot be given value ranges
67instance ValueRange IA5String
68instance ValueRange PrintableString
69instance ValueRange Integer
70
71
72class PermittedAlphabet a
73
74-- BIT STRING cannot be given permitted alphabet
75instance PermittedAlphabet IA5String
76instance PermittedAlphabet PrintableString
77instance PermittedAlphabet VisibleString
78-- INTEGER cannot be given permitted alphabet
79
80class SizeConstraint a
81
82instance SizeConstraint BitString
83instance SizeConstraint IA5String
84instance SizeConstraint PrintableString
85instance SizeConstraint [a]
86instance SizeConstraint VisibleString
87-- INTEGER cannot be given a size constraint
88
89
90-- Heterogeneous lists of constrained types
91
92data Nil = Empty
93data a:*:l = a:*:l
94
95data Sequence :: * -> * where
96   Nil :: Sequence Nil
97   Cons ::  ConstrainedType a -> Sequence l -> Sequence (a:*:l)
98   Optional :: ConstrainedType a -> Sequence l -> Sequence ((Maybe a):*:l)
99   Default :: ConstrainedType a -> a -> Sequence l -> Sequence ((Maybe a):*:l)
100
101-- The Choice type is similar to a Sequence except that each value
102-- is optional and only one value can exist at a time. Note that
103-- the Choice type has no PER-visible constraints.
104
105data Choice :: * -> * where
106    NoChoice     :: Choice Nil
107    ChoiceOption :: ConstrainedType a -> Choice l -> Choice ((Maybe a):*:l)
108
109-- Type Aliases for Tag Information
110type TagInfo    = (TagType, TagValue, TagPlicity)
111type TagHistory = [TagInfo]
112
113-- The major data structure itself
114
115data ConstrainedType :: * -> * where
116   BOOLEAN         :: TagHistory -> ConstrainedType Bool
117   INTEGER         :: TagHistory -> ConstrainedType Integer
118--   ENUMERATED      :: TagHistory -> ConstrainedType Enumerated
119   BITSTRING       :: TagHistory -> ConstrainedType BitString
120   PRINTABLESTRING :: TagHistory -> ConstrainedType PrintableString
121   IA5STRING       :: TagHistory -> ConstrainedType IA5String
122   VISIBLESTRING   :: TagHistory -> ConstrainedType VisibleString
123   Single          :: SingleValue a => TagHistory -> ConstrainedType a -> a -> ConstrainedType a
124   Includes        :: ContainedSubtype a => TagHistory -> ConstrainedType a -> ConstrainedType a -> ConstrainedType a
125   Range           :: (Ord a, ValueRange a) => TagHistory -> ConstrainedType a -> Maybe a -> Maybe a -> ConstrainedType a
126   SEQUENCE        :: TagHistory -> Sequence a -> ConstrainedType a
127   SEQUENCEOF      :: TagHistory -> ConstrainedType a -> ConstrainedType [a]
128   SIZE            :: SizeConstraint a => TagHistory -> ConstrainedType a -> Lower -> Upper -> ConstrainedType a
129   SET             :: TagHistory -> Sequence a -> ConstrainedType a
130   SETOF           :: TagHistory -> ConstrainedType a -> ConstrainedType [a]
131   CHOICE          :: TagHistory -> Choice a -> ConstrainedType a
132   FROM            :: PermittedAlphabet a => TagHistory -> ConstrainedType a
133                        -> a -> ConstrainedType a
134{-
135   -- Regular expression constraint - ignore for now but it would be cool to do them
136   -- Subtyping the content of an OCTET STRING - ignore for now
137   -- Constraint combinations
138   -- Note that we don't need intersections - we need a longer explanation for this
139   Union        :: ConstrainedType a -> ConstrainedType a -> ConstrainedType a
140-}
141
142
143-- dna = From PRINTABLESTRING (SingleValueAlpha (PrintableString "TAGC")) shouldn't typecheck
144
145
146type Upper = Maybe Integer
147type Lower = Maybe Integer
148
149data Constraint a = Constrained (Maybe a) (Maybe a)
150   deriving Show
151
152instance Ord a => Monoid (Constraint a) where
153   mempty = Constrained Nothing Nothing
154   mappend x y = Constrained (g x y) (f x y)
155      where
156         f (Constrained _ Nothing)  (Constrained _ Nothing)  = Nothing
157         f (Constrained _ Nothing)  (Constrained _ (Just y)) = Just y
158         f (Constrained _ (Just x)) (Constrained _ Nothing)  = Just x
159         f (Constrained _ (Just x)) (Constrained _ (Just y)) = Just (min x y)
160         g (Constrained Nothing _)  (Constrained Nothing _)  = Nothing
161         g (Constrained Nothing _)  (Constrained (Just y) _) = Just y
162         g (Constrained (Just x) _) (Constrained Nothing _)  = Just x
163         g (Constrained (Just x) _) (Constrained (Just y) _) = Just (max x y)
164
165-- bounds returns the range of a value. Nothing indicates
166-- no lower or upper bound.
167
168bounds :: Ord a => ConstrainedType a -> Constraint a
169bounds (Includes _ t1 t2)   = (bounds t1) `mappend` (bounds t2)
170bounds (Range _ t l u)      = (bounds t) `mappend` (Constrained l u)
171bounds _                    = Constrained Nothing Nothing
172
173
174-- sizeLimit returns the size limits of a value. Nothing
175-- indicates no lower or upper bound.
176
177sizeLimit :: ConstrainedType a -> Constraint Integer
178sizeLimit (SIZE _ _ l u) = Constrained l u
179sizeLimit _              = Constrained Nothing Nothing
180
181-- manageSize is a HOF used to manage the three size cases for a
182-- type amenable to a size constraint.
183
184manageSize :: (ConstrainedType a -> Integer -> Integer -> t -> t1) -> (ConstrainedType a -> t -> t1)
185                -> ConstrainedType a -> t -> t1
186manageSize fn1 fn2 t x
187    = case p of
188       Constrained (Just lb) (Just ub) ->
189         fn1 t lb ub x
190       Constrained (Just lb) Nothing ->
191         fn2 t x
192       Constrained Nothing Nothing ->
193         fn2 t x
194     where
195      p = sizeLimit t
196
197-- toPer is the top-level PER encoding function.
198
199toPer :: ConstrainedType a -> a -> [Int]
200toPer t@(BOOLEAN tgs) x                         = encodeBool t x
201toPer t@(INTEGER tgs) x                         = encodeInt t x
202toPer r@(Range tgs1 (INTEGER tgs2) l u) x       = encodeInt r x
203toPer t@(BITSTRING tgs) x                       = encodeBS t x
204toPer t@(SIZE tgs1 (BITSTRING tgs) l u) x       = encodeBS t x
205toPer (SEQUENCE tgs s) x                        = encodeSeq s x
206toPer t@(SEQUENCEOF tgs s) x                    = encodeSO t x
207toPer t@(SIZE tgs1 (SEQUENCEOF tgs2 c) l u) x   = encodeSO t x
208toPer (SET tgs s) x                             = encodeSet s x
209toPer t@(SETOF tgs s) x                         = encodeSO t x
210toPer t@(CHOICE tgs c) x                        = encodeChoice c x
211toPer t@(VISIBLESTRING tgs) x                   = encodeVS t x
212toPer t@(SIZE tgs1 (VISIBLESTRING tgs) l u) x   = encodeVS t x
213toPer t@(FROM tgs1 (VISIBLESTRING tgs) pac) x   = encodeVSF t x
214toPer t@(SIZE tgs1 (FROM tgs2 (VISIBLESTRING tgs) pac) l u) x
215                                                = encodeVSF t x
216
217-- 11 ENCODING THE BOOLEAN TYPE
218
219encodeBool :: ConstrainedType Bool -> Bool -> BitStream
220encodeBool t True = [1]
221encodeBool t _    = [0]
222
223-- 10.3 - 10.8 ENCODING THE INTEGER TYPE
224
225encodeInt :: ConstrainedType Integer -> Integer -> BitStream
226encodeInt t x =
227   case p of
228      -- 10.5 Encoding of a constrained whole number
229      Constrained (Just lb) (Just ub) ->
230         let range = ub - lb + 1 in
231            if range <= 1
232               -- 10.5.4
233               then []
234               -- 10.5.6 and 10.3 Encoding as a non-negative-binary-integer
235               else minBits ((x-lb),range-1)
236      -- 12.2.3, 10.7 Encoding of a semi-constrained whole number,
237      -- 10.3 Encoding as a non-negative-binary-integer, 12.2.6, 10.9 and 12.2.6 (b)
238      Constrained (Just lb) Nothing ->
239         encodeWithLengthDeterminant (minOctets (x-lb))
240      -- 12.2.4, 10.8 Encoding of an unconstrained whole number, 10.8.3 and
241      -- 10.4 Encoding as a 2's-complement-binary-integer
242      Constrained Nothing _ ->
243        encodeWithLengthDeterminant (to2sComplement x)
244   where
245      p = bounds t
246
247
248-- minBits encodes a constrained whole number (10.5.6) in the minimum
249-- number of bits required for the range (assuming the range is at least 2).
250
251minBits :: (Integer, Integer) -> BitStream
252minBits
253    = reverse . (map fromInteger) . unfoldr h
254      where
255        h (_,0) = Nothing
256        h (0,w) = Just (0, (0, w `div` 2))
257        h (n,w) = Just (n `mod` 2, (n `div` 2, w `div` 2))
258
259-- minOctets is used in the encoding of a semi-constrained integer (10.7). It is encoded
260-- as a non-negative-binary-integer (10.3, 10.3.6) where the offset
261-- from the lower bound is encoded in the minimum number of octets, preceded by
262-- (or interspersed with) the encoding of the length (using encodeWithLengthDeterminant)
263-- of the octet representation of the offset. (10.7.4)
264
265minOctets :: Integer -> BitStream
266minOctets =
267   reverse . (map fromInteger) . flip (curry (unfoldr (uncurry g))) 8 where
268      g 0 0 = Nothing
269      g 0 p = Just (0,(0,p-1))
270      g n 0 = Just (n `mod` 2,(n `div` 2,7))
271      g n p = Just (n `mod` 2,(n `div` 2,p-1))
272
273
274-- 10.9 General rules for encoding a length determinant
275-- 10.9.4, 10.9.4.2 and 10.9.3.4 to 10.9.3.8.4.
276
277-- encodeInsert is a HOF which manages the fragmentation and
278-- encoding of a value with an unconstrained length.
279
280encodeInsert :: (t -> [[[t1]]] -> [[a]]) -> t -> [t1] -> [a]
281encodeInsert f s = concat . f s . groupBy 4 . groupBy (16*(2^10))
282
283encodeWithLengthDeterminant :: [Int] -> [Int]
284encodeWithLengthDeterminant = concat . encodeInsert unfoldr intLengths . groupBy 8
285
286groupBy :: Int -> [t] -> [[t]]
287groupBy n =
288   unfoldr k
289      where
290         k [] = Nothing
291         k p = Just (splitAt n p)
292
293-- HOFs of use when encoding values with an unconstrained length
294-- where the length value has to be interspersed with value encoding.
295
296ulWrapper :: (Num t) => ([a] -> [a1]) -> (t1 -> [a1] -> [a1]) -> (Integer -> t -> t1)
297                    -> (Integer -> [a1]) -> [[[a]]] -> Maybe ([a1], [[[a]]])
298ulWrapper fn op inp lf [] = Nothing
299ulWrapper fn op inp lf (x:xs)
300   | l == n && lm == l1b = Just (ws x,xs)
301   | l == 1 && lm <  l1b = Just (us,[])
302   | otherwise           = Just (vs,[])
303   where
304      bl  = bigIntLength x
305      l   = length x
306      m   = x!!(l-1)
307      lm  = length m
308      ws  = abs1 fn op (inp bl r)
309      us  = lf (bigIntLength m) ++ fn m
310      vs  = if lm == l1b then
311               ws x ++ lf 0
312            else
313               ws (take (l-1) x) ++ lf (bigIntLength m) ++ fn m
314      n   = 4
315      l1b = 16*(2^10)
316      r = 2^6 - 1
317
318abs1 :: (a1 -> [a]) -> (t -> [a] -> t1) -> t -> [a1] -> t1
319abs1 f op x y
320    = x `op` (concat . map f) y
321
322arg1 :: Integer -> Integer -> [Int]
323arg1 x y = (1:1:(minBits (x,y)))
324
325
326-- intLengths adds length value to section of int value
327
328intLengths :: [[[BitStream]]] -> Maybe ([BitStream], [[[BitStream]]])
329intLengths = ulWrapper id (:) arg1 ld
330
331ld :: Integer -> [BitStream]
332ld n
333-- 10.9.4.2, 10.9.3.5, 10.9.3.6 Note not very efficient since we know log2 128 = 7
334   | n <= 127       = [0:(minBits (n, 127))]
335-- 10.9.3.7 Note not very efficient since we know log2 16*(2^10) = 14
336   | n < 16*(2^10)  = [1:0:(minBits (n, (16*(2^10)-1)))]
337-- Note there is no clause for >= 16*(2^10) as we have groupBy 16*(2^10)
338
339
340-- 10.4 Encoding as a 2's-complement-binary-integer is used when
341-- encoding an integer with no lower bound (10.8) as in the final
342-- case of encodeInt. The encoding of the integer is accompanied
343-- by the encoding of its length using encodeWithLengthDeterminant
344-- (10.8.3)
345
346to2sComplement :: Integer -> BitStream
347to2sComplement n
348   | n >= 0 = 0:(h n)
349   | otherwise = minOctets (2^p + n)
350   where
351      p = length (h (-n-1)) + 1
352
353g :: (Integer, Integer) -> Maybe (Integer, (Integer, Integer))
354g (0,0) = Nothing
355g (0,p) = Just (0,(0,p-1))
356g (n,0) = Just (n `rem` 2,(n `quot` 2,7))
357g (n,p) = Just (n `rem` 2,(n `quot` 2,p-1))
358
359h :: Integer -> BitStream
360h n = (reverse . map fromInteger) (flip (curry (unfoldr g)) 7 n)
361
362-- 13 ENCODING THE ENUMERATED TYPE
363
364
365
366-- 15 ENCODING THE BITSTRING TYPE
367
368--
369
370encodeBS :: ConstrainedType BitString -> BitString -> BitStream
371encodeBS = manageSize encodeBSSz encodeBSNoSz
372
373
374encodeBSSz :: ConstrainedType BitString -> Integer -> Integer -> BitString -> BitStream
375encodeBSSz t@(SIZE tgs ty _ _) l u x@(BitString xs)
376    = let exs = editBS l u xs
377      in
378        if u == 0
379            then []
380            else if u == l && u <= 65536
381                    then exs
382                    else encodeBSWithLD exs
383
384encodeBSWithLD  = encodeInsert insertBSL (INTEGER [])
385
386insertBSL s = unfoldr (bsLengths s)
387
388bsLengths t = ulWrapper (id) (++) arg1 ld2
389
390editBS :: Integer -> Integer -> BitStream -> BitStream
391editBS l u xs
392    = let lxs = bigIntLength xs
393      in if lxs < l
394        then add0s (l-lxs) xs
395        else
396            if lxs > u
397             then rem0s (lxs-u) xs
398             else xs
399
400add0s :: Integer -> BitStream -> BitStream
401add0s n xs = xs ++ take (fromInteger n) [0,0..]
402
403rem0s (n+1) xs
404    = if last xs == 0
405           then rem0s n (init xs)
406           else error "Last value is not 0"
407rem0s 0 xs = xs
408
409encodeBSNoSz :: ConstrainedType BitString -> BitString -> BitStream
410encodeBSNoSz t (BitString bs)
411    = let rbs = reverse bs
412          rem0 = strip0s rbs
413       in reverse rem0
414
415strip0s (a:r)
416    = if a == 0
417        then strip0s r
418        else (a:r)
419strip0s [] = []
420
421-- 18 ENCODING THE SEQUENCE TYPE
422
423encodeSeq :: Sequence a -> a -> BitStream
424encodeSeq s x
425    =   let (p,es) = encodeSeqAux [] [] s x
426        in  concat p ++ concat es
427
428-- encodeSeqAux is the auxillary function for encodeSeq. When
429-- encoding a sequence, one has to both encode each component and
430-- produce a preamble which indicates the presence or absence of an
431-- optional or default value. The first list in the result is the
432-- preamble.
433
434encodeSeqAux :: [BitStream] -> [BitStream] -> Sequence a -> a ->
435    ([BitStream],[BitStream])
436encodeSeqAux preamble body Nil _ = ((reverse preamble),(reverse body))
437encodeSeqAux preamble body (Cons a as) (x:*:xs) =
438   encodeSeqAux ([]:preamble) ((toPer a x):body) as xs
439encodeSeqAux preamble body (Optional a as) (Nothing:*:xs) =
440   encodeSeqAux ([0]:preamble)([]:body) as xs
441encodeSeqAux preamble body (Optional a as) ((Just x):*:xs) =
442   encodeSeqAux ([1]:preamble) ((toPer a x):body) as xs
443encodeSeqAux preamble body (Default a d as) (Nothing:*:xs) =
444   encodeSeqAux ([0]:preamble) ([]:body) as xs
445encodeSeqAux preamble body (Default a d as) ((Just x):*:xs) =
446   encodeSeqAux ([1]:preamble) ((toPer a x):body) as xs
447
448
449-- 19. ENCODING THE SEQUENCE-OF TYPE
450
451-- encodeSO implements the encoding of an unconstrained
452-- sequence-of value. This requires both the encoding of
453-- each of the components, and in most cases the encoding
454-- of the length of the sequence of (which may require
455-- fragmentation into 64K blocks). It uses the function manageSize
456-- which manages the 3 possible size cases.
457
458encodeSO :: ConstrainedType [a] -> [a] -> BitStream
459encodeSO  = manageSize encodeSeqSz encodeSeqOf
460
461-- encodeSeqSz encodes a size-constrained SEQUENCEOF. It uses the
462-- function manageExtremes which manages the 3 upper/lower bound size value cases.
463
464manageExtremes :: ([a] -> BitStream) -> ([a] -> BitStream) -> Integer -> Integer -> [a] -> BitStream
465manageExtremes fn1 fn2 l u x
466    = let range = u - l + 1
467        in
468            if range == 1 && u < 65536
469               then fn1 x
470               else if u >= 65536
471                   then fn2 x
472                   else minBits ((bigIntLength x-l),range-1) ++ fn1 x
473
474encodeSeqSz :: ConstrainedType [a] -> Integer -> Integer -> [a] -> BitStream
475encodeSeqSz (SIZE tgs ty _ _) l u x
476        = manageExtremes (encodeNoL ty) (encodeSeqOf ty) l u x
477
478
479encodeSeqOf :: ConstrainedType a -> a -> BitStream
480encodeSeqOf (SEQUENCEOF tgs s) xs
481    = encodeWithLD s xs
482
483-- encodeWithLD splits the components into 16K blocks, and then
484-- splits these into blocks of 4 (thus a maximum of 64K in each
485-- block). insertL then manages the interleaving of the length-value
486-- encoding of the components.
487
488encodeWithLD :: ConstrainedType a -> [a] -> BitStream
489encodeWithLD s
490    = encodeInsert insertL s
491
492insertL :: ConstrainedType a -> [[[a]]] -> [BitStream]
493insertL s = unfoldr (soLengths s)
494
495
496-- soLengths adds length values to encodings of SEQUENCEOF
497-- components.
498
499soLengths :: ConstrainedType a -> [[[a]]] -> Maybe (BitStream, [[[a]]])
500soLengths t = ulWrapper (concat . map (toPer t)) (++) arg1 ld2
501
502ld2 n
503   | n <= 127       = 0:(minBits (n, 127))
504   | n < 16*(2^10)  = 1:0:(minBits (n, (16*(2^10)-1)))
505
506
507-- No length encoding of SEQUENCEOF
508
509encodeNoL :: ConstrainedType a -> a -> BitStream
510encodeNoL (SEQUENCEOF _ s) xs
511    = (concat . map (toPer s)) xs
512
513
514-- 20. Encoding the SET type. The encoding is the same as for a
515-- SEQUENCE except that the components must be canonically ordered.
516-- The ordering is based on the component's tags. Note, the
517-- preamble must be reordered to match the ordering of the
518-- components.
519
520encodeSet :: Sequence a -> a -> BitStream
521encodeSet s x
522    =   let ts     = getTags s
523            (p,es) = (encodeSeqAux [] [] s x)
524            ps     = zip ts es
525            pps    = zip p ps
526            os     = mergesort setPred pps
527            pr     = concat (map fst os)
528            en     = concat (map (snd . snd) os)
529        in
530            pr ++ en
531
532
533
534-- Sorting
535
536mergesort :: (a -> a -> Bool) -> [a] -> [a]
537mergesort pred [] = []
538mergesort pred [x] = [x]
539mergesort pred xs = merge pred (mergesort pred xs1) (mergesort pred xs2)
540                             where (xs1,xs2) = split xs
541split :: [a] -> ([a],[a])
542split xs = splitrec xs xs []
543splitrec :: [a] -> [a] -> [a] -> ([a],[a])
544splitrec [] ys zs = (reverse zs, ys)
545splitrec [x] ys zs = (reverse zs, ys)
546splitrec (x1:x2:xs) (y:ys) zs = splitrec xs ys (y:zs)
547
548merge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
549merge pred xs [] = xs
550merge pred [] ys = ys
551merge pred (x:xs) (y:ys)
552    = case pred x y
553        of True -> x: merge pred xs (y:ys)
554           False -> y: merge pred (x:xs) ys
555
556-- Sorting predicate and tag selector
557
558setPred :: (BitStream,(TagInfo, BitStream)) -> (BitStream,(TagInfo, BitStream)) -> Bool
559setPred (_,(t1,_)) (_,(t2,_)) = t1 < t2
560
561tagOrder :: ConstrainedType a -> ConstrainedType a -> Bool
562tagOrder x y = getTI x < getTI y
563
564getTags :: Sequence a -> [TagInfo]
565getTags Nil               = []
566getTags (Cons a xs)       = getTI a : getTags xs
567getTags (Optional a xs)   = getTI a : getTags xs
568getTags (Default a d xs)  = getTI a : getTags xs
569
570getTI :: ConstrainedType a -> TagInfo
571getTI (INTEGER t)       = if null t then (Universal,2, Explicit) else head t
572getTI (Range t c _ _)   = if null t then getTI c else head t
573getTI (IA5STRING t)     = if null t then (Universal,22, Explicit) else head t
574getTI (BITSTRING t)     = if null t then (Universal, 3, Explicit) else head t
575getTI (PRINTABLESTRING t)
576                        = if null t then (Universal, 19, Explicit) else head t
577getTI (VISIBLESTRING t) = if null t then (Universal, 26, Explicit) else head t
578getTI (SEQUENCE t s)    = if null t then (Universal, 16, Explicit) else head t
579getTI (SEQUENCEOF t s)  = if null t then (Universal, 16, Explicit) else head t
580getTI (SET t s)         = if null t then (Universal, 17, Explicit) else head t
581getTI (SETOF t s)       = if null t then (Universal, 17, Explicit) else head t
582getTI (SIZE t c _ _)    = if null t then getTI c else head t
583getTI (CHOICE t c)      = if null t then (minimum . getCTags) c else head t
584
585
586
587-- 21. Encoding the set-of type.
588
589-- Since we are implementing BASIC-PER (and not CANONICAL-PER) the
590-- encoding is as for a sequence-of.
591
592
593-- 22. Encoding the choice type.
594
595-- encodeChoice encodes CHOICE values. It is not dissimilar to
596-- encodeSet in that the possible choice components must be
597-- assigned an index based on their canonical ordering. This index,
598-- which starts from 0, prefixes the value encoding and is absent if
599-- there is only a single choice.
600
601encodeChoice :: Choice a -> a -> BitStream
602encodeChoice c x
603    =   let ts  = getCTags c
604            ec  = (encodeChoiceAux [] c x)
605        in
606            if length ec == 1
607                then concat ec
608            else
609                let ps  = zip ts ec
610                    os  = mergesort choicePred ps
611                    pps = zip [0..] os
612                    fr  = (head . filter (not . nullValue)) pps
613                    ls  = bigIntLength os
614                in
615                     minBits (fst fr,ls-1) ++ (snd .snd) fr
616
617nullValue :: (Integer, (TagInfo, BitStream)) -> Bool
618nullValue (f,(s,t)) = null t
619
620getCTags :: Choice a -> [TagInfo]
621getCTags NoChoice              = []
622getCTags (ChoiceOption a xs)   = getTI a : getCTags xs
623
624choicePred :: (TagInfo, BitStream) -> (TagInfo, BitStream) -> Bool
625choicePred (t1,_) (t2,_) = t1 < t2
626
627
628encodeChoiceAux :: [BitStream] -> Choice a -> a -> [BitStream]
629encodeChoiceAux body NoChoice _ = reverse body
630encodeChoiceAux body (ChoiceOption a as) (Nothing:*:xs) =
631   encodeChoiceAux ([]:body) as xs
632encodeChoiceAux body (ChoiceOption a as) ((Just x):*:xs) =
633   encodeChoiceAux' ((toPer a x):body) as xs
634
635encodeChoiceAux' :: [BitStream] -> Choice a -> a -> [BitStream]
636encodeChoiceAux' body NoChoice _ = reverse body
637encodeChoiceAux' body (ChoiceOption a as) (Nothing:*:xs) =
638   encodeChoiceAux' ([]:body) as xs
639
640
641-- 27. Encoding the restricted character string types (VISIBLESTRING)
642
643encodeVS :: ConstrainedType VisibleString -> VisibleString -> BitStream
644encodeVS = manageSize encodeVisSz encodeVis
645
646encodeVisSz :: ConstrainedType VisibleString -> Integer -> Integer -> VisibleString -> BitStream
647encodeVisSz t@(SIZE tgs ty _ _) l u x@(VisibleString xs)
648    = manageExtremes encS (encodeVis ty . VisibleString) l u xs
649
650encodeVis :: ConstrainedType VisibleString -> VisibleString -> BitStream
651encodeVis vs (VisibleString s)
652    = encodeInsert insertLVS vs s
653
654insertLVS :: ConstrainedType VisibleString -> [[String]] -> [BitStream]
655insertLVS s = unfoldr (vsLengths s)
656
657
658-- vsLengths adds lengths values to encoding of sections of
659-- VISIBLESTRING.
660
661vsLengths :: ConstrainedType VisibleString -> [[String]] -> Maybe (BitStream, [[String]])
662vsLengths s = ulWrapper encS (++) arg1 ld2
663
664encC c  = minBits ((toInteger . ord) c, 94)
665encS s  = (concat . map encC) s
666
667
668-- 27.5.4 Encoding of a VISIBLESTRING with a permitted alphabet
669-- constraint.
670
671encodeVSF :: ConstrainedType VisibleString -> VisibleString -> BitStream
672encodeVSF = manageSize encodeVisSzF encodeVisF
673
674encodeVisSzF :: ConstrainedType VisibleString -> Integer -> Integer -> VisibleString -> BitStream
675encodeVisSzF t@(SIZE tgs ty@(FROM tgs2 cv pac)_ _) l u x@(VisibleString xs)
676    = manageExtremes (encSF pac) (encodeVisF ty . VisibleString) l u xs
677
678encodeVisF :: ConstrainedType VisibleString -> VisibleString -> BitStream
679encodeVisF vs@(FROM tgs2 cv pac) (VisibleString s)
680    = encodeInsert (insertLVSF pac) vs s
681
682insertLVSF :: VisibleString -> t -> [[String]] -> [BitStream]
683insertLVSF p s = unfoldr (vsLengthsF s p)
684
685
686-- vsLengths adds lengths values to encoding of sections of
687-- VISIBLESTRING.
688
689vsLengthsF :: t -> VisibleString -> [[String]] -> Maybe (BitStream, [[String]])
690vsLengthsF s p = ulWrapper (encSF p) (++) arg1 ld2
691
692encSF (VisibleString p) str
693    = let sp  = sort p
694          lp  = (toInteger. length) p
695          b   = minExp 2 0 lp
696          mp  = maximum p
697      in
698        if ord mp < 2^b -1
699            then
700                encS str
701            else
702                concat (canEnc (lp-1) sp str)
703
704
705minExp n e p
706    = if n^e < p
707        then minExp n (e+1) p
708        else e
709
710-- Clause 38.8 in X680 (Canonical ordering of VisibleString characters)
711
712canEnc b sp [] = []
713canEnc b sp (f:r)
714        = let v = (toInteger . length . findV f) sp
715           in minBits (v,b) : canEnc b sp r
716
717findV m []  = []
718findV m (a:rs)
719          = if m == a
720                then []
721                else a : findV m rs
722
723
724
725-- Decoding
726
727n16k = 16*(2^10)
728
729mGetBit o xs =
730   if B.null ys
731      then throwError ("Unable to decode " ++ show xs ++ " at bit " ++ show o)
732      else return u
733   where (nBytes,nBits) = o `divMod` 8
734         ys = B.drop nBytes xs
735         z = B.head ys
736         u = (z .&. ((2^(7 - nBits)))) `shiftR` (fromIntegral (7 - nBits))
737
738-- Very inefficient
739mGetBits o n b = mapM (flip mGetBit b) [o..o+n-1]
740
741mDecodeWithLengthDeterminant k b =
742   do n <- get
743      p <- mGetBit n b
744      case p of
745         -- 10.9.3.6
746         0 ->
747            do j <- mGetBits (n+1) 7 b
748               let l = fromNonNeg j
749               put (n + 8 + l*k)
750               mGetBits (n+8) (l*k) b
751         1 ->
752            do q <- mGetBit (n+1) b
753               case q of
754                  -- 10.9.3.7
755                  0 ->
756                     do j <- mGetBits (n+2) 14 b
757                        let l = fromNonNeg j
758                        put (n + 16 + l*k)
759                        mGetBits (n+16) (l*k) b
760                  1 ->
761                     do j <- mGetBits (n+2) 6 b
762                        let fragSize = fromNonNeg j
763                        if fragSize <= 0 || fragSize > 4
764                           then throwError ("Unable to decode " ++ show b ++ " at bit " ++ show n)
765                           else do frag <- mGetBits (n+8) (fragSize*n16k*k) b
766                                   put (n + 8 + fragSize*n16k*k)
767                                   -- This looks like it might be quadratic in efficiency!
768                                   rest <- mDecodeWithLengthDeterminant k b
769                                   return (frag ++ rest)
770
771mUntoPerInt t b =
772   case p of
773      -- 10.5 Encoding of a constrained whole number
774      Constrained (Just lb) (Just ub) ->
775         let range = ub - lb + 1
776             n     = genericLength (minBits ((ub-lb),range-1)) in
777            if range <= 1
778               -- 10.5.4
779               then return lb
780               -- 10.5.6 and 10.3 Encoding as a non-negative-binary-integer
781               else do offset <- get
782                       put (offset + n)
783                       j <- mGetBits offset (fromIntegral n) b
784                       return (lb + (fromNonNeg j))
785      -- 12.2.3, 10.7 Encoding of a semi-constrained whole number,
786      -- 10.3 Encoding as a non-negative-binary-integer, 12.2.6, 10.9 and 12.2.6 (b)
787      Constrained (Just lb) Nothing ->
788         do o <- mDecodeWithLengthDeterminant 8 b
789            return (lb + (fromNonNeg o))
790      _ -> undefined
791   where
792      p = bounds t
793
794from2sComplement a@(x:xs) =
795   -(x*(2^(l-1))) + sum (zipWith (*) xs ys)
796   where
797      l = length a
798      ys = map (2^) (f (l-2))
799      f 0 = [0]
800      f x = x:(f (x-1))
801
802fromNonNeg xs =
803   sum (zipWith (*) (map fromIntegral xs) ys)
804   where
805      l = genericLength xs
806      ys = map (2^) (f (l-1))
807      f 0 = [0]
808      f x = x:(f (x-1))
809
810
811
812
813{-
814FooBaz {1 2 0 0 6 3} DEFINITIONS ::=
815   BEGIN
816      T1 ::= INTEGER (25..30)
817      Test1 ::=
818         SEQUENCE {
819            first  T1,
820            second T1
821         }
822      Test2 ::=
823         SEQUENCE {
824            first  T1 OPTIONAL,
825            second T1 OPTIONAL
826         }
827   END
828-}
829
830t0 = INTEGER []
831t01 = INTEGER [(Context,0,Implicit)]
832t02 = INTEGER [(Context,2, Implicit)]
833t03 = INTEGER [(Context, 3, Implicit)]
834t04 = INTEGER [(Context, 4, Implicit)]
835t1 = Range [(Context,1,Implicit)] (INTEGER []) (Just 25) (Just 30)
836t2 = Includes [] (INTEGER []) t1
837t3 = Includes [] t1 t1
838t4 = Range [] (INTEGER []) (Just (-256)) Nothing
839t41 = Range [] (INTEGER []) (Just 0) (Just 18000)
840t42 = Range [] (INTEGER []) (Just 3) (Just 3)
841t5 = SEQUENCE [] (Cons t4 (Cons t4 Nil))
842t6 = SEQUENCE [] (Cons t1 (Cons t1 Nil))
843t7 = SIZE [] (SEQUENCEOF [] t1) (Just 3) (Just 5)
844t8 = SIZE [] (SEQUENCEOF [] t5) (Just 2) (Just 2)
845t9 = SEQUENCE [] (Optional t4 (Cons t4 Nil))
846t10 = SIZE [] (SEQUENCEOF [] t9) (Just 1) (Just 3)
847t11 = CHOICE [] (ChoiceOption t0 (ChoiceOption t1 (ChoiceOption t01 (ChoiceOption t02 NoChoice))))
848t12 = CHOICE [] (ChoiceOption t04 (ChoiceOption t03 NoChoice))
849
850-- Unconstrained INTEGER
851integer1 = toPer (INTEGER []) 4096
852integer2 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 127
853integer3 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) (-128)
854integer4 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 128
855
856
857-- Semi-constrained INTEGER
858
859tInteger5 = Range [] (INTEGER []) (Just (-1)) Nothing
860vInteger5 = 4096
861integer5  = toPer (Range [] (INTEGER []) (Just (-1)) Nothing) 4096
862tInteger6 = Range [] (INTEGER []) (Just 1) Nothing
863vInteger6 = 127
864integer6  = toPer (Range [] (INTEGER []) (Just 1) Nothing) 127
865tInteger7 = Range [] (INTEGER []) (Just 0) Nothing
866vInteger7 = 128
867integer7  = toPer (Range [] (INTEGER []) (Just 0) Nothing) 128
868
869-- Constrained INTEGER
870
871integer8'1 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 3
872integer8'2 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 4
873integer8'3 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 5
874integer8'4 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 6
875integer9'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4002
876integer9'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4006
877integer10'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4002
878integer10'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4006
879integer11'1 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 0
880integer11'2 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 31000
881integer11'3 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 32000
882integer12'1 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 1
883integer12'2 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 257
884integer12'3 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 65538
885
886
887
888test0 = toPer t1 27
889
890-- BITSTRING
891
892bsTest1 = toPer (BITSTRING []) (BitString [1,1,0,0,0,1,0,0,0,0])
893
894-- Size-constrained BITSTRING
895
896bsTest2 = toPer (SIZE [] (BITSTRING []) (Just 7) (Just 7)) (BitString [1,1,0,0,0,1,0,0,0,0])
897bsTest3 = toPer (SIZE [] (BITSTRING []) (Just 12) (Just 15)) (BitString [1,1,0,0,0,1,0,0,0,0])
898
899
900-- SEQUENCE
901test1 = toPer (SEQUENCE [] (Cons (SEQUENCE [] (Cons t1 Nil)) Nil)) ((27:*:Empty):*:Empty)
902test2 = toPer (SEQUENCE [] (Cons t1 (Cons t1 Nil))) (29:*:(30:*:Empty))
903test2a = encodeSeqAux [] [] (Cons t1 (Cons t1 Nil)) (29:*:(30:*:Empty))
904test20 = toPer (SEQUENCE [] (Cons t1 (Cons t1 (Cons t1 Nil)))) (29:*:(30:*:(26:*:Empty)))
905test3 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil))) ((Just 29):*:((Just 30):*:Empty))
906test3a = encodeSeqAux [] [] (Optional t1 (Optional t1 Nil)) ((Just 29):*:((Just 30):*:Empty))
907petest2 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil)))
908
909test4 = petest2 ((Just 29):*:((Just 30):*:Empty))
910test5 = petest2 (Nothing:*:((Just 30):*:Empty))
911test6 = petest2 ((Just 29):*:(Nothing:*:Empty))
912test7 = petest2 (Nothing:*:(Nothing:*:Empty))
913
914-- SEQUENCEOF
915test8 = toPer (SEQUENCEOF [] t1) [26,27,28,25]
916test9 = toPer (SEQUENCEOF [] t6) [29:*:(30:*:Empty),28:*:(28:*:Empty)]
917test10
918    = do
919        c <- return (toPer (SEQUENCEOF [] t41) (take (17000) [1,2..]))
920        writeFile "test12.txt" (show c)
921
922test11
923    = do
924        c <- return (toPer (SEQUENCEOF [] t42) (take (17000) [3..]))
925        writeFile "test14.txt" (show c)
926
927test12
928    = do
929        c <- return (toPer (SEQUENCEOF [] t42) (take (93000) [3..]))
930        writeFile "test15.txt" (show c)
931
932-- SIZE-CONSTRAINED SEQUENCEOF
933
934test14 = toPer t7 [26,25,28,27]
935
936test15 = toPer t8 [(29:*:(30:*:Empty)),((-10):*:(2:*:Empty))]
937
938test16 = toPer t10 [(Just (-10):*:(2:*:Empty))]
939
940-- SET tests
941
942test17  = toPer (SET [] (Cons t1 (Cons t0 Nil))) (27 :*: (5 :*: Empty))
943test17a = toPer (SEQUENCE [] (Cons t1 (Cons t0 Nil))) (27 :*: (5 :*: Empty))
944test17b = encodeSeqAux [] [] (Cons t1 (Cons t0 Nil)) (27 :*: (5 :*: Empty))
945
946test18  = toPer (SET [] (Optional t1 (Optional t0 Nil))) ((Just 29):*:(Nothing:*:Empty))
947test18a = toPer (SEQUENCE [] (Optional t1 (Optional t0 Nil))) ((Just 29):*:(Nothing:*:Empty))
948test18b = encodeSeqAux [] [] (Optional t1 (Optional t0 Nil)) ((Just 29):*:(Nothing:*:Empty))
949
950test19 = toPer (SET [] (Optional t1 (Optional t0 (Optional t01 Nil))))
951                ((Just 29):*: ((Just 19):*:(Nothing:*:Empty)))
952test19a = toPer (SEQUENCE [] (Optional t1 (Optional t0 (Optional t01 Nil))))
953                ((Just 29):*: ((Just 19):*:(Nothing:*:Empty)))
954test19b = encodeSeqAux [] [] (Optional t1 (Optional t0 (Optional t01 Nil)))
955                ((Just 29):*: ((Just 19):*:(Nothing:*:Empty)))
956
957-- CHOICE tests
958
959test20c  = toPer (CHOICE [] (ChoiceOption t0 (ChoiceOption t1 (ChoiceOption t01 (ChoiceOption t02 NoChoice)))))
960            (Nothing :*: (Just 27 :*: (Nothing :*: (Nothing :*: Empty))))
961
962test21c  = toPer (CHOICE [] (ChoiceOption t0 NoChoice)) (Just 31 :*: Empty)
963
964test22c
965  = toPer (CHOICE [] (ChoiceOption t0 (ChoiceOption t12 NoChoice)))
966             (Nothing :*: (Just (Just 52 :*: (Nothing :*: Empty)) :*: Empty))
967
968test23c
969    = toPer (CHOICE [] (ChoiceOption t11 (ChoiceOption t12 NoChoice)))
970        (Just (Nothing :*: (Just 27 :*: (Nothing :*: (Nothing :*: Empty))))
971            :*: (Nothing :*: Empty))
972
973-- VISIBLESTRING tests
974
975testvs1 = toPer (VISIBLESTRING []) (VisibleString "Director")
976
977-- VISIBLESTRING with permitted alphabet constraint and size constraints tests
978
979x = (SIZE [] (FROM [] (VISIBLESTRING []) (VisibleString ['0'..'9'])) (Just 8) (Just 8))
980
981testvsc1 = toPer x (VisibleString "19710917")
982
983-- X691: A.2.1 Example
984
985prTest = toPer personnelRecord pr
986
987pr = (emp :*: (t :*: (num :*: (hiredate :*: (sp :*: (Just cs :*: Empty))))))
988
989personnelRecord
990    = SET [(Application, 0, Implicit)]
991        (Cons name (Cons title (Cons number (Cons date (Cons spouse (Default children [] Nil))))))
992
993name
994    = SEQUENCE [(Application, 1, Implicit)]
995        (Cons givenName (Cons initial (Cons familyName Nil)))
996
997title
998    = VISIBLESTRING [(Context, 0, Explicit)]
999
1000t = VisibleString "Director"
1001
1002number
1003    = INTEGER [(Application, 2, Implicit)]
1004
1005num = 51
1006
1007date
1008    = (SIZE [(Context, 1, Explicit),(Application, 3, Implicit)]
1009            (FROM [] (VISIBLESTRING []) (VisibleString ['0'..'9'])) (Just 8) (Just 8))
1010
1011hiredate = VisibleString "19710917"
1012
1013spouse
1014    = SEQUENCE [(Context, 2, Explicit),(Application, 1, Implicit)]
1015        (Cons givenName (Cons initial (Cons familyName Nil)))
1016
1017spGN = VisibleString "Mary"
1018
1019spI  = VisibleString "T"
1020
1021spFN = VisibleString "Smith"
1022
1023sp = (spGN :*: (spI :*: (spFN :*: Empty)))
1024
1025children
1026    = SEQUENCEOF [(Context, 3, Implicit)] childInfo
1027
1028
1029c1GN = VisibleString "Ralph"
1030c1I  = VisibleString "T"
1031c1FN = VisibleString "Smith"
1032c1BD = VisibleString "19571111"
1033
1034c2GN = VisibleString "Susan"
1035c2I  = VisibleString "B"
1036c2FN = VisibleString "Jones"
1037c2BD = VisibleString "19590717"
1038
1039c1 = ((c1GN :*: (c1I :*: (c1FN :*: Empty))) :*: (c1BD :*: Empty))
1040c2 = ((c2GN :*: (c2I :*: (c2FN :*: Empty))) :*: (c2BD :*: Empty))
1041
1042cs = [c1,c2]
1043
1044childInfo
1045    = SET [] (Cons name (Cons birthDate Nil))
1046
1047birthDate
1048    = (SIZE [(Context, 0, Explicit),(Application, 3, Implicit)]
1049            (FROM [] (VISIBLESTRING []) (VisibleString ['0'..'9'])) (Just 8) (Just 8))
1050
1051
1052givenName
1053    = (SIZE []
1054            (FROM [] (VISIBLESTRING []) (VisibleString (['a'..'z'] ++ ['A'..'Z'] ++ ['-','.'])) )
1055                            (Just 1) (Just 64))
1056
1057empGN = VisibleString "John"
1058
1059familyName
1060    = givenName
1061
1062empFN = VisibleString "Smith"
1063
1064initial
1065    = (SIZE []
1066            (FROM [] (VISIBLESTRING [])(VisibleString (['a'..'z'] ++ ['A'..'Z'] ++ ['-','.'])) )
1067                (Just 1) (Just 1))
1068
1069empI = VisibleString "P"
1070
1071emp = (empGN :*: (empI :*: (empFN :*: Empty)))
1072
1073-- Decoding
1074
1075-- Tests for constrained INTEGERs
1076-- ** uncompTest1 = runState (runErrorT (untoPerInt (Range INTEGER (Just 3) (Just 6)) (B.pack [0xc0,0,0,0]))) 0
1077mUncompTest1 = runState (runErrorT (mUntoPerInt (Range [] (INTEGER []) (Just 3) (Just 6)) (B.pack [0xc0,0,0,0]))) 0
1078
1079-- These tests are wrong
1080-- uncompTest2 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x18,0,1,1]))) 0
1081-- uncompTest3 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x81,0x80,0,0]))) 0
1082
1083
1084-- Tests for semi-constrained INTEGERs
1085-- We need to replace decodeLengthDeterminant with untoPerInt
1086-- ** unInteger5 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x02,0x10,0x01]))) 0
1087mUnInteger5 = runState (runErrorT (mUntoPerInt (Range [] (INTEGER []) (Just (-1)) Nothing) (B.pack [0x02,0x10,0x01]))) 0
1088
1089{-
1090**
1091decodeEncode :: BitStream -> BitStream
1092decodeEncode x =
1093   case runTest x 0 of
1094      (Left _,_)   -> undefined
1095      (Right xs,_) -> xs
1096   where
1097      runTest = runState . runErrorT . decodeLengthDeterminant . B.pack . map (fromIntegral . fromNonNeg) . groupBy 8
1098-}
1099
1100mDecodeEncode :: ConstrainedType Integer -> BitStream -> Integer
1101mDecodeEncode t x =
1102   case runTest x 0 of
1103      (Left _,_)   -> undefined
1104      (Right xs,_) -> xs
1105   where
1106      runTest = runState . runErrorT . mUntoPerInt t . B.pack . map (fromIntegral . fromNonNeg) . groupBy 8
1107
1108{-
1109**
1110unSemi5 = decodeEncode integer5
1111semi5 = drop 8 integer5
1112semiTest5 = semi5 == unSemi5
1113-}
1114
1115mUnSemi5 = mDecodeEncode tInteger5 integer5
1116mSemiTest5 = vInteger5 == mUnSemi5
1117{-
1118**
1119unSemi6 = decodeEncode integer6
1120semi6 = drop 8 integer6
1121semiTest6 = semi6 == unSemi6
1122-}
1123
1124mUnSemi6 = mDecodeEncode tInteger6 integer6
1125mSemiTest6 = vInteger6 == mUnSemi6
1126
1127{-
1128**
1129unSemi7 = decodeEncode integer7
1130semi7 = drop 8 integer7
1131semiTest7 = semi7 == unSemi7
1132-}
1133
1134mUnSemi7 = mDecodeEncode tInteger7 integer7
1135mSemiTest7 = vInteger7 == mUnSemi7
1136
1137-- This used to give the wrong answer presumably because we were using Int
1138
1139{-
1140**
1141wrong = toPer (Range INTEGER (Just 0) Nothing) (256^4)
1142unWrong = decodeEncode wrong
1143wrongTest = drop 8 wrong == unWrong
1144-}
1145
1146natural = Range [] (INTEGER []) (Just 0) Nothing
1147
1148longIntegerVal1 = 256^4
1149longIntegerPER1 = toPer natural longIntegerVal1
1150mUnLong1 = mDecodeEncode natural longIntegerPER1
1151mUnLongTest1 = longIntegerVal1 == mUnLong1
1152
1153{-
1154**
1155longer = toPer (Range INTEGER (Just 0) Nothing) (256^128)
1156unLonger = decodeEncode longer
1157longerTest = drop 16 longer == unLonger
1158-}
1159
1160longIntegerVal2 = 256^128
1161longIntegerPER2 = toPer natural longIntegerVal2
1162mUnLong2 = mDecodeEncode natural longIntegerPER2
1163mUnLongTest2 = longIntegerVal2 == mUnLong2
1164
1165{-
1166**
1167longer1 = toPer (Range INTEGER (Just 0) Nothing) (256^(2^11))
1168unLonger1 = decodeEncode longer1
1169longerTest1 = drop 16 longer1 == unLonger1
1170-}
1171
1172longIntegerVal3 = 256^(2^11)
1173longIntegerPER3 = toPer natural longIntegerVal3
1174mUnLong3 = mDecodeEncode natural longIntegerPER3
1175mUnLongTest3 = longIntegerVal3 == mUnLong3
1176
1177foo =
1178   do h <- openFile "test" ReadMode
1179      b <- B.hGetContents h
1180      let d =  runState (runErrorT (mUntoPerInt (Range []  (INTEGER []) (Just 25) (Just 30)) b)) 0
1181      case d of
1182         (Left e,s)  -> return (e ++ " " ++ show s)
1183         (Right n,s) -> return (show n ++ " " ++ show s)