Test Framework Progress I

:l Run

main

*** Exception: NewPretty.hs:138:0-47: Non-exhaustive patterns in function prettyTypeVal

Constraints and Monads

As discussed last night, I've hit a problem with the type for decoding
SEQUENCE.

1. I have a function for decoding INTEGER.

> > (MonadError [Char] (t1 BG.BitGet), MonadTrans t1, Monad t) =>
> > t IntegerConstraint -> Bool -> t IntegerConstraint -> t (t1 BG.BitGet InfInteger)

As you can see the constraints live inside a monad as they may fail.

2. I have an auxialliary function for SEQUENCE. It takes a bit map and a
SEQUENCE and returns either an error or action (which when evaluated
will decode the bits). Note that the monad has become concrete as m =
Either String.

> > fromSequenceAuz :: (MonadTrans t, MonadError [Char] (t BG.BitGet)) => [Bool] -> Sequence a -> Either String (t BG.BitGet a)

In other words, this is

> > fromSequenceAuz :: (MonadTrans t, MonadError [Char] (t BG.BitGet)) => [Bool] -> Sequence a -> m (t BG.BitGet a)

but there'd probably need to be some extra constraints on m.

3. I have a function which returns (an action which when run returns)
the bit mask

> > Int -> BG.BitGet [Bool]

4. Here's where I have a problem. I can't "extract" the bit map from the
BG.BitGet monad (what I mean by extract is x <- bitMask 3 for example)
until I have extracted the action to run the decoding (fromSequenceAuz).
But I can't run this until I have the bit map.

Having spent all day yesterday on this, I think the answer is that we
should run the constraint monad before even attempting decoding whereas
at the moment I try to delay the constraint monad and evaluate it at the
last possible moment. I think this is the right approach. After all we
know the constraints are valid or invalid before we start decoding so
there's no point in doing any decoding work only to find out that the
constraints were invalid in the first place.

This will also make the code simpler. For example, the type signature
for decoding INTEGER would now be

> > (MonadError [Char] (t1 BG.BitGet), MonadTrans t1, Monad t) =>
> > IntegerConstraint -> Bool -> IntegerConstraint -> (t1 BG.BitGet InfInteger)

and there would be one less level of "do <- " in the function definition.

I'm inclined to do something like this (although I haven't quite thought
it through)

> > forget :: (MonadTrans t, MonadError [Char] (t BG.BitGet)) => Either String (t BG.BitGet a) -> t BG.BitGet a
> > forget (Left e) = throwError e
> > forget (Right x) = x

So the constraint error percolates through the (transformed) BitGet
monad and no decoding actually gets done.

A further thought: currently the error monad for throwError is just a
string. I think it would be better to have our own error monad with e.g.

data OurError = ConstraintError String | DecodeError String

then we can distinguish what sort of error caused the failure.

Thoughts?

Haddock and HPC

I'm sure I cannot be using haddock correctly. Here's what I currently use to get it to work:

haddock -h Integer.hs -B /usr/lib/ghc-6.8.2 
--optghc=-i/home/dom/backup/asn15/binary-strict_0/src 
--optghc=-i/home/dom/backup/asn15/asn1            

And here's how I'm using HPC:

ghc-6.8.2 -fhpc Tests/Main.hs --make -i../binary-strict/src
rm Main.tix
hpc report Main
hpc markup Main

Object Class Experiment

If you type

prettyOC1 x

at the command line you get

Fixed Type Value Set Errors BOOLEAN
Information Object other function
Variable Type Value Set Supported Arguments {Type ArgumentType}
Fixed Type Value Set Alphabet IA5STRING
Variable Type Value result-if-error {Type ResultType}
Type ResultType
Fixed Type Value code INTEGER
Type ArgumentType

The code is in Example.hs in the darcs repository.

import Text.PrettyPrint

data ZeroTuple = ZeroTuple
data Tuple e es = Tuple e es

newtype IA5String = IA5String {unIA5String :: String}

data ASNType :: * -> * where
   BOOLEAN   :: ASNType Bool
   INTEGER   :: ASNType Integer
   IA5STRING :: ASNType IA5String

prettyType :: ASNType a -> Doc
prettyType BOOLEAN   = text "BOOLEAN"
prettyType INTEGER   = text "INTEGER"
prettyType IA5STRING = text "IA5STRING"


data UbjClass :: * where
   USingleton :: UbjClassComponent -> UbjClass
   UCons      :: UbjClassComponent -> UbjClass -> UbjClass

