language-webidl 0.1.2.0 → 0.1.3.0

raw patch · 5 files changed

+123/−51 lines, 5 filesdep +HUnitdep +language-webidlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HUnit, language-webidl

API changes (from Hackage documentation)

Files

• language-webidl.cabal +10/−2
• src/Language/WebIDL/AST.hs +29/−17
• src/Language/WebIDL/PPrint.hs +26/−9
• src/Language/WebIDL/Parser.hs +36/−23
• test/Test.hs +22/−0

@@ -1,5 +1,5 @@-name:                language-webidl-version:             0.1.2.0+name:               language-webidl+version:            0.1.3.0 synopsis:           Parser and Pretty Printer for WebIDL description:     It is intended to replace the old package@@ -23,4 +23,12 @@                        Language.WebIDL.PPrint   build-depends:       base >=4.9 && <4.10, parsec, wl-pprint   hs-source-dirs:      src+  default-language:    Haskell2010++test-suite language-webidl-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Test.hs+  build-depends:       base >=4.9 && <4.10, language-webidl, HUnit+  ghc-options:         -Wall   default-language:    Haskell2010

@@ -3,6 +3,8 @@   Description: Abstract Syntax Tree of WebIDL -} +{-# LANGUAGE DeriveFunctor #-}+ module Language.WebIDL.AST where  import Prelude hiding (Enum)@@ -15,55 +17,65 @@                   | DefEnum (Enum a)                   | DefTypedef (Typedef a)                   | DefImplementsStatement (ImplementsStatement a)-                  deriving (Show, Eq)+                  deriving (Show, Eq, Functor) +-- | Extended attribute+data ExtendedAttribute a = ExtendedAttributeNoArgs a Ident -- ^ identifier+                         | ExtendedAttributeArgList a Ident [Argument a] -- ^ identifier "(" ArgumentList ")"+                         | ExtendedAttributeIdent a Ident Ident -- ^ identifier "=" identifier+                         | ExtendedAttributeIdentList a Ident [Ident] -- ^ identifier "=" "(" IdentifierList ")"+                         | ExtendedAttributeNamedArgList a Ident Ident [Argument a] -- ^ identifier "=" identifier "(" ArgumentList ")"+                         deriving (Show, Eq, Functor)+ -- | @interface@-data Interface a = Interface a Ident (Maybe Ident) [InterfaceMember a] deriving (Show, Eq)+data Interface a = Interface a [ExtendedAttribute a] Ident (Maybe Ident) [InterfaceMember a]+                 deriving (Show, Eq, Functor)  -- | Partial Definition data Partial a = PartialInterface a Ident [InterfaceMember a]                | PartialDictionary a Ident [DictionaryMember a]-               deriving (Show, Eq)+               deriving (Show, Eq, Functor)  -- | @dictionary@-data Dictionary a = Dictionary a Ident (Maybe Ident) [DictionaryMember a] deriving (Show, Eq)+data Dictionary a = Dictionary a Ident (Maybe Ident) [DictionaryMember a] deriving (Show, Eq, Functor)  -- | @exception@-data Exception a = Exception a Ident (Maybe Ident) [ExceptionMember a] deriving (Show, Eq)+data Exception a = Exception a Ident (Maybe Ident) [ExceptionMember a] deriving (Show, Eq, Functor)  -- | @enum@-data Enum a = Enum a Ident [EnumValue] deriving (Show, Eq)+data Enum a = Enum a Ident [EnumValue] deriving (Show, Eq, Functor)  -- | @typedef@-data Typedef a = Typedef a Type Ident deriving (Show, Eq)+data Typedef a = Typedef a Type Ident deriving (Show, Eq, Functor)  -- | @implements@ statement-data ImplementsStatement a = ImplementsStatement a Ident Ident deriving (Show, Eq)+data ImplementsStatement a = ImplementsStatement a Ident Ident deriving (Show, Eq, Functor)  -- | Member of interface definition data InterfaceMember a = IMemConst (Const a)                        | IMemAttribute (Attribute a)                        | IMemOperation (Operation a)-                       deriving (Show, Eq)+                       deriving (Show, Eq, Functor)  -- | Member of dictionary-data DictionaryMember a = DictionaryMember a Type Ident (Maybe Default) deriving (Show, Eq)+data DictionaryMember a = DictionaryMember a Type Ident (Maybe Default) deriving (Show, Eq, Functor)  -- | Member of exception definition data ExceptionMember a = ExConst a (Const a)                        | ExField a Type Ident-                       deriving (Show, Eq)+                       deriving (Show, Eq, Functor)  -- | Attribute member of interface-data Attribute a = Attribute a (Maybe Inherit) (Maybe ReadOnly) Type Ident deriving (Show, Eq)+data Attribute a = Attribute a (Maybe Inherit) (Maybe ReadOnly) Type Ident deriving (Show, Eq, Functor)  -- | Operation member of interface-data Operation a = Operation a (Maybe Qualifier) ReturnType (Maybe Ident) [Argument] deriving (Show, Eq)+data Operation a = Operation a [ExtendedAttribute a] (Maybe Qualifier) ReturnType (Maybe Ident) [Argument a]+                 deriving (Show, Eq, Functor)  -- | Argument of operation signature-data Argument = ArgOptional Type ArgumentName Default-              | ArgNonOpt Type (Maybe Ellipsis) ArgumentName-              deriving (Show, Eq)+data Argument a = ArgOptional [ExtendedAttribute a] Type ArgumentName (Maybe Default)+                | ArgNonOpt [ExtendedAttribute a] Type (Maybe Ellipsis) ArgumentName+                deriving (Show, Eq, Functor)  -- | Value of a @enum@ newtype EnumValue = EnumValue String deriving (Show, Eq)@@ -73,7 +85,7 @@                   | ArgIdent Ident                   deriving (Show, Eq) -- | @const@-data Const a = Const a ConstType Ident ConstValue deriving (Show, Eq)+data Const a = Const a ConstType Ident ConstValue deriving (Show, Eq, Functor)  -- | @default@ specification data Default = DefaultValue ConstValue

@@ -25,9 +25,20 @@     pretty (DefImplementsStatement x) = pretty x  instance Pretty (Interface a) where-    pretty (Interface _ x mInherit members) =-        text "interface" <+> pretty x <+> prettyInherit mInherit <+> scope members <> semi+    pretty (Interface _ extAttrs x mInherit members) =+        prettyExtAttrs extAttrs line <> text "interface" <+> pretty x <+> prettyInherit mInherit <+> scope members <> semi +prettyExtAttrs :: [ExtendedAttribute a] -> Doc -> Doc+prettyExtAttrs [] _ = empty+prettyExtAttrs attrs delimiter = brackets (hcat (punctuate (comma <> space) (map pretty attrs))) <> delimiter++instance Pretty (ExtendedAttribute a) where+    pretty (ExtendedAttributeNoArgs _ x) = pretty x+    pretty (ExtendedAttributeArgList _ x args) = pretty x <> prettyParenList args+    pretty (ExtendedAttributeIdent _ x y) = pretty x <+> equals <+> pretty y+    pretty (ExtendedAttributeIdentList _ x ids) = pretty x <+> equals <+> prettyParenList ids+    pretty (ExtendedAttributeNamedArgList _ x f args) = pretty x <+> equals <+> pretty f <> prettyParenList args+ prettyMaybe Nothing  _ = empty prettyMaybe (Just x) f = f x @@ -64,8 +75,10 @@  instance Pretty Type where     pretty (TySingleType s) = pretty s-    pretty (TyUnionType ut suffix) = pretty ut <> pretty suffix+    pretty (TyUnionType ut suffix) = prettyUnionType ut <> pretty suffix +prettyUnionType ut = parens (hcat (punctuate (space <> text "or" <> space) (map pretty ut)))+ instance Pretty SingleType where     pretty (STyNonAny t) = pretty t     pretty (STyAny suffix) = text "any" <> pretty suffix@@ -139,14 +152,18 @@     pretty (IMemOperation op) = pretty op  instance Pretty (Operation a) where-    pretty (Operation _ mQ retty mIdent args) =-        pretty mQ <> pretty retty <+> prettyMaybe mIdent pretty-                  <> parens (hcat (punctuate (comma <> space) (map pretty args))) <> semi+    pretty (Operation _ extAttrs mQ retty mIdent args) =+        prettyExtAttrs extAttrs space <> pretty mQ <> pretty retty+            <+> prettyMaybe mIdent pretty <> prettyParenList args <> semi +prettyParenList :: Pretty a => [a] -> Doc+prettyParenList args = parens (hcat (punctuate (comma <> space) (map pretty args))) -instance Pretty Argument where-    pretty (ArgOptional t name def) = text "optional" <+> pretty t <+> pretty name <> prettyDefault def-    pretty (ArgNonOpt t mElli name) = pretty t <> prettyMaybe mElli (\_ -> text "...") <+> pretty name+instance Pretty (Argument a) where+    pretty (ArgOptional extAttrs t name def) =+        prettyExtAttrs extAttrs space <> text "optional" <+> pretty t <+> pretty name <> prettyMaybe def prettyDefault+    pretty (ArgNonOpt extAttrs t mElli name) =+        prettyExtAttrs extAttrs space <> pretty t <> prettyMaybe mElli (\_ -> text "...") <+> pretty name  prettyDefault def = space <> equals <+> pretty def 

@@ -46,7 +46,7 @@ parseIDL = testParse (pSpaces *> many1 (pDef <* pSpaces))  pDef :: MyParser (Definition Tag)-pDef = DefInterface <$> (pExtAttrs *> pInterface)+pDef = try (DefInterface <$> pInterface)    <|> DefPartial <$> pPartial    <|> DefDictionary <$> pDictionary    <|> DefException <$> pException@@ -54,11 +54,17 @@    <|> DefTypedef <$> pTypedef    <|> DefImplementsStatement <$> pImplementsStatement --- FIXME: currently we ignore extended attributes-pExtAttrs :: MyParser ()-pExtAttrs = pSpaces *> void (char '[' *> (manyTill anyChar (try (char ']')))) <* pSpaces-        <|> pSpaces+pExtAttrs :: MyParser [ExtendedAttribute Tag]+pExtAttrs = try (brackets (pSpaces *> sepBy (pExtAttr <* pSpaces) (char ',' <* pSpaces)))+        <|> return [] +pExtAttr :: MyParser (ExtendedAttribute Tag)+pExtAttr = try (ExtendedAttributeNamedArgList <$> getTag <*> (pIdent <* pEq) <*> pIdent <*> pParenComma pArg)+       <|> try (ExtendedAttributeArgList <$> getTag <*> pIdent <*> pParenComma pArg)+       <|> try (ExtendedAttributeIdent <$> getTag <*> (pIdent <* pEq) <*> pIdent)+       <|> try (ExtendedAttributeIdentList <$> getTag <*> (pIdent <* pEq) <*> pParenComma pIdent)+       <|> ExtendedAttributeNoArgs <$> getTag <*> pIdent+ pPartial :: MyParser (Partial Tag) pPartial = string "partial" *> pSpaces *> p   where@@ -72,8 +78,8 @@                          <*> pInheritance <*> braces (many pDictionaryMember) <* semi  pInterface :: MyParser (Interface Tag)-pInterface = Interface <$> getTag <*> (string "interface" *> pSpaces *> pIdent)-                          <*> pInheritance <*> braces (pSpaces *> many (pInterfaceMember <* pSpaces)) <* semi+pInterface = Interface <$> getTag <*> pExtAttrs <*> (string "interface" *> pSpaces *> pIdent)+                       <*> pInheritance <*> braces (pSpaces *> many (pInterfaceMember <* pSpaces)) <* semi  pException :: MyParser (Exception Tag) pException = Exception <$> getTag <*> (string "exception" *> pSpaces *> pIdent)@@ -88,7 +94,6 @@ pEnumValues :: MyParser [EnumValue] pEnumValues = sepBy1 (EnumValue <$> stringLit) (char ',') - pTypedef :: MyParser (Typedef Tag) pTypedef = do   tag <- getTag@@ -106,7 +111,7 @@  pDictionaryMember :: MyParser (DictionaryMember Tag) pDictionaryMember = DictionaryMember <$> getTag <*> pType <* pSpaces-                                     <*> pIdent <*> optionMaybe (spaces *> pEq *> spaces *> pDefault) <* semi+                                     <*> pIdent <*> pDefault <* semi  pExceptionMember :: MyParser (ExceptionMember Tag) pExceptionMember =  ExConst <$> getTag <*> pConst@@ -118,7 +123,7 @@ pInterfaceMember :: MyParser (InterfaceMember Tag) pInterfaceMember =  try (IMemConst <$> pConst)                 <|> try (IMemAttribute <$> pAttribute)-                <|> IMemOperation <$> (pExtAttrs *> pOperation)+                <|> IMemOperation <$> pOperation  pConst :: MyParser (Const Tag) pConst = Const <$> getTag <*> (string "const" *> pSpaces *> pConstType <* pSpaces)@@ -131,20 +136,21 @@ pAttribute :: MyParser (Attribute Tag) pAttribute = Attribute <$> getTag <*> pModifier Inherit "inherit"                        <*> pModifier ReadOnly "readonly"-                       <*> (string "attribute" *> pSpaces *> pType) <*> (pSpaces *> pIdent <* semi)+                       <*> (string "attribute" *> pSpaces *> pType)+                       <*> (pSpaces *> pIdent <* semi)  pModifier :: a -> String -> MyParser (Maybe a) pModifier m s = optionMaybe (string s *> pSpaces *> return m)  pOperation :: MyParser (Operation Tag)-pOperation = Operation <$> getTag <*> pQualifier <* spaces+pOperation = Operation <$> getTag <*> pExtAttrs <*> pQualifier <* spaces                        <*> pReturnType <* pSpaces                        <*> pMaybeIdent <* pSpaces-                       <*> parens (pSpaces *> sepBy (pArg <* pSpaces) (char ',' <* pSpaces)) <* semi+                       <*> pParenComma pArg <* semi -pArg :: MyParser Argument-pArg =  ArgOptional <$> (string "optional" *> pType <* pSpaces) <*> pArgumentName <*> pDefault-    <|> ArgNonOpt   <$> (pType <* pSpaces) <*> (pModifier Ellipsis "...") <*> (pSpaces *> pArgumentName)+pArg :: MyParser (Argument Tag)+pArg =  try (ArgOptional <$> pExtAttrs <*> (string "optional" *> spaces *> pType <* pSpaces) <*> pArgumentName <*> pDefault)+    <|> ArgNonOpt <$> pExtAttrs <*> (pType <* pSpaces) <*> (pModifier Ellipsis "...") <*> (pSpaces *> pArgumentName)  pArgumentName :: MyParser ArgumentName pArgumentName = try (ArgKey <$> pArgumentNameKeyword)@@ -171,9 +177,12 @@                     <|> string "typedef" *> return ArgTypedef                     <|> string "unrestricted" *> return ArgUnrestricted -pDefault :: MyParser Default-pDefault =  DefaultValue <$> pConstValue-        <|> DefaultString <$> stringLit+pDefault :: MyParser (Maybe Default)+pDefault = Just <$> (spaces *> pEq *> spaces *> pDefault')+       <|> return Nothing+  where+    pDefault' = DefaultValue <$> pConstValue+            <|> DefaultString <$> stringLit   pQualifier :: MyParser (Maybe Qualifier)@@ -220,7 +229,7 @@ pUnsigned = optionMaybe (string "unsigned" *> return Unsigned)  pIntegerWidth = string "short" *> return Short-             <|> Long . length <$> many1 (string "long" <* pSpaces)+             <|> Long . length <$> many1 (try (string "long" <* pSpaces))  pFloatType :: MyParser FloatType pFloatType =  try (TyFloat <$> pModifier Unrestricted "unrestricted" <* spaces <* string "float")@@ -239,7 +248,7 @@            <|> TySequence <$> (string "sequence" *> pSpaces *> angles pType) <*> pNull            <|> TyObject <$> (string "object" *> pTypeSuffix)            <|> try (TyDOMString <$> (string "DOMString" *> pTypeSuffix))-           <|> TyDate <$> (string "Date" *> pTypeSuffix)+           <|> try (TyDate <$> (string "Date" *> pTypeSuffix))            <|> TyIdent <$> pIdent <*> pTypeSuffix  pTypeSuffix :: MyParser TypeSuffix@@ -249,7 +258,7 @@  -- FIXME: Not working correctly currently pUnionType :: MyParser UnionType-pUnionType = parens (sepBy1 pUnionMemberType (string "or"))+pUnionType = parens (sepBy1 pUnionMemberType (spaces *> string "or" <* spaces))  pUnionMemberType :: MyParser UnionMemberType pUnionMemberType =  UnionTy <$> pUnionType <*> pTypeSuffix@@ -259,6 +268,7 @@ lexer = Tok.makeTokenParser emptyDef  parens     = Tok.parens lexer+brackets   = Tok.brackets lexer braces     = Tok.braces lexer angles     = Tok.angles lexer reserved   = Tok.reserved lexer@@ -269,7 +279,7 @@ pFloat     = Tok.float lexer semi       = Tok.semi lexer stringLit  = Tok.stringLiteral lexer-pEq        = char '='+pEq        = spaces *> char '=' <* spaces  pSpaces = try (skipMany (spaces *> pComment <* spaces) <* spaces)       <|> spaces@@ -292,3 +302,6 @@   ParserState comments <- getState   putState $ ParserState []   return $ Tag comments pos++pParenComma :: MyParser a -> MyParser [a]+pParenComma p = parens (pSpaces *> sepBy (p <* pSpaces) (char ',' <* pSpaces))

@@ -0,0 +1,22 @@+import Test.HUnit+import Language.WebIDL.Parser+import Language.WebIDL.PPrint+import Control.Monad.IO.Class (liftIO)++main :: IO ()+main = runTestTT tests >>= print++tests :: Test+tests = TestList [ TestLabel "WebGL" (testIDL "examples/webgl.idl")+                 , TestLabel "File API" (testIDL "examples/fileapi.idl") ]++testIDL :: FilePath -> Test+testIDL idlpath = TestCase $ do+    text <- liftIO $ readFile idlpath+    case parseIDL text of+        Right defs -> do+            let text' = unlines $ map printDef defs+            case parseIDL text' of+                Right defs' -> assertEqual "Definitions should be equal" defs defs'+                Left err -> assertFailure ("Incorrect parsing of regenerated file: " ++ show err ++ "\n" ++ text')+        Left err -> assertFailure ("Incorrect parsing of original file: " ++ show err)