Subject: Darcs Hangs
Newsgroups: gmane.comp.version-control.darcs.user
Date: 2007-08-15 18:40:53 GMT (1 year, 46 weeks, 1 day, 9 hours and 1 minute ago)
I'm applying a patch to a repository but so far it's been running for 37 minutes. Is this normal? I've tried it on 2 different machines. The repository is here http://www.haskell.org/asn1. And the patch is attached. Thanks, Dominic.
New patches:
[Updates to allow for tag information in types. Imported ASN1 module where tag types defined and updated all relavant function and test suite to allow for extra tag input.
djrussell <at> kingston.ac.uk**20070719102716] {
hunk ./attempt5.hs 13
+import Language.ASN1 hiding (Optional, BitString, PrintableString, IA5String)
hunk ./attempt5.hs 93
- INTEGER :: ConstrainedType Int
- BITSTRING :: ConstrainedType BitString
- PRINTABLESTRING :: ConstrainedType PrintableString
- IA5STRING :: ConstrainedType IA5String
- Single :: SingleValue a => ConstrainedType a -> a -> ConstrainedType a
- Includes :: ContainedSubtype a => ConstrainedType a -> ConstrainedType a -> ConstrainedType a
- Range :: (Ord a, ValueRange a) => ConstrainedType a -> Maybe a -> Maybe a -> ConstrainedType a
- SEQUENCE :: Sequence a -> ConstrainedType a
- SEQUENCEOF :: ConstrainedType a -> ConstrainedType [a]
- SIZE :: SizeConstraint a => ConstrainedType a -> Lower -> Upper -> ConstrainedType a
+ INTEGER :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType Int
+ BITSTRING :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType BitString
+ PRINTABLESTRING :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType PrintableString
+ IA5STRING :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType IA5String
+ Single :: SingleValue a => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> a -> ConstrainedType a
+ Includes :: ContainedSubtype a => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> ConstrainedType a -> ConstrainedType a
+ Range :: (Ord a, ValueRange a) => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> Maybe a -> Maybe a -> ConstrainedType a
+ SEQUENCE :: [(TagType, TagValue, TagPlicity)] -> Sequence a -> ConstrainedType a
+ SEQUENCEOF :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> ConstrainedType [a]
+ SIZE :: SizeConstraint a => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> Lower -> Upper -> ConstrainedType a
hunk ./attempt5.hs 146
-bounds INTEGER = Constrained Nothing Nothing
-bounds (Includes t1 t2) =
- (bounds t1) `mappend` (bounds t2)
-bounds (Range t l u) =
- (bounds t) `mappend` (Constrained l u)
-bounds (SEQUENCEOF x) = Constrained Nothing Nothing
-bounds (SIZE t l u) = Constrained Nothing Nothing
+bounds (INTEGER _) = Constrained Nothing Nothing
+bounds (Includes _ t1 t2) = (bounds t1) `mappend` (bounds t2)
+bounds (Range _ t l u) = (bounds t) `mappend` (Constrained l u)
+bounds (SEQUENCEOF _ x) = Constrained Nothing Nothing
+bounds (SIZE _ t l u) = Constrained Nothing Nothing
hunk ./attempt5.hs 156
-sizeLimit (SIZE t l u) = Constrained l u
-sizeLimit _ = Constrained Nothing Nothing
+sizeLimit (SIZE _ _ l u) = Constrained l u
+sizeLimit _ = Constrained Nothing Nothing
hunk ./attempt5.hs 162
-toPer INTEGER x = encodeInt INTEGER x
-toPer r <at> (Range INTEGER l u) x = encodeInt r x
-toPer (SEQUENCE s) x = encodeSeq s x
-toPer t <at> (SEQUENCEOF s) xs = encodeSO t xs
-toPer t <at> (SIZE (SEQUENCEOF c) l u) x = encodeSO t x
+toPer t <at> (INTEGER tgs) x = encodeInt t x
+toPer r <at> (Range tgs1 (INTEGER tgs2) l u) x = encodeInt r x
+toPer (SEQUENCE tgs s) x = encodeSeq s x
+toPer t <at> (SEQUENCEOF tgs s) xs = encodeSO t xs
+toPer t <at> (SIZE tgs1 (SEQUENCEOF tgs2 c) l u) x = encodeSO t x
hunk ./attempt5.hs 316
-encodeSeqSz t <at> (SIZE ty _ _) l u x
+encodeSeqSz t <at> (SIZE tgs ty _ _) l u x
hunk ./attempt5.hs 329
-encodeSeqOf (SEQUENCEOF s) xs
+encodeSeqOf (SEQUENCEOF tgs s) xs
hunk ./attempt5.hs 373
-encodeNoL (SEQUENCEOF s) xs
+encodeNoL (SEQUENCEOF _ s) xs
hunk ./attempt5.hs 472
-t1 = Range INTEGER (Just 25) (Just 30)
-t2 = Includes INTEGER t1
-t3 = Includes t1 t1
-t4 = Range INTEGER (Just (-256)) Nothing
-t41 = Range INTEGER (Just 0) (Just 18000)
-t42 = Range INTEGER (Just 3) (Just 3)
-t5 = SEQUENCE (Cons t4 (Cons t4 Nil))
-t6 = SEQUENCE (Cons t1 (Cons t1 Nil))
-t7 = SIZE (SEQUENCEOF t1) (Just 3) (Just 5)
-t8 = SIZE (SEQUENCEOF t5) (Just 2) (Just 2)
-t9 = SEQUENCE (Optional t4 (Cons t4 Nil))
-t10 = SIZE (SEQUENCEOF t9) (Just 1) (Just 3)
+t1 = Range [] (INTEGER []) (Just 25) (Just 30)
+t2 = Includes [] (INTEGER []) t1
+t3 = Includes [] t1 t1
+t4 = Range [] (INTEGER []) (Just (-256)) Nothing
+t41 = Range [] (INTEGER []) (Just 0) (Just 18000)
+t42 = Range [] (INTEGER []) (Just 3) (Just 3)
+t5 = SEQUENCE [] (Cons t4 (Cons t4 Nil))
+t6 = SEQUENCE [] (Cons t1 (Cons t1 Nil))
+t7 = SIZE [] (SEQUENCEOF [] t1) (Just 3) (Just 5)
+t8 = SIZE [] (SEQUENCEOF [] t5) (Just 2) (Just 2)
+t9 = SEQUENCE [] (Optional t4 (Cons t4 Nil))
+t10 = SIZE [] (SEQUENCEOF [] t9) (Just 1) (Just 3)
hunk ./attempt5.hs 486
-integer1 = toPer INTEGER 4096
-integer2 = toPer (Range INTEGER Nothing (Just 65535)) 127
-integer3 = toPer (Range INTEGER Nothing (Just 65535)) (-128)
-integer4 = toPer (Range INTEGER Nothing (Just 65535)) 128
+integer1 = toPer (INTEGER []) 4096
+integer2 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 127
+integer3 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) (-128)
+integer4 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 128
hunk ./attempt5.hs 494
-integer5 = toPer (Range INTEGER (Just (-1)) Nothing) 4096
-integer6 = toPer (Range INTEGER (Just 1) Nothing) 127
-integer7 = toPer (Range INTEGER (Just 0) Nothing) 128
+integer5 = toPer (Range [] (INTEGER []) (Just (-1)) Nothing) 4096
+integer6 = toPer (Range [] (INTEGER []) (Just 1) Nothing) 127
+integer7 = toPer (Range [] (INTEGER []) (Just 0) Nothing) 128
hunk ./attempt5.hs 500
-integer8'1 = toPer (Range INTEGER (Just 3) (Just 6)) 3
-integer8'2 = toPer (Range INTEGER (Just 3) (Just 6)) 4
-integer8'3 = toPer (Range INTEGER (Just 3) (Just 6)) 5
-integer8'4 = toPer (Range INTEGER (Just 3) (Just 6)) 6
-integer9'1 = toPer (Range INTEGER (Just 4000) (Just 4254)) 4002
-integer9'2 = toPer (Range INTEGER (Just 4000) (Just 4254)) 4006
-integer10'1 = toPer (Range INTEGER (Just 4000) (Just 4255)) 4002
-integer10'2 = toPer (Range INTEGER (Just 4000) (Just 4255)) 4006
-integer11'1 = toPer (Range INTEGER (Just 0) (Just 32000)) 0
-integer11'2 = toPer (Range INTEGER (Just 0) (Just 32000)) 31000
-integer11'3 = toPer (Range INTEGER (Just 0) (Just 32000)) 32000
-integer12'1 = toPer (Range INTEGER (Just 1) (Just 65538)) 1
-integer12'2 = toPer (Range INTEGER (Just 1) (Just 65538)) 257
-integer12'3 = toPer (Range INTEGER (Just 1) (Just 65538)) 65538
+integer8'1 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 3
+integer8'2 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 4
+integer8'3 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 5
+integer8'4 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 6
+integer9'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4002
+integer9'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4006
+integer10'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4002
+integer10'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4006
+integer11'1 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 0
+integer11'2 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 31000
+integer11'3 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 32000
+integer12'1 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 1
+integer12'2 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 257
+integer12'3 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 65538
hunk ./attempt5.hs 522
-test1 = toPer (SEQUENCE (Cons (SEQUENCE (Cons t1 Nil)) Nil)) ((27:*:Empty):*:Empty)
-test2 = toPer (SEQUENCE (Cons t1 (Cons t1 Nil))) (29:*:(30:*:Empty))
-test20 = toPer (SEQUENCE (Cons t1 (Cons t1 (Cons t1 Nil)))) (29:*:(30:*:(26:*:Empty)))
-test3 = toPer (SEQUENCE (Optional t1 (Optional t1 Nil))) ((Just 29):*:((Just 30):*:Empty))
-petest2 = toPer (SEQUENCE (Optional t1 (Optional t1 Nil)))
+test1 = toPer (SEQUENCE [] (Cons (SEQUENCE [] (Cons t1 Nil)) Nil)) ((27:*:Empty):*:Empty)
+test2 = toPer (SEQUENCE [] (Cons t1 (Cons t1 Nil))) (29:*:(30:*:Empty))
+test20 = toPer (SEQUENCE [] (Cons t1 (Cons t1 (Cons t1 Nil)))) (29:*:(30:*:(26:*:Empty)))
+test3 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil))) ((Just 29):*:((Just 30):*:Empty))
+petest2 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil)))
hunk ./attempt5.hs 534
-test8 = toPer (SEQUENCEOF t1) [26,27,28,25]
-test9 = toPer (SEQUENCEOF t6) [29:*:(30:*:Empty),28:*:(28:*:Empty)]
+test8 = toPer (SEQUENCEOF [] t1) [26,27,28,25]
+test9 = toPer (SEQUENCEOF [] t6) [29:*:(30:*:Empty),28:*:(28:*:Empty)]
hunk ./attempt5.hs 538
- c <- return (toPer (SEQUENCEOF t41) (take (17000) [1,2..]))
+ c <- return (toPer (SEQUENCEOF [] t41) (take (17000) [1,2..]))
hunk ./attempt5.hs 543
- c <- return (toPer (SEQUENCEOF t42) (take (17000) [3..]))
+ c <- return (toPer (SEQUENCEOF [] t42) (take (17000) [3..]))
hunk ./attempt5.hs 548
- c <- return (toPer (SEQUENCEOF t42) (take (93000) [3..]))
+ c <- return (toPer (SEQUENCEOF [] t42) (take (93000) [3..]))
hunk ./attempt5.hs 559
-uncompTest1 = runState (untoPerInt (Range INTEGER (Just 3) (Just 6)) (B.pack [0xc0,0,0,0])) 0
+uncompTest1 = runState (untoPerInt (Range [] (INTEGER []) (Just 3) (Just 6)) (B.pack [0xc0,0,0,0])) 0
hunk ./attempt5.hs 569
-wrong = toPer (Range INTEGER (Just 0) Nothing) (256^4)
+wrong = toPer (Range [] (INTEGER []) (Just 0) Nothing) (256^4)
}
[Added SET constructor to ConstrainedType and simplified the definition of bounds to 4 cases.
djrussell <at> kingston.ac.uk**20070719103319] {
hunk ./attempt5.hs 103
-
+ SET :: [(TagType, TagValue, TagPlicity)] -> Sequence a -> ConstrainedType a
hunk ./attempt5.hs 149
-bounds (SEQUENCEOF _ x) = Constrained Nothing Nothing
-bounds (SIZE _ t l u) = Constrained Nothing Nothing
+bounds _ = Constrained Nothing Nothing
+
}
[Type aliases for tag types.
djrussell <at> kingston.ac.uk**20070719123945] {
hunk ./attempt5.hs 90
+-- Type Aliases for Tag Information
+type TagInfo = (TagType, TagValue, TagPlicity)
+type TagHistory = [TagInfo]
+
hunk ./attempt5.hs 97
- INTEGER :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType Int
- BITSTRING :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType BitString
- PRINTABLESTRING :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType PrintableString
- IA5STRING :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType IA5String
- Single :: SingleValue a => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> a -> ConstrainedType a
- Includes :: ContainedSubtype a => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> ConstrainedType a -> ConstrainedType a
- Range :: (Ord a, ValueRange a) => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> Maybe a -> Maybe a -> ConstrainedType a
- SEQUENCE :: [(TagType, TagValue, TagPlicity)] -> Sequence a -> ConstrainedType a
- SEQUENCEOF :: [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> ConstrainedType [a]
- SIZE :: SizeConstraint a => [(TagType, TagValue, TagPlicity)] -> ConstrainedType a -> Lower -> Upper -> ConstrainedType a
- SET :: [(TagType, TagValue, TagPlicity)] -> Sequence a -> ConstrainedType a
+ INTEGER :: TagHistory -> ConstrainedType Int
+ BITSTRING :: TagHistory -> ConstrainedType BitString
+ PRINTABLESTRING :: TagHistory -> ConstrainedType PrintableString
+ IA5STRING :: TagHistory -> ConstrainedType IA5String
+ Single :: SingleValue a => TagHistory -> ConstrainedType a -> a -> ConstrainedType a
+ Includes :: ContainedSubtype a => TagHistory -> ConstrainedType a -> ConstrainedType a -> ConstrainedType a
+ Range :: (Ord a, ValueRange a) => TagHistory -> ConstrainedType a -> Maybe a -> Maybe a -> ConstrainedType a
+ SEQUENCE :: TagHistory -> Sequence a -> ConstrainedType a
+ SEQUENCEOF :: TagHistory -> ConstrainedType a -> ConstrainedType [a]
+ SIZE :: SizeConstraint a => TagHistory -> ConstrainedType a -> Lower -> Upper -> ConstrainedType a
+ SET :: TagHistory -> Sequence a -> ConstrainedType a
}
[Changes to ASN1 module -- adding Ord to derived type classes.
djrussell <at> kingston.ac.uk**20070724102802] {
hunk ./Language/ASN1.hs 6
---
+--
hunk ./Language/ASN1.hs 75
- deriving (Eq,Show, Enum)
+ deriving (Eq,Ord, Show, Enum)
hunk ./Language/ASN1.hs 80
- deriving (Eq,Show)
+ deriving (Eq,Ord,Show)
hunk ./Language/ASN1.hs 87
- | AbsOID
+ | AbsOID
hunk ./Language/ASN1.hs 131
- modTagType :: TagType -> a -> a
+ modTagType :: TagType -> a -> a
hunk ./Language/ASN1.hs 134
- modTagVal x a <at> (AbsBasePrim tt tv at) =
- case x of
+ modTagVal x a <at> (AbsBasePrim tt tv at) =
+ case x of
hunk ./Language/ASN1.hs 142
- modTagVal x a <at> (AbsSeq tt tv tp as) =
+ modTagVal x a <at> (AbsSeq tt tv tp as) =
hunk ./Language/ASN1.hs 157
- modTagType x a <at> (AbsBasePrim tt tv at) =
+ modTagType x a <at> (AbsBasePrim tt tv at) =
hunk ./Language/ASN1.hs 161
- modTagType x a <at> (AbsSeq tt tv tp as) =
+ modTagType x a <at> (AbsSeq tt tv tp as) =
hunk ./Language/ASN1.hs 231
-data DirectoryString = VS VisibleString
+data DirectoryString = VS VisibleString
hunk ./Language/ASN1.hs 260
-absVisibleString =
+absVisibleString =
hunk ./Language/ASN1.hs 320
-oids =
+oids =
}
[Various changes to attempt5 including SET encoding functions and new tests.
djrussell <at> kingston.ac.uk**20070724103302] {
hunk ./attempt5.hs 1
-{-
-A fifth attempt to model subtyping constraints
-
-The encoding is for UNALIGNED PER
--}
-
-import Data.Monoid
-import Data.List hiding (groupBy)
-import Data.Bits
-import Control.Monad.State
-import Control.Monad.Error
-import qualified Data.ByteString.Lazy as B
-import Language.ASN1 hiding (Optional, BitString, PrintableString, IA5String)
-
-data BitString = BitString
- deriving Show
-
-newtype IA5String = IA5String {iA5String :: String}
-
-instance Show IA5String where
- show (IA5String x) = show x
-
-newtype IA5Char = IA5Char {iA5Char :: Char}
-
-class List a b | a -> b where
- nil :: b
- cons :: a -> b -> b
-
-instance List IA5Char IA5String where
- nil = IA5String []
- cons x y = IA5String ((iA5Char x):(iA5String y))
-
-data AlphabetConstraint :: * -> * where
- SingleValueAlpha :: List a b => a -> AlphabetConstraint b
- RangeAlpha :: List a b => a -> a -> AlphabetConstraint b
- UnionAlpha :: AlphabetConstraint a -> AlphabetConstraint a -> AlphabetConstraint a
-
-newtype PrintableString = PrintableString {unPrintableString :: String}
- deriving Show
-
--- X.680 (07/2002) Section 47.1 Table 9
-
-class SingleValue a
-
-instance SingleValue BitString
-instance SingleValue IA5String
-instance SingleValue PrintableString
-instance SingleValue Int
-
-class ContainedSubtype a
-
-instance ContainedSubtype BitString
-instance ContainedSubtype IA5String
-instance ContainedSubtype PrintableString
-instance ContainedSubtype Int
-
-class ValueRange a
-
--- BIT STRING cannot be given value ranges
-instance ValueRange IA5String
-instance ValueRange PrintableString
-instance ValueRange Int
-
-class PermittedAlphabet a
-
--- BIT STRING cannot be given permitted alphabet
-instance PermittedAlphabet IA5String
-instance PermittedAlphabet PrintableString
--- INTEGER cannot be given permitted alphabet
-
-class SizeConstraint a
-
-instance SizeConstraint BitString
-instance SizeConstraint IA5String
-instance SizeConstraint PrintableString
-instance SizeConstraint [a]
--- INTEGER cannot be given a size constraint
-
--- Heterogeneous lists of constrained types
-
-data Nil = Empty
-data a:*:l = a:*:l
-
-data Sequence :: * -> * where
- Nil :: Sequence Nil
- Cons :: ConstrainedType a -> Sequence l -> Sequence (a:*:l)
- Optional :: ConstrainedType a -> Sequence l -> Sequence ((Maybe a):*:l)
- Default :: ConstrainedType a -> Sequence l -> Sequence (a:*:l)
-
--- Type Aliases for Tag Information
-type TagInfo = (TagType, TagValue, TagPlicity)
-type TagHistory = [TagInfo]
-
--- The major data structure itself
-
-data ConstrainedType :: * -> * where
- INTEGER :: TagHistory -> ConstrainedType Int
- BITSTRING :: TagHistory -> ConstrainedType BitString
- PRINTABLESTRING :: TagHistory -> ConstrainedType PrintableString
- IA5STRING :: TagHistory -> ConstrainedType IA5String
- Single :: SingleValue a => TagHistory -> ConstrainedType a -> a -> ConstrainedType a
- Includes :: ContainedSubtype a => TagHistory -> ConstrainedType a -> ConstrainedType a -> ConstrainedType a
- Range :: (Ord a, ValueRange a) => TagHistory -> ConstrainedType a -> Maybe a -> Maybe a -> ConstrainedType a
- SEQUENCE :: TagHistory -> Sequence a -> ConstrainedType a
- SEQUENCEOF :: TagHistory -> ConstrainedType a -> ConstrainedType [a]
- SIZE :: SizeConstraint a => TagHistory -> ConstrainedType a -> Lower -> Upper -> ConstrainedType a
- SET :: TagHistory -> Sequence a -> ConstrainedType a
-{-
- -- Size constraint: there are two sorts modelled by SizeConstraint
- Size :: Sized a => ConstrainedType a -> SizeConstraint -> ConstrainedType a
- -- Alphabet constraint - not quite right see note below
- From :: PermittedAlphabet a => ConstrainedType a -> AlphabetConstraint a -> ConstrainedType a
- -- Regular expression constraint - ignore for now but it would be cool to do them
- -- Constraint on SEQUENCE OF or SET OF - ignore for now until we fix the main datatype
- -- Constraint on SEQUENCE, SET or CHOICE - ignore for now until we fix the main datatype
- -- Subtyping the content of an OCTET STRING - ignore for now
- -- Constraint combinations
- -- Note that we don't need intersections - we need a longer explanation for this
- Union :: ConstrainedType a -> ConstrainedType a -> ConstrainedType a
--}
-
--- dna = From PRINTABLESTRING (SingleValueAlpha (PrintableString "TAGC")) shouldn't typecheck
-
-isExtensible :: ConstrainedType a -> Bool
-isExtensible = undefined
-
-type Upper = Maybe Int
-type Lower = Maybe Int
-
-data Constraint a = Constrained (Maybe a) (Maybe a)
- deriving Show
-
-instance Ord a => Monoid (Constraint a) where
- mempty = Constrained Nothing Nothing
- mappend x y = Constrained (g x y) (f x y)
- where
- f (Constrained _ Nothing) (Constrained _ Nothing) = Nothing
- f (Constrained _ Nothing) (Constrained _ (Just y)) = Just y
- f (Constrained _ (Just x)) (Constrained _ Nothing) = Just x
- f (Constrained _ (Just x)) (Constrained _ (Just y)) = Just (min x y)
- g (Constrained Nothing _) (Constrained Nothing _) = Nothing
- g (Constrained Nothing _) (Constrained (Just y) _) = Just y
- g (Constrained (Just x) _) (Constrained Nothing _) = Just x
- g (Constrained (Just x) _) (Constrained (Just y) _) = Just (max x y)
-
--- bounds returns the range of a value. Nothing indicates
--- no lower or upper bound.
-
-bounds :: Ord a => ConstrainedType a -> Constraint a
-bounds (INTEGER _) = Constrained Nothing Nothing
-bounds (Includes _ t1 t2) = (bounds t1) `mappend` (bounds t2)
-bounds (Range _ t l u) = (bounds t) `mappend` (Constrained l u)
-bounds _ = Constrained Nothing Nothing
-
-
--- sizeLimit returns the size limits of a value. Nothing
--- indicates no lower or upper bound.
-
-sizeLimit :: ConstrainedType a -> Constraint Int
-sizeLimit (SIZE _ _ l u) = Constrained l u
-sizeLimit _ = Constrained Nothing Nothing
-
--- toPer is the top-level PER encoding function.
-
-toPer :: ConstrainedType a -> a -> [Int]
-toPer t <at> (INTEGER tgs) x = encodeInt t x
-toPer r <at> (Range tgs1 (INTEGER tgs2) l u) x = encodeInt r x
-toPer (SEQUENCE tgs s) x = encodeSeq s x
-toPer t <at> (SEQUENCEOF tgs s) xs = encodeSO t xs
-toPer t <at> (SIZE tgs1 (SEQUENCEOF tgs2 c) l u) x = encodeSO t x
-
--- INTEGER ENCODING 10.3 - 10.8
-
-encodeInt :: ConstrainedType Int -> Int -> [Int]
-encodeInt t x =
- case p of
- -- 10.5 Encoding of a constrained whole number
- Constrained (Just lb) (Just ub) ->
- let range = ub - lb + 1 in
- if range <= 1
- -- 10.5.4
- then []
- -- 10.5.6 and 10.3 Encoding as a non-negative-binary-integer
- else minBits ((x-lb),range-1)
- -- 12.2.3, 10.7 Encoding of a semi-constrained whole number,
- -- 10.3 Encoding as a non-negative-binary-integer, 12.2.6, 10.9 and 12.2.6 (b)
- Constrained (Just lb) Nothing ->
- encodeWithLengthDeterminant (minOctets (x-lb))
- -- 12.2.4, 10.8 Encoding of an unconstrained whole number, 10.8.3 and
- -- 10.4 Encoding as a 2's-complement-binary-integer
- Constrained Nothing _ ->
- encodeWithLengthDeterminant (to2sComplement x)
- where
- p = bounds t
-
-
--- minBits encodes a constrained whole number (10.5.6) in the minimum
--- number of bits required for the range (assuming the range is at least 2).
-
-minBits
- = reverse . unfoldr h
- where
- h (_,0) = Nothing
- h (0,w) = Just (0, (0, w `div` 2))
- h (n,w) = Just (n `mod` 2, (n `div` 2, w `div` 2))
-
--- minOctets is used in the encoding of a semi-constrained integer (10.7). It is encoded
--- as a non-negative-binary-integer (10.3, 10.3.6) where the offset
--- from the lower bound is encoded in the minimum number of octets, preceded by
--- (or interspersed with) the encoding of the length (using encodeWithLengthDeterminant)
--- of the octet representation of the offset. (10.7.4)
-
-minOctets :: Int -> [Int]
-minOctets =
- reverse . flip (curry (unfoldr (uncurry g))) 8 where
- g 0 0 = Nothing
- g 0 p = Just (0,(0,p-1))
- g n 0 = Just (n `mod` 2,(n `div` 2,7))
- g n p = Just (n `mod` 2,(n `div` 2,p-1))
-
-
--- 10.9 General rules for encoding a length determinant
--- 10.9.4, 10.9.4.2 and 10.9.3.4 to 10.9.3.8.4.
-encodeWithLengthDeterminant =
- concat . concat . insertLengths . groupBy 4 . groupBy (16*(2^10)) . groupBy 8
-
-groupBy n =
- unfoldr k
- where
- k [] = Nothing
- k p = Just (splitAt n p)
-
-insertLengths = unfoldr k
-
-k [] = Nothing
-k (x:xs)
- | l == n && lm >= l1b = Just (ws,xs)
- | l == 1 && lm < l1b = Just (us,[])
- | otherwise = Just (vs,[])
- where
- l = length x
- m = x!!(l-1)
- lm = length m
- ws = (1:1:(minBits (l,w6))):(concat x)
- us = ld (length m) ++ m
- vs = if lm >= l1b then
- (1:1:(minBits (l,w6))):(concat x ++ ld 0)
- else
- ((1:1:(minBits ((l-1), w6))):(concat (take (l-1) x)) ++ ld (length m) ++ m)
- n = 4
- w6 = 2^6 - 1
- l1b = 16*(2^10)
-
-ld n
--- 10.9.4.2, 10.9.3.5, 10.9.3.6 Note not very efficient since we know log2 128 = 7
- | n <= 127 = [0:(minBits (n, 127))]
--- 10.9.3.7 Note not very efficient since we know log2 16*(2^10) = 14
- | n < 16*(2^10) = [1:0:(minBits (n, (16*(2^10)-1)))]
--- Note there is no clause for >= 16*(2^10) as we have groupBy 16*(2^10)
-
-
--- 10.4 Encoding as a 2's-complement-binary-integer is used when
--- encoding an integer with no lower bound (10.8) as in the final
--- case of encodeInt. The encoding of the integer is accompanied
--- by the encoding of its length using encodeWithLengthDeterminant
--- (10.8.3)
-
-to2sComplement n
- | n >= 0 = 0:(h n)
- | otherwise = minOctets (2^p + n)
- where
- p = length (h (-n-1)) + 1
-
-g (0,0) = Nothing
-g (0,p) = Just (0,(0,p-1))
-g (n,0) = Just (n `rem` 2,(n `quot` 2,7))
-g (n,p) = Just (n `rem` 2,(n `quot` 2,p-1))
-
-h n = reverse (flip (curry (unfoldr g)) 7 n)
-
-
--- 18 ENCODING THE SEQUENCE TYPE
-
-encodeSeq s x = concat (encodeSeqAux [] [] s x)
-
--- encodeSeqAux is the auxillary function for encodeSeq. When
--- encoding a sequence, one has to both encode each component and
--- produce a preamble which indicates the presence or absence of an
--- optional or default value.
-
-encodeSeqAux :: [Int] -> [[Int]] -> Sequence a -> a -> [[Int]]
-encodeSeqAux preamble body Nil _ = (reverse preamble):(reverse body)
-encodeSeqAux preamble body (Cons a as) (x:*:xs) = encodeSeqAux preamble ((toPer a x):body) as xs
-encodeSeqAux preamble body (Optional a as) (Nothing:*:xs) =
- encodeSeqAux (0:preamble) body as xs
-encodeSeqAux preamble body (Optional a as) ((Just x):*:xs) =
- encodeSeqAux (1:preamble) ((toPer a x):body) as xs
-
--- 19. ENCODING THE SEQUENCE-OF TYPE
-
--- encodeSO implements the encoding of an unconstrained
--- sequence-of value. This requires both the encoding of
--- each of the components, and in most cases the encoding
--- of the length of the sequence of (which may require
--- fragmentation into 64K blocks).
-
-encodeSO :: ConstrainedType [a] -> [a] -> [Int]
-encodeSO t x
- = case p of
- Constrained (Just lb) (Just ub) ->
- encodeSeqSz t lb ub x
- Constrained (Just lb) Nothing ->
- encodeSeqOf t x
- Constrained Nothing Nothing ->
- encodeSeqOf t x
- where
- p = sizeLimit t
-
-encodeSeqSz :: ConstrainedType [a] -> Int -> Int -> [a] -> [Int]
-encodeSeqSz t <at> (SIZE tgs ty _ _) l u x
- = let range = u - l + 1
- in
- if range == 1 && u < 65536
---19.5
- then encodeNoL ty x
- else if u >= 65536
---19.6
- then encodeSeqOf ty x
- else minBits ((length x-l),range-1) ++ encodeNoL ty x
-
-
-encodeSeqOf :: ConstrainedType a -> a -> [Int]
-encodeSeqOf (SEQUENCEOF tgs s) xs
- = encodeWithLD s xs
-
--- encodeWithLD splits the components into 16K blocks, and then
--- splits these into blocks of 4 (thus a maximum of 64K in each
--- block). insertL then manages the interleaving of the length-value
--- encoding of the components.
-
-encodeWithLD :: ConstrainedType a -> [a] -> [Int]
-encodeWithLD s
- = concat . insertL s . groupBy 4 . groupBy (16*(2^10))
-
-insertL :: ConstrainedType a -> [[[a]]] -> [[Int]]
-insertL s = unfoldr (sk s)
-
-sk :: ConstrainedType a -> [[[a]]] -> Maybe ([Int], [[[a]]])
-sk t [] = Nothing
-sk t (x:xs)
- | l == n && lm == l1b = Just (ws,xs)
- | l == 1 && lm < l1b = Just (us,[])
- | otherwise = Just (vs,[])
- where
- l = length x
- m = x!!(l-1)
- lm = length m
- ws = (1:1:(minBits (l,w6)))++ (concat . map (concat . map (toPer t))) x
- us = ld2 (length m) ++ (concat . map (toPer t)) m
- vs = if lm == l1b then
- (1:1:(minBits (l,w6)))++ (concat . map (concat . map (toPer t))) x ++ ld2 0
- else
- (1:1:(minBits ((l-1), w6)))++ (concat . map (concat . map (toPer t)))
- (take (l-1) x) ++ ld2 (length m) ++ (concat . map (toPer t)) m
- n = 4
- w6 = 2^6 - 1
- l1b = 16*(2^10)
-
-ld2 n
- | n <= 127 = 0:(minBits (n, 127))
- | n < 16*(2^10) = 1:0:(minBits (n, (16*(2^10)-1)))
-
-
--- No length encoding of SEQUENCEOF
-
-encodeNoL :: ConstrainedType a -> a -> [Int]
-encodeNoL (SEQUENCEOF _ s) xs
- = (concat . map (toPer s)) xs
-
-
-decodeLengthDeterminant b =
- do n <- get
- let bit8 = getBit n b
- if null bit8
- then throwError ("Unable to decode " ++ show b ++ " at bit " ++ show n)
- else
- case (head bit8) of
- -- 10.9.3.6
- 0 ->
- do let l = fromNonNeg (getBits (n+1) 7 b)
- put (n + 8 + l*8)
- return (fromNonNeg (getBits (n+8) (l*8) b))
- 1 ->
- do let bit7 = getBit (n+1) b
- if null bit7
- then throwError ("Unable to decode " ++ show b ++ " at bit " ++ show n)
- else case (head bit7) of
- -- 10.9.3.7
- 0 ->
- do let l = fromNonNeg (getBits (n+2) 14 b)
- put (n + 16 + l*8)
- return (fromNonNeg (getBits (n+16) (l*8) b))
- 1 ->
- undefined
-
-
-untoPerInt t b =
- case p of
- -- 10.5 Encoding of a constrained whole number
- Constrained (Just lb) (Just ub) ->
- let range = ub - lb + 1
- n = length (minBits ((ub-lb),range-1)) in
- if range <= 1
- -- 10.5.4
- then return lb
- -- 10.5.6 and 10.3 Encoding as a non-negative-binary-integer
- else do offset <- get
- put (offset + (fromIntegral n))
- return (lb + (fromNonNeg (map fromIntegral (getBits offset (fromIntegral n) b))))
- -- 12.2.3, 10.7 Encoding of a semi-constrained whole number,
- -- 10.3 Encoding as a non-negative-binary-integer, 12.2.6, 10.9 and 12.2.6 (b)
- Constrained (Just lb) Nothing ->
- -- encodeWithLengthDeterminant (minOctets (x-lb))
- undefined
- _ -> undefined
- where
- p = bounds t
-
--- Very inefficient
-getBits o n b =
- map fromIntegral (concat (map (flip getBit b) [o..o+n-1]))
-
-getBit o xs =
- if B.null ys
- then []
- else [u]
- where (nBytes,nBits) = o `divMod` 8
- ys = B.drop nBytes xs
- z = B.head ys
- u = (z .&. ((2^(7 - nBits)))) `shiftR` (fromIntegral (7 - nBits))
-
-
-from2sComplement a <at> (x:xs) =
- -(x*(2^(l-1))) + sum (zipWith (*) xs ys)
- where
- l = length a
- ys = map (2^) (f (l-2))
- f 0 = [0]
- f x = x:(f (x-1))
-
-fromNonNeg xs =
- sum (zipWith (*) xs ys)
- where
- l = length xs
- ys = map (2^) (f (l-1))
- f 0 = [0]
- f x = x:(f (x-1))
-
-{-
-FooBaz {1 2 0 0 6 3} DEFINITIONS ::=
- BEGIN
- T1 ::= INTEGER (25..30)
- Test1 ::=
- SEQUENCE {
- first T1,
- second T1
- }
- Test2 ::=
- SEQUENCE {
- first T1 OPTIONAL,
- second T1 OPTIONAL
- }
- END
--}
-
-t1 = Range [] (INTEGER []) (Just 25) (Just 30)
-t2 = Includes [] (INTEGER []) t1
-t3 = Includes [] t1 t1
-t4 = Range [] (INTEGER []) (Just (-256)) Nothing
-t41 = Range [] (INTEGER []) (Just 0) (Just 18000)
-t42 = Range [] (INTEGER []) (Just 3) (Just 3)
-t5 = SEQUENCE [] (Cons t4 (Cons t4 Nil))
-t6 = SEQUENCE [] (Cons t1 (Cons t1 Nil))
-t7 = SIZE [] (SEQUENCEOF [] t1) (Just 3) (Just 5)
-t8 = SIZE [] (SEQUENCEOF [] t5) (Just 2) (Just 2)
-t9 = SEQUENCE [] (Optional t4 (Cons t4 Nil))
-t10 = SIZE [] (SEQUENCEOF [] t9) (Just 1) (Just 3)
-
--- Unconstrained INTEGER
-integer1 = toPer (INTEGER []) 4096
-integer2 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 127
-integer3 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) (-128)
-integer4 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 128
-
-
--- Semi-constrained INTEGER
-
-integer5 = toPer (Range [] (INTEGER []) (Just (-1)) Nothing) 4096
-integer6 = toPer (Range [] (INTEGER []) (Just 1) Nothing) 127
-integer7 = toPer (Range [] (INTEGER []) (Just 0) Nothing) 128
-
--- Constrained INTEGER
-
-integer8'1 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 3
-integer8'2 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 4
-integer8'3 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 5
-integer8'4 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 6
-integer9'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4002
-integer9'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4006
-integer10'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4002
-integer10'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4006
-integer11'1 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 0
-integer11'2 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 31000
-integer11'3 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 32000
-integer12'1 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 1
-integer12'2 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 257
-integer12'3 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 65538
-
-
-
-test0 = toPer t1 27
-
-
-
--- SEQUENCE
-test1 = toPer (SEQUENCE [] (Cons (SEQUENCE [] (Cons t1 Nil)) Nil)) ((27:*:Empty):*:Empty)
-test2 = toPer (SEQUENCE [] (Cons t1 (Cons t1 Nil))) (29:*:(30:*:Empty))
-test20 = toPer (SEQUENCE [] (Cons t1 (Cons t1 (Cons t1 Nil)))) (29:*:(30:*:(26:*:Empty)))
-test3 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil))) ((Just 29):*:((Just 30):*:Empty))
-petest2 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil)))
-
-test4 = petest2 ((Just 29):*:((Just 30):*:Empty))
-test5 = petest2 (Nothing:*:((Just 30):*:Empty))
-test6 = petest2 ((Just 29):*:(Nothing:*:Empty))
-test7 = petest2 (Nothing:*:(Nothing:*:Empty))
-
--- SEQUENCEOF
-test8 = toPer (SEQUENCEOF [] t1) [26,27,28,25]
-test9 = toPer (SEQUENCEOF [] t6) [29:*:(30:*:Empty),28:*:(28:*:Empty)]
-test10
- = do
- c <- return (toPer (SEQUENCEOF [] t41) (take (17000) [1,2..]))
- writeFile "test12.txt" (show c)
-
-test11
- = do
- c <- return (toPer (SEQUENCEOF [] t42) (take (17000) [3..]))
- writeFile "test14.txt" (show c)
-
-test12
- = do
- c <- return (toPer (SEQUENCEOF [] t42) (take (93000) [3..]))
- writeFile "test15.txt" (show c)
-
--- SIZE-CONSTRAINED SEQUENCEOF
-test14 = toPer t7 [26,25,28,27]
-
-test15 = toPer t8 [(29:*:(30:*:Empty)),((-10):*:(2:*:Empty))]
-
-test16 = toPer t10 [(Just (-10):*:(2:*:Empty))]
-
-
-uncompTest1 = runState (untoPerInt (Range [] (INTEGER []) (Just 3) (Just 6)) (B.pack [0xc0,0,0,0])) 0
-
--- These tests are wrong
--- uncompTest2 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x18,0,1,1]))) 0
--- uncompTest3 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x81,0x80,0,0]))) 0
-
-unInteger5 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x02,0x10,0x01]))) 0
-
--- This gives the wrong answer presumably because we are using Int
-
-wrong = toPer (Range [] (INTEGER []) (Just 0) Nothing) (256^4)
+{-
+A fifth attempt to model subtyping constraints
+
+The encoding is for UNALIGNED PER
+-}
+
+import Data.Monoid
+import Data.List hiding (groupBy)
+import Data.Bits
+import Control.Monad.State
+import Control.Monad.Error
+import qualified Data.ByteString.Lazy as B
+import Language.ASN1 hiding (Optional, BitString, PrintableString, IA5String, ComponentType(Default))
+
+data BitString = BitString
+ deriving Show
+
+newtype IA5String = IA5String {iA5String :: String}
+
+instance Show IA5String where
+ show (IA5String x) = show x
+
+newtype IA5Char = IA5Char {iA5Char :: Char}
+
+class List a b | a -> b where
+ nil :: b
+ cons :: a -> b -> b
+
+instance List IA5Char IA5String where
+ nil = IA5String []
+ cons x y = IA5String ((iA5Char x):(iA5String y))
+
+data AlphabetConstraint :: * -> * where
+ SingleValueAlpha :: List a b => a -> AlphabetConstraint b
+ RangeAlpha :: List a b => a -> a -> AlphabetConstraint b
+ UnionAlpha :: AlphabetConstraint a -> AlphabetConstraint a -> AlphabetConstraint a
+
+newtype PrintableString = PrintableString {unPrintableString :: String}
+ deriving Show
+
+-- X.680 (07/2002) Section 47.1 Table 9
+
+class SingleValue a
+
+instance SingleValue BitString
+instance SingleValue IA5String
+instance SingleValue PrintableString
+instance SingleValue Int
+
+class ContainedSubtype a
+
+instance ContainedSubtype BitString
+instance ContainedSubtype IA5String
+instance ContainedSubtype PrintableString
+instance ContainedSubtype Int
+
+class ValueRange a
+
+-- BIT STRING cannot be given value ranges
+instance ValueRange IA5String
+instance ValueRange PrintableString
+instance ValueRange Int
+
+class PermittedAlphabet a
+
+-- BIT STRING cannot be given permitted alphabet
+instance PermittedAlphabet IA5String
+instance PermittedAlphabet PrintableString
+-- INTEGER cannot be given permitted alphabet
+
+class SizeConstraint a
+
+instance SizeConstraint BitString
+instance SizeConstraint IA5String
+instance SizeConstraint PrintableString
+instance SizeConstraint [a]
+-- INTEGER cannot be given a size constraint
+
+-- Heterogeneous lists of constrained types
+
+data Nil = Empty
+data a:*:l = a:*:l
+
+data Sequence :: * -> * where
+ Nil :: Sequence Nil
+ Cons :: ConstrainedType a -> Sequence l -> Sequence (a:*:l)
+ Optional :: ConstrainedType a -> Sequence l -> Sequence ((Maybe a):*:l)
+ Default :: ConstrainedType a -> Sequence l -> Sequence (a:*:l)
+
+
+
+
+-- Type Aliases for Tag Information
+type TagInfo = (TagType, TagValue, TagPlicity)
+type TagHistory = [TagInfo]
+
+-- The major data structure itself
+
+data ConstrainedType :: * -> * where
+ INTEGER :: TagHistory -> ConstrainedType Int
+ BITSTRING :: TagHistory -> ConstrainedType BitString
+ PRINTABLESTRING :: TagHistory -> ConstrainedType PrintableString
+ IA5STRING :: TagHistory -> ConstrainedType IA5String
+ Single :: SingleValue a => TagHistory -> ConstrainedType a -> a -> ConstrainedType a
+ Includes :: ContainedSubtype a => TagHistory -> ConstrainedType a -> ConstrainedType a -> ConstrainedType a
+ Range :: (Ord a, ValueRange a) => TagHistory -> ConstrainedType a -> Maybe a -> Maybe a -> ConstrainedType a
+ SEQUENCE :: TagHistory -> Sequence a -> ConstrainedType a
+ SEQUENCEOF :: TagHistory -> ConstrainedType a -> ConstrainedType [a]
+ SIZE :: SizeConstraint a => TagHistory -> ConstrainedType a -> Lower -> Upper -> ConstrainedType a
+ SET :: TagHistory -> Sequence a -> ConstrainedType a
+{-
+ -- Size constraint: there are two sorts modelled by SizeConstraint
+ Size :: Sized a => ConstrainedType a -> SizeConstraint -> ConstrainedType a
+ -- Alphabet constraint - not quite right see note below
+ From :: PermittedAlphabet a => ConstrainedType a -> AlphabetConstraint a -> ConstrainedType a
+ -- Regular expression constraint - ignore for now but it would be cool to do them
+ -- Constraint on SEQUENCE OF or SET OF - ignore for now until we fix the main datatype
+ -- Constraint on SEQUENCE, SET or CHOICE - ignore for now until we fix the main datatype
+ -- Subtyping the content of an OCTET STRING - ignore for now
+ -- Constraint combinations
+ -- Note that we don't need intersections - we need a longer explanation for this
+ Union :: ConstrainedType a -> ConstrainedType a -> ConstrainedType a
+-}
+
+-- NEED EVERY CASE IMPLEMENTED
+
+getInfo :: ConstrainedType a -> TagInfo
+getInfo (INTEGER (f:r)) = f
+
+-- dna = From PRINTABLESTRING (SingleValueAlpha (PrintableString "TAGC")) shouldn't typecheck
+
+isExtensible :: ConstrainedType a -> Bool
+isExtensible = undefined
+
+type Upper = Maybe Int
+type Lower = Maybe Int
+
+data Constraint a = Constrained (Maybe a) (Maybe a)
+ deriving Show
+
+instance Ord a => Monoid (Constraint a) where
+ mempty = Constrained Nothing Nothing
+ mappend x y = Constrained (g x y) (f x y)
+ where
+ f (Constrained _ Nothing) (Constrained _ Nothing) = Nothing
+ f (Constrained _ Nothing) (Constrained _ (Just y)) = Just y
+ f (Constrained _ (Just x)) (Constrained _ Nothing) = Just x
+ f (Constrained _ (Just x)) (Constrained _ (Just y)) = Just (min x y)
+ g (Constrained Nothing _) (Constrained Nothing _) = Nothing
+ g (Constrained Nothing _) (Constrained (Just y) _) = Just y
+ g (Constrained (Just x) _) (Constrained Nothing _) = Just x
+ g (Constrained (Just x) _) (Constrained (Just y) _) = Just (max x y)
+
+-- bounds returns the range of a value. Nothing indicates
+-- no lower or upper bound.
+
+bounds :: Ord a => ConstrainedType a -> Constraint a
+bounds (INTEGER _) = Constrained Nothing Nothing
+bounds (Includes _ t1 t2) = (bounds t1) `mappend` (bounds t2)
+bounds (Range _ t l u) = (bounds t) `mappend` (Constrained l u)
+bounds _ = Constrained Nothing Nothing
+
+
+-- sizeLimit returns the size limits of a value. Nothing
+-- indicates no lower or upper bound.
+
+sizeLimit :: ConstrainedType a -> Constraint Int
+sizeLimit (SIZE _ _ l u) = Constrained l u
+sizeLimit _ = Constrained Nothing Nothing
+
+-- toPer is the top-level PER encoding function.
+
+toPer :: ConstrainedType a -> a -> [Int]
+toPer t <at> (INTEGER tgs) x = encodeInt t x
+toPer r <at> (Range tgs1 (INTEGER tgs2) l u) x = encodeInt r x
+toPer (SEQUENCE tgs s) x = encodeSeq s x
+toPer t <at> (SEQUENCEOF tgs s) xs = encodeSO t xs
+toPer t <at> (SIZE tgs1 (SEQUENCEOF tgs2 c) l u) x = encodeSO t x
+toPer (SET tgs s) x = encodeSet s x
+
+-- INTEGER ENCODING 10.3 - 10.8
+
+encodeInt :: ConstrainedType Int -> Int -> [Int]
+encodeInt t x =
+ case p of
+ -- 10.5 Encoding of a constrained whole number
+ Constrained (Just lb) (Just ub) ->
+ let range = ub - lb + 1 in
+ if range <= 1
+ -- 10.5.4
+ then []
+ -- 10.5.6 and 10.3 Encoding as a non-negative-binary-integer
+ else minBits ((x-lb),range-1)
+ -- 12.2.3, 10.7 Encoding of a semi-constrained whole number,
+ -- 10.3 Encoding as a non-negative-binary-integer, 12.2.6, 10.9 and 12.2.6 (b)
+ Constrained (Just lb) Nothing ->
+ encodeWithLengthDeterminant (minOctets (x-lb))
+ -- 12.2.4, 10.8 Encoding of an unconstrained whole number, 10.8.3 and
+ -- 10.4 Encoding as a 2's-complement-binary-integer
+ Constrained Nothing _ ->
+ encodeWithLengthDeterminant (to2sComplement x)
+ where
+ p = bounds t
+
+
+-- minBits encodes a constrained whole number (10.5.6) in the minimum
+-- number of bits required for the range (assuming the range is at least 2).
+
+minBits
+ = reverse . unfoldr h
+ where
+ h (_,0) = Nothing
+ h (0,w) = Just (0, (0, w `div` 2))
+ h (n,w) = Just (n `mod` 2, (n `div` 2, w `div` 2))
+
+-- minOctets is used in the encoding of a semi-constrained integer (10.7). It is encoded
+-- as a non-negative-binary-integer (10.3, 10.3.6) where the offset
+-- from the lower bound is encoded in the minimum number of octets, preceded by
+-- (or interspersed with) the encoding of the length (using encodeWithLengthDeterminant)
+-- of the octet representation of the offset. (10.7.4)
+
+minOctets :: Int -> [Int]
+minOctets =
+ reverse . flip (curry (unfoldr (uncurry g))) 8 where
+ g 0 0 = Nothing
+ g 0 p = Just (0,(0,p-1))
+ g n 0 = Just (n `mod` 2,(n `div` 2,7))
+ g n p = Just (n `mod` 2,(n `div` 2,p-1))
+
+
+-- 10.9 General rules for encoding a length determinant
+-- 10.9.4, 10.9.4.2 and 10.9.3.4 to 10.9.3.8.4.
+encodeWithLengthDeterminant =
+ concat . concat . insertLengths . groupBy 4 . groupBy (16*(2^10)) . groupBy 8
+
+groupBy n =
+ unfoldr k
+ where
+ k [] = Nothing
+ k p = Just (splitAt n p)
+
+insertLengths = unfoldr k
+
+k [] = Nothing
+k (x:xs)
+ | l == n && lm >= l1b = Just (ws,xs)
+ | l == 1 && lm < l1b = Just (us,[])
+ | otherwise = Just (vs,[])
+ where
+ l = length x
+ m = x!!(l-1)
+ lm = length m
+ ws = (1:1:(minBits (l,w6))):(concat x)
+ us = ld (length m) ++ m
+ vs = if lm >= l1b then
+ (1:1:(minBits (l,w6))):(concat x ++ ld 0)
+ else
+ ((1:1:(minBits ((l-1), w6))):(concat (take (l-1) x)) ++ ld (length m) ++ m)
+ n = 4
+ w6 = 2^6 - 1
+ l1b = 16*(2^10)
+
+ld n
+-- 10.9.4.2, 10.9.3.5, 10.9.3.6 Note not very efficient since we know log2 128 = 7
+ | n <= 127 = [0:(minBits (n, 127))]
+-- 10.9.3.7 Note not very efficient since we know log2 16*(2^10) = 14
+ | n < 16*(2^10) = [1:0:(minBits (n, (16*(2^10)-1)))]
+-- Note there is no clause for >= 16*(2^10) as we have groupBy 16*(2^10)
+
+
+-- 10.4 Encoding as a 2's-complement-binary-integer is used when
+-- encoding an integer with no lower bound (10.8) as in the final
+-- case of encodeInt. The encoding of the integer is accompanied
+-- by the encoding of its length using encodeWithLengthDeterminant
+-- (10.8.3)
+
+to2sComplement n
+ | n >= 0 = 0:(h n)
+ | otherwise = minOctets (2^p + n)
+ where
+ p = length (h (-n-1)) + 1
+
+g (0,0) = Nothing
+g (0,p) = Just (0,(0,p-1))
+g (n,0) = Just (n `rem` 2,(n `quot` 2,7))
+g (n,p) = Just (n `rem` 2,(n `quot` 2,p-1))
+
+h n = reverse (flip (curry (unfoldr g)) 7 n)
+
+
+-- 18 ENCODING THE SEQUENCE TYPE
+
+encodeSeq :: Sequence a -> a -> [Int]
+encodeSeq s x = concat (encodeSeqAux [] [] s x)
+
+-- encodeSeqAux is the auxillary function for encodeSeq. When
+-- encoding a sequence, one has to both encode each component and
+-- produce a preamble which indicates the presence or absence of an
+-- optional or default value. The first list in the result is the
+-- preamble.
+
+encodeSeqAux :: [Int] -> [[Int]] -> Sequence a -> a -> [[Int]]
+encodeSeqAux preamble body Nil _ = (reverse preamble):(reverse body)
+encodeSeqAux preamble body (Cons a as) (x:*:xs) = encodeSeqAux preamble ((toPer a x):body) as xs
+encodeSeqAux preamble body (Optional a as) (Nothing:*:xs) =
+ encodeSeqAux (0:preamble) body as xs
+encodeSeqAux preamble body (Optional a as) ((Just x):*:xs) =
+ encodeSeqAux (1:preamble) ((toPer a x):body) as xs
+
+-- 19. ENCODING THE SEQUENCE-OF TYPE
+
+-- encodeSO implements the encoding of an unconstrained
+-- sequence-of value. This requires both the encoding of
+-- each of the components, and in most cases the encoding
+-- of the length of the sequence of (which may require
+-- fragmentation into 64K blocks).
+
+encodeSO :: ConstrainedType [a] -> [a] -> [Int]
+encodeSO t x
+ = case p of
+ Constrained (Just lb) (Just ub) ->
+ encodeSeqSz t lb ub x
+ Constrained (Just lb) Nothing ->
+ encodeSeqOf t x
+ Constrained Nothing Nothing ->
+ encodeSeqOf t x
+ where
+ p = sizeLimit t
+
+encodeSeqSz :: ConstrainedType [a] -> Int -> Int -> [a] -> [Int]
+encodeSeqSz t <at> (SIZE tgs ty _ _) l u x
+ = let range = u - l + 1
+ in
+ if range == 1 && u < 65536
+--19.5
+ then encodeNoL ty x
+ else if u >= 65536
+--19.6
+ then encodeSeqOf ty x
+ else minBits ((length x-l),range-1) ++ encodeNoL ty x
+
+
+encodeSeqOf :: ConstrainedType a -> a -> [Int]
+encodeSeqOf (SEQUENCEOF tgs s) xs
+ = encodeWithLD s xs
+
+-- encodeWithLD splits the components into 16K blocks, and then
+-- splits these into blocks of 4 (thus a maximum of 64K in each
+-- block). insertL then manages the interleaving of the length-value
+-- encoding of the components.
+
+encodeWithLD :: ConstrainedType a -> [a] -> [Int]
+encodeWithLD s
+ = concat . insertL s . groupBy 4 . groupBy (16*(2^10))
+
+insertL :: ConstrainedType a -> [[[a]]] -> [[Int]]
+insertL s = unfoldr (sk s)
+
+sk :: ConstrainedType a -> [[[a]]] -> Maybe ([Int], [[[a]]])
+sk t [] = Nothing
+sk t (x:xs)
+ | l == n && lm == l1b = Just (ws,xs)
+ | l == 1 && lm < l1b = Just (us,[])
+ | otherwise = Just (vs,[])
+ where
+ l = length x
+ m = x!!(l-1)
+ lm = length m
+ ws = (1:1:(minBits (l,w6)))++ (concat . map (concat . map (toPer t))) x
+ us = ld2 (length m) ++ (concat . map (toPer t)) m
+ vs = if lm == l1b then
+ (1:1:(minBits (l,w6)))++ (concat . map (concat . map (toPer t))) x ++ ld2 0
+ else
+ (1:1:(minBits ((l-1), w6)))++ (concat . map (concat . map (toPer t)))
+ (take (l-1) x) ++ ld2 (length m) ++ (concat . map (toPer t)) m
+ n = 4
+ w6 = 2^6 - 1
+ l1b = 16*(2^10)
+
+ld2 n
+ | n <= 127 = 0:(minBits (n, 127))
+ | n < 16*(2^10) = 1:0:(minBits (n, (16*(2^10)-1)))
+
+
+-- No length encoding of SEQUENCEOF
+
+encodeNoL :: ConstrainedType a -> a -> [Int]
+encodeNoL (SEQUENCEOF _ s) xs
+ = (concat . map (toPer s)) xs
+
+
+-- Encoding the SET type (20)
+encodeSet :: Sequence a -> a -> [Int]
+encodeSet s x
+ = let ts = getTags s
+ es = (encodeSeqAux [] [] s x)
+ hs = head es
+ ls = tail es
+ ps = zip ts ls
+ os = mergesort setPred ps
+ in
+ concat (hs:(map snd os))
+
+
+
+
+-- Sorting
+
+mergesort :: (a -> a -> Bool) -> [a] -> [a]
+mergesort pred [] = []
+mergesort pred [x] = [x]
+mergesort pred xs = merge pred (mergesort pred xs1) (mergesort pred xs2)
+ where (xs1,xs2) = split xs
+split :: [a] -> ([a],[a])
+split xs = splitrec xs xs []
+splitrec :: [a] -> [a] -> [a] -> ([a],[a])
+splitrec [] ys zs = (reverse zs, ys)
+splitrec [x] ys zs = (reverse zs, ys)
+splitrec (x1:x2:xs) (y:ys) zs = splitrec xs ys (y:zs)
+
+merge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+merge pred xs [] = xs
+merge pred [] ys = ys
+merge pred (x:xs) (y:ys)
+ = case pred x y
+ of True -> x: merge pred xs (y:ys)
+ False -> y: merge pred (x:xs) ys
+
+-- Sorting predicate and tag selector
+
+setPred :: (TagInfo, [Int]) -> (TagInfo, [Int]) -> Bool
+setPred (t1,_) (t2,_) = t1 < t2
+
+tagOrder :: ConstrainedType a -> ConstrainedType a -> Bool
+tagOrder x y = getTI x < getTI y
+
+getTags :: Sequence a -> [TagInfo]
+getTags Nil = []
+getTags (Cons a xs) = getTI a : getTags xs
+getTags (Optional a xs) = getTI a : getTags xs
+getTags (Default a xs) = getTI a : getTags xs
+
+getTI :: ConstrainedType a -> TagInfo
+getTI (INTEGER t) = if null t then (Universal,2, Explicit) else head t
+getTI (Range t c _ _) = if null t then getTI c else head t
+getTI (IA5STRING t) = if null t then (Universal,22, Explicit) else head t
+
+
+
+-- Decoding
+
+decodeLengthDeterminant b =
+ do n <- get
+ let bit8 = getBit n b
+ if null bit8
+ then throwError ("Unable to decode " ++ show b ++ " at bit " ++ show n)
+ else
+ case (head bit8) of
+ -- 10.9.3.6
+ 0 ->
+ do let l = fromNonNeg (getBits (n+1) 7 b)
+ put (n + 8 + l*8)
+ return (fromNonNeg (getBits (n+8) (l*8) b))
+ 1 ->
+ do let bit7 = getBit (n+1) b
+ if null bit7
+ then throwError ("Unable to decode " ++ show b ++ " at bit " ++ show n)
+ else case (head bit7) of
+ -- 10.9.3.7
+ 0 ->
+ do let l = fromNonNeg (getBits (n+2) 14 b)
+ put (n + 16 + l*8)
+ return (fromNonNeg (getBits (n+16) (l*8) b))
+ 1 ->
+ undefined
+
+
+untoPerInt t b =
+ case p of
+ -- 10.5 Encoding of a constrained whole number
+ Constrained (Just lb) (Just ub) ->
+ let range = ub - lb + 1
+ n = length (minBits ((ub-lb),range-1)) in
+ if range <= 1
+ -- 10.5.4
+ then return lb
+ -- 10.5.6 and 10.3 Encoding as a non-negative-binary-integer
+ else do offset <- get
+ put (offset + (fromIntegral n))
+ return (lb + (fromNonNeg (map fromIntegral (getBits offset (fromIntegral n) b))))
+ -- 12.2.3, 10.7 Encoding of a semi-constrained whole number,
+ -- 10.3 Encoding as a non-negative-binary-integer, 12.2.6, 10.9 and 12.2.6 (b)
+ Constrained (Just lb) Nothing ->
+ -- encodeWithLengthDeterminant (minOctets (x-lb))
+ undefined
+ _ -> undefined
+ where
+ p = bounds t
+
+-- Very inefficient
+getBits o n b =
+ map fromIntegral (concat (map (flip getBit b) [o..o+n-1]))
+
+getBit o xs =
+ if B.null ys
+ then []
+ else [u]
+ where (nBytes,nBits) = o `divMod` 8
+ ys = B.drop nBytes xs
+ z = B.head ys
+ u = (z .&. ((2^(7 - nBits)))) `shiftR` (fromIntegral (7 - nBits))
+
+
+from2sComplement a <at> (x:xs) =
+ -(x*(2^(l-1))) + sum (zipWith (*) xs ys)
+ where
+ l = length a
+ ys = map (2^) (f (l-2))
+ f 0 = [0]
+ f x = x:(f (x-1))
+
+fromNonNeg xs =
+ sum (zipWith (*) xs ys)
+ where
+ l = length xs
+ ys = map (2^) (f (l-1))
+ f 0 = [0]
+ f x = x:(f (x-1))
+
+{-
+FooBaz {1 2 0 0 6 3} DEFINITIONS ::=
+ BEGIN
+ T1 ::= INTEGER (25..30)
+ Test1 ::=
+ SEQUENCE {
+ first T1,
+ second T1
+ }
+ Test2 ::=
+ SEQUENCE {
+ first T1 OPTIONAL,
+ second T1 OPTIONAL
+ }
+ END
+-}
+
+t0 = INTEGER []
+t1 = Range [(Context,1,Implicit)] (INTEGER []) (Just 25) (Just 30)
+t2 = Includes [] (INTEGER []) t1
+t3 = Includes [] t1 t1
+t4 = Range [] (INTEGER []) (Just (-256)) Nothing
+t41 = Range [] (INTEGER []) (Just 0) (Just 18000)
+t42 = Range [] (INTEGER []) (Just 3) (Just 3)
+t5 = SEQUENCE [] (Cons t4 (Cons t4 Nil))
+t6 = SEQUENCE [] (Cons t1 (Cons t1 Nil))
+t7 = SIZE [] (SEQUENCEOF [] t1) (Just 3) (Just 5)
+t8 = SIZE [] (SEQUENCEOF [] t5) (Just 2) (Just 2)
+t9 = SEQUENCE [] (Optional t4 (Cons t4 Nil))
+t10 = SIZE [] (SEQUENCEOF [] t9) (Just 1) (Just 3)
+
+-- Unconstrained INTEGER
+integer1 = toPer (INTEGER []) 4096
+integer2 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 127
+integer3 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) (-128)
+integer4 = toPer (Range [] (INTEGER []) Nothing (Just 65535)) 128
+
+
+-- Semi-constrained INTEGER
+
+integer5 = toPer (Range [] (INTEGER []) (Just (-1)) Nothing) 4096
+integer6 = toPer (Range [] (INTEGER []) (Just 1) Nothing) 127
+integer7 = toPer (Range [] (INTEGER []) (Just 0) Nothing) 128
+
+-- Constrained INTEGER
+
+integer8'1 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 3
+integer8'2 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 4
+integer8'3 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 5
+integer8'4 = toPer (Range [] (INTEGER []) (Just 3) (Just 6)) 6
+integer9'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4002
+integer9'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4254)) 4006
+integer10'1 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4002
+integer10'2 = toPer (Range [] (INTEGER []) (Just 4000) (Just 4255)) 4006
+integer11'1 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 0
+integer11'2 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 31000
+integer11'3 = toPer (Range [] (INTEGER []) (Just 0) (Just 32000)) 32000
+integer12'1 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 1
+integer12'2 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 257
+integer12'3 = toPer (Range [] (INTEGER []) (Just 1) (Just 65538)) 65538
+
+
+
+test0 = toPer t1 27
+
+
+
+-- SEQUENCE
+test1 = toPer (SEQUENCE [] (Cons (SEQUENCE [] (Cons t1 Nil)) Nil)) ((27:*:Empty):*:Empty)
+test2 = toPer (SEQUENCE [] (Cons t1 (Cons t1 Nil))) (29:*:(30:*:Empty))
+test2a = encodeSeqAux [] [] (Cons t1 (Cons t1 Nil)) (29:*:(30:*:Empty))
+test20 = toPer (SEQUENCE [] (Cons t1 (Cons t1 (Cons t1 Nil)))) (29:*:(30:*:(26:*:Empty)))
+test3 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil))) ((Just 29):*:((Just 30):*:Empty))
+test3a = encodeSeqAux [] [] (Optional t1 (Optional t1 Nil)) ((Just 29):*:((Just 30):*:Empty))
+petest2 = toPer (SEQUENCE [] (Optional t1 (Optional t1 Nil)))
+
+test4 = petest2 ((Just 29):*:((Just 30):*:Empty))
+test5 = petest2 (Nothing:*:((Just 30):*:Empty))
+test6 = petest2 ((Just 29):*:(Nothing:*:Empty))
+test7 = petest2 (Nothing:*:(Nothing:*:Empty))
+
+-- SEQUENCEOF
+test8 = toPer (SEQUENCEOF [] t1) [26,27,28,25]
+test9 = toPer (SEQUENCEOF [] t6) [29:*:(30:*:Empty),28:*:(28:*:Empty)]
+test10
+ = do
+ c <- return (toPer (SEQUENCEOF [] t41) (take (17000) [1,2..]))
+ writeFile "test12.txt" (show c)
+
+test11
+ = do
+ c <- return (toPer (SEQUENCEOF [] t42) (take (17000) [3..]))
+ writeFile "test14.txt" (show c)
+
+test12
+ = do
+ c <- return (toPer (SEQUENCEOF [] t42) (take (93000) [3..]))
+ writeFile "test15.txt" (show c)
+
+-- SIZE-CONSTRAINED SEQUENCEOF
+test14 = toPer t7 [26,25,28,27]
+
+test15 = toPer t8 [(29:*:(30:*:Empty)),((-10):*:(2:*:Empty))]
+
+test16 = toPer t10 [(Just (-10):*:(2:*:Empty))]
+
+-- SET tests
+
+test17 = toPer (SET [] (Cons t1 (Cons t0 Nil))) (27 :*: (5 :*: Empty))
+test17a = toPer (SEQUENCE [] (Cons t1 (Cons t0 Nil))) (27 :*: (5 :*: Empty))
+test17b = encodeSeqAux [] [] (Cons t1 (Cons t0 Nil)) (27 :*: (5 :*: Empty))
+
+test18 = toPer (SET [] (Optional t1 (Optional t0 Nil))) ((Just 29):*:(Nothing:*:Empty))
+test18a = toPer (SEQUENCE [] (Optional t1 (Optional t0 Nil))) ((Just 29):*:(Nothing:*:Empty))
+test18b = encodeSeqAux [] [] (Optional t1 (Optional t0 Nil)) ((Just 29):*:(Nothing:*:Empty))
+
+-- Decoding
+
+uncompTest1 = runState (untoPerInt (Range [] (INTEGER []) (Just 3) (Just 6)) (B.pack [0xc0,0,0,0])) 0
+
+-- These tests are wrong
+-- uncompTest2 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x18,0,1,1]))) 0
+-- uncompTest3 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x81,0x80,0,0]))) 0
+
+unInteger5 = runState (runErrorT (decodeLengthDeterminant (B.pack [0x02,0x10,0x01]))) 0
+
+-- This gives the wrong answer presumably because we are using Int
+
+wrong = toPer (Range [] (INTEGER []) (Just 0) Nothing) (256^4)
}
[Default case added to Sequence type. Updated encodeSeq and encodeSeqAux to allow for a preamble that can be reordered in line with SET ordering. Updated encodeSet.
djrussell <at> kingston.ac.uk**20070724121101] {
hunk ./attempt5.hs 88
- Default :: ConstrainedType a -> Sequence l -> Sequence (a:*:l)
+ Default :: ConstrainedType a -> a -> Sequence l -> Sequence ((Maybe a):*:l)
hunk ./attempt5.hs 294
-encodeSeq s x = concat (encodeSeqAux [] [] s x)
+encodeSeq s x
+ = let (p,es) = encodeSeqAux [] [] s x
+ in concat p ++ concat es
hunk ./attempt5.hs 304
-encodeSeqAux :: [Int] -> [[Int]] -> Sequence a -> a -> [[Int]]
-encodeSeqAux preamble body Nil _ = (reverse preamble):(reverse body)
-encodeSeqAux preamble body (Cons a as) (x:*:xs) = encodeSeqAux preamble ((toPer a x):body) as xs
+encodeSeqAux :: [[Int]] -> [[Int]] -> Sequence a -> a ->
+ ([[Int]],[[Int]])
+encodeSeqAux preamble body Nil _ = ((reverse preamble),(reverse body))
+encodeSeqAux preamble body (Cons a as) (x:*:xs) =
+ encodeSeqAux ([]:preamble) ((toPer a x):body) as xs
hunk ./attempt5.hs 310
- encodeSeqAux (0:preamble) body as xs
+ encodeSeqAux ([0]:preamble)([]:body) as xs
hunk ./attempt5.hs 312
- encodeSeqAux (1:preamble) ((toPer a x):body) as xs
+ encodeSeqAux ([1]:preamble) ((toPer a x):body) as xs
+encodeSeqAux preamble body (Default a d as) (Nothing:*:xs) =
+ encodeSeqAux ([0]:preamble) ([]:body) as xs
+encodeSeqAux preamble body (Default a d as) ((Just x):*:xs) =
+ encodeSeqAux ([1]:preamble) ((toPer a x):body) as xs
hunk ./attempt5.hs 403
- = let ts = getTags s
- es = (encodeSeqAux [] [] s x)
- hs = head es
- ls = tail es
- ps = zip ts ls
- os = mergesort setPred ps
+ = let ts = getTags s
+ (p,es) = (encodeSeqAux [] [] s x)
+ ps = zip ts es
+ pps = zip p ps
+ os = mergesort setPred pps
+ pr = concat (map fst os)
+ en = concat (map (snd . snd) os)
hunk ./attempt5.hs 411
- concat (hs:(map snd os))
+ pr ++ en
hunk ./attempt5.hs 440
-setPred :: (TagInfo, [Int]) -> (TagInfo, [Int]) -> Bool
-setPred (t1,_) (t2,_) = t1 < t2
+setPred :: ([Int],(TagInfo, [Int])) -> ([Int],(TagInfo, [Int])) -> Bool
+setPred (_,(t1,_)) (_,(t2,_)) = t1 < t2
hunk ./attempt5.hs 447
-getTags Nil = []
-getTags (Cons a xs) = getTI a : getTags xs
-getTags (Optional a xs) = getTI a : getTags xs
-getTags (Default a xs) = getTI a : getTags xs
+getTags Nil = []
+getTags (Cons a xs) = getTI a : getTags xs
+getTags (Optional a xs) = getTI a : getTags xs
+getTags (Default a d xs) = getTI a : getTags xs
hunk ./attempt5.hs 557
+t01 = INTEGER [(Context,0,Implicit)]
hunk ./attempt5.hs 640
+
hunk ./attempt5.hs 656
+
+test19 = toPer (SET [] (Optional t1 (Optional t0 (Optional t01 Nil))))
+ ((Just 29):*: ((Just 19):*:(Nothing:*:Empty)))
+test19a = toPer (SEQUENCE [] (Optional t1 (Optional t0 (Optional t01 Nil))))
+ ((Just 29):*: ((Just 19):*:(Nothing:*:Empty)))
+test19b = encodeSeqAux [] [] (Optional t1 (Optional t0 (Optional t01 Nil)))
+ ((Just 29):*: ((Just 19):*:(Nothing:*:Empty)))
}
[Definition of Choice type, addition to ConstrainedType and to toPer.
djrussell <at> kingston.ac.uk**20070730094820] {
hunk ./attempt5.hs 90
+-- The Choice type is similar to a Sequence except that each value
+-- is optional and only one value can exist at a time.
hunk ./attempt5.hs 93
+data Choice :: * -> * where
+ NoChoice :: Choice Nil
+ ChoiceOption :: ConstrainedType a -> Choice l -> Choice ((Maybe a):*:l)
hunk ./attempt5.hs 97
-
hunk ./attempt5.hs 115
+ SETOF :: TagHistory -> ConstrainedType a -> ConstrainedType [a]
+ CHOICE :: TagHistory -> Choice a -> ConstrainedType a
hunk ./attempt5.hs 186
+toPer t <at> (SETOF tgs s) xs = encodeSO t xs
+toPer t <at> (CHOICE tgs c) xs = encodeChoice c xs
}
[New comment for SET encoding.
djrussell <at> kingston.ac.uk**20070730094958] {
hunk ./attempt5.hs 408
--- Encoding the SET type (20)
+-- 20. Encoding the SET type. The encoding is the same as for a
+-- SEQUENCE except that the components must be canonically ordered.
+-- The ordering is based on the component's tags. Note, the
+-- preamble must be reordered to match the ordering of the
+-- components.
+
hunk ./attempt5.hs 425
-
}
[CHOICE encoding and new tests.
djrussell <at> kingston.ac.uk**20070730095038] {
hunk ./attempt5.hs 468
+-- Can use this to implement for a CHOICE
+-- mergesort choicePred ps (see defn of encodeChoice)
+
+
+-- 21. Encoding the set-of type.
+
+-- Since we are implementing BASIC-PER (and not CANONICAL-PER) the
+-- encoding is as for a sequence-of.
+
+
+-- 22. Encoding the choice type.
+
+-- encodeChoice encodes CHOICE values. It is not dissimilar to
+-- encodeSet in that the possible choice components must be
+-- assigned an index based on their canonical ordering. This index,
+-- which starts from 0, prefixes the value encoding and is absent if
+-- there is only a single choice.
+
+encodeChoice :: Choice a -> a -> [Int]
+encodeChoice c x
+ = let ts = getCTags c
+ ec = (encodeChoiceAux [] c x)
+ in
+ if length ec == 1
+ then concat ec
+ else
+ let ps = zip ts ec
+ os = mergesort choicePred ps
+ pps = zip [0..] os
+ fr = (head . filter (not . nullValue)) pps
+ ls = length os
+ in
+ minBits (fst fr,ls-1) ++ (snd .snd) fr
+
+nullValue :: (Int, (TagInfo, [Int])) -> Bool
+nullValue (f,(s,t)) = null t
+
+getCTags :: Choice a -> [TagInfo]
+getCTags NoChoice = []
+getCTags (ChoiceOption a xs) = getTI a : getCTags xs
+
+choicePred :: (TagInfo, [Int]) -> (TagInfo, [Int]) -> Bool
+choicePred (t1,_) (t2,_) = t1 < t2
+
+
+encodeChoiceAux :: [[Int]] -> Choice a -> a -> [[Int]]
+encodeChoiceAux body NoChoice _ = reverse body
+encodeChoiceAux body (ChoiceOption a as) (Nothing:*:xs) =
+ encodeChoiceAux ([]:body) as xs
+encodeChoiceAux body (ChoiceOption a as) ((Just x):*:xs) =
+ encodeChoiceAux' ((toPer a x):body) as xs
+
+encodeChoiceAux' :: [[Int]] -> Choice a -> a -> [[Int]]
+encodeChoiceAux' body NoChoice _ = reverse body
+encodeChoiceAux' body (ChoiceOption a as) (Nothing:*:xs) =
+ encodeChoiceAux' ([]:body) as xs
hunk ./attempt5.hs 626
+t02 = INTEGER [(Context,2, Implicit)]
hunk ./attempt5.hs 732
+
+-- CHOICE tests
+
+test20c = toPer (CHOICE [] (ChoiceOption t0 (ChoiceOption t1 (ChoiceOption t01 (ChoiceOption t02 NoChoice)))))
+ (Nothing :*: (Just 27 :*: (Nothing :*: (Nothing :*: Empty))))
+
+test21c = toPer (CHOICE [] (ChoiceOption t0 NoChoice)) (Just 31 :*: Empty)
+
+
}
[Additional cases for getTI and more CHOICE test cases.
djrussell <at> kingston.ac.uk**20070730122100] {
hunk ./attempt5.hs 465
-getTI (INTEGER t) = if null t then (Universal,2, Explicit) else head t
-getTI (Range t c _ _) = if null t then getTI c else head t
-getTI (IA5STRING t) = if null t then (Universal,22, Explicit) else head t
--- Can use this to implement for a CHOICE
--- mergesort choicePred ps (see defn of encodeChoice)
+getTI (INTEGER t) = if null t then (Universal,2, Explicit) else head t
+getTI (Range t c _ _) = if null t then getTI c else head t
+getTI (IA5STRING t) = if null t then (Universal,22, Explicit) else head t
+getTI (BITSTRING t) = if null t then (Universal, 3, Explicit) else head t
+getTI (PRINTABLESTRING t)
+ = if null t then (Universal, 19, Explicit) else head t
+getTI (SEQUENCE t s) = if null t then (Universal, 16, Explicit) else head t
+getTI (SEQUENCEOF t s) = if null t then (Universal, 16, Explicit) else head t
+getTI (SET t s) = if null t then (Universal, 17, Explicit) else head t
+getTI (SETOF t s) = if null t then (Universal, 17, Explicit) else head t
+getTI (SIZE t c _ _) = if null t then getTI c else head t
+getTI (CHOICE t c) = if null t then (minimum . getCTags) c else head t
+
hunk ./attempt5.hs 635
+t03 = INTEGER [(Context, 3, Implicit)]
+t04 = INTEGER [(Context, 4, Implicit)]
hunk ./attempt5.hs 649
+t11 = CHOICE [] (ChoiceOption t0 (ChoiceOption t1 (ChoiceOption t01 (ChoiceOption t02 NoChoice))))
+t12 = CHOICE [] (ChoiceOption t04 (ChoiceOption t03 NoChoice))
hunk ./attempt5.hs 752
+test22c
+ = toPer (CHOICE [] (ChoiceOption t0 (ChoiceOption t12 NoChoice)))
+ (Nothing :*: (Just (Just 52 :*: (Nothing :*: Empty)) :*: Empty))
hunk ./attempt5.hs 756
+test23c
+ = toPer (CHOICE [] (ChoiceOption t11 (ChoiceOption t12 NoChoice)))
+ (Just (Nothing :*: (Just 27 :*: (Nothing :*: (Nothing :*: Empty))))
+ :*: (Nothing :*: Empty))
}
[Import Data.Char to use ord function in VisibleString encoding.
djrussell <at> kingston.ac.uk**20070731124115] {
hunk ./attempt5.hs 10
+import Data.Char
hunk ./attempt5.hs 41
+
+
}
[Edit of CHOICE type comment.
djrussell <at> kingston.ac.uk**20070731124230] {
hunk ./attempt5.hs 94
--- is optional and only one value can exist at a time.
+-- is optional and only one value can exist at a time. Note that
+-- the Choice type has no PER-visible constraints.
}
[Addition of VISIBLESTRING and related functions/test.
djrussell <at> kingston.ac.uk**20070731124325] {
hunk ./attempt5.hs 112
+ VISIBLESTRING :: TagHistory -> ConstrainedType VisibleString
hunk ./attempt5.hs 193
+toPer t <at> (VISIBLESTRING tgs) (VisibleString xs) = encodeVS t xs
+toPer t <at> (SIZE tgs1 (VISIBLESTRING tgs) l u)
+ (VisibleString xs) = encodeVS t xs
hunk ./attempt5.hs 259
+
+
+
hunk ./attempt5.hs 771
+
+-- VISIBLESTRING tests
+
+testvs1 = toPer (VISIBLESTRING []) (VisibleString "Director")
}
[Removal of unnecessary bounds function case, and new HOFs to replace functions with common behaviour when inserting length encodings.
djrussell <at> kingston.ac.uk**20070731124509] {
hunk ./attempt5.hs 169
-bounds (INTEGER _) = Constrained Nothing Nothing
hunk ./attempt5.hs 380
- = concat . insertL s . groupBy 4 . groupBy (16*(2^10))
+ = encodeInsert insertL s
+
+encodeInsert :: (t -> [[[t1]]] -> [[a]]) -> t -> [t1] -> [a]
+encodeInsert f s = concat . f s . groupBy 4 . groupBy (16*(2^10))
hunk ./attempt5.hs 387
+
hunk ./attempt5.hs 389
-sk :: ConstrainedType a -> [[[a]]] -> Maybe ([Int], [[[a]]])
-sk t [] = Nothing
-sk t (x:xs)
+ufWrapper :: ([a] -> [Int]) -> [[[a]]] -> Maybe ([Int],[[[a]]])
+ufWrapper fn [] = Nothing
+ufWrapper fn (x:xs)
hunk ./attempt5.hs 399
- ws = (1:1:(minBits (l,w6)))++ (concat . map (concat . map (toPer t))) x
- us = ld2 (length m) ++ (concat . map (toPer t)) m
+ ws = (1:1:(minBits (l,r))) ++ (concat . map fn) x
+ us = ld2 (length m) ++ fn m
hunk ./attempt5.hs 402
- (1:1:(minBits (l,w6)))++ (concat . map (concat . map (toPer t))) x ++ ld2 0
+ (1:1:(minBits (l,r))) ++ (concat . map fn) x ++ ld2 0
hunk ./attempt5.hs 404
- (1:1:(minBits ((l-1), w6)))++ (concat . map (concat . map (toPer t)))
- (take (l-1) x) ++ ld2 (length m) ++ (concat . map (toPer t)) m
+ (1:1:(minBits ((l-1), r))) ++ (concat . map fn) (take (l-1) x)
+ ++ ld2 (length m) ++ fn m
hunk ./attempt5.hs 407
- w6 = 2^6 - 1
hunk ./attempt5.hs 408
+ r = 2^6 - 1
+
+sk :: ConstrainedType a -> [[[a]]] -> Maybe ([Int], [[[a]]])
+sk t = ufWrapper (concat . map (toPer t))
+
hunk ./attempt5.hs 550
+
+
+-- 27. Encoding the restricted character string types (VISIBLESTRING)
+
+encodeVS :: ConstrainedType VisibleString -> String -> [Int]
+encodeVS t x
+ = case p of
+ Constrained (Just lb) (Just ub) ->
+ encodeVisSz t lb ub x
+ Constrained (Just lb) Nothing ->
+ encodeVis t x
+ Constrained Nothing Nothing ->
+ encodeVis t x
+ where
+ p = sizeLimit t
+
+encodeVisSz :: (Num a, Ord a) => ConstrainedType VisibleString -> a -> a -> [Char] -> [Int]
+encodeVisSz t <at> (SIZE tgs ty _ _) l u x
+ = let range = u - l + 1
+ in
+ if range == 1 && u < 65536
+ then encS x
+ else encodeVis ty x
+
+encodeVis :: ConstrainedType VisibleString -> String -> [Int]
+encodeVis vs
+ = encodeInsert insertLVS vs
+
+insertLVS :: ConstrainedType VisibleString -> [[String]] -> [[Int]]
+insertLVS s = unfoldr (encVS s)
+
+
+encVS :: ConstrainedType VisibleString -> [[String]] -> Maybe ([Int], [[String]])
+encVS s = ufWrapper encS
+
+encC c = minBits (ord c, 94)
+encS s = (concat . map encC) s
}
[Updated ufWrapper to take more arguments and thus be usable for all `length-adders' required when encoding various types such as INTEGER, SEQUENCEOF and VISIBLESTRING. Renamed some existing functions such as k (intLengths) and
djrussell <at> kingston.ac.uk**20070802121116
sk (soLengths).
] {
hunk ./attempt5.hs 257
-insertLengths = unfoldr k
+insertLengths = unfoldr intLengths
hunk ./attempt5.hs 259
+-- HOFs of use when encoding values with an unconstrained length
+-- where the length value has to be interspersed with value encoding.
hunk ./attempt5.hs 262
-
-
-k [] = Nothing
-k (x:xs)
- | l == n && lm >= l1b = Just (ws,xs)
+ufWrapper fn op inp lf [] = Nothing
+ufWrapper fn op inp lf (x:xs)
+ | l == n && lm == l1b = Just (ws x,xs)
hunk ./attempt5.hs 271
- ws = (1:1:(minBits (l,w6))):(concat x)
- us = ld (length m) ++ m
- vs = if lm >= l1b then
- (1:1:(minBits (l,w6))):(concat x ++ ld 0)
+ ws = abs1 fn op (inp l r)
+ us = lf (length m) ++ fn m
+ vs = if lm == l1b then
+ ws x ++ lf 0
hunk ./attempt5.hs 276
- ((1:1:(minBits ((l-1), w6))):(concat (take (l-1) x)) ++ ld (length m) ++ m)
+ ws (take (l-1) x) ++ lf (length m) ++ fn m
hunk ./attempt5.hs 278
- w6 = 2^6 - 1
hunk ./attempt5.hs 279
+ r = 2^6 - 1
hunk ./attempt5.hs 281
+abs1 :: (a1 -> [a]) -> (t -> [a] -> t1) -> t -> [a1] -> t1
+abs1 f op x y
+ = x `op` (concat . map f) y
+
+arg1 x y = (1:1:(minBits (x,y)))
+
+
+-- intLengths adds length value to section of int value
+
+intLengths :: [[[[Int]]]] -> Maybe ([[Int]], [[[[Int]]]])
+intLengths = ufWrapper id (:) arg1 ld
+
+
hunk ./attempt5.hs 399
-insertL s = unfoldr (sk s)
+insertL s = unfoldr (soLengths s)
hunk ./attempt5.hs 402
-ufWrapper :: ([a] -> [Int]) -> [[[a]]] -> Maybe ([Int],[[[a]]])
-ufWrapper fn [] = Nothing
-ufWrapper fn (x:xs)
- | l == n && lm == l1b = Just (ws,xs)
- | l == 1 && lm < l1b = Just (us,[])
- | otherwise = Just (vs,[])
- where
- l = length x
- m = x!!(l-1)
- lm = length m
- ws = (1:1:(minBits (l,r))) ++ (concat . map fn) x
- us = ld2 (length m) ++ fn m
- vs = if lm == l1b then
- (1:1:(minBits (l,r))) ++ (concat . map fn) x ++ ld2 0
- else
- (1:1:(minBits ((l-1), r))) ++ (concat . map fn) (take (l-1) x)
- ++ ld2 (length m) ++ fn m
- n = 4
- l1b = 16*(2^10)
- r = 2^6 - 1
+-- soLengths adds length values to encodings of SEQUENCEOF
+-- components.
hunk ./attempt5.hs 405
-sk :: ConstrainedType a -> [[[a]]] -> Maybe ([Int], [[[a]]])
-sk t = ufWrapper (concat . map (toPer t))
+soLengths :: ConstrainedType a -> [[[a]]] -> Maybe ([Int], [[[a]]])
+soLengths t = ufWrapper (concat . map (toPer t)) (++) arg1 ld2
hunk ./attempt5.hs 408
-
hunk ./attempt5.hs 573
-insertLVS s = unfoldr (encVS s)
+insertLVS s = unfoldr (vsLengths s)
hunk ./attempt5.hs 576
-encVS :: ConstrainedType VisibleString -> [[String]] -> Maybe ([Int], [[String]])
-encVS s = ufWrapper encS
+-- vsLengths adds lengths values to encoding of sections of
+-- VISIBLESTRING.
+
+vsLengths :: ConstrainedType VisibleString -> [[String]] -> Maybe ([Int], [[String]])
+vsLengths s = ufWrapper encS (++) arg1 ld2
}
[Added VISIBLESTRING case to getTI.
djrussell <at> kingston.ac.uk**20070802123622] {
hunk ./attempt5.hs 483
+getTI (VISIBLESTRING t) = if null t then (Universal, 26, Explicit) else head t
}
[Added VisibleString to PermittedAlphabet and SizeConstraint type classes.
djrussell <at> kingston.ac.uk**20070806090129] {
hunk ./attempt5.hs 67
+
hunk ./attempt5.hs 73
+instance PermittedAlphabet VisibleString
hunk ./attempt5.hs 82
+instance SizeConstraint VisibleString
}
[Added FROM cases to ConstrainedType and toPer.
djrussell <at> kingston.ac.uk**20070806090251] {
hunk ./attempt5.hs 125
+ FROM :: PermittedAlphabet a => TagHistory -> ConstrainedType a -> a -> ConstrainedType a
hunk ./attempt5.hs 199
+toPer t <at> (FROM tgs1 (VISIBLESTRING tgs) pac)
+ (VisibleString xs) = encodeVSF t xs
+toPer t <at> (SIZE tgs1 (FROM tgs2 (VISIBLESTRING tgs3) pac) l u)
+ (VisibleString xs) = encodeVSF t xs
}
[Encoding of permitted alphabet-constrained VisibleString plus test.
djrussell <at> kingston.ac.uk**20070806090405] {
hunk ./attempt5.hs 595
+-- 27.5.4 Encoding of a VISIBLESTRING with a permitted alphabet
+-- constraint.
+
+encodeVSF :: ConstrainedType VisibleString -> String -> [Int]
+encodeVSF t x
+ = case p of
+ Constrained (Just lb) (Just ub) ->
+ encodeVisSzF t lb ub x
+ Constrained (Just lb) Nothing ->
+ encodeVisF t x
+ Constrained Nothing Nothing ->
+ encodeVisF t x
+ where
+ p = sizeLimit t
+
+encodeVisSzF :: (Num a, Ord a) => ConstrainedType VisibleString -> a -> a -> [Char] -> [Int]
+encodeVisSzF t <at> (SIZE tgs ty <at> (FROM tgs2 cv pac)_ _) l u x
+ = let range = u - l + 1
+ in
+ if range == 1 && u < 65536
+ then encSF pac x
+ else encodeVisF ty x
+
+--encodeVisF :: ConstrainedType VisibleString -> String -> [Int]
+encodeVisF vs <at> (FROM tgs2 cv pac)
+ = encodeInsert (insertLVSF pac) vs
+
+--insertLVSF :: ConstrainedType VisibleString -> [[String]] -> [[Int]]
+insertLVSF p s = unfoldr (vsLengthsF s p)
+
+
+-- vsLengths adds lengths values to encoding of sections of
+-- VISIBLESTRING.
+
+-- vsLengths :: ConstrainedType VisibleString -> [[String]] -> Maybe ([Int], [[String]])
+vsLengthsF s p = ufWrapper (encSF p) (++) arg1 ld2
+
+encSF (VisibleString p) str
+ = let sp = sort p
+ lp = length p
+ b = minExp 2 0 lp
+ mp = maximum p
+ in
+ if ord mp < 2^b -1
+ then
+ encS str
+ else
+ concat (canEnc (lp-1) sp str)
+
+
+minExp n e p
+ = if n^e < p
+ then minExp n (e+1) p
+ else e
+
+-- Clause 38.8 in X680 (Canonical ordering of VisibleString characters)
+
+canEnc b sp [] = []
+canEnc b sp (f:r)
+ = let v = (length . findV f) sp
+ in minBits (v,b) : canEnc b sp r
+
+findV m [] = []
+findV m (a:rs)
+ = if m == a
+ then []
+ else a : findV m rs
+
+
hunk ./attempt5.hs 894
+
+-- VISIBLESTRING with permitted alphabet constraint and size constraints tests
+
+x = (SIZE [] (FROM [] (VISIBLESTRING []) (VisibleString ['0'..'9'])) (Just 8) (Just 8))
+
+testvsc1 = toPer x (VisibleString "19710917")
+
}
[Change name of value argument to x in all cases of toPer
djrussell <at> kingston.ac.uk**20070808141602] {
hunk ./attempt5.hs 191
-toPer t <at> (SEQUENCEOF tgs s) xs = encodeSO t xs
+toPer t <at> (SEQUENCEOF tgs s) x = encodeSO t x
hunk ./attempt5.hs 194
-toPer t <at> (SETOF tgs s) xs = encodeSO t xs
-toPer t <at> (CHOICE tgs c) xs = encodeChoice c xs
-toPer t <at> (VISIBLESTRING tgs) (VisibleString xs) = encodeVS t xs
-toPer t <at> (SIZE tgs1 (VISIBLESTRING tgs) l u)
- (VisibleString xs) = encodeVS t xs
-toPer t <at> (FROM tgs1 (VISIBLESTRING tgs) pac)
- (VisibleString xs) = encodeVSF t xs
-toPer t <at> (SIZE tgs1 (FROM tgs2 (VISIBLESTRING tgs3) pac) l u)
- (VisibleString xs) = encodeVSF t xs
+toPer t <at> (SETOF tgs s) x = encodeSO t x
+toPer t <at> (CHOICE tgs c) x = encodeChoice c x
+toPer t <at> (VISIBLESTRING tgs) x = encodeVS t x
+toPer t <at> (SIZE tgs1 (VISIBLESTRING tgs) l u) x = encodeVS t x
+toPer t <at> (FROM tgs1 (VISIBLESTRING tgs) pac) x = encodeVSF t x
+toPer t <at> (SIZE tgs1 (FROM tgs2 (VISIBLESTRING tgs) pac) l u) x
+ = encodeVSF t x
}
[New manageSize and manageExtremes functions which factor out the common behaviour required by functions which have to deal with potential size constraints (manageSize) and the possible values of their upper and lower bounds (manageExtremes).
djrussell <at> kingston.ac.uk**20070808141807] {
hunk ./attempt5.hs 361
--- fragmentation into 64K blocks).
+-- fragmentation into 64K blocks). It uses the function manageSize
+-- which manages the 3 possible size cases.
hunk ./attempt5.hs 364
-encodeSO :: ConstrainedType [a] -> [a] -> [Int]
-encodeSO t x
- = case p of
+manageSize :: (ConstrainedType a -> Int -> Int -> t -> t1) -> (ConstrainedType a -> t -> t1)
+ -> ConstrainedType a -> t -> t1
+manageSize fn1 fn2 t x
+ = case p of
hunk ./attempt5.hs 369
- encodeSeqSz t lb ub x
+ fn1 t lb ub x
hunk ./attempt5.hs 371
- encodeSeqOf t x
+ fn2 t x
hunk ./attempt5.hs 373
- encodeSeqOf t x
+ fn2 t x
hunk ./attempt5.hs 377
-encodeSeqSz :: ConstrainedType [a] -> Int -> Int -> [a] -> [Int]
-encodeSeqSz t <at> (SIZE tgs ty _ _) l u x
+encodeSO :: ConstrainedType [a] -> [a] -> [Int]
+encodeSO = manageSize encodeSeqSz encodeSeqOf
+
+-- encodeSeqSz encodes a size-constrained SEQUENCEOF. It uses the
+-- function manageExtremes which manages the 3 upper/lower bound value cases.
+
+manageExtremes fn1 fn2 l u x
hunk ./attempt5.hs 387
---19.5
- then encodeNoL ty x
+ then fn1 x
hunk ./attempt5.hs 389
---19.6
- then encodeSeqOf ty x
- else minBits ((length x-l),range-1) ++ encodeNoL ty x
+ then fn2 x
+ else minBits ((length x-l),range-1) ++ fn1 x
+
+encodeSeqSz :: ConstrainedType [a] -> Int -> Int -> [a] -> [Int]
+encodeSeqSz (SIZE tgs ty _ _) l u x
+ = manageExtremes (encodeNoL ty) (encodeSeqOf ty) l u x
hunk ./attempt5.hs 564
-encodeVS :: ConstrainedType VisibleString -> String -> [Int]
-encodeVS t x
- = case p of
- Constrained (Just lb) (Just ub) ->
- encodeVisSz t lb ub x
- Constrained (Just lb) Nothing ->
- encodeVis t x
- Constrained Nothing Nothing ->
- encodeVis t x
- where
- p = sizeLimit t
+encodeVS :: ConstrainedType VisibleString -> VisibleString -> [Int]
+encodeVS = manageSize encodeVisSz encodeVis
hunk ./attempt5.hs 567
-encodeVisSz :: (Num a, Ord a) => ConstrainedType VisibleString -> a -> a -> [Char] -> [Int]
-encodeVisSz t <at> (SIZE tgs ty _ _) l u x
- = let range = u - l + 1
- in
- if range == 1 && u < 65536
- then encS x
- else encodeVis ty x
+encodeVisSz :: ConstrainedType VisibleString -> Int -> Int -> VisibleString -> [Int]
+encodeVisSz t <at> (SIZE tgs ty _ _) l u x <at> (VisibleString xs)
+ = manageExtremes encS (encodeVis ty . VisibleString) l u xs
hunk ./attempt5.hs 592
-encodeVSF :: ConstrainedType VisibleString -> String -> [Int]
-encodeVSF t x
- = case p of
- Constrained (Just lb) (Just ub) ->
- encodeVisSzF t lb ub x
- Constrained (Just lb) Nothing ->
- encodeVisF t x
- Constrained Nothing Nothing ->
- encodeVisF t x
- where
- p = sizeLimit t
+encodeVSF :: ConstrainedType VisibleString -> VisibleString -> [Int]
+encodeVSF = manageSize encodeVisSzF encodeVisF
hunk ./attempt5.hs 595
-encodeVisSzF :: (Num a, Ord a) => ConstrainedType VisibleString -> a -> a -> [Char] -> [Int]
-encodeVisSzF t <at> (SIZE tgs ty <at> (FROM tgs2 cv pac)_ _) l u x
- = let range = u - l + 1
- in
- if range == 1 && u < 65536
- then encSF pac x
- else encodeVisF ty x
+encodeVisSzF :: ConstrainedType VisibleString -> Int -> Int -> VisibleString -> [Int]
+encodeVisSzF t <at> (SIZE tgs ty <at> (FROM tgs2 cv pac)_ _) l u x <at> (VisibleString xs)
+ = manageExtremes (encSF pac) (encodeVisF ty . VisibleString) l u xs
}
[encodeVis and encodeVisF now take a VisibleString (instead of a string) as second argument.
djrussell <at> kingston.ac.uk**20070808142141] {
hunk ./attempt5.hs 571
-encodeVis :: ConstrainedType VisibleString -> String -> [Int]
-encodeVis vs
- = encodeInsert insertLVS vs
+encodeVis :: ConstrainedType VisibleString -> VisibleString -> [Int]
+encodeVis vs (VisibleString s)
+ = encodeInsert insertLVS vs s
hunk ./attempt5.hs 599
---encodeVisF :: ConstrainedType VisibleString -> String -> [Int]
-encodeVisF vs <at> (FROM tgs2 cv pac)
- = encodeInsert (insertLVSF pac) vs
+encodeVisF :: ConstrainedType VisibleString -> VisibleString -> [Int]
+encodeVisF vs <at> (FROM tgs2 cv pac) (VisibleString s)
+ = encodeInsert (insertLVSF pac) vs s
}
[Unocmmented and changes types for insertLVSF and vsLengthF (first argument is now a VisibleString and not a ConstrainedType VisibleString). Plus added a test case from X691 -- A.2.1.
djrussell <at> kingston.ac.uk**20070808142304] {
hunk ./attempt5.hs 603
---insertLVSF :: ConstrainedType VisibleString -> [[String]] -> [[Int]]
+insertLVSF :: VisibleString -> t -> [[String]] -> [[Int]]
hunk ./attempt5.hs 610
--- vsLengths :: ConstrainedType VisibleString -> [[String]] -> Maybe ([Int], [[String]])
+vsLengthsF :: t -> VisibleString -> [[String]] -> Maybe ([Int], [[String]])
hunk ./attempt5.hs 882
+-- X691: A.2.1 Example
+
+prTest = toPer personnelRecord pr
+
+pr = (emp :*: (t :*: (num :*: (hiredate :*: (sp :*: (Just cs :*: Empty))))))
+
+personnelRecord
+ = SET [(Application, 0, Implicit)]
+ (Cons name (Cons title (Cons number (Cons date (Cons spouse (Default children [] Nil))))))
+
+name
+ = SEQUENCE [(Application, 1, Implicit)]
+ (Cons givenName (Cons initial (Cons familyName Nil)))
+
+title
+ = VISIBLESTRING [(Context, 0, Explicit)]
+
+t = VisibleString "Director"
+
+number
+ = INTEGER [(Application, 2, Implicit)]
+
+num = 51
+
+date
+ = (SIZE [(Context, 1, Explicit),(Application, 3, Implicit)]
+ (FROM [] (VISIBLESTRING []) (VisibleString ['0'..'9'])) (Just 8) (Just 8))
+
+hiredate = VisibleString "19710917"
+
+spouse
+ = SEQUENCE [(Context, 2, Explicit),(Application, 1, Implicit)]
+ (Cons givenName (Cons initial (Cons familyName Nil)))
+
+spGN = VisibleString "Mary"
+
+spI = VisibleString "T"
+
+spFN = VisibleString "Smith"
+
+sp = (spGN :*: (spI :*: (spFN :*: Empty)))
+
+children
+ = SEQUENCEOF [(Context, 3, Implicit)] childInfo
+
+
+c1GN = VisibleString "Ralph"
+c1I = VisibleString "T"
+c1FN = VisibleString "Smith"
+c1BD = VisibleString "19571111"
+
+c2GN = VisibleString "Susan"
+c2I = VisibleString "B"
+c2FN = VisibleString "Jones"
+c2BD = VisibleString "19590717"
+
+c1 = ((c1GN :*: (c1I :*: (c1FN :*: Empty))) :*: (c1BD :*: Empty))
+c2 = ((c2GN :*: (c2I :*: (c2FN :*: Empty))) :*: (c2BD :*: Empty))
+
+cs = [c1,c2]
+
+childInfo
+ = SET [] (Cons name (Cons birthDate Nil))
+
+birthDate
+ = (SIZE [(Context, 0, Explicit),(Application, 3, Implicit)]
+ (FROM [] (VISIBLESTRING []) (VisibleString ['0'..'9'])) (Just 8) (Just 8))
+
+
+givenName
+ = (SIZE []
+ (FROM [] (VISIBLESTRING []) (VisibleString (['a'..'z'] ++ ['A'..'Z'] ++ ['-','.'])) )
+ (Just 1) (Just 64))
+
+empGN = VisibleString "John"
+
+familyName
+ = givenName
+
+empFN = VisibleString "Smith"
+
+initial
+ = (SIZE []
+ (FROM [] (VISIBLESTRING [])(VisibleString (['a'..'z'] ++ ['A'..'Z'] ++ ['-','.'])) )
+ (Just 1) (Just 1))
+
+empI = VisibleString "P"
+
+emp = (empGN :*: (empI :*: (empFN :*: Empty)))
}
[Change to declaration of BitString type.
djrussell <at> kingston.ac.uk**20070814090706] {
hunk ./attempt5.hs 16
-data BitString = BitString
- deriving Show
hunk ./attempt5.hs 18
+newtype BitString = BitString {bitString :: [Int]}
hunk ./attempt5.hs 39
- deriving Show
hunk ./attempt5.hs 83
+
}
[Boolean constructor added to ConstrainedType and BitString encoding and testing added. Various comments removed that are now unnecessary. A couple of small unused functions (isExtensible and getTags) removed.
djrussell <at> kingston.ac.uk**20070814090827] {
hunk ./attempt5.hs 110
+ BOOLEAN :: TagHistory -> ConstrainedType Bool
hunk ./attempt5.hs 125
- FROM :: PermittedAlphabet a => TagHistory -> ConstrainedType a -> a -> ConstrainedType a
+ FROM :: PermittedAlphabet a => TagHistory -> ConstrainedType a
+ -> a -> ConstrainedType a
hunk ./attempt5.hs 128
- -- Size constraint: there are two sorts modelled by SizeConstraint
- Size :: Sized a => ConstrainedType a -> SizeConstraint -> ConstrainedType a
- -- Alphabet constraint - not quite right see note below
- From :: PermittedAlphabet a => ConstrainedType a -> AlphabetConstraint a -> ConstrainedType a
hunk ./attempt5.hs 129
- -- Constraint on SEQUENCE OF or SET OF - ignore for now until we fix the main datatype
- -- Constraint on SEQUENCE, SET or CHOICE - ignore for now until we fix the main datatype
hunk ./attempt5.hs 135
--- NEED EVERY CASE IMPLEMENTED
hunk ./attempt5.hs 136
-getInfo :: ConstrainedType a -> TagInfo
-getInfo (INTEGER (f:r)) = f
-
hunk ./attempt5.hs 138
-isExtensible :: ConstrainedType a -> Bool
-isExtensible = undefined
hunk ./attempt5.hs 177
+toPer t <at> (BOOLEAN tgs) x = encodeBool t x
hunk ./attempt5.hs 180
+toPer t <at> (BITSTRING tgs) x = encodeBS t x
+toPer t <at> (SIZE tgs1 (BITSTRING tgs) l u) x = encodeBS t x
hunk ./attempt5.hs 194
--- INTEGER ENCODING 10.3 - 10.8
+-- 11 ENCODING THE BOOLEAN TYPE
hunk ./attempt5.hs 196
+encodeBool :: ConstrainedType Bool -> Bool -> [Int]
+encodeBool t True = [1]
+encodeBool t _ = [0]
+
+-- 10.3 - 10.8 ENCODING THE INTEGER TYPE
+
hunk ./attempt5.hs 326
+-- 15 ENCODING THE BITSTRING TYPE
+
+encodeBS :: ConstrainedType BitString -> BitString -> [Int]
+encodeBS = manageSize encodeBSSz encodeBSNoSz
+
+
+encodeBSSz :: ConstrainedType BitString -> Int -> Int -> BitString -> [Int]
+encodeBSSz t <at> (SIZE tgs ty _ _) l u x <at> (BitString xs)
+ = let exs = editBS l u xs
+ in
+ if u == 0
+ then []
+ else if u == l && u <= 65536
+ then exs
+ else encodeBSWithLD exs
+
+encodeBSWithLD = encodeInsert insertBSL (INTEGER [])
+
+insertBSL s = unfoldr (bsLengths s)
+
+bsLengths t = ufWrapper (id) (++) arg1 ld2
+
+editBS l u xs
+ = let lxs = length xs
+ in if lxs < l
+ then add0s (l-lxs) xs
+ else
+ if lxs > u
+ then rem0s (lxs-u) xs
+ else xs
+
+add0s n xs = xs ++ take n [0,0..]
+
+rem0s (n+1) xs
+ = if last xs == 0
+ then rem0s n (init xs)
+ else error "Last value is not 0"
+rem0s 0 xs = xs
+
+encodeBSNoSz :: ConstrainedType BitString -> BitString -> [Int]
+encodeBSNoSz t (BitString bs)
+ = let rbs = reverse bs
+ rem0 = strip0s rbs
+ in reverse rem0
+
+strip0s (a:r)
+ = if a == 0
+ then strip0s r
+ else (a:r)
+strip0s [] = []
+
hunk ./attempt5.hs 846
+-- BITSTRING
+
+bsTest1 = toPer (BITSTRING []) (BitString [1,1,0,0,0,1,0,0,0,0])
+
+-- Size-constrained BITSTRING
+
+bsTest2 = toPer (SIZE [] (BITSTRING []) (Just 7) (Just 7)) (BitString [1,1,0,0,0,1,0,0,0,0])
+bsTest3 = toPer (SIZE [] (BITSTRING []) (Just 12) (Just 15)) (BitString [1,1,0,0,0,1,0,0,0,0])
}
Context:
[export Name in ASN1.X509
Pavel Shramov <shramov <at> mexmat.net>**20070703065641
Also fixed examples that import InformationFramework which
exports Name too
]
[ASN1.BER.typeCheck type signature fix
Pavel Shramov <shramov <at> mexmat.net>**20070703065110
Fixed monad in type signature. typeCheck is not performing any i/o and
IO was only used as error monad so replacing it with MonadError e m seem
to be correct.
This fix allow usage of typeCheck in pure functions (for example
with Either String monad)
]
[Lots of compress renaming to toPer (and unCompress to untoPer).
djrussell <at> kingston.ac.uk**20070713103509]
[The type and semantics of bounds have changed given the change to Constraint type. It now is only used for range limits, and the new function sizeLimit deals with size limits (and is thus used in encodeSO).
djrussell <at> kingston.ac.uk**20070713103102]
[The type Constraint is now parameterised and type class Monoid instantiation now reflects this.
djrussell <at> kingston.ac.uk**20070713102911]
[Added context Ord a to Range constructor type specification.
djrussell <at> kingston.ac.uk**20070713102650]
[compress was renamed to toPer.
dominic.steinitz <at> blueyonder.co.uk**20070711203727]
[Dan's workround for Range & bounds.
dominic.steinitz <at> blueyonder.co.uk**20070711202534]
[Resolve conflicts.
dominic.steinitz <at> blueyonder.co.uk**20070711202408]
[Remove redundant code (was commented out).
dominic.steinitz <at> blueyonder.co.uk**20070708082443]
[Correct mispellt names.
dominic.steinitz <at> blueyonder.co.uk**20070708082421]
[Convention for newtype naming.
dominic.steinitz <at> blueyonder.co.uk**20070708082345]
[But restricted character string types can!
dominic.steinitz <at> blueyonder.co.uk**20070707072850]
[Strings cannot be given value ranges.
dominic.steinitz <at> blueyonder.co.uk**20070707072708]
[Input pattern of 5th case of toPer changed to match size-constrained sequence-of values only. Type of SIZE changed to allow for any size-constrained type and type specification added to encodeSeqSz.
djrussell <at> kingston.ac.uk**20070711104222]
[In definition of toPer, encodeSeqOf and encodeSz replaced by encodeSO (manages all cases constrained and otherwise of sequence-of encoding). encodeSO replaces encodeSeqOf (but uses it in definition) plus some new test values.
djrussell <at> kingston.ac.uk**20070711094811]
[unCompressInt renamed untoPerInt and new tests added.
djrussell <at> kingston.ac.uk**20070711092930]
[compress replaced by toPer in test functions and Maybe a replaced by Lower or Upper in Range case of ConstrainedType dec.
djrussell <at> kingston.ac.uk**20070710113422]
[compressIntWithRange and perConstrainedness' (and related functions) removed.
djrussell <at> kingston.ac.uk**20070710104221]
[perConstrainedness replaced by bounds in uncompressInt
djrussell <at> kingston.ac.uk**20070710104112]
[Encoding of a size-constrained sequence-of added.
djrussell <at> kingston.ac.uk**20070710102723]
[Addition of functions for encoding the sequence-of type.
djrussell <at> kingston.ac.uk**20070710095333]
[compressSeq and compressSeqAux renamed as encodeSeq and encodeSeqAux and placed after the integer encoding block.
djrussell <at> kingston.ac.uk**20070710095012]
[to2sComplement moved to below the auxillary functions for encodeWithLengthDeterminant, and embeed comment added.
djrussell <at> kingston.ac.uk**20070710094121]
[Removed commented out unused lengthDeterminant function.
djrussell <at> kingston.ac.uk**20070710092830]
[New embedded comment for minOctets and type specification is uncommented.
djrussell <at> kingston.ac.uk**20070710092603]
[minBits placed before minOctets (used first in encodeInt). Embedded comments added.
djrussell <at> kingston.ac.uk**20070709145555]
[encodeInt replaces encode and appears immediately after toPer.
djrussell <at> kingston.ac.uk**20070709144345]
[compress renamed toPer and two additional cases for SEQUENCEOF and SIZE.
djrussell <at> kingston.ac.uk**20070709143329]
[Top-level compress function moved before supplementary functions
djrussell <at> kingston.ac.uk**20070709143027]
[perConstrainedness renamed bounds and SEQUENCEOF and SIZE cases added.
djrussell <at> kingston.ac.uk**20070709142346]
[Addition of SEQUENCEOF and SIZE to ConstrainedType
djrussell <at> kingston.ac.uk**20070709141746]
[per09071
djrussell <at> kingston.ac.uk**20070709135825]
[remove
djrussell <at> kingston.ac.uk**20070709135748]
[List instantiation for SizeConstraint
djrussell <at> kingston.ac.uk**20070709122819]
[hhh
djrussell <at> kingston.ac.uk**20070709104828]
[djrpatch1
djrussell <at> kingston.ac.uk**20070709104514]
[blah
djrussell <at> kingston.ac.uk**20070709104440]
[Add references to X.691.
dominic.steinitz <at> blueyonder.co.uk**20070701062752]
[Start work to fix Int overflow problem.
dominic.steinitz <at> blueyonder.co.uk**20070701062608]
[Cosmetic changes.
dominic.steinitz <at> blueyonder.co.uk**20070701062514]
[More work on decoding INTEGER.
dominic.steinitz <at> blueyonder.co.uk**20070701062309]
[A very inefficient start on uncompress for INTEGER.
dominic.steinitz <at> blueyonder.co.uk**20070623142901]
[Tests for INTEGER.
dominic.steinitz <at> blueyonder.co.uk**20070617100548]
[Finish off encoding of INTEGER (unconstrained).
dominic.steinitz <at> blueyonder.co.uk**20070617100523]
[Fix bug in usage of minBits.
dominic.steinitz <at> blueyonder.co.uk**20070617100505]
[Spelling correction.
dominic.steinitz <at> blueyonder.co.uk**20070616195711]
[Twos complement functions.
dominic.steinitz <at> blueyonder.co.uk**20070616142759]
[Start encoding of unconstrained INTEGER.
dominic.steinitz <at> blueyonder.co.uk**20070616142722]
[Final fix to compression of SEQUENCEs.
dominic.steinitz <at> blueyonder.co.uk**20070616142542]
[dan1patch
djrussell <at> kingston.ac.uk**20070611093613]
[Issue 7 (compressSeqAux problem) fix.
dominic.steinitz <at> blueyonder.co.uk**20070609134538]
[See issue 12 (Constraint Monoid Question).
dominic.steinitz <at> blueyonder.co.uk**20070609082225
The result of two lower bounds should be the max of them not the min.
]
[Fixes issue 8 (Compressing INTEGER is wrong).
dominic.steinitz <at> blueyonder.co.uk**20070609061745
This removes the duplicate code / function compressIntWithRange.
]
[Encoding of OPTIONAL is actually correct!
dominic.steinitz <at> blueyonder.co.uk**20070603160004]
[Seeing how to do preambles for OPTIONAL.
dominic.steinitz <at> blueyonder.co.uk**20070603110536]
[Some rearranging to make it easier to read.
dominic.steinitz <at> blueyonder.co.uk**20070603075418]
[Check that empty SEQUENCEs are possible.
dominic.steinitz <at> blueyonder.co.uk**20070603061114]
[A fifth attempt.
dominic.steinitz <at> blueyonder.co.uk**20070603061046]
[Improvements to encoding INTEGERs.
dominic.steinitz <at> blueyonder.co.uk**20070603060928]
[The first type we should aim to encode.
dominic.steinitz <at> blueyonder.co.uk**20070520204111]
[Encoding semi-constrained INTEGER almost.
dominic.steinitz <at> blueyonder.co.uk**20070520075946
Currently EncodeWithLengthDeterminant is [Bit] -> [Bit]
so length count is always the number of bits.
It needs to be something like [a] -> [Bit] so the length
count is the real length.
]
[Simplification of integer encode to use minBits.
dominic.steinitz <at> blueyonder.co.uk**20070519182222]
[First attempt at indefinite length.
dominic.steinitz <at> blueyonder.co.uk**20070519182143]
[Misreading of 10.9.4.1
dominic.steinitz <at> blueyonder.co.uk**20070519071342]
[Start of encodings for lengths.
dominic.steinitz <at> blueyonder.co.uk**20070513084221]
[The 3rd attempt.
dominic.steinitz <at> blueyonder.co.uk**20070512151346]
[A calculus of constraints?
dominic.steinitz <at> blueyonder.co.uk**20070512151321]
[Some more ASN.1 types for testing.
dominic.steinitz <at> blueyonder.co.uk**20070507151803]
[More ASN.1 types to test.
dominic.steinitz <at> blueyonder.co.uk**20070507150955]
[TAG 0.0.2
dominic.steinitz <at> blueyonder.co.uk**20070507130857]
Patch bundle hash:
6dacbd091b8787dec819017f2d5426432ef7c874
_______________________________________________ darcs-users mailing list darcs-users <at> darcs.net http://lists.osuosl.org/mailman/listinfo/darcs-users