type FieldName = String
   
data UbjClassComponent :: * where
   UCFTV :: FieldName -> ASNType a -> UbjClassComponent
   UCIO  :: FieldName -> UbjClass -> UbjClassComponent

uF2 = UCFTV "code" INTEGER

uF = UCons (UCIO "another" uF) (USingleton uF2)

data ObjClass :: * -> * where
   Singleton :: ObjClassComponent a -> ObjClass a
   Cons      :: ObjClassComponent a -> ObjClass l -> ObjClass (Tuple a l)
   Lift      :: Mu a l -> ObjClass (Mu a l)

data ObjClassComponent :: * -> * where
   OCFTV :: FieldName -> ASNType a -> ObjClassComponent a
   OCIO  :: FieldName -> ObjClass a -> ObjClassComponent a

oF2 = OCFTV "code" INTEGER

oF = Lift (Inl (Cons (OCIO "another" oF) (Singleton oF2)))

oG = Lift (Inr (Cons oF2 (Singleton (OCIO "another" oG))))

oH = Lift (Inl (Cons (OCIO "another" oH) (Cons oF2 (Singleton oF2))))

oJ = Cons ((OCIO "bar") $ oH) (Singleton  . (OCIO "foo") $ oH) 

oK = Lift (Inr (Cons oF2 (Lift (Inl (Cons (OCIO "foo" oK) (Singleton oF2))))))

data Mu :: * -> * -> * where
   Inl :: ObjClass (Tuple (Mu a b) b) -> Mu a b
   Inr :: ObjClass (Tuple a (Mu a b)) -> Mu a b

prettyOCC :: ObjClassComponent a -> String
prettyOCC (OCFTV fn ty) = fn ++ " " ++ prettyASN ty
prettyOCC (OCIO fn oc)  = fn

prettyASN :: ASNType a -> String
prettyASN BOOLEAN = "BOOLEAN"
prettyASN INTEGER = "INTEGER"

prettyOC :: ObjClass a -> String
prettyOC (Singleton occ) = prettyOCC occ
prettyOC (Cons occ oc) = prettyOCC occ ++ " " ++ prettyOC oc
prettyOC (Lift mu) = prettyMu mu

prettyMu :: Mu a b -> String
prettyMu (Inl oc) = prettyOC oc
prettyMu (Inr oc) = prettyOC oc

data ObjClassComponent1 :: * -> * where
   OCType :: FieldName -> ObjClassComponent1 a
   OCFixedTypeValue :: FieldName -> ASNType a -> ObjClassComponent1 a
   OCVariableTypeValue :: FieldName -> ObjClassComponent1 a -> ObjClassComponent1 a
   OCFixedTypeValueSet :: FieldName -> ASNType a -> ObjClassComponent1 a
   OCVariableTypeValueSet :: FieldName -> ObjClassComponent1 a -> ObjClassComponent1 a
   OCInformationObject :: FieldName -> ObjClass1 a -> ObjClassComponent1 a

data ObjClass1 :: * -> * where
   Singleton1 :: ObjClassComponent1 a -> ObjClass1 a
   Cons1      :: ObjClassComponent1 a -> ObjClass1 l -> ObjClass1 (Tuple a l)
   Lift1      :: Mu1 a l -> ObjClass1 (Mu1 a l)

data Mu1 :: * -> * -> * where
   Inl1 :: ObjClass1 (Tuple (Mu1 a b) b) -> Mu1 a b
   Inr1 :: ObjClass1 (Tuple a (Mu1 a b)) -> Mu1 a b

{-

The definition in Haskell below is very similar to the one on page 314 in
Dubuisson which is reproduced below.

OTHER-FUNCTION ::= CLASS {
  &code                INTEGER (0..MAX) UNIQUE,
  &Alphabet            BMPString
    DEFAULT {Latin1 INTERSECTION Level1},
  &ArgumentType        ,
  &SupportedArguments &ArgumentType OPTIONAL,
  &ResultType          DEFAULT NULL,
  &result-if-error     &ResultType DEFAULT NULL,
  &associated-function OTHER-FUNCTION OPTIONAL,
  &Errors              ERROR DEFAULT
    {rejected-argument | memory-fault} }

-}

x1 = OCType "ArgumentType"
x2 = OCFixedTypeValue "code" INTEGER
x3 = OCType "ResultType"
x4 = OCVariableTypeValue "result-if-error" x3
x5 = OCFixedTypeValueSet "Alphabet" IA5STRING
x6 = OCVariableTypeValueSet "Supported Arguments" x1
x7 = OCFixedTypeValueSet "Errors" BOOLEAN

