| This example program takes a modified version of the example in Annex A 
of X.690 (ISO 8825-1) and demonstrates how to produce Haskell types 
and encoding and decoding functions for each type. 
 Here's the ASN.1.
 PersonnelRecord ::= [APPLICATION 0] IMPLICIT SEQUENCE {
   name         Name,
   title        [0] VisibleString,
   number       EmployeeNumber,
   dateOfHire   [1] Date,
   nameOfSpouse [2] Name,
   children     [3] IMPLICIT
      SEQUENCE OF ChildInformation DEFAULT {} }
ChildInformation ::= SEQUENCE
    { name        Name,
      dateOfBirth [0] Date}
Name ::= [APPLICATION 1] IMPLICIT SEQUENCE
   {givenName  VisibleString,
    initial    VisibleString,
    familyName VisibleString}
EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER
 Date ::= [APPLICATION 3] IMPLICIT VisibleString -- YYYYMMDD
 And here is the corresponding Haskell.
 module Main(main) where
 import Char
import IO
import Control.Monad.State
import List
 import Codec.ASN1.ASN1
 newtype Date = MkDate VisibleString
   deriving Show
 instance ASNable Date where
   toASN NoTag (MkDate d) = toASN (Implicit (Application,3)) d
   toASN tag   (MkDate d) = toASN tag d 
   fromASN t x =
      let (u,e1,e2) = 
            case t of
               NoTag ->
	          ((Application,3),
	           "fromASN: invalid application primitive tag for Date",
	           "fromASN: invalid constructed tag for Date")
               (Implicit v) ->
	          (v,
	           "fromASN: invalid implicit primitive tag for Date",
	           "fromASN: invalid implicit constructed tag for Date") in
         f u x e1 e2        
      where
         f t x errMsg1 errMsg2 =
            case x of
	       Primitive' t' v ->
	          if t == t'
		     -- VisibleString normally has the Universal tag 26.
		     -- Decode it as an OctetString, encode it with the
		     -- expected tag and then properly decode it.
	             then let (y::OctetString) = fromASN (Implicit t) x 
	                      z = map (chr . fromIntegral) $
	                          encode $ toASN (Implicit (Universal,26)) y 
	                      ((_,(u::ASN)),_)  = runState (decode stdin) z
	                      (v::VisibleString) = fromASN NoTag u in 
	                         MkDate v
	             else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
	       otherwise ->
	          error errMsg2
newtype EmployeeNumber = MkEmployeeNumber Integer
   deriving Show
 instance ASNable EmployeeNumber where
   toASN NoTag (MkEmployeeNumber n) =
      toASN (Implicit (Application,2)) n
   toASN tag (MkEmployeeNumber n) =
      toASN tag n
   fromASN t x =
      let (u,e1,e2) = 
            case t of
               NoTag ->
	          ((Application,2),
	           "fromASN: invalid application primitive tag for EmployeeNumber",
	           "fromASN: invalid constructed tag for EmployeeNumber")
               (Implicit v) ->
	          (v,
	           "fromASN: invalid implicit primitive tag for EmployeeNumber",
	           "fromASN: invalid implicit constructed tag for EmployeeNumber") in
         f u x e1 e2        
      where
         f t x errMsg1 errMsg2 =
            case x of
	       Primitive' t' v ->
	          if t == t'
		     -- Integer normally has the Universal tag 2.
		     -- Decode it as an OctetString, encode it with the
		     -- expected tag and then properly decode it.
	             then let (y::OctetString) = fromASN (Implicit t) x 
	                      z = map (chr . fromIntegral) $
	                          encode $ toASN (Implicit (Universal,2)) y 
	                      ((_,(u::ASN)),_)  = runState (decode stdin) z
	                      (v::Integer) = fromASN NoTag u in 
	                         MkEmployeeNumber v
	             else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
	       otherwise ->
	          error errMsg2
