hunk ./NewPretty.hs 1 -{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns #-} - --- -fwarn-incomplete-patterns - -module NewPretty where - -import ASNTYPE -import PERWriter -import Language.ASN1 ( - -- TagPlicity (..), - TagType (..) - ) -import Text.PrettyPrint as PP - -import Control.Monad.Identity -import Control.Monad.State - -import qualified Data.Map as Map - -import NewTestData -- FIXME: For temporary testing - testing should - -- really be done outside of the module being tested - -type ASNPrettyM = StateT (Map.Map TypeReference Doc) Identity - -prettyTypeNonM :: ASNType a -> Doc -prettyTypeNonM t = vcat $ d:(map (\(k, v) -> text (ref k) <+> text "::=" <+> v) $ Map.toList m) - where - (d, m) = runIdentity . flip (runStateT . prettyType) Map.empty $ t - -prettyNamedType :: NamedType a -> ASNPrettyM Doc -prettyNamedType (NamedType n ct) = do d <- prettyType ct - return $ text n <+> d - -prettyChoice :: Choice a -> ASNPrettyM Doc -prettyChoice EmptyChoice = return $ PP.empty -prettyChoice (ChoiceOption nt EmptyChoice) = prettyNamedType nt -prettyChoice (ChoiceOption nt xs) = do - d1 <- prettyNamedType nt - d2 <- prettyChoice xs - return $ vcat [d1 <> comma, d2] -prettyChoice (ChoiceExtensionMarker x) = do - d <- prettyChoice x - return $ vcat [text "..." <> comma, d <> comma] --- FIXME: What should we do with v? -prettyChoice (ChoiceExtensionAdditionGroup v x) = - liftM (brackets . brackets) $ prettyChoice' x - -prettyChoice' :: Choice' a -> ASNPrettyM Doc -prettyChoice' EmptyChoice' = return $ PP.empty -prettyChoice' (ChoiceOption' nt EmptyChoice') = prettyNamedType nt -prettyChoice' (ChoiceOption' nt xs) = do - do d1 <- prettyNamedType nt - d2 <- prettyChoice' xs - return $ vcat [d1 <> comma, d2] -prettyChoice' ChoiceExtensionMarker' = return $ text "..." - -prettyType :: ASNType a -> ASNPrettyM Doc -prettyType (ReferencedType r t) = prettyReferencedType r t -prettyType (BuiltinType bt) = prettyBuiltinType bt -prettyType (ConstrainedType t e) = do d1 <- prettyType t - d2 <- prettyElementSetSpecs t e - return $ d1 <+> parens d2 - -prettySeq :: Sequence a -> ASNPrettyM Doc -prettySeq EmptySequence = return $ PP.empty -prettySeq (AddComponent x EmptySequence) = prettyComponentType x -prettySeq (AddComponent x xs) = do d <- prettyComponentType x - ds <- prettySeq xs - return $ vcat [d <> comma, ds] -prettySeq (ExtensionMarker x) = do d <- prettySeq x - return $ vcat [text "..." <> comma, d <> comma] --- FIXME: What should we do with v? -prettySeq (ExtensionAdditionGroup v x y) = do d1 <- prettySeq2 x - d2 <- prettySeq y - return $ vcat [(brackets $ brackets d1) <> comma, d2] - -prettySeq2 :: Sequence' a -> ASNPrettyM Doc -prettySeq2 EmptySequence' = return $ PP.empty -prettySeq2 (AddComponent' x EmptySequence') = prettyComponentType x -prettySeq2 (AddComponent' x xs) = do d1 <- prettyComponentType x - d2 <- prettySeq2 xs - return $ vcat [d1 <> comma, d2] - -prettySeq' :: Sequence a -> ASNPrettyM [Doc] -prettySeq' EmptySequence = return [] -prettySeq' (AddComponent x xs) = do d <- prettyComponentType x - ds <- prettySeq' xs - return (d:ds) -prettySeq' (ExtensionMarker x) = do ds <- prettySeq' x - return $ (text "..."):ds --- FIXME: What should we do with v? -prettySeq' (ExtensionAdditionGroup v x y) = do - d1s <- prettySeq2' x - d2s <- prettySeq' y - return $ (brackets $ brackets $ vcat $ punctuate comma d1s):d2s - -prettySeq2' :: Sequence' a -> ASNPrettyM [Doc] -prettySeq2' EmptySequence' = return [] -prettySeq2' (AddComponent' x xs) = do d <- prettyComponentType x - ds <- prettySeq2' xs - return $ d:ds - -prettySeq'' :: Sequence a -> ASNPrettyM Doc -prettySeq'' x = liftM (vcat . punctuate comma) $ prettySeq' x - -prettyComponentType :: ComponentType a -> ASNPrettyM Doc -prettyComponentType (MandatoryComponent m) = prettyNamedType m -prettyComponentType (OptionalComponent m) = do d <- prettyNamedType m - return $ d <+> text "OPTIONAL" -prettyComponentType (DefaultComponent m@(NamedType _ n) v) = do d <- prettyNamedType m - return $ d <+> text "DEFAULT" -- <+> prettyTypeVal n v - -prettyBuiltinType :: ASNBuiltin a -> ASNPrettyM Doc -prettyBuiltinType (BITSTRING []) = return $ text "BIT STRING" -prettyBuiltinType INTEGER = return $ text "INTEGER" -prettyBuiltinType PRINTABLESTRING = return $ text "PrintableString" -prettyBuiltinType BOOLEAN = return $ text "BOOLEAN" -prettyBuiltinType IA5STRING = return $ text "IA5STRING" -prettyBuiltinType (CHOICE c) = do d <- prettyChoice c - return $ text "CHOICE" <+> braces d -prettyBuiltinType (SEQUENCE s) = do d <- prettySeq'' s - return $ text "SEQUENCE" <> space <> braces d -prettyBuiltinType (SET s) = do d <- prettySeq s - return $ text "SET" <> space <> braces d -prettyBuiltinType (SEQUENCEOF t) = do d <- prettySeqOfType t - return $ text "SEQUENCE OF" <+> d -prettyBuiltinType (SETOF t) = do d <- prettySeqOfType t - - return $ text "SET OF" <+> d -prettyBuiltinType OCTETSTRING = return $ text "OCTETSTRING" -prettyBuiltinType (BITSTRING namedBits) = return $ text "BITSTRING" <+> braces (text "FIXME: the named bits") -prettyBuiltinType VISIBLESTRING = return $ text "VISIBLESTRING" -prettyBuiltinType NUMERICSTRING = return $ text "NUMERICSTRING" -prettyBuiltinType UNIVERSALSTRING = return $ text "UNIVERSALSTRING" -prettyBuiltinType BMPSTRING = return $ text "BMPSTRING" -prettyBuiltinType NULL = return $ text "NULL" -prettyBuiltinType (ENUMERATED enums) = return $ text "ENUMERATED" <+> braces (text "FIXME: the enumeratees") --- FIXME: For now ignore the tag information -prettyBuiltinType (TAGGED _tagInfo t) = prettyType t - - -prettySeqOfType :: SeqSetOf c => c a -> ASNPrettyM Doc -prettySeqOfType t - = let (f,s) = splitName t - in - case f of - Nothing -> do prettyType s - Just n -> do prettyNamedType (NamedType n s) - - -prettyReferencedType :: TypeReference -> ASNType a -> ASNPrettyM Doc -prettyReferencedType r t = do - refTypes <- get - let x = Map.lookup r refTypes - case x of - Nothing -> do - d <- prettyType t - let refTypes' = Map.insert r d refTypes - put refTypes' - Just _ -> do - return () - return $ text (ref r) - - - -prettyPlicity Implicit = text "IMPLICIT" -prettyPlicity Explicit = text "EXPLICIT" - -prettyElementSetSpecs :: ASNType a -> SubtypeConstraint a -> ASNPrettyM Doc -prettyElementSetSpecs t (RootOnly c) = prettyConstraint t c -prettyElementSetSpecs t (EmptyExtension c) = do d <- prettyConstraint t c - return $ d <> comma <+> text "..." -prettyElementSetSpecs t (NonEmptyExtension c1 c2) = do d1 <- prettyConstraint t c1 - d2 <- prettyConstraint t c2 - return $ d1 <> comma <+> text "..." <> comma <+> d2 - - -prettyConstraint :: ASNType a -> ElementSetSpec a -> ASNPrettyM Doc -prettyConstraint t (UnionSet u) = prettyUnion t u -prettyConstraint t (ComplementSet e) = prettyExcept t e - -prettyExcept :: ASNType a -> Exclusions a -> ASNPrettyM Doc -prettyExcept t (EXCEPT e) = prettyElem t e - -prettyUnion :: ASNType a -> Unions a -> ASNPrettyM Doc -prettyUnion t (NoUnion ic) = prettyIntersectionConstraint t ic -prettyUnion t (UnionMark u i) = do d1 <- prettyUnion t u - d2 <- prettyIntersectionConstraint t i - return $ d1 <+> text "|" <+> d2 - - -prettyIntersectionConstraint :: ASNType a -> Intersections a -> ASNPrettyM Doc -prettyIntersectionConstraint t (NoIntersection ie) = prettyInterSectionElement t ie -prettyIntersectionConstraint t (IntersectionMark ic ie) = do d1 <- prettyIntersectionConstraint t ic - d2 <- prettyInterSectionElement t ie - return $ d1 <+> text "^" <+> d2 - -prettyInterSectionElement t (ElementConstraint e) = prettyElem t e -prettyInterSectionElement t (ExclusionConstraint e exc) = do d1 <- prettyElem t e - d2 <- prettyExclusion t exc - return $ d1 <+> text "EXCEPT" <+> d2 - -prettyExclusion :: ASNType a -> Exclusions a -> ASNPrettyM Doc -prettyExclusion t (EXCEPT e) = prettyElem t e - -prettyElem :: ASNType a -> Element a -> ASNPrettyM Doc -prettyElem t (S s) = prettySingleValue t s -prettyElem t (V r) = prettyValueRange t r -prettyElem t (P a) = prettyPermittedAlphabet t a -prettyElem t (C c) = error "C" -prettyElem t (SZ s) = prettySizedElem t s -prettyElem t (IT i) = error "IT" - -prettySizedElem :: ASNType a -> SizeConstraint a -> ASNPrettyM Doc -prettySizedElem t (SC x) = do d <- prettyElementSetSpecs (BuiltinType INTEGER) x - return $ text "SIZE" <+> parens d - -prettyPermittedAlphabet :: ASNType a -> PermittedAlphabetConstraint a -> ASNPrettyM Doc -prettyPermittedAlphabet t (FR a) = do d <- prettyElementSetSpecs t a - return $ text "FROM" <+> parens d - -prettyValueRange :: ASNType a -> ValueRangeConstraint a -> ASNPrettyM Doc -prettyValueRange (BuiltinType INTEGER) (R (x,y)) = return $ pretty x <> text ".." <> pretty y -prettyValueRange (BuiltinType IA5STRING) (R (x,y)) = return $ text (iA5String x) <> text ".." <> text (iA5String y) -prettyValueRange (BuiltinType PRINTABLESTRING) (R (x,y)) = return $ text (printableString x) <> text ".." <> text (printableString y) -prettyValueRange (BuiltinType NUMERICSTRING) (R (x,y)) = return $ text (numericString x) <> text ".." <> text (numericString y) -prettyValueRange (BuiltinType (BITSTRING _)) (R (x,y)) = return $ text (show x) <> text ".." <> text (show y) - --- FIXME: Everything below is temporary -prettyValueRange (ReferencedType _ _) _ = return $ text "FIXME: prettyValueRange ReferencedType" -prettyValueRange (ConstrainedType _ _) _ = return $ text "FIXME: prettyValueRange ConstrainedType" -prettyValueRange (BuiltinType BOOLEAN) _ = return $ text "FIXME: prettyValueRange BuiltinType BOOLEAN" -prettyValueRange (BuiltinType (ENUMERATED _)) _ = return $ text "FIXME: prettyValueRange BuiltinType ENUMERATED" -prettyValueRange (BuiltinType OCTETSTRING) _ = return $ text "FIXME: prettyValueRange BuiltinType OCTETSTRING" -prettyValueRange (BuiltinType VISIBLESTRING) (R (x, y)) = return $ doubleQuotes (text $ visibleString x) <> - text ".." <> - doubleQuotes (text $ visibleString y) -prettyValueRange (BuiltinType UNIVERSALSTRING) _ = return $ text "FIXME: prettyValueRange BuiltinType UNIVERSALSTRING" -prettyValueRange (BuiltinType BMPSTRING) _ = return $ text "FIXME: prettyValueRange BuiltinType BMPSTRING" -prettyValueRange (BuiltinType NULL) _ = return $ text "FIXME: prettyValueRange BuiltinType NULL" -prettyValueRange (BuiltinType (SEQUENCE _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SEQUENCE" -prettyValueRange (BuiltinType (SEQUENCEOF _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SEQUENCEOF" -prettyValueRange (BuiltinType (SET _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SET" -prettyValueRange (BuiltinType (SETOF _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SETOF" -prettyValueRange (BuiltinType (CHOICE _)) _ = return $ text "FIXME: prettyValueRange BuiltinType CHOICE" -prettyValueRange (BuiltinType (TAGGED _ _)) _ = return $ text "FIXME: prettyValueRange BuiltinType TAGGED" - - - -prettySingleValue :: ASNType a -> SingleValueConstraint a -> ASNPrettyM Doc -prettySingleValue (BuiltinType INTEGER) (SV e) = return $ text (show e) -prettySingleValue (BuiltinType (BITSTRING _)) (SV e) = return $ prettyBitString e -prettySingleValue (BuiltinType IA5STRING) (SV e) = return $ text (show e) -prettySingleValue (BuiltinType PRINTABLESTRING) (SV e) = return $ doubleQuotes (text (printableString e)) - --- FIXME: Everything below is temporary -prettySingleValue (ReferencedType _ _) _ = return $ text "FIXME: prettySingleValue ReferencedType" -prettySingleValue (ConstrainedType _ _) _ = return $ text "FIXME: prettySingleValue ConstrainedType" -prettySingleValue (BuiltinType BOOLEAN) _ = return $ text "FIXME: prettySingleValue BOOLEAN" -prettySingleValue (BuiltinType (ENUMERATED _)) _ = return $ text "FIXME: prettySingleValue ENUMERATED" -prettySingleValue (BuiltinType OCTETSTRING) _ = return $ text "FIXME: prettySingleValue OCTETSTRING" -prettySingleValue (BuiltinType VISIBLESTRING) (SV x) = return $ text $ show $ visibleString x -prettySingleValue (BuiltinType NUMERICSTRING) _ = return $ text "FIXME: prettySingleValue NUMERICSTRING" -prettySingleValue (BuiltinType UNIVERSALSTRING) _ = return $ text "FIXME: prettySingleValue UNIVERSALSTRING" -prettySingleValue (BuiltinType BMPSTRING) _ = return $ text "FIXME: prettySingleValue BMPSTRING" -prettySingleValue (BuiltinType NULL) _ = return $ text "FIXME: prettySingleValue NULL" -prettySingleValue (BuiltinType (SEQUENCE _)) _ = return $ text "FIXME: prettySingleValue SEQUENCE" -prettySingleValue (BuiltinType (SEQUENCEOF _)) _ = return $ text "FIXME: prettySingleValue SEQUENCEOF" -prettySingleValue (BuiltinType (SET _)) _ = return $ text "FIXME: prettySingleValue SET" -prettySingleValue (BuiltinType (SETOF _)) _ = return $ text "FIXME: prettySingleValue SETOF" -prettySingleValue (BuiltinType (CHOICE _)) _ = return $ text "FIXME: prettySingleValue CHOICE" -prettySingleValue (BuiltinType (TAGGED _ _)) _ = return $ text "FIXME: prettySingleValue TAGGED" - - -prettyBitString = (<> text "B") . (quotes . text . concat . map show . bitString) - -class Pretty a where - pretty :: a -> Doc - -instance Pretty InfInteger where - pretty NegInf = text "MIN" - pretty PosInf = text "MAX" - pretty (Val x) = text (show x) - -prettyTypeVal :: ASNType a -> a -> Doc -prettyTypeVal (BuiltinType INTEGER) x = pretty x -prettyTypeVal (BuiltinType (SEQUENCE s)) x = error "SEQUENCE" - -prettyElementTypeVal :: ComponentType a -> a -> Doc -prettyElementTypeVal (MandatoryComponent (NamedType n t)) x = - text n <+> prettyTypeVal t x - - - - rmfile ./NewPretty.hs hunk ./PERWriter.hs 138 +fromPER t cl = error $ prettyType t hunk ./Pretty.hs 1 -{-# OPTIONS_GHC - -XMultiParamTypeClasses - -XFlexibleInstances - -XScopedTypeVariables - -fwarn-incomplete-patterns #-} +{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns #-} hunk ./Pretty.hs 3 -module Pretty( - prettyType, - prettyTypeVal, - pretty, - prettyVal - ) where +-- -fwarn-incomplete-patterns hunk ./Pretty.hs 5 -import Text.PrettyPrint -import ConstrainedType -import Language.ASN1 (TagType(..), TagPlicity(..)) +module NewPretty where hunk ./Pretty.hs 7 -prettyConstraint :: Constraint -> Doc -prettyConstraint (Elem s) = let (x,y) = s in parens (text (show x) <> text ".." <> text (show y)) -- WARNING for now - Dan is changing -prettyConstraint (Union c1 c2) = parens (prettyConstraint c1 <+> text "|" <+> prettyConstraint c2) -prettyConstraint (Intersection c1 c2) = parens (prettyConstraint c1 <+> text "^" <+> prettyConstraint c2) -prettyConstraint (Except c1 c2) = parens (prettyConstraint c1 <+> text "EXCEPT" <+> prettyConstraint c2) +import ASNTYPE +import PERWriter +import Language.ASN1 ( + -- TagPlicity (..), + TagType (..) + ) +import Text.PrettyPrint as PP hunk ./Pretty.hs 15 -class Pretty a where - pretty :: a -> Doc +import Control.Monad.Identity +import Control.Monad.State hunk ./Pretty.hs 18 -class PrettyVal a b where - prettyVal :: a -> b -> Doc +import qualified Data.Map as Map hunk ./Pretty.hs 20 -instance Pretty (ASNType a) where - pretty = prettyType +import NewTestData -- FIXME: For temporary testing - testing should + -- really be done outside of the module being tested hunk ./Pretty.hs 23 -instance PrettyVal (ASNType a) a where - prettyVal = prettyTypeVal +type ASNPrettyM = StateT (Map.Map TypeReference Doc) Identity hunk ./Pretty.hs 25 -prettyType :: ASNType a -> Doc -prettyType (TYPEASS tr _ t) = - text tr <+> text "::=" <+> prettyType t -prettyType (BITSTRING []) = - text "BIT STRING" -prettyType INTEGER = - text "INTEGER" -prettyType BOOLEAN = - text "BOOLEAN" -prettyType IA5STRING = - text "IA5STRING" -prettyType(RANGE x l u) = - prettyType x <+> outer x l u -prettyType (SEQUENCE x) = - text "SEQUENCE" <> space <> braces (prettySeq x) -prettyType (CHOICE xs) = - text "CHOICE" <+> braces (prettyChoice xs) -prettyType(SIZE t s _) = - prettyType t <+> parens (text "SIZE" <+> prettyConstraint s) -- text (show s)) +prettyTypeNonM :: ASNType a -> Doc +prettyTypeNonM t = vcat $ d:(map (\(k, v) -> text (ref k) <+> text "::=" <+> v) $ Map.toList m) + where + (d, m) = runIdentity . flip (runStateT . prettyType) Map.empty $ t hunk ./Pretty.hs 30 -prettyTypeVal :: ASNType a -> a -> Doc -prettyTypeVal a@(TYPEASS tr _ t) x = text tr <+> text "::=" <+> prettyTypeVal t x -prettyTypeVal a@(BITSTRING []) x = prettyBitString x -prettyTypeVal a@INTEGER x = text (show x) -prettyTypeVal a@(RANGE t l u) x = prettyTypeVal t x -prettyTypeVal a@(SIZE t s e) x = prettyTypeVal t x -prettyTypeVal a@(SEQUENCE s) x = braces (prettySeqVal s x) -prettyTypeVal a@(CHOICE c) x = prettyChoiceVal c x +prettyNamedType :: NamedType a -> ASNPrettyM Doc +prettyNamedType (NamedType n ct) = do d <- prettyType ct + return $ text n <+> d hunk ./Pretty.hs 34 -outer :: ASNType a -> Maybe a -> Maybe a -> Doc -outer INTEGER Nothing Nothing = parens (text "MIN" <> text ".." <> text "MAX") -outer INTEGER Nothing (Just y) = parens (text "MIN" <> text ".." <> text (show y)) -outer INTEGER (Just x) Nothing = parens (text (show x) <> text ".." <> text "MAX") -outer INTEGER (Just x) (Just y) = parens (text (show x) <> text ".." <> text (show y)) -outer (RANGE t l u) x y = outer t x y +prettyChoice :: Choice a -> ASNPrettyM Doc +prettyChoice EmptyChoice = return $ PP.empty +prettyChoice (ChoiceOption nt EmptyChoice) = prettyNamedType nt +prettyChoice (ChoiceOption nt xs) = do + d1 <- prettyNamedType nt + d2 <- prettyChoice xs + return $ vcat [d1 <> comma, d2] +prettyChoice (ChoiceExtensionMarker x) = do + d <- prettyChoice x + return $ vcat [text "..." <> comma, d <> comma] +-- FIXME: What should we do with v? +prettyChoice (ChoiceExtensionAdditionGroup v x) = + liftM (brackets . brackets) $ prettyChoice' x hunk ./Pretty.hs 48 -instance Pretty (Sequence a) where - pretty = prettySeq +prettyChoice' :: Choice' a -> ASNPrettyM Doc +prettyChoice' EmptyChoice' = return $ PP.empty +prettyChoice' (ChoiceOption' nt EmptyChoice') = prettyNamedType nt +prettyChoice' (ChoiceOption' nt xs) = do + do d1 <- prettyNamedType nt + d2 <- prettyChoice' xs + return $ vcat [d1 <> comma, d2] +prettyChoice' ChoiceExtensionMarker' = return $ text "..." hunk ./Pretty.hs 57 -instance PrettyVal (Sequence a) a where - prettyVal = prettySeqVal +prettyType :: ASNType a -> ASNPrettyM Doc +prettyType (ReferencedType r t) = prettyReferencedType r t +prettyType (BuiltinType bt) = prettyBuiltinType bt +prettyType (ConstrainedType t e) = do d1 <- prettyType t + d2 <- prettyElementSetSpecs t e + return $ d1 <+> parens d2 hunk ./Pretty.hs 64 -prettySeq :: Sequence a -> Doc -prettySeq Nil = - empty -prettySeq (Cons x Nil) = - prettyElem x -prettySeq (Cons x xs) = - vcat [prettyElem x <> comma, prettySeq xs] +prettySeq :: Sequence a -> ASNPrettyM Doc +prettySeq EmptySequence = return $ PP.empty +prettySeq (AddComponent x EmptySequence) = prettyComponentType x +prettySeq (AddComponent x xs) = do d <- prettyComponentType x + ds <- prettySeq xs + return $ vcat [d <> comma, ds] +prettySeq (ExtensionMarker x) = do d <- prettySeq x + return $ vcat [text "..." <> comma, d <> comma] +-- FIXME: What should we do with v? +prettySeq (ExtensionAdditionGroup v x y) = do d1 <- prettySeq2 x + d2 <- prettySeq y + return $ vcat [(brackets $ brackets d1) <> comma, d2] hunk ./Pretty.hs 77 -prettySeqVal :: Sequence a -> a -> Doc -prettySeqVal Nil _ = empty -prettySeqVal (Cons e Nil) (x:*:Empty) = - prettyElementTypeVal e x -prettySeqVal (Cons e l) (x:*:xs) = - prettyElementTypeVal e x <> comma $$ prettySeqVal l xs +prettySeq2 :: Sequence' a -> ASNPrettyM Doc +prettySeq2 EmptySequence' = return $ PP.empty +prettySeq2 (AddComponent' x EmptySequence') = prettyComponentType x +prettySeq2 (AddComponent' x xs) = do d1 <- prettyComponentType x + d2 <- prettySeq2 xs + return $ vcat [d1 <> comma, d2] hunk ./Pretty.hs 84 -instance Pretty (ComponentType a) where - pretty = prettyElem +prettySeq' :: Sequence a -> ASNPrettyM [Doc] +prettySeq' EmptySequence = return [] +prettySeq' (AddComponent x xs) = do d <- prettyComponentType x + ds <- prettySeq' xs + return (d:ds) +prettySeq' (ExtensionMarker x) = do ds <- prettySeq' x + return $ (text "..."):ds +-- FIXME: What should we do with v? +prettySeq' (ExtensionAdditionGroup v x y) = do + d1s <- prettySeq2' x + d2s <- prettySeq' y + return $ (brackets $ brackets $ vcat $ punctuate comma d1s):d2s hunk ./Pretty.hs 97 -instance PrettyVal (ComponentType a) a where - prettyVal = prettyElementTypeVal +prettySeq2' :: Sequence' a -> ASNPrettyM [Doc] +prettySeq2' EmptySequence' = return [] +prettySeq2' (AddComponent' x xs) = do d <- prettyComponentType x + ds <- prettySeq2' xs + return $ d:ds hunk ./Pretty.hs 103 -prettyElem :: ComponentType a -> Doc -prettyElem (CTMandatory nt) = prettyNamedType nt +prettySeq'' :: Sequence a -> ASNPrettyM Doc +prettySeq'' x = liftM (vcat . punctuate comma) $ prettySeq' x hunk ./Pretty.hs 106 -prettyElementTypeVal :: ComponentType a -> a -> Doc -prettyElementTypeVal (CTMandatory (NamedType n _ t)) x = - text n <+> prettyTypeVal t x +prettyComponentType :: ComponentType a -> ASNPrettyM Doc +prettyComponentType (MandatoryComponent m) = prettyNamedType m +prettyComponentType (OptionalComponent m) = do d <- prettyNamedType m + return $ d <+> text "OPTIONAL" +prettyComponentType (DefaultComponent m@(NamedType _ n) v) = do d <- prettyNamedType m + return $ d <+> text "DEFAULT" -- <+> prettyTypeVal n v hunk ./Pretty.hs 113 -instance Pretty (Choice a) where - pretty = prettyChoice +prettyBuiltinType :: ASNBuiltin a -> ASNPrettyM Doc +prettyBuiltinType (BITSTRING []) = return $ text "BIT STRING" +prettyBuiltinType INTEGER = return $ text "INTEGER" +prettyBuiltinType PRINTABLESTRING = return $ text "PrintableString" +prettyBuiltinType BOOLEAN = return $ text "BOOLEAN" +prettyBuiltinType IA5STRING = return $ text "IA5STRING" +prettyBuiltinType (CHOICE c) = do d <- prettyChoice c + return $ text "CHOICE" <+> braces d +prettyBuiltinType (SEQUENCE s) = do d <- prettySeq'' s + return $ text "SEQUENCE" <> space <> braces d +prettyBuiltinType (SET s) = do d <- prettySeq s + return $ text "SET" <> space <> braces d +prettyBuiltinType (SEQUENCEOF t) = do d <- prettySeqOfType t + return $ text "SEQUENCE OF" <+> d +prettyBuiltinType (SETOF t) = do d <- prettySeqOfType t hunk ./Pretty.hs 129 -instance PrettyVal (Choice a) (HL a (S Z)) where - prettyVal = prettyChoiceVal + return $ text "SET OF" <+> d +prettyBuiltinType OCTETSTRING = return $ text "OCTETSTRING" +prettyBuiltinType (BITSTRING namedBits) = return $ text "BITSTRING" <+> braces (text "FIXME: the named bits") +prettyBuiltinType VISIBLESTRING = return $ text "VISIBLESTRING" +prettyBuiltinType NUMERICSTRING = return $ text "NUMERICSTRING" +prettyBuiltinType UNIVERSALSTRING = return $ text "UNIVERSALSTRING" +prettyBuiltinType BMPSTRING = return $ text "BMPSTRING" +prettyBuiltinType NULL = return $ text "NULL" +prettyBuiltinType (ENUMERATED enums) = return $ text "ENUMERATED" <+> braces (text "FIXME: the enumeratees") +-- FIXME: For now ignore the tag information +prettyBuiltinType (TAGGED _tagInfo t) = prettyType t hunk ./Pretty.hs 141 -prettyChoice :: Choice a -> Doc -prettyChoice NoChoice = - empty -prettyChoice (ChoiceOption nt NoChoice) = - prettyNamedType nt -prettyChoice (ChoiceOption nt xs) = - vcat [prettyNamedType nt <> comma, prettyChoice xs] hunk ./Pretty.hs 142 -prettyChoiceVal :: Choice a -> (HL a (S Z)) -> Doc -prettyChoiceVal NoChoice _ = empty -prettyChoiceVal (ChoiceOption (NamedType n i t) cs) (NoValueC NoValue vs) = - prettyChoiceVal cs vs -prettyChoiceVal (ChoiceOption (NamedType n i t) cs) (ValueC v vs) = - text n <> colon <> prettyTypeVal t v +prettySeqOfType :: SeqSetOf c => c a -> ASNPrettyM Doc +prettySeqOfType t + = let (f,s) = splitName t + in + case f of + Nothing -> do prettyType s + Just n -> do prettyNamedType (NamedType n s) hunk ./Pretty.hs 150 -instance Pretty (NamedType a) where - pretty = prettyNamedType hunk ./Pretty.hs 151 -{- -[UNIVERSAL 29] tag-value 29, "universal" class -[APPLICATION 10] tag-value 10, "application" class -[PRIVATE 0] tag-value 0, "private" class -[3] tag-value 3, "context-specific" class +prettyReferencedType :: TypeReference -> ASNType a -> ASNPrettyM Doc +prettyReferencedType r t = do + refTypes <- get + let x = Map.lookup r refTypes + case x of + Nothing -> do + d <- prettyType t + let refTypes' = Map.insert r d refTypes + put refTypes' + Just _ -> do + return () + return $ text (ref r) + hunk ./Pretty.hs 165 -integer1 INTEGER ::= 72 -integer2 [1] IMPLICIT INTEGER ::= 72 -integer3 [APPLICATION 27] EXPLICIT INTEGER ::= 72 --} hunk ./Pretty.hs 166 -prettyPlicity :: TagPlicity -> Doc hunk ./Pretty.hs 169 -prettyNamedType :: NamedType a -> Doc -prettyNamedType (NamedType n ti ct) = - case ti of - Nothing -> - text n <+> prettyType ct - Just (tt, tv, tp) -> - case tt of - Context -> - text n <+> brackets (text (show tv)) <+> prettyPlicity tp <+> prettyType ct - _ -> - text n <+> brackets (text (show tt) <+> text (show tv)) <+> prettyPlicity tp <+> prettyType ct +prettyElementSetSpecs :: ASNType a -> SubtypeConstraint a -> ASNPrettyM Doc +prettyElementSetSpecs t (RootOnly c) = prettyConstraint t c +prettyElementSetSpecs t (EmptyExtension c) = do d <- prettyConstraint t c + return $ d <> comma <+> text "..." +prettyElementSetSpecs t (NonEmptyExtension c1 c2) = do d1 <- prettyConstraint t c1 + d2 <- prettyConstraint t c2 + return $ d1 <> comma <+> text "..." <> comma <+> d2 + + +prettyConstraint :: ASNType a -> ElementSetSpec a -> ASNPrettyM Doc +prettyConstraint t (UnionSet u) = prettyUnion t u +prettyConstraint t (ComplementSet e) = prettyExcept t e + +prettyExcept :: ASNType a -> Exclusions a -> ASNPrettyM Doc +prettyExcept t (EXCEPT e) = prettyElem t e + +prettyUnion :: ASNType a -> Unions a -> ASNPrettyM Doc +prettyUnion t (NoUnion ic) = prettyIntersectionConstraint t ic +prettyUnion t (UnionMark u i) = do d1 <- prettyUnion t u + d2 <- prettyIntersectionConstraint t i + return $ d1 <+> text "|" <+> d2 + + +prettyIntersectionConstraint :: ASNType a -> Intersections a -> ASNPrettyM Doc +prettyIntersectionConstraint t (NoIntersection ie) = prettyInterSectionElement t ie +prettyIntersectionConstraint t (IntersectionMark ic ie) = do d1 <- prettyIntersectionConstraint t ic + d2 <- prettyInterSectionElement t ie + return $ d1 <+> text "^" <+> d2 + +prettyInterSectionElement t (ElementConstraint e) = prettyElem t e +prettyInterSectionElement t (ExclusionConstraint e exc) = do d1 <- prettyElem t e + d2 <- prettyExclusion t exc + return $ d1 <+> text "EXCEPT" <+> d2 + +prettyExclusion :: ASNType a -> Exclusions a -> ASNPrettyM Doc +prettyExclusion t (EXCEPT e) = prettyElem t e + +prettyElem :: ASNType a -> Element a -> ASNPrettyM Doc +prettyElem t (S s) = prettySingleValue t s +prettyElem t (V r) = prettyValueRange t r +prettyElem t (P a) = prettyPermittedAlphabet t a +prettyElem t (C c) = error "C" +prettyElem t (SZ s) = prettySizedElem t s +prettyElem t (IT i) = error "IT" + +prettySizedElem :: ASNType a -> SizeConstraint a -> ASNPrettyM Doc +prettySizedElem t (SC x) = do d <- prettyElementSetSpecs (BuiltinType INTEGER) x + return $ text "SIZE" <+> parens d + +prettyPermittedAlphabet :: ASNType a -> PermittedAlphabetConstraint a -> ASNPrettyM Doc +prettyPermittedAlphabet t (FR a) = do d <- prettyElementSetSpecs t a + return $ text "FROM" <+> parens d + +prettyValueRange :: ASNType a -> ValueRangeConstraint a -> ASNPrettyM Doc +prettyValueRange (BuiltinType INTEGER) (R (x,y)) = return $ pretty x <> text ".." <> pretty y +prettyValueRange (BuiltinType IA5STRING) (R (x,y)) = return $ text (iA5String x) <> text ".." <> text (iA5String y) +prettyValueRange (BuiltinType PRINTABLESTRING) (R (x,y)) = return $ text (printableString x) <> text ".." <> text (printableString y) +prettyValueRange (BuiltinType NUMERICSTRING) (R (x,y)) = return $ text (numericString x) <> text ".." <> text (numericString y) +prettyValueRange (BuiltinType (BITSTRING _)) (R (x,y)) = return $ text (show x) <> text ".." <> text (show y) + +-- FIXME: Everything below is temporary +prettyValueRange (ReferencedType _ _) _ = return $ text "FIXME: prettyValueRange ReferencedType" +prettyValueRange (ConstrainedType _ _) _ = return $ text "FIXME: prettyValueRange ConstrainedType" +prettyValueRange (BuiltinType BOOLEAN) _ = return $ text "FIXME: prettyValueRange BuiltinType BOOLEAN" +prettyValueRange (BuiltinType (ENUMERATED _)) _ = return $ text "FIXME: prettyValueRange BuiltinType ENUMERATED" +prettyValueRange (BuiltinType OCTETSTRING) _ = return $ text "FIXME: prettyValueRange BuiltinType OCTETSTRING" +prettyValueRange (BuiltinType VISIBLESTRING) (R (x, y)) = return $ doubleQuotes (text $ visibleString x) <> + text ".." <> + doubleQuotes (text $ visibleString y) +prettyValueRange (BuiltinType UNIVERSALSTRING) _ = return $ text "FIXME: prettyValueRange BuiltinType UNIVERSALSTRING" +prettyValueRange (BuiltinType BMPSTRING) _ = return $ text "FIXME: prettyValueRange BuiltinType BMPSTRING" +prettyValueRange (BuiltinType NULL) _ = return $ text "FIXME: prettyValueRange BuiltinType NULL" +prettyValueRange (BuiltinType (SEQUENCE _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SEQUENCE" +prettyValueRange (BuiltinType (SEQUENCEOF _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SEQUENCEOF" +prettyValueRange (BuiltinType (SET _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SET" +prettyValueRange (BuiltinType (SETOF _)) _ = return $ text "FIXME: prettyValueRange BuiltinType SETOF" +prettyValueRange (BuiltinType (CHOICE _)) _ = return $ text "FIXME: prettyValueRange BuiltinType CHOICE" +prettyValueRange (BuiltinType (TAGGED _ _)) _ = return $ text "FIXME: prettyValueRange BuiltinType TAGGED" + + + +prettySingleValue :: ASNType a -> SingleValueConstraint a -> ASNPrettyM Doc +prettySingleValue (BuiltinType INTEGER) (SV e) = return $ text (show e) +prettySingleValue (BuiltinType (BITSTRING _)) (SV e) = return $ prettyBitString e +prettySingleValue (BuiltinType IA5STRING) (SV e) = return $ text (show e) +prettySingleValue (BuiltinType PRINTABLESTRING) (SV e) = return $ doubleQuotes (text (printableString e)) + +-- FIXME: Everything below is temporary +prettySingleValue (ReferencedType _ _) _ = return $ text "FIXME: prettySingleValue ReferencedType" +prettySingleValue (ConstrainedType _ _) _ = return $ text "FIXME: prettySingleValue ConstrainedType" +prettySingleValue (BuiltinType BOOLEAN) _ = return $ text "FIXME: prettySingleValue BOOLEAN" +prettySingleValue (BuiltinType (ENUMERATED _)) _ = return $ text "FIXME: prettySingleValue ENUMERATED" +prettySingleValue (BuiltinType OCTETSTRING) _ = return $ text "FIXME: prettySingleValue OCTETSTRING" +prettySingleValue (BuiltinType VISIBLESTRING) (SV x) = return $ text $ show $ visibleString x +prettySingleValue (BuiltinType NUMERICSTRING) _ = return $ text "FIXME: prettySingleValue NUMERICSTRING" +prettySingleValue (BuiltinType UNIVERSALSTRING) _ = return $ text "FIXME: prettySingleValue UNIVERSALSTRING" +prettySingleValue (BuiltinType BMPSTRING) _ = return $ text "FIXME: prettySingleValue BMPSTRING" +prettySingleValue (BuiltinType NULL) _ = return $ text "FIXME: prettySingleValue NULL" +prettySingleValue (BuiltinType (SEQUENCE _)) _ = return $ text "FIXME: prettySingleValue SEQUENCE" +prettySingleValue (BuiltinType (SEQUENCEOF _)) _ = return $ text "FIXME: prettySingleValue SEQUENCEOF" +prettySingleValue (BuiltinType (SET _)) _ = return $ text "FIXME: prettySingleValue SET" +prettySingleValue (BuiltinType (SETOF _)) _ = return $ text "FIXME: prettySingleValue SETOF" +prettySingleValue (BuiltinType (CHOICE _)) _ = return $ text "FIXME: prettySingleValue CHOICE" +prettySingleValue (BuiltinType (TAGGED _ _)) _ = return $ text "FIXME: prettySingleValue TAGGED" + hunk ./Pretty.hs 276 + +class Pretty a where + pretty :: a -> Doc + +instance Pretty InfInteger where + pretty NegInf = text "MIN" + pretty PosInf = text "MAX" + pretty (Val x) = text (show x) + +prettyTypeVal :: ASNType a -> a -> Doc +prettyTypeVal (BuiltinType INTEGER) x = pretty x +prettyTypeVal (BuiltinType (SEQUENCE s)) x = error "SEQUENCE" + +prettyElementTypeVal :: ComponentType a -> a -> Doc +prettyElementTypeVal (MandatoryComponent (NamedType n t)) x = + text n <+> prettyTypeVal t x + + + + hunk ./Tests/Properties.hs 20 +foo1 = roundTrip sibDataVariableType sibDataVariableValue @?= sibDataVariableValue + hunk ./Tests/Properties.hs 26 + , testCase "Foo" foo1 hunk ./PERWriter.hs 25 +import Pretty hunk ./PERWriter.hs 32 + +import Text.PrettyPrint + hunk ./PERWriter.hs 142 -fromPER t cl = error $ prettyType t +fromPER t cl = error $ render $ prettyTypeNonM (BuiltinType t) hunk ./PERWriter.hs 761 + hunk ./Pretty.hs 5 -module NewPretty where +module Pretty where hunk ./Pretty.hs 8 -import PERWriter hunk ./Pretty.hs 138 -prettyBuiltinType (TAGGED _tagInfo t) = prettyType t - +prettyBuiltinType (TAGGED _tagInfo t) = do u <- prettyType t + error $ render u hunk ./Tests/Properties.hs 12 -import NewPretty +import Pretty hunk ./PERWriter.hs 761 +decodeLargeLengthDeterminant3' :: (Integer -> a -> UnPERMonad [b]) -> a -> UnPERMonad [b] +decodeLargeLengthDeterminant3' f t = + do p <- lift BG.getBit + if (not p) + then + do j <- lift $ BG.getLeftByteString 7 + let l = fromNonNegativeBinaryInteger' 7 j + f l t + else + do q <- lift BG.getBit + if (not q) + then + do k <- lift $ BG.getLeftByteString 14 + let m = fromNonNegativeBinaryInteger' 14 k + f m t + else + do n <- lift $ BG.getLeftByteString 6 + let fragSize = fromNonNegativeBinaryInteger' 6 n + if fragSize <= 0 || fragSize > 4 + then undefined -- (DecodeError (fragError ++ show fragSize)) + else do frag <- f (fragSize * 16 * (2^10)) t + rest <- decodeLargeLengthDeterminant3' f t + return (frag ++ rest) + where + fragError = "Unable to decode with fragment size of " hunk ./PERWriter.hs 787 +-- decode4 (BuiltinType t) cl = undefined -- fromPer3 t cl +-- decode4 (ConstrainedType t c) cl = decode4 t (c:cl) +-- decode4 (ReferencedType r t) cl = decode4 t cl +-- fromPer3 t@INTEGER cl = decodeInt3 cl + +-- decodeBitString constraints = +-- do xs <- decodeBitStringAux (errorize (evaluateConstraint pvBitStringElements top constraints)) +-- return (BitString . concat . (map bitString) $ xs) + +-- decodeBitStringAux mx = +-- do x <- mx +-- let rc = getBSRC x +-- decodeLengthDeterminant rc chunkBy1 undefined +-- where +-- chunkBy1 = let compose = (.).(.) in lift `compose` (flip (const (sequence . return . (liftM BitString) . getBits . fromIntegral))) + +-- getBits 0 = +-- return [] +-- getBits n = +-- do x <- BG.getBit +-- xs <- getBits (n-1) +-- return (fromEnum x:xs) + +-- decodeLengthDeterminant c f t +-- | ub /= maxBound && +-- ub == lb && +-- v <= 64*(2^10) = f v t +-- | ub == maxBound = decodeLargeLengthDeterminant3' f t -- FIXME: We don't seem to check if the number +-- -- of elements satisfies the lower constraint. +-- | v <= 64*(2^10) = do k <- decode4 (ConstrainedType (BuiltinType INTEGER) (rangeConstraint (lb,ub))) [] +-- let (Val l) = k +-- f l t +-- | otherwise = decodeLargeLengthDeterminant3' f t +-- where +-- ub = upper c +-- lb = lower c +-- (Val v) = ub + +-- rangeConstraint :: (InfInteger, InfInteger) -> ElementSetSpecs InfInteger +-- rangeConstraint = RootOnly . UnionSet . NoUnion . NoIntersection . ElementConstraint . V . R + +-- errorize (Left e) = throwError (ConstraintError e) +-- errorize (Right x) = return x + +-- decodeInt3 [] = +-- lDecConsInt3 (return top) undefined (return top) +-- decodeInt3 cs = +-- lDecConsInt3 effRoot extensible effExt +-- where +-- effectiveCon :: Either String (ExtensibleConstraint IntegerConstraint) +-- effectiveCon = evaluateConstraint pvIntegerElements top cs +-- extensible = eitherExtensible effectiveCon +-- effRoot = either (\x -> undefined) -- (ConstraintError "Invalid root")) +-- (return . getRootConstraint) effectiveCon +-- effExt = either (\x -> undefined) -- (ConstraintError "Invalid extension")) +-- (return . getExtConstraint) effectiveCon + +lDecConsInt3 mrc isExtensible mec = + do rc <- mrc + ec <- mec + let extensionConstraint = ec /= top + tc = rc `ljoin` ec + extensionRange = fromIntegral $ let (Val x) = (upper tc) - (lower tc) + (Val 1) in x -- FIXME: fromIntegral means there's an Int bug lurking here + rootConstraint = rc /= top + rootLower = let Val x = lower rc in x + rootRange = fromIntegral $ let (Val x) = (upper rc) - (lower rc) + (Val 1) in x -- FIXME: fromIntegral means there's an Int bug lurking here + -- These were just hacks anyway so rather than trying to fix extractValue to allow us to see how many bits were + -- required to encode e.g. the root range, we should have a function which does this directly. + -- Dan must have one for encoding somewhere. + numOfRootBits = bitWidth $ rootRange - 1 + numOfExtensionBits = bitWidth $ extensionRange - 1 + emptyConstraint = (not rootConstraint) && (not extensionConstraint) + inRange v x = (Val v) >= (lower x) && (Val v) <= (upper x) + unconstrained x = (lower x) == minBound + semiconstrained x = (upper x) == maxBound + constrained x = not (unconstrained x) && not (semiconstrained x) + constraintType x + | unconstrained x = UnConstrained + | semiconstrained x = SemiConstrained + | otherwise = Constrained + decodeRootConstrained = + if rootRange <= 1 + then + return (Val rootLower) + else + do j <- lift $ BG.getLeftByteString (fromIntegral numOfRootBits) + let v = rootLower + (fromNonNegativeBinaryInteger' numOfRootBits j) + if v `inRange` rc + then + return (Val v) + else + throwError (BoundsError "Value not in root constraint") + decodeExtensionConstrained = + do v <- decodeUInt3 + if v `inRange` tc + then + return (Val v) + else + throwError (BoundsError "Value not in extension constraint: could be invalid value or unsupported extension") + foobar + | emptyConstraint + = do x <- decodeUInt3 + return (Val x) + | rootConstraint && + extensionConstraint + = do isExtension <- lift $ BG.getBit + if isExtension + then + decodeExtensionConstrained + else + decodeRootConstrained + | rootConstraint && + isExtensible + = do isExtension <- lift $ BG.getBit + if isExtension + then + throwError (ExtensionError "Extension for constraint not supported") + else + decodeRootConstrained + | rootConstraint + = decodeRootConstrained + | extensionConstraint + = throwError (ConstraintError "Extension constraint without a root constraint") + | otherwise + = throwError (OtherError "Unexpected error decoding INTEGER") + foobar + +bitWidth n = genericLength $ revNonNegativeBinaryInteger (n,n) + where + revNonNegativeBinaryInteger :: (Integer, Integer) -> BitStream + revNonNegativeBinaryInteger = + (map fromInteger) . unfoldr toNonNegativeBinaryIntegerAux + where + toNonNegativeBinaryIntegerAux (_,0) = Nothing + toNonNegativeBinaryIntegerAux (0,w) = Just (0, (0, w `div` 2)) + toNonNegativeBinaryIntegerAux (n,w) = Just (fromIntegral (n `mod` 2), (n `div` 2, w `div` 2)) + +decodeUInt3 = + do o <- octets + return (from2sComplement' o) + where + chunkBy8 = let compose = (.).(.) in lift `compose` (flip (const (BG.getLeftByteString . fromIntegral . (*8)))) + octets = decodeLargeLengthDeterminant3 chunkBy8 undefined + +encodeConstrainedInt :: (InfInteger, InfInteger) -> PERMonad () +encodeConstrainedInt (val, range) + = toNonNegBinaryInteger val range + +decodeLargeLengthDeterminant3 :: (Integer -> a -> UnPERMonad B.ByteString) -> a -> UnPERMonad B.ByteString +decodeLargeLengthDeterminant3 f t = + do p <- lift BG.getBit + if (not p) + then + do j <- lift $ BG.getLeftByteString 7 + let l = fromNonNegativeBinaryInteger' 7 j + f l t + else + do q <- lift BG.getBit + if (not q) + then + do k <- lift $ BG.getLeftByteString 14 + let m = fromNonNegativeBinaryInteger' 14 k + f m t + else + do n <- lift $ BG.getLeftByteString 6 + let fragSize = fromNonNegativeBinaryInteger' 6 n + if fragSize <= 0 || fragSize > 4 + then undefined -- (DecodeError (fragError ++ show fragSize)) + else do frag <- f (fragSize * 16 * (2^10)) t + rest <- decodeLargeLengthDeterminant3 f t + return (B.append frag rest) + where + fragError = "Unable to decode with fragment size of " + +