x = Lift1 (Inr1 (Cons1 x7 (Lift1 (Inl1 (Cons1 (OCInformationObject "other function" x) (Cons1 x6 (Cons1 x5 (Cons1 x4 (Cons1 x3 (Cons1 x2 (Singleton1 x1)))))))))))

printObjClassComp (OCType fn) = text "Type" <+> text fn
printObjClassComp (OCFixedTypeValue fn t) = text "Fixed Type Value" <+> text fn <+> prettyType t
printObjClassComp (OCVariableTypeValue fn c) = text "Variable Type Value" <+> text fn <+> braces (printObjClassComp c)
printObjClassComp (OCFixedTypeValueSet fn t) = text "Fixed Type Value Set" <+> text fn <+> prettyType t
printObjClassComp (OCVariableTypeValueSet fn c) = text "Variable Type Value Set" <+> text fn <+> braces (printObjClassComp c)
printObjClassComp (OCInformationObject fn oc)  = text "Information Object" <+> text fn

prettyOC1 :: ObjClass1 a -> Doc
prettyOC1 (Singleton1 occ) = printObjClassComp occ
prettyOC1 (Cons1 occ oc) = printObjClassComp occ $$ prettyOC1 oc
prettyOC1 (Lift1 mu) = prettyMu1 mu

prettyMu1 :: Mu1 a b -> Doc
prettyMu1 (Inl1 oc) = prettyOC1 oc
prettyMu1 (Inr1 oc) = prettyOC1 oc

Inter-operability Testing

Given that asn1c can't cope with entirely random (although legal) ASN.1, I've had to move away from using QuickCheck (for that particular purpose). I'm now going to use the unit tests to test inter-operability. Running main in Run.hs will:

• generate ASN.1


• run asn1c


• generate C to encode a value


• compile the C


• run the C (encoding the value)


• decode the value

I haven't yet put in code to check that the decoded value equals the original value.

It would be useful to be able to generate and encode values for multiple types rather than creating all the asn1c overhead for each type.

Upgrading System

As a test, I've generated some ASN.1 and C. Unfortunately, asn1c gives an error for PER encoding with this but not for BER encoding :-(

FooBar {1 2 3 4 5 6} DEFINITIONS ::=
 BEGIN
   Integer5 ::= INTEGER (-1..MAX)
   value1 Integer5 ::= 4096
 END

#include ?stdio.h>   /* for stdout */
#include  ?stdlib.h> /* for malloc () */
#include  ?assert.h> /* for run-time control */
#include ?integer5.h> /* Integer5 ASN.1 type */

/*
* This is a custom function which writes the
* encoded output into some FILE stream.
*/

static int
write_out(const void *buffer, size_t size, void *app_key) {
    FILE *out_fp = app_key;
    size_t wrote;
    wrote = fwrite(buffer, 1, size, out_fp);
    return (wrote == size) ? 0 : -1;
}

int main(int ac, char **av) {
 
 /* Encoder return value */
 asn_enc_rval_t ec;
 
 
 /* Declare a pointer to a Integer5 type */
 Integer5_t *integer5;
 
 /* Allocate an instance of  Integer5 */
 integer5 = calloc(1, sizeof(Integer5_t)); /* not malloc! */
 assert(integer5); /* Assume infinite memory */
 
 (*integer5) = 4097;
 
 if(ac < filename =" av[1];" fp =" fopen(filename," ec =" uper_encode(&asn_DEF_Integer5,integer5,write_out,fp);" encoded ="="">name : "unknown");
      exit(65); /* better, EX_DATAERR */
      } else {
      fprintf(stderr,"Created %s with PER encoded Integer5\n",filename);
      }
      fclose(fp);
 }
 /* Also print the constructed ???? XER encoded (XML) */
 xer_fprint(stdout,&asn_DEF_Integer5,integer5);
 return 0; /* Encoding finished successfully */
}

We may need this:

dom@heisenberg:~/asn15/asn1> darcs whatsnew
{
hunk ./UnitTest.lhs 33
+import qualified Data.Binary.Strict.Util   as BU
+
+bar = BU.hexDump
+bax = BU.hexDumpString
}

ASN.1 Library Starts to Use Bytestrings

You'll need this to make the latest Constrained.lhs compile.