data Name =
   MkName {
      givenName  :: VisibleString,
      initial    :: VisibleString,
      familyName :: VisibleString }
   deriving Show
instance ASNable Name where
   toASN NoTag n =
      toASN (Implicit (Application,1)) [toASN NoTag (givenName n),
                                        toASN NoTag (initial n),
                                        toASN NoTag (familyName n)]
   toASN tag n =
      toASN tag [toASN NoTag $ givenName n,
                 toASN NoTag $ initial n,
                 toASN NoTag $ familyName n]
   fromASN t x =
      let (u,e1,e2,e3) = 
            case t of
               NoTag ->
	          ((Application,1),
	           "fromASN: invalid application constructed tag for Name",
	           "fromASN: invalid primitive tag for Name",
                   "fromASN: invalid number of components for Name") 
               (Implicit v) ->
	          (v,
	           "fromASN: invalid implicit constructed tag for Name",
	           "fromASN: invalid implicit primitive tag for Name",
                   "fromASN: invalid number of components for Name") in 
         f u x e1 e2 e3       
      where
         f t x errMsg1 errMsg2 errMsg3 =
            case x of
	       Constructed' t' v ->
	          if t == t'
	             then case v of
		             [b1,b2,b3] ->
			        let gn = fromASN NoTag b1
				    i  = fromASN NoTag b2
				    fn = fromASN NoTag b3 in
				       MkName {givenName = gn, initial = i, familyName = fn}
			     otherwise ->
			        error errMsg3
	             else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
	       otherwise ->
	          error errMsg2
data ChildInformation =
   MkChildInformation {
      name :: Name,
      dateOfBirth ::Date }
   deriving Show
instance ASNable ChildInformation where
   toASN t c =
      case t of
         NoTag ->
            Constructed' (Universal,16) bs
         Implicit tag ->
            Constructed' tag bs
      where
          bs = [toASN NoTag (name c), 
                toASN (Implicit (Context,1)) (dateOfBirth c)]
   fromASN t x =
      let (u,e1,e2,e3) = 
            case t of
               NoTag ->
	          ((Universal,16),
	           "fromASN: invalid universal constructed tag for ChildInformation",
	           "fromASN: invalid primitive tag for ChildInformation",
                   "fromASN: invalid number of components for ChildInformation") 
               (Implicit v) ->
	          (v,
	           "fromASN: invalid implicit constructed tag for ChildInformation",
	           "fromASN: invalid implicit primitive tag for ChildInformation",
                   "fromASN: invalid number of components for ChildInformation") in 
         f u x e1 e2 e3       
      where
         f t x errMsg1 errMsg2 errMsg3 =
            case x of
	       Constructed' t' v ->
	          if t == t'
	             then case v of
		             [b1,b2] ->
			        let dob = fromASN (Implicit (Context,1)) b2
				    nm  = fromASN NoTag b1 in
				       MkChildInformation {dateOfBirth = dob, name = nm}
			     otherwise ->
			        error errMsg3
	             else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
	       otherwise ->
	          error errMsg2
data PersonnelRecord = 
   MkPersonnelRecord {
      name_1       :: Name,
      title        :: VisibleString,
      number       :: EmployeeNumber,
      dateOfHire   :: Date,
      nameOfSpouse :: Name,
      children     :: [ChildInformation] }
   deriving Show
