module Language.ASN1.Parser where
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import System.Exit (exitFailure)
import Data.Generics
import Control.Applicative ((<$>),(<*),(*>),(<*>),(<$))
import Control.Monad (when)
import Data.Char (isUpper, isAlpha, isSpace, ord)
import Data.List (isInfixOf, intercalate)
import Data.Maybe (fromJust)
parseASN1FromFileOrDie :: String -> IO ([Module])
parseASN1FromFileOrDie fname =
do result <- parseASN1FromFile fname
case result of
Left err -> do { putStr "parse error at: "
; print err
; exitFailure
}
Right x -> return x
parseASN1FromFile :: String -> IO (Either ParseError [Module])
parseASN1FromFile fname =
parseFromFile asn1Input fname
parseASN1 p source =
case parse p' "" source of
Left err -> Nothing
Right x -> Just x
where
p' = fixupComments *> whiteSpace *> p <* eof
asn1Input = do
fixupComments
whiteSpace
modules <- many1 moduleDefinition
eof
return modules
<?> "asn1Input"
fixupComments = do
inp <- getInput
setInput $ fixup inp
fixup = repl 0 False
where
repl 0 True [] = "*/"
repl starComment inDashComment [] = []
repl 0 False (c:'-':'-':rest) | isSpace c = c:'/':'*':(repl 0 True rest)
| otherwise = c:'-':'-':(repl 0 False rest)
repl 0 False ('-':'-':rest) = '/':'*':(repl 0 True rest)
repl 0 True ('-':'-':rest) = '*':'/':(repl 0 False rest)
repl 0 True (c:rest) | isNewline c = '*':'/':c:(repl 0 False rest)
repl n False ('/':'*':rest) = '/':'*':(repl (n+1) False rest)
repl n False ('*':'/':rest) = '*':'/':(repl (n1) False rest)
repl n inDashComment (c:rest) = c:(repl n inDashComment rest)
isNewline c | ord c >= 10 && ord c <= 13 = True
| otherwise = False
newtype TypeReference = TypeReference String deriving (Eq,Ord,Show, Typeable, Data)
_typereference = ucaseFirstIdent
typereference = TypeReference <$> _typereference
newtype Identifier = Identifier String deriving (Eq,Ord,Show, Typeable, Data)
_identifier = lcaseFirstIdent
identifier = Identifier <$> _identifier
newtype ValueReference = ValueReference String deriving (Eq,Ord,Show, Typeable, Data)
valuereference = ValueReference <$> _identifier
_valuereference = _identifier
data ModuleReference = ModuleReference String deriving (Eq,Ord,Show, Typeable, Data)
modulereference = ModuleReference <$> _typereference
number = natural <?> "number"
realnumber =
choice [ try $ negate <$> (char '-' *> float)
, try float
, fromInteger <$> integer
]
where
float = P.float asn1
type BString = BinString
bstring = binString " 01" 'B' <?> "bstring"
type HString = BinString
hstring = binString " 0123456789ABCDEF" 'H' <?> "hstring"
data BinString = BinString Char String deriving (Eq,Ord,Show, Typeable, Data)
binString allowedSet marker = BinString marker <$> ( ( symbol "'" *> (filter (not.isSpace) <$> many (oneOf allowedSet) ) ) <* char '\'' <* char marker <* whiteSpace)
newtype CString = CString String deriving (Eq,Ord,Show, Typeable, Data)
cstring = CString <$> (filter (not.isNewline) <$> intercalate "\"" <$> many1 ( char '"' *> anyChar `manyTill` (char '"'))) <* whiteSpace
lcaseFirstIdent = do
i <- parsecIdent
when (isUpper $ head i) $ unexpected "uppercase first letter"
when (last i == '-') $ unexpected "trailing hyphen"
return i
ucaseFirstIdent = do
i <- parsecIdent
when (not . isUpper $ head i) $ unexpected "lowercase first letter"
when (last i == '-') $ unexpected "trailing hyphen"
return i
ucaseIdent = do
i <- parsecIdent
when (not $ all isUpper $ filter isAlpha i) $ unexpected "lowercase letter"
when (last i == '-') $ unexpected "trailing hyphen"
return i
asn1Style
= emptyDef
{ commentStart = "/*"
, commentEnd = "*/"
, nestedComments = True
, identStart = letter
, identLetter = alphaNum <|> ( char '-' <* notFollowedBy (char '-') )
, caseSensitive = True
, reservedNames = [ "ABSENT", "ENCODED", "INTEGER", "RELATIVE-OID",
"ABSTRACT-SYNTAX", "END", "INTERSECTION", "SEQUENCE",
"ALL", "ENUMERATED", "ISO646String", "SET",
"APPLICATION", "EXCEPT", "MAX", "SIZE",
"AUTOMATIC", "EXPLICIT", "MIN", "STRING",
"BEGIN", "EXPORTS", "MINUS-INFINITY", "SYNTAX",
"BIT", "EXTENSIBILITY", "NULL", "T61String",
"BMPString", "EXTERNAL", "NumericString", "TAGS",
"BOOLEAN", "FALSE", "OBJECT", "TeletexString",
"BY", "FROM", "ObjectDescriptor", "TRUE",
"CHARACTER", "GeneralizedTime", "OCTET", "TYPE-IDENTIFIER",
"CHOICE", "GeneralString", "OF", "UNION",
"CLASS", "GraphicString", "OPTIONAL", "UNIQUE",
"COMPONENT", "IA5String", "PATTERN", "UNIVERSAL",
"COMPONENTS", "IDENTIFIER", "PDV", "UniversalString",
"CONSTRAINED", "IMPLICIT", "PLUS-INFINITY", "UTCTime",
"CONTAINING", "IMPLIED", "PRESENT", "UTF8String",
"DEFAULT", "IMPORTS", "PrintableString", "VideotexString",
"DEFINITIONS", "INCLUDES", "PRIVATE", "VisibleString",
"EMBEDDED", "INSTANCE", "REAL", "WITH" ]
}
asn1 = P.makeTokenParser asn1Style
whiteSpace = P.whiteSpace asn1
symbol = P.symbol asn1
parsecIdent = P.identifier asn1
reserved = P.reserved asn1
comma = P.comma asn1
commaSep = P.commaSep asn1
commaSep1 = P.commaSep1 asn1
braces = P.braces asn1
squares = P.squares asn1
parens = P.parens asn1
semi = P.semi asn1
colon = P.colon asn1
natural = P.natural asn1
integer = P.integer asn1
dot = P.dot asn1
commaSepEndBy1 p = p `sepEndBy1` comma
data Module = Module { module_id::ModuleIdentifier
, default_tag_type::TagDefault
, extensibility_implied :: Bool
, module_body::Maybe ModuleBody
} deriving (Eq,Ord,Show, Typeable, Data)
moduleDefinition =
Module <$> moduleIdentifier <*> (reserved "DEFINITIONS" *> tagDefault) <*> extensibility
<*> (symbol "::=" *> reserved "BEGIN" *> moduleBody) <* reserved "END"
<?> "ModuleDefinition"
where
extensibility = option False $ True <$ (reserved "EXTENSIBILITY" >> reserved "IMPLIED")
data ModuleIdentifier = ModuleIdentifier ModuleReference (Maybe DefinitiveOID) deriving (Eq,Ord,Show, Typeable, Data)
moduleIdentifier = ModuleIdentifier <$> modulereference <*> definitiveIdentifier
<?> "ModuleIdentifier"
type DefinitiveOID = [DefinitiveOIDComponent]
definitiveIdentifier =
optionMaybe (braces (many1 definitiveOIDComponent))
<?> "DefinitiveIdentifier"
data DefinitiveOIDComponent = DefinitiveOIDNumber Integer
| DefinitiveOIDNamedNumber Identifier Integer
| DefinitiveOIDName Identifier deriving (Eq,Ord,Show, Typeable, Data)
definitiveOIDComponent =
choice [ DefinitiveOIDNumber <$> number
, try $ DefinitiveOIDNamedNumber <$> identifier <*> parens number
, DefinitiveOIDName . Identifier <$> reservedOIDIdentifier
]
<?> "DefinitiveObjectIdComponent"
data TagDefault = ExplicitTags | ImplicitTags | AutomaticTags deriving (Eq,Ord,Show, Typeable, Data)
tagDefault = option ExplicitTags td <?> "tagDefault"
where
td = choice [ ExplicitTags <$ reserved "EXPLICIT"
, ImplicitTags <$ reserved "IMPLICIT"
, AutomaticTags <$ reserved "AUTOMATIC"
]
<* reserved "TAGS"
data Exports = ExportsAll | Exports [ExportedSymbol] deriving (Eq,Ord,Show, Typeable, Data)
data Imports = ImportsNone | Imports [SymbolsFromModule] deriving (Eq,Ord,Show, Typeable, Data)
data ModuleBody = ModuleBody { module_exports::Exports
, module_imports::Imports
, module_assignments::[Assignment]
} deriving (Eq,Ord,Show, Typeable, Data)
moduleBody = optionMaybe ( ModuleBody <$> exports <*> imports <*> assignmentList )
<?> "ModuleBody"
newtype ExportedSymbol = ExportedSymbol Symbol deriving (Eq,Ord,Show, Typeable, Data)
exports =
option ExportsAll (
choice [ try $ ExportsAll <$ ( reserved "EXPORTS" *> reserved "ALL" *> semi )
, Exports <$> (reserved "EXPORTS" *> symbolsExported )
]) <?> "Exports"
where symbolsExported = (commaSep $ ExportedSymbol <$> theSymbol) <* semi
imports = option ImportsNone ( Imports <$> (reserved "IMPORTS" *> symbolsImported) )
<?> "Imports"
where symbolsImported = (many1 symbolsFromModule) <* semi
data SymbolsFromModule = SymbolsFromModule [Symbol] GlobalModuleReference deriving (Eq,Ord,Show, Typeable, Data)
symbolsFromModule = SymbolsFromModule <$> commaSep1 theSymbol <*> (reserved "FROM" *> globalModuleReference)
<?> "SymbolsFromModule"
data GlobalModuleReference = GlobalModuleReference ModuleReference (Maybe AssignedIdentifier) deriving (Eq,Ord,Show, Typeable, Data)
globalModuleReference = GlobalModuleReference <$> modulereference <*> assignedIdentifier
data AssignedIdentifier = AssignedIdentifierOID OID | AssignedIdentifierDefinedValue DefinedValue deriving (Eq,Ord,Show, Typeable, Data)
assignedIdentifier =
optionMaybe $
choice [ AssignedIdentifierOID <$> try oid
, try $ AssignedIdentifierDefinedValue <$> definedValue
]
data Symbol = TypeReferenceSymbol TypeReference
| ValueReferenceSymbol ValueReference
| ObjectClassReferenceSymbol ObjectClassReference
| ObjectReferenceSymbol ObjectReference
| ObjectSetReferenceSymbol ObjectSetReference
deriving (Eq,Ord,Show, Typeable, Data)
theSymbol =
choice ( map try [ TypeReferenceSymbol <$> typereference
, ObjectClassReferenceSymbol <$> objectclassreference
, ObjectReferenceSymbol <$> objectreference
, ObjectSetReferenceSymbol <$> objectsetreference
, ValueReferenceSymbol <$> valuereference
] ) <* parametrizedDesignation
where
parametrizedDesignation = optional (symbol "{" >> symbol "}")
assignmentList = many1 assignment <?> "assignmentList"
data Assignment = ValueAssignment { value_ref::ValueReference
, value_ref_type::Type
, assigned_value::Value
}
| TypeAssignment TypeReference Type
| ValueSetTypeAssignment TypeReference Type ValueSet
| ObjectClassAssignment ObjectClassReference ObjectClass
| ObjectAssignment ObjectReference DefinedObjectClass Object
| ObjectSetAssignment ObjectSetReference DefinedObjectClass ObjectSet
deriving (Eq,Ord,Show, Typeable, Data)
assignment =
choice $ map try [ objectAssignment
, valueAssignment
, typeAssignment
, objectClassAssignment
, valueSetTypeAssignment
, objectSetAssignment
]
definedType = simpleDefinedType
simpleDefinedType =
choice [ try $ ExternalTypeReference <$> moduleReferenceAndDot <*> typereference
, LocalTypeReference <$> typereference
] <?> "SimpleDefinedType"
moduleReferenceAndDot = modulereference <* dot
data DefinedValue = ExternalValueReference ModuleReference ValueReference
| LocalValueReference ValueReference
deriving (Eq,Ord,Show, Typeable, Data)
definedValue =
choice [ try $ ExternalValueReference <$> moduleReferenceAndDot <*> valuereference
, LocalValueReference <$> valuereference
] <?> "DefinedValue"
typeAssignment = TypeAssignment <$> typereference <*> (symbol "::=" *> theType)
<?> "TypeAssignment"
valueAssignment = do
ref <- valuereference
t <- theType
v <- (symbol "::=" *> valueOfType t)
return $ ValueAssignment ref t v
valueSetTypeAssignment = do
tr <- typereference
t <- theType
ValueSetTypeAssignment tr t <$> (symbol "::=" *> valueSet (Just t))
where
valueSetOrAlternative = valueSet Nothing <|> parens (elementSetSpecs Nothing)
type ValueSet = ElementSets
valueSet t = braces $ elementSetSpecs t
data Type = Type { type_id::BuiltinType
, subtype::Maybe Constraint
}
deriving (Eq,Ord,Show, Typeable, Data)
theType = do
t <- builtinType <|> referencedType
Type t <$> optionMaybe (constraint $ Just $ Type t Nothing)
data BuiltinType = BitString [NamedNumber]
| Boolean
| CharacterString
| BMPString
| GeneralString
| GraphicString
| IA5String
| ISO646String
| NumericString
| PrintableString
| TeletexString
| T61String
| UniversalString
| UTF8String
| VideotexString
| VisibleString
| Choice AlternativeTypeLists
| EmbeddedPDV
| SimpleEnumeration [EnumerationItem]
| EnumerationWithException [EnumerationItem] (Maybe ExceptionIdentification)
| EnumerationWithExceptionAndAddition [EnumerationItem] (Maybe ExceptionIdentification) [EnumerationItem]
| External
| InstanceOf DefinedObjectClass
| TheInteger [NamedNumber]
| Null
| ObjectClassField DefinedObjectClass FieldName
| ObjectIdentifier
| OctetString
| Real
| RelativeOID
| Sequence ComponentTypeLists
| SequenceOf (Maybe Constraint) (Either Type NamedType)
| Set ComponentTypeLists
| SetOf (Maybe Constraint) (Either Type NamedType)
| Tagged Tag (Maybe TagType) Type
| LocalTypeReference TypeReference
| ExternalTypeReference ModuleReference TypeReference
| GeneralizedTime
| UTCTime
| ObjectDescriptor
| Selection Identifier Type
| TypeFromObject ReferencedObjects FieldName
| ValueSetFromObjects ReferencedObjects FieldName
| Any (Maybe Identifier)
deriving (Eq,Ord,Show, Typeable, Data)
builtinType =
choice $ map try [ integerType
, bitStringType
, try $ sequenceType
, try $ setType
, setOrSequenceOfType
, choiceType
, taggedType
, enumeratedType
, OctetString <$ (reserved "OCTET" *> reserved "STRING")
, ObjectIdentifier <$ (reserved "OBJECT" *> reserved "IDENTIFIER")
, RelativeOID <$ reserved "RELATIVE-OID"
, Real <$ reserved "REAL"
, Boolean <$ reserved "BOOLEAN"
, Null <$ reserved "NULL"
, External <$ reserved "EXTERNAL"
, characterStringType
, EmbeddedPDV <$ ( reserved "EMBEDDED" *> reserved "PDV" )
, instanceOfType
, objectClassFieldType
, anyType
]
referencedType = try definedType
<|> usefulType
<|> selectionType
<|> typeFromObject
<|> valueSetFromObjects
<?> "ReferencedType"
data NamedType = NamedType Identifier Type deriving (Eq,Ord,Show, Typeable, Data)
namedType = NamedType <$> identifier <*> theType
data Value =
HexString BinString
| BinaryString BinString
| Containing Value
| IdentifierListBitString [Identifier]
| IdentifiedNumber Identifier
| BooleanValue Bool
| RestrictedCharacterStringValue [CharsDefn]
| UnrestrictedCharacterStringValue ComponentValueList
| ChoiceValue Identifier Value
| EmbeddedPDVValue ComponentValueList
| EnumeratedValue Identifier
| ExternalValue ComponentValueList
| InstanceOfValue ComponentValueList
| SignedNumber Integer
| NullValue
| OID [OIDComponent]
| RealValue Double
| SequenceRealValue ComponentValueList
| PlusInfinity
| MinusInfinity
| RelativeOIDValue [RelativeOIDComponent]
| SequenceValue ComponentValueList
| SetValue ComponentValueList
| SequenceOfValue (Either [Value] ComponentValueList)
| SetOfValue (Either [Value] ComponentValueList)
| DefinedV DefinedValue
| GeneralizedTimeValue CString
| UTCTimeValue CString
| ObjectDescriptorValue CString
| ValueFromObject ReferencedObjects FieldName
| OpenTypeFieldValue Type Value
| FixedTypeFieldValue Value
| SomeNumber Double
| SomeNamedValueList ComponentValueList
| SomeValueList [Value]
| SomeIdentifiedValue Identifier
| SomeOIDLikeValue OID
deriving (Eq,Ord,Show, Typeable, Data)
maybeValueOfType Nothing = value
maybeValueOfType (Just t) = valueOfType t
valueOfType (Type t _) = v t
where
v (BitString _) = bitStringValue
v Boolean = booleanValue
v CharacterString = unrestrictedCharacterStringValue
v BMPString = restrictedCharacterStringValue
v GeneralString = restrictedCharacterStringValue
v GraphicString = restrictedCharacterStringValue
v IA5String = restrictedCharacterStringValue
v ISO646String = restrictedCharacterStringValue
v NumericString = restrictedCharacterStringValue
v PrintableString = restrictedCharacterStringValue
v TeletexString = restrictedCharacterStringValue
v T61String = restrictedCharacterStringValue
v UniversalString = restrictedCharacterStringValue
v UTF8String = restrictedCharacterStringValue
v VideotexString = restrictedCharacterStringValue
v VisibleString = restrictedCharacterStringValue
v (Choice _) = choiceValue
v EmbeddedPDV = embeddedPDVValue
v (SimpleEnumeration _) = enumeratedValue
v (EnumerationWithException _ _) = enumeratedValue
v (EnumerationWithExceptionAndAddition _ _ _) = enumeratedValue
v External = externalValue
v (InstanceOf _) = instanceOfValue
v (TheInteger namedNumber) = integerValue
v Null = nullValue
v ObjectIdentifier = objectIdentifierValue
v OctetString = octetStringValue
v Real = realValue
v RelativeOID = relativeOIDValue
v (Sequence _) = sequenceValue
v (SequenceOf _ _) = sequenceOfValue
v (Set _) = setValue
v (SetOf _ _) = setOfValue
v (Tagged _ _ innerType) = valueOfType innerType
v (LocalTypeReference _) = value
v (ExternalTypeReference _ _) = value
v GeneralizedTime = generalizedTimeValue
v UTCTime = utcTimeValue
v ObjectDescriptor = objectDescriptorValue
v (Selection _ innerType) = valueOfType innerType
v (Any _) = value
value = builtinValue <|> referencedValue <|> objectClassFieldValue
<?> "Value"
builtinValue =
choice $ map try [ booleanValue
, nullValue
, SomeNumber <$> realnumber
, PlusInfinity <$ reserved "PLUS-INFINITY"
, MinusInfinity <$ reserved "MINUS-INFINITY"
, restrictedCharacterStringValue
, choiceValue
, SomeNamedValueList <$> componentValueList
, SomeValueList <$> braces (commaSep value)
, SomeOIDLikeValue <$> oid
, bitStringValue
, SomeIdentifiedValue <$> identifier
]
referencedValue =
choice [ DefinedV <$> definedValue
, valueFromObject
]
data NamedValue = NamedValue Identifier Value deriving (Eq,Ord,Show, Typeable, Data)
namedValue = NamedValue <$> identifier <*> value
<?> "NamedValue"
booleanValue =
BooleanValue <$>
choice [ True <$ reserved "TRUE"
, False <$ reserved "FALSE"
]
integerType = TheInteger <$> (reserved "INTEGER" *> option [] (braces namedNumberList))
namedNumberList = commaSep1 namedNumber
data NamedNumber = NamedNumber Identifier Integer
| NamedDefinedValue Identifier DefinedValue
deriving (Eq,Ord,Show, Typeable, Data)
namedNumber =
choice [ try $ NamedNumber <$> identifier <*> parens signedNumber
, NamedDefinedValue <$> identifier <*> parens definedValue
]
<?> "NamedNumber"
signedNumber = integer <?> "SignedNumber"
integerValue =
choice [ SignedNumber <$> signedNumber
, IdentifiedNumber <$> identifier
]
enumeratedType = reserved "ENUMERATED" *> braces enumerations
enumerations =
choice [ try $ EnumerationWithExceptionAndAddition <$> enumeration <*> ( symbol "..." *> exceptionSpec) <*> (comma *> enumeration)
, try $ EnumerationWithException <$> enumeration <*> ( symbol "..." *> exceptionSpec)
, SimpleEnumeration <$> enumeration
]
enumeration = commaSepEndBy1 enumerationItem
data EnumerationItem = EnumerationItemNumber NamedNumber
| EnumerationItemIdentifier Identifier
deriving (Eq,Ord,Show, Typeable, Data)
enumerationItem =
choice [ try $ EnumerationItemNumber <$> namedNumber
, EnumerationItemIdentifier <$> identifier
]
enumeratedValue = EnumeratedValue <$> identifier
realValue =
choice [ PlusInfinity <$ reserved "PLUS-INFINITY"
, MinusInfinity <$ reserved "MINUS-INFINITY"
, RealValue <$> realnumber
, SequenceRealValue <$> componentValueList
]
bitStringType = BitString <$> ( reserved "BIT" *> reserved "STRING" *> option [] (braces namedNumberList) )
bitStringValue =
choice [ try $ BinaryString <$> bstring
, HexString <$> hstring
, IdentifierListBitString <$> braces (commaSep identifier)
, Containing <$> (reserved "CONTAINING" *> value)
]
octetStringValue =
choice [ try $ BinaryString <$> bstring
, HexString <$> hstring
, Containing <$> (reserved "CONTAINING" *> value)
]
nullValue = NullValue <$ reserved "NULL"
sequenceType =
Sequence <$>
choice [ try $ Empty <$ ( reserved "SEQUENCE" >> symbol "{" >> symbol "}" )
, try $ JustException <$> ( reserved "SEQUENCE" *> braces (extensionAndException <* optionalExtensionMarker) )
, (reserved "SEQUENCE" *> braces componentTypeLists)
]
extensionAndException = symbol "..." >> exceptionSpec
optionalExtensionMarker = optional $ extensionEndMarker
data ComponentTypeLists = ComponentTypeList [ComponentType]
| Empty
| JustException (Maybe ExceptionIdentification)
| JustExtensions (Maybe ExceptionIdentification) (Maybe [ExtensionAddition])
| ExtensionsAtStart (Maybe ExceptionIdentification) (Maybe [ExtensionAddition]) [ComponentType]
| ExtensionsAtEnd [ComponentType] (Maybe ExceptionIdentification) (Maybe [ExtensionAddition])
| ExtensionsInTheMiddle [ComponentType] (Maybe ExceptionIdentification) (Maybe [ExtensionAddition]) [ComponentType]
deriving (Eq,Ord,Show, Typeable, Data)
componentTypeLists =
choice [ try $ ExtensionsInTheMiddle <$> componentTypeList <*> ( extensionAndException) <*> extensionsAdditions <*> (extensionEndMarker *> comma *> componentTypeList)
, try $ ExtensionsAtStart <$> extensionAndException <*> extensionsAdditions <*> (extensionEndMarker *> comma *> componentTypeList)
, JustExtensions <$> extensionAndException <*> extensionsAdditions <* optionalExtensionMarker
, try $ ExtensionsAtEnd <$> componentTypeList <*> ( extensionAndException) <*> extensionsAdditions <* optionalExtensionMarker
, ComponentTypeList <$> componentTypeList
]
extensionEndMarker = optional comma >> symbol "..."
extensionsAdditions = optionMaybe (comma >> extensionAdditionList)
extensionAdditionList = commaSepEndBy1 extensionAddition
data ExtensionAddition = ExtensionAdditionGroup (Maybe Integer) [ComponentType]
| ExtensionAdditionType ComponentType
deriving (Eq,Ord,Show, Typeable, Data)
extensionAddition =
choice [ extensionAdditionGroup
, ExtensionAdditionType <$> componentType
]
where
extensionAdditionGroup = ExtensionAdditionGroup <$> ( symbol "[[" *> versionNumber ) <*> componentTypeList <* symbol "]]"
versionNumber = optionMaybe $ number <* colon
componentTypeList = commaSepEndBy1 componentType
data ComponentType = NamedTypeComponent { element_type::NamedType
, element_presence::Maybe ValueOptionality
}
| ComponentsOf Type deriving (Eq,Ord,Show, Typeable, Data)
componentType =
choice [ try $ ComponentsOf <$> (reserved "COMPONENTS" *> reserved "OF" *> theType)
, NamedTypeComponent <$> namedType <*> valueOptionality Nothing
]
data ValueOptionality = OptionalValue | DefaultValue Value deriving (Eq,Ord,Show, Typeable, Data)
valueOptionality t = optionMaybe $
choice [ OptionalValue <$ reserved "OPTIONAL"
, DefaultValue <$> ( reserved "DEFAULT" *> maybeValueOfType t)
]
type ComponentValueList = [NamedValue]
componentValueList = braces (commaSep namedValue)
sequenceValue = SequenceValue <$> componentValueList
setOrSequenceOfType = do
constr <- constructor
c <- optionMaybe setSeqConstraint
reserved "OF"
t <- choice [ try $ Right <$> namedType
, Left <$> theType
]
return $ constr c t
where
constructor = ( SetOf <$ reserved "SET" ) <|> ( SequenceOf <$ reserved "SEQUENCE")
setSeqConstraint =
choice [
flip Constraint Nothing . ClosedSet False . Singleton . Subtype <$> sizeConstraint
, constraint Nothing
]
setOrSequenceOfValue =
choice [ try $ Right <$> componentValueList
, Left <$> braces (commaSep value)
]
sequenceOfValue = SequenceOfValue <$> setOrSequenceOfValue
setOfValue = SetOfValue <$> setOrSequenceOfValue
setType =
Set <$>
choice [ try $ Empty <$ ( reserved "SET" >> symbol "{" >> symbol "}" )
, try $ JustException <$> ( reserved "SET" *> braces ( extensionAndException <* optionalExtensionMarker ) )
, (reserved "SET" *> braces componentTypeLists)
]
setValue = SetValue <$> componentValueList
choiceType = Choice <$> ( reserved "CHOICE" *> braces alternativeTypeLists )
<?> "ChoiceType"
data AlternativeTypeLists = SimpleAlternativeTypeList [NamedType]
| AlternativeTypeListWithExtension [NamedType] (Maybe ExceptionIdentification) (Maybe [ExtensionAdditionAlternative])
deriving (Eq,Ord,Show, Typeable, Data)
alternativeTypeLists =
choice [ try $ AlternativeTypeListWithExtension <$> alternativeTypeList <*> extensionAndException <*> extensionAdditionAlternatives <* optionalExtensionMarker
, SimpleAlternativeTypeList <$> alternativeTypeList
]
extensionAdditionAlternatives = optionMaybe (comma >> extensionAdditionAlternativesList)
extensionAdditionAlternativesList = commaSepEndBy1 extensionAdditionAlternative
data ExtensionAdditionAlternative = ExtensionAdditionAlternativesGroup (Maybe Integer) [NamedType]
| ExtensionAdditionAlternativesType NamedType
deriving (Eq,Ord,Show, Typeable, Data)
extensionAdditionAlternative =
choice [ extensionAdditionGroupAlternatives
, ExtensionAdditionAlternativesType <$> namedType
]
extensionAdditionGroupAlternatives = ExtensionAdditionAlternativesGroup <$> ( symbol "[[" *> versionNumber) <*> alternativeTypeList <* symbol "]]"
alternativeTypeList = commaSepEndBy1 namedType
choiceValue = ChoiceValue <$> identifier <*> ( colon *> value)
selectionType = Selection <$> identifier <*> (symbol "<" *> theType)
<?> "SelectionType"
taggedType = Tagged <$> tag <*> tagType <*> theType
data TagType = Explicit | Implicit deriving (Eq,Ord,Show, Typeable, Data)
tagType =
optionMaybe $
choice [ Explicit <$ reserved "EXPLICIT"
, Implicit <$ reserved "IMPLICIT"
]
data Tag = Tag (Maybe Class) ClassNumber deriving (Eq,Ord,Show, Typeable, Data)
tag = squares (Tag <$> optionMaybe theClass <*> classNumber)
data ClassNumber = ClassNumber Integer | ClassNumberAsDefinedValue DefinedValue deriving (Eq,Ord,Show, Typeable, Data)
classNumber =
choice [ ClassNumber <$> number
, ClassNumberAsDefinedValue <$> definedValue
]
data Class = Universal | Application | Private deriving (Eq,Ord,Show, Typeable, Data)
theClass = choice [ Universal <$ reserved "UNIVERSAL"
, Application <$ reserved "APPLICATION"
, Private <$ reserved "PRIVATE"
]
objectIdentifierValue = OID <$> oid
type OID = [OIDComponent]
oid = braces (many1 oidComponent) <?> "OID"
data OIDComponent = ObjIdDefinedValue DefinedValue | ObjIdNumber Integer | ObjIdNamedNumber NamedNumber | ObjIdName Identifier deriving (Eq,Ord,Show, Typeable, Data)
oidComponent =
choice [ ObjIdNamedNumber <$> try namedNumber
, ObjIdName . Identifier <$> try reservedOIDIdentifier
, ObjIdNumber <$> number
, ObjIdDefinedValue <$> definedValue
]
<?> "OIDComponent"
reservedOIDIdentifier = do
(Identifier i) <- identifier
when (not $ i `elem` reservedIds ) $ unexpected ("non-reserved identifier "++i)
return i
where
reservedIds = [ "itu-t", "ccitt", "iso", "joint-iso-itu-t", "joint-iso-ccitt"
, "recommendation", "question", "administration", "network-operator"
, "identified-organization", "standard", "member-body"] ++ map (:[]) ['a'..'z']
data RelativeOIDComponent =
RelativeOIDNumber Integer
| RelativeOIDNamedNumber NamedNumber
| RelativeOIDDefinedValue DefinedValue
deriving (Eq,Ord,Show, Typeable, Data)
relativeOIDComponent =
choice [ RelativeOIDNamedNumber <$> try namedNumber
, RelativeOIDNumber <$> number
, RelativeOIDDefinedValue <$> definedValue
]
relativeOIDValue = RelativeOIDValue <$> braces (many1 relativeOIDComponent)
embeddedPDVValue = EmbeddedPDVValue <$> componentValueList
externalValue = ExternalValue <$> componentValueList
characterStringType =
choice [ reserved "BMPString" >> return BMPString
, reserved "GeneralString" >> return GeneralString
, reserved "GraphicString" >> return GraphicString
, reserved "IA5String" >> return IA5String
, reserved "ISO646String" >> return ISO646String
, reserved "NumericString" >> return NumericString
, reserved "PrintableString" >> return PrintableString
, reserved "TeletexString" >> return TeletexString
, reserved "T61String" >> return T61String
, reserved "UniversalString" >> return UniversalString
, reserved "UTF8String" >> return UTF8String
, reserved "VideotexString" >> return VideotexString
, reserved "VisibleString" >> return VisibleString
, reserved "CHARACTER" >> reserved "STRING" >> return CharacterString
]
restrictedCharacterStringValue =
RestrictedCharacterStringValue <$>
choice [ braces (many1 ( try (CharsDefinedValue <$> definedValue) <|> charsDefn ))
, (:[]) <$> charsDefn
]
data CharsDefn =
Tuple {table_column::Integer, table_row::Integer}
| Quadruple Integer Integer Integer Integer
| CharsDefinedValue DefinedValue
| CharsCString CString
deriving (Eq,Ord,Show, Typeable, Data)
charsDefn =
choice [ try $ braces ( Tuple <$> number <*> (comma *> number) )
, try $ braces ( Quadruple <$> number <*> (comma *> number) <*> (comma *> number) <*> (comma *> number) )
, CharsCString <$> cstring
]
unrestrictedCharacterStringValue = UnrestrictedCharacterStringValue <$> componentValueList
usefulType =
choice [ GeneralizedTime <$ reserved "GeneralizedTime"
, UTCTime <$ reserved "UTCTime"
, ObjectDescriptor <$ reserved "ObjectDescriptor"
]
generalizedTimeValue = GeneralizedTimeValue <$> cstring
utcTimeValue = UTCTimeValue <$> cstring
objectDescriptorValue = ObjectDescriptorValue <$> cstring
data Constraint = Constraint ElementSets (Maybe ExceptionIdentification) deriving (Eq,Ord,Show, Typeable, Data)
constraint t = parens ( Constraint <$> constraintSpec t <*> exceptionSpec )
onlySubtypeConstraint t = parens ( Constraint <$> subtypeConstraint t <*> exceptionSpec )
constraintSpec t = subtypeConstraint t
subtypeConstraint t = elementSetSpecs t
data ElementSets =
ClosedSet Bool ElementSet
| ExtendableSet ElementSet
| SetRange ElementSet ElementSet deriving (Eq,Ord,Show, Typeable, Data)
elementSetSpecs t =
choice [ try $ SetRange <$> elementSetSpec t <*> (comma *> symbol "..." *> comma *> elementSetSpec t)
, try $ ClosedSet True <$> (elementSetSpec t <* comma <* symbol "...")
, ClosedSet False <$> elementSetSpec t
]
data ElementSet = AllExcept Exclusions
| Union [[Intersection]]
| Singleton Elements
deriving (Eq,Ord,Show, Typeable, Data)
elementSetSpec t =
choice [ AllExcept <$> ( reserved "ALL" *> exclusions t )
, mkUnion <$> unions t
]
where
mkUnion ([[Intersection es Nothing]]) = Singleton es
mkUnion s = Union s
unions t = (intersections t) `sepBy1` unionMark
intersections t = (intersectionElements t) `sepBy1` intersectionMark
data Intersection = Intersection Elements (Maybe Exclusions) deriving (Eq,Ord,Show, Typeable, Data)
intersectionElements t = Intersection <$> elements t <*> optionMaybe (exclusions t)
type Exclusions = Elements
exclusions t = reserved "EXCEPT" *> elements t
unionMark = ( () <$ symbol "|" ) <|> reserved "UNION"
intersectionMark = ( () <$ symbol "^" ) <|> reserved "INTERSECTION"
data Elements = Subset ElementSet | Subtype SubtypeElements | ObjSet ObjectSetElements
deriving (Eq,Ord,Show, Typeable, Data)
elements t =
choice [ Subset <$> parens (elementSetSpec t)
, try $ Subtype <$> (subtypeElements t)
, ObjSet <$> objectSetElements
]
data SubtypeElements =
SingleValue Value
| ContainedSubtype Type
| ValueRange ValueRangeEndpoint ValueRangeEndpoint
| PermittedAlphabet Constraint
| SizeConstraint Constraint
| SingleTypeConstraint Constraint
| MultipleTypeConstaints TypeConstraints
| PatternConstraint CString
deriving (Eq,Ord,Show, Typeable, Data)
subtypeElements t =
choice [ try $ valueRange t
, permittedAlphabet t
, sizeConstraint
, innerTypeConstraints t
, try $ containedSubtype
, SingleValue <$> maybeValueOfType t
]
containedSubtype = ContainedSubtype <$> ( optional (reserved "INCLUDES") *> theType )
data ValueRangeEndpoint = Closed ValueRangeEndValue | Open ValueRangeEndValue deriving (Eq,Ord,Show, Typeable, Data)
data ValueRangeEndValue = MinValue | MaxValue | Value Value deriving (Eq,Ord,Show, Typeable, Data)
valueRange t = ValueRange <$> lowerEndpoint t <*> ( symbol ".." *> upperEndpoint t )
lowerEndpoint t =
choice [ try $ Open <$> ( lowerEndValue t <* symbol "<" )
, Closed <$> lowerEndValue t
]
upperEndpoint t =
choice [ Open <$> ( symbol "<" *> upperEndValue t )
, Closed <$> upperEndValue t
]
lowerEndValue t = (MinValue <$ reserved "MIN") <|> (Value <$> maybeValueOfType t)
upperEndValue t = (MaxValue <$ reserved "MAX") <|> (Value <$> maybeValueOfType t)
sizeConstraint = SizeConstraint <$> ( reserved "SIZE" *> onlySubtypeConstraint sizeConstraintType)
where sizeConstraintType = parseASN1 theType "INTEGER (0..MAX)"
permittedAlphabet t = PermittedAlphabet <$> ( reserved "FROM" *> onlySubtypeConstraint t )
innerTypeConstraints t = do
reserved "WITH"
choice [ MultipleTypeConstaints <$> ( reserved "COMPONENTS" *> multipleTypeConstraints t )
, SingleTypeConstraint <$> ( reserved "COMPONENT" *> constraint t )
]
multipleTypeConstraints t = braces( optional (symbol "..." >> symbol ",") >> typeConstraints t )
type TypeConstraints = [NamedConstraint]
typeConstraints t = commaSep1 (namedConstraint t)
data NamedConstraint = NamedConstraint Identifier ComponentConstraint deriving (Eq,Ord,Show, Typeable, Data)
namedConstraint t = NamedConstraint <$> identifier <*> componentConstraint t
data ComponentConstraint = ComponentConstraint (Maybe Constraint) (Maybe PresenceConstraint) deriving (Eq,Ord,Show, Typeable, Data)
componentConstraint t = ComponentConstraint <$> optionMaybe (constraint t) <*> optionMaybe presenceConstraint
data PresenceConstraint = Present
| Absent
| Optional
deriving (Eq,Ord,Show, Typeable, Data)
presenceConstraint =
choice [ Present <$ reserved "PRESENT"
, Absent <$ reserved "ABSENT"
, Optional <$ reserved "OPTIONAL"
]
patternConstraint = PatternConstraint <$> ( reserved "PATTERN" *> cstring )
exceptionSpec =
optionMaybe ( symbol "!" >> exceptionIdentification )
data ExceptionIdentification = ExceptionNumber Integer
| ExceptionValue DefinedValue
| ExceptionTypeAndValue Type Value
deriving (Eq,Ord,Show, Typeable, Data)
exceptionIdentification =
choice [ ExceptionNumber <$> signedNumber
, ExceptionValue <$> definedValue
, do t <- theType
colon
v <- valueOfType t
return $ ExceptionTypeAndValue t v
]
anyType = Any <$> ( reserved "ANY" *> optionMaybe ( reserved "DEFINED" *> reserved "BY" *> identifier ) )
newtype ObjectClassReference = ObjectClassReference String deriving (Eq,Ord,Show, Typeable, Data)
objectclassreference = ObjectClassReference <$> ucaseIdent
newtype ObjectReference = ObjectReference String deriving (Eq,Ord,Show, Typeable, Data)
objectreference = ObjectReference <$> _valuereference
_objectreference = _valuereference
newtype ObjectSetReference = ObjectSetReference String deriving (Eq,Ord,Show, Typeable, Data)
objectsetreference = ObjectSetReference <$> _typereference
_objectsetreference = _typereference
newtype TypeFieldReference = TypeFieldReference String deriving (Eq,Ord,Show, Typeable, Data)
typefieldreference = TypeFieldReference <$> (char '&' *> _typereference)
newtype ValueFieldReference = ValueFieldReference String deriving (Eq,Ord,Show, Typeable, Data)
valuefieldreference = ValueFieldReference <$> ( char '&' *> _valuereference)
newtype ValueSetFieldReference = ValueSetFieldReference String deriving (Eq,Ord,Show, Typeable, Data)
valuesetfieldreference = ValueSetFieldReference <$> ( char '&' *> _typereference )
newtype ObjectFieldReference = ObjectFieldReference String deriving (Eq,Ord,Show, Typeable, Data)
objectfieldreference = ObjectFieldReference <$> ( char '&' *> _objectreference )
newtype ObjectSetFieldReference = ObjectSetFieldReference String deriving (Eq,Ord,Show, Typeable, Data)
objectsetfieldreference = ObjectSetFieldReference <$> ( char '&' *> _objectsetreference )
data DefinedObjectClass = ExternalObjectClassReference ModuleReference ObjectClassReference
| LocalObjectClassReference ObjectClassReference
| TypeIdentifier
| AbstractSyntax
deriving (Eq,Ord,Show, Typeable, Data)
definedObjectClass =
choice [ try $ ExternalObjectClassReference <$> moduleReferenceAndDot <*> objectclassreference
, LocalObjectClassReference <$> objectclassreference
, TypeIdentifier <$ reserved "TYPE-IDENTIFIER"
, AbstractSyntax <$ reserved "ABSTRACT-SYNTAX"
]
data DefinedObject = ExternalObjectReference ModuleReference ObjectReference
| LocalObjectReference ObjectReference
deriving (Eq,Ord,Show, Typeable, Data)
definedObject =
choice [ try $ ExternalObjectReference <$> moduleReferenceAndDot <*> objectreference
, LocalObjectReference <$> objectreference
] <?> "DefinedObject"
data DefinedObjectSet = ExternalObjectSetReference ModuleReference ObjectSetReference
| LocalObjectSetReference ObjectSetReference
deriving (Eq,Ord,Show, Typeable, Data)
definedObjectSet =
choice [ try $ ExternalObjectSetReference <$> moduleReferenceAndDot <*> objectsetreference
, LocalObjectSetReference <$> objectsetreference
] <?> "DefinedObjectSet"
objectClassAssignment = ObjectClassAssignment <$> objectclassreference <*> ( symbol "::=" *> objectClass )
data ObjectClass = ObjectClassDefn [Field] | DefinedObjectClassDefn DefinedObjectClass deriving (Eq,Ord,Show, Typeable, Data)
objectClass =
choice [ DefinedObjectClassDefn <$> definedObjectClass
, objectClassDefn
]
objectClassDefn = do
reserved "CLASS"
ObjectClassDefn <$> (braces $ commaSep1 field)
data Field = TypeField TypeFieldReference (Maybe TypeOptionality)
| FixedTypeValueField ValueFieldReference Type Bool (Maybe ValueOptionality)
| VariableTypeValueField ValueFieldReference FieldName (Maybe ValueOptionality)
| FixedTypeValueSetField ValueSetFieldReference Type (Maybe ValueSetOptionality)
| VariableTypeValueSetField ValueSetFieldReference FieldName (Maybe ValueSetOptionality)
| ObjectField ObjectFieldReference DefinedObjectClass (Maybe ObjectOptionality)
| ObjectSetField ObjectSetFieldReference DefinedObjectClass (Maybe ObjectSetOptionality)
deriving (Eq,Ord,Show, Typeable, Data)
data TypeOptionality = OptionalType | DefaultType Type deriving (Eq,Ord,Show, Typeable, Data)
data ObjectOptionality = OptionalObject | DefaultObject Object deriving (Eq,Ord,Show, Typeable, Data)
data ObjectSetOptionality = OptionalObjectSet | DefaultObjectSet ObjectSet deriving (Eq,Ord,Show, Typeable, Data)
data ValueSetOptionality = OptionalValueSet | DefaultValueSet ValueSet deriving (Eq,Ord,Show, Typeable, Data)
field = try objectField
<|> try objectSetField
<|> try fixedTypeValueField
<|> try variableTypeValueField
<|> try fixedTypeValueSetField
<|> try variableTypeValueSetField
<|> typeField
<?> "Field"
typeField = TypeField <$> typefieldreference <*> optionality
where optionality = optionMaybe $ ( OptionalType <$ reserved "OPTIONAL" ) <|> ( DefaultType <$> ( reserved "DEFAULT" *> theType ) )
fixedTypeValueField = do
vfr <- valuefieldreference
t <- theType
FixedTypeValueField vfr t <$> uniqueness <*> valueOptionality (Just t)
where
uniqueness = option False (reserved "UNIQUE" >> return True)
variableTypeValueField = VariableTypeValueField <$> valuefieldreference <*> fieldName <*> valueOptionality Nothing
fixedTypeValueSetField = do
vsfr <- valuesetfieldreference
t <- theType
FixedTypeValueSetField vsfr t <$> valueSetOptionality (Just t)
valueSetOptionality t =
optionMaybe $
choice [ OptionalValueSet <$ reserved "OPTIONAL"
, DefaultValueSet <$> ( reserved "DEFAULT" *> valueSet t )
]
variableTypeValueSetField = VariableTypeValueSetField <$> valuesetfieldreference <*> fieldName <*> valueSetOptionality Nothing
objectField = ObjectField <$> objectfieldreference <*> definedObjectClass <*> objectOptionality
objectOptionality = optionMaybe $
choice [ OptionalObject <$ reserved "OPTIONAL"
, DefaultObject <$> ( reserved "DEFAULT" *> object )
]
objectSetField = ObjectSetField <$> objectsetfieldreference <*> definedObjectClass <*> objectSetOptionality
objectSetOptionality = optionMaybe $
choice [ OptionalObjectSet <$ reserved "OPTIONAL"
, DefaultObjectSet <$> ( reserved "DEFAULT" *> objectSet )
]
data PrimitiveFieldName = PrimTFR TypeFieldReference | PrimVFR ValueFieldReference | PrimOFR ObjectFieldReference
| PrimVSFR ValueSetFieldReference | PrimOSFR ObjectSetFieldReference
deriving (Eq,Ord,Show, Typeable, Data)
primitiveFieldName =
choice [ PrimTFR <$> try typefieldreference
, PrimOFR <$> objectfieldreference
, PrimVFR <$> valuefieldreference
, PrimVSFR <$> valuesetfieldreference
, PrimOSFR <$> objectsetfieldreference
]
type FieldName = [PrimitiveFieldName]
fieldName = primitiveFieldName `sepBy1` dot
objectAssignment = ObjectAssignment <$> objectreference <*> definedObjectClass <*> ( symbol "::=" *> object )
data Object = ObjectDefn [FieldSetting]
| ObjDefinedObject DefinedObject
| ObjectFromObject ReferencedObjects FieldName
deriving (Eq,Ord,Show, Typeable, Data)
object =
choice [ objectDefn
, ObjDefinedObject <$> definedObject
, objectFromObject
]
objectDefn =
choice [ ObjectDefn <$> defaultSyntax
]
where
defaultSyntax = braces $ commaSep fieldSetting
data FieldSetting =
TypeFieldSetting TypeFieldReference Type
| ValueFieldSetting ValueFieldReference Value
| ValueSetFieldSetting ValueSetFieldReference ValueSet
| ObjectFieldSetting ObjectFieldReference Object
| ObjectSetFieldSetting ObjectSetFieldReference ObjectSet
deriving (Eq,Ord,Show, Typeable, Data)
fieldSetting =
choice $ map try [ TypeFieldSetting <$> typefieldreference <*> theType
, ValueFieldSetting <$> valuefieldreference <*> value
, ValueSetFieldSetting <$> valuesetfieldreference <*> valueSet Nothing
, ObjectFieldSetting <$> objectfieldreference <*> object
, ObjectSetFieldSetting <$> objectsetfieldreference <*> objectSet
]
objectSetAssignment = ObjectSetAssignment <$> objectsetreference <*> definedObjectClass <*> ( symbol "::=" *> objectSet )
objectSet = braces objectSetSpec
data ObjectSet =
ObjectSet ElementSet
| ObjectSetExtendableAtEnd ElementSet
| EmptyExtendableObjectSet
| ObjectSetExtendableAtStart ElementSet
| ObjectSetExtendableInTheMiddle ElementSet ElementSet
deriving (Eq,Ord,Show, Typeable, Data)
objectSetSpec =
choice [ try $ ObjectSetExtendableAtStart <$> ( symbol "..." *> comma *> elementSetSpec Nothing )
, EmptyExtendableObjectSet <$ (symbol "...")
, try $ ObjectSetExtendableInTheMiddle <$> elementSetSpec Nothing <*> ( comma *> symbol "..." *> comma *> elementSetSpec Nothing )
, try $ ObjectSetExtendableAtEnd <$> elementSetSpec Nothing <* comma <* symbol "..."
, ObjectSet <$> elementSetSpec Nothing
]
data ObjectSetElements =
ObjectElement Object
| DefinedObjectSetElement DefinedObjectSet
| ObjectSetFromObjectsElement ReferencedObjects FieldName
deriving (Eq,Ord,Show, Typeable, Data)
objectSetElements =
choice [ ObjectElement <$> object
, DefinedObjectSetElement <$> definedObjectSet
, ObjectSetFromObjectsElement <$> referencedObjects <*> ( dot *> fieldName )
]
objectClassFieldType = ObjectClassField <$> definedObjectClass <*> ( dot *> fieldName )
objectClassFieldValue = openTypeFieldVal <|> fixedTypeFieldVal
openTypeFieldVal = do
t <- theType
OpenTypeFieldValue t <$> ( colon *> valueOfType t )
fixedTypeFieldVal = FixedTypeFieldValue <$> ( builtinValue <|> referencedValue )
valueFromObject = ValueFromObject <$> referencedObjects <*> ( dot *> fieldName )
valueSetFromObjects = ValueSetFromObjects <$> referencedObjects <*> (dot *> fieldName )
typeFromObject = TypeFromObject <$> referencedObjects <*> ( dot *> fieldName )
objectFromObject = ObjectFromObject <$> referencedObjects <*> (dot *> fieldName )
data ReferencedObjects =
ReferencedObject DefinedObject
| ReferencedObjectSet DefinedObjectSet
deriving (Eq,Ord,Show, Typeable, Data)
referencedObjects =
choice [ ReferencedObject <$> definedObject
, ReferencedObjectSet <$> definedObjectSet
]
instanceOfType = InstanceOf <$> ( reserved "INSTANCE" *> reserved "OF" *> definedObjectClass )
instanceOfValue = InstanceOfValue <$> componentValueList