instance ASNable PersonnelRecord where
   toASN t p =
      case t of
         NoTag ->
            Constructed' (Application,0) bs
         Implicit tag ->
            Constructed' tag bs
      where
          bs = [toASN NoTag (name_1 p), 
                toASN (Implicit (Context,0)) (title p),
		toASN NoTag (number p), 
		toASN (Implicit (Context,1)) (dateOfHire p),
		toASN (Implicit (Context,2)) (nameOfSpouse p),
		toASN (Implicit (Context,3)) (map (toASN NoTag) (children p))]
   fromASN t x =
      let (u,e1,e2,e3) = 
            case t of
               NoTag ->
	          ((Application,0),
	           "fromASN: invalid application constructed tag for PersonnelRecord",
	           "fromASN: invalid primitive tag for PersonnelRecord",
                   "fromASN: invalid number of components for PersonnelRecord") 
               (Implicit v) ->
	          (v,
	           "fromASN: invalid implicit constructed tag for PersonnelRecord",
	           "fromASN: invalid implicit primitive tag for PersonnelRecord",
                   "fromASN: invalid number of components for PersonnelRecord") in 
         f u x e1 e2 e3       
      where
         f t x errMsg1 errMsg2 errMsg3 =
            case x of
	       Constructed' t' v ->
	          if t == t'
	             then case v of
		             [b1,b2,b3,b4,b5,b6] ->
			        let nm  = fromASN NoTag b1
		                   -- VisibleString normally has the Universal tag 26.
		                   -- Decode it as an OctetString and then encode it with the
		                   -- expected tag and then properly decode it.
				    tio :: OctetString
				    tio = fromASN (Implicit (Context,0)) b2
	                            tie = map (chr . fromIntegral) $
	                                     encode $ toASN (Implicit (Universal,26)) tio 
	                            ((_,(tia::ASN)),_)  = runState (decode stdin) tie
	                            ti  = fromASN NoTag tia 
				    en  = fromASN NoTag b3
				    doh = fromASN (Implicit (Context,1)) b4
				    nos = fromASN (Implicit (Context,2)) b5
				    as  = fromASN (Implicit (Context,3)) b6 
				    cs  = map (fromASN NoTag) as in
				       MkPersonnelRecord { name_1       = nm, 
				                           title        = ti,
							   number       = en,
							   dateOfHire   = doh,
							   nameOfSpouse = nos,
							   children     = cs }
			     otherwise ->
			        error errMsg3
	             else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
	       otherwise ->
	          error errMsg2
name1 = MkName { givenName  = MkVisibleString "John",
                initial    = MkVisibleString "P",
                familyName = MkVisibleString "Smith" }
name2 = MkName { givenName  = MkVisibleString "Mary",
                initial    = MkVisibleString "T",
                familyName = MkVisibleString "Smith" }
name3 = MkName { givenName = MkVisibleString "Ralph",
                 initial   = MkVisibleString "T",
                 familyName = MkVisibleString "Smith" }
name4 = MkName { givenName = MkVisibleString "Susan",
                 initial   = MkVisibleString "B",
                 familyName = MkVisibleString "Jones" }
date1 = MkDate (MkVisibleString "19710917")
date2 = MkDate (MkVisibleString "19571111")
date3 = MkDate (MkVisibleString "19590717")
employeeNumber1 = MkEmployeeNumber 51
child1 = MkChildInformation { name = name3,
                              dateOfBirth = date2 }
child2 = MkChildInformation { name = name4,
                              dateOfBirth = date3 }
personnelRecord1 = MkPersonnelRecord { name_1 = name1,
                                       title  = MkVisibleString "Director",
				       number = employeeNumber1,
				       dateOfHire = date1,
				       nameOfSpouse = name2,
				       children = [child1,child2] }
encodedPR = map (chr . fromIntegral) $ encode $ toASN NoTag personnelRecord1
-- Decoding can either be done using a state monad or the IO monad - see below.
-- stdin is a dummy file handle so that the overloaded function decode can be used
-- with either monad.
unASNedAndDecodedPR :: (PersonnelRecord,String)
unASNedAndDecodedPR = runState (do (m,y) <- decode stdin; return $ fromASN NoTag y) encodedPR 
main = 
   do ofh <- openFile "tst.txt" WriteMode 
      hPutStr ofh encodedPR
      hClose ofh
      ifh <- openFile "tst.txt" ReadMode
      (m,y) <- decode ifh
      putStrLn (show ((fromASN NoTag y)::PersonnelRecord))
 |