diff --git a/language-webidl.cabal b/language-webidl.cabal --- a/language-webidl.cabal +++ b/language-webidl.cabal @@ -1,5 +1,5 @@ name: language-webidl -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Parser and Pretty Printer for WebIDL description: It is intended to replace this package: @@ -18,7 +18,9 @@ location: https://github.com/izgzhen/language-webidl-hs library - exposed-modules: AST, Parser, PPrint + exposed-modules: Language.WebIDL.AST + Language.WebIDL.Parser + Language.WebIDL.PPrint build-depends: base >=4.8 && <4.9, parsec, wl-pprint hs-source-dirs: src default-language: Haskell2010 diff --git a/src/AST.hs b/src/AST.hs deleted file mode 100644 --- a/src/AST.hs +++ /dev/null @@ -1,159 +0,0 @@ -module AST where - -import Prelude hiding (Enum) - --- Definition -data Definition a = DefInterface (Interface a) - | DefPartial (Partial a) - | DefDictionary (Dictionary a) - | DefException (Exception a) - | DefEnum (Enum a) - | DefTypedef (Typedef a) - | DefImplementsStatement (ImplementsStatement a) - deriving (Show) - --- Interface -data Interface a = Interface a Ident (Maybe Ident) [InterfaceMember a] deriving (Show) - --- Partial -data Partial a = PartialInterface a Ident [InterfaceMember a] - | PartialDictionary a Ident [DictionaryMember a] - deriving (Show) - --- Dictionary -data Dictionary a = Dictionary a Ident (Maybe Ident) [DictionaryMember a] deriving (Show) - --- Exception -data Exception a = Exception a Ident (Maybe Ident) [ExceptionMember a] deriving (Show) - --- Enum -data Enum a = Enum a Ident [EnumValue] deriving (Show) - --- Typedef -data Typedef a = Typedef a Type Ident deriving (Show) - --- Implements -data ImplementsStatement a = ImplementsStatement a Ident Ident deriving (Show) - --- Fields -data InterfaceMember a = IMemConst (Const a) - | IMemAttribute (Attribute a) - | IMemOperation (Operation a) - deriving (Show) - -data DictionaryMember a = DictionaryMember a Type Ident (Maybe Default) deriving (Show) - -data ExceptionMember a = ExConst a (Const a) - | ExField a Type Ident - deriving (Show) - -data Attribute a = Attribute a (Maybe Inherit) (Maybe ReadOnly) Type Ident deriving (Show) - -data Operation a = Operation a (Maybe Qualifier) ReturnType (Maybe Ident) [Argument] deriving (Show) - -data Argument = ArgOptional Type ArgumentName Default - | ArgNonOpt Type (Maybe Ellipsis) ArgumentName - deriving (Show) - -newtype EnumValue = EnumValue String deriving (Show) - -data ArgumentName = ArgKey ArgumentNameKeyword - | ArgIdent Ident - deriving (Show) - --- Values -data Const a = Const a ConstType Ident ConstValue deriving (Show) - -data Default = DefaultValue ConstValue - | DefaultString String - deriving (Show) - -data ConstValue = ConstBooleanLiteral Bool - | ConstFloatLiteral Double - | ConstInteger Integer - | ConstNull - deriving (Show) - - --- Qualifers -data Qualifier = QuaStatic - | QSpecials [Special] - deriving (Show) - -data Special = Getter - | Setter - | Ccreator - | Deleter - | Legacycaller - deriving (Show) - -data ArgumentNameKeyword = ArgAttribute | ArgCallback | ArgConst | ArgCreator - | ArgDeleter | ArgDictionary | ArgEnum | ArgException - | ArgGetter | ArgImplements | ArgInherit | ArgInterface - | ArgLegacycaller | ArgPartial | ArgSetter | ArgStatic - | ArgStringifier | ArgTypedef | ArgUnrestricted - deriving (Show) - --- Types -data Type = TySingleType SingleType | TyUnionType UnionType TypeSuffix deriving (Show) - -data SingleType = STyNonAny NonAnyType - | STyAny TypeSuffix - deriving (Show) - -data NonAnyType = TyPrim PrimitiveType TypeSuffix - | TyDOMString TypeSuffix - | TyIdent Ident TypeSuffix - | TySequence Type (Maybe Null) - | TyObject TypeSuffix - | TyDate TypeSuffix - deriving (Show) - - -data PrimitiveType = PrimIntegerType IntegerType - | PrimFloatType FloatType - | Boolean - | Byte - | Octet - deriving (Show) - -data IntegerType = IntegerType (Maybe Unsigned) IntegerWidth deriving (Show) - -data IntegerWidth = Short | Long Int deriving (Show) - -data TypeSuffix = TypeSuffixArray - | TypeSuffixNullable - | TypeSuffixNone - deriving (Show) - -data FloatType = TyFloat (Maybe Unrestricted) - | TyDouble (Maybe Unrestricted) - deriving (Show) - -type UnionType = [UnionMemberType] - -data UnionMemberType = UnionTy UnionType TypeSuffix - | UnionTyNonAny NonAnyType - | UnionTyAny TypeSuffix - deriving (Show) - -data ReturnType = RetType Type - | RetVoid - deriving (Show) - - -data ConstType = ConstPrim PrimitiveType (Maybe Null) - | ConstIdent Ident (Maybe Null) - deriving (Show) - --- Markers - -data Ellipsis = Ellipsis deriving (Show) -data ReadOnly = ReadOnly deriving (Show) -data Inherit = Inherit deriving (Show) -data Unrestricted = Unrestricted deriving (Show) -data Null = Null deriving (Show) -data Unsigned = Unsigned deriving (Show) - --- Ident -newtype Ident = Ident String deriving (Show) diff --git a/src/Language/WebIDL/AST.hs b/src/Language/WebIDL/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/WebIDL/AST.hs @@ -0,0 +1,159 @@ +module Language.WebIDL.AST where + +import Prelude hiding (Enum) + +-- Definition +data Definition a = DefInterface (Interface a) + | DefPartial (Partial a) + | DefDictionary (Dictionary a) + | DefException (Exception a) + | DefEnum (Enum a) + | DefTypedef (Typedef a) + | DefImplementsStatement (ImplementsStatement a) + deriving (Show, Eq) + +-- Interface +data Interface a = Interface a Ident (Maybe Ident) [InterfaceMember a] deriving (Show, Eq) + +-- Partial +data Partial a = PartialInterface a Ident [InterfaceMember a] + | PartialDictionary a Ident [DictionaryMember a] + deriving (Show, Eq) + +-- Dictionary +data Dictionary a = Dictionary a Ident (Maybe Ident) [DictionaryMember a] deriving (Show, Eq) + +-- Exception +data Exception a = Exception a Ident (Maybe Ident) [ExceptionMember a] deriving (Show, Eq) + +-- Enum +data Enum a = Enum a Ident [EnumValue] deriving (Show, Eq) + +-- Typedef +data Typedef a = Typedef a Type Ident deriving (Show, Eq) + +-- Implements +data ImplementsStatement a = ImplementsStatement a Ident Ident deriving (Show, Eq) + +-- Fields +data InterfaceMember a = IMemConst (Const a) + | IMemAttribute (Attribute a) + | IMemOperation (Operation a) + deriving (Show, Eq) + +data DictionaryMember a = DictionaryMember a Type Ident (Maybe Default) deriving (Show, Eq) + +data ExceptionMember a = ExConst a (Const a) + | ExField a Type Ident + deriving (Show, Eq) + +data Attribute a = Attribute a (Maybe Inherit) (Maybe ReadOnly) Type Ident deriving (Show, Eq) + +data Operation a = Operation a (Maybe Qualifier) ReturnType (Maybe Ident) [Argument] deriving (Show, Eq) + +data Argument = ArgOptional Type ArgumentName Default + | ArgNonOpt Type (Maybe Ellipsis) ArgumentName + deriving (Show, Eq) + +newtype EnumValue = EnumValue String deriving (Show, Eq) + +data ArgumentName = ArgKey ArgumentNameKeyword + | ArgIdent Ident + deriving (Show, Eq) + +-- Values +data Const a = Const a ConstType Ident ConstValue deriving (Show, Eq) + +data Default = DefaultValue ConstValue + | DefaultString String + deriving (Show, Eq) + +data ConstValue = ConstBooleanLiteral Bool + | ConstFloatLiteral Double + | ConstInteger Integer + | ConstNull + deriving (Show, Eq) + + +-- Qualifers +data Qualifier = QuaStatic + | QSpecials [Special] + deriving (Show, Eq) + +data Special = Getter + | Setter + | Ccreator + | Deleter + | Legacycaller + deriving (Show, Eq) + +data ArgumentNameKeyword = ArgAttribute | ArgCallback | ArgConst | ArgCreator + | ArgDeleter | ArgDictionary | ArgEnum | ArgException + | ArgGetter | ArgImplements | ArgInherit | ArgInterface + | ArgLegacycaller | ArgPartial | ArgSetter | ArgStatic + | ArgStringifier | ArgTypedef | ArgUnrestricted + deriving (Show, Eq) + +-- Types +data Type = TySingleType SingleType | TyUnionType UnionType TypeSuffix deriving (Show, Eq) + +data SingleType = STyNonAny NonAnyType + | STyAny TypeSuffix + deriving (Show, Eq) + +data NonAnyType = TyPrim PrimitiveType TypeSuffix + | TyDOMString TypeSuffix + | TyIdent Ident TypeSuffix + | TySequence Type (Maybe Null) + | TyObject TypeSuffix + | TyDate TypeSuffix + deriving (Show, Eq) + + +data PrimitiveType = PrimIntegerType IntegerType + | PrimFloatType FloatType + | Boolean + | Byte + | Octet + deriving (Show, Eq) + +data IntegerType = IntegerType (Maybe Unsigned) IntegerWidth deriving (Show, Eq) + +data IntegerWidth = Short | Long Int deriving (Show, Eq) + +data TypeSuffix = TypeSuffixArray + | TypeSuffixNullable + | TypeSuffixNone + deriving (Show, Eq) + +data FloatType = TyFloat (Maybe Unrestricted) + | TyDouble (Maybe Unrestricted) + deriving (Show, Eq) + +type UnionType = [UnionMemberType] + +data UnionMemberType = UnionTy UnionType TypeSuffix + | UnionTyNonAny NonAnyType + | UnionTyAny TypeSuffix + deriving (Show, Eq) + +data ReturnType = RetType Type + | RetVoid + deriving (Show, Eq) + + +data ConstType = ConstPrim PrimitiveType (Maybe Null) + | ConstIdent Ident (Maybe Null) + deriving (Show, Eq) + +-- Markers + +data Ellipsis = Ellipsis deriving (Show, Eq) +data ReadOnly = ReadOnly deriving (Show, Eq) +data Inherit = Inherit deriving (Show, Eq) +data Unrestricted = Unrestricted deriving (Show, Eq) +data Null = Null deriving (Show, Eq) +data Unsigned = Unsigned deriving (Show, Eq) + +-- Ident +newtype Ident = Ident String deriving (Show, Eq) diff --git a/src/Language/WebIDL/PPrint.hs b/src/Language/WebIDL/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/WebIDL/PPrint.hs @@ -0,0 +1,207 @@ +module Language.WebIDL.PPrint where + +import Language.WebIDL.AST +import Prelude hiding (Enum) +import Text.PrettyPrint.Leijen + +printDef :: Definition a -> String +printDef = show . pretty + +instance Pretty (Definition a) where + pretty (DefInterface x) = pretty x + pretty (DefPartial x) = pretty x + pretty (DefDictionary x) = pretty x + pretty (DefException x) = pretty x + pretty (DefEnum x) = pretty x + pretty (DefTypedef x) = pretty x + pretty (DefImplementsStatement x) = pretty x + +instance Pretty (Interface a) where + pretty (Interface _ x mInherit members) = + text "interface" <+> pretty x <+> prettyInherit mInherit <+> scope members <> semi + +prettyMaybe Nothing _ = empty +prettyMaybe (Just x) f = f x + +prettyInherit x = prettyMaybe x (\e -> colon <+> pretty e) + +instance Pretty (Exception a) where + pretty (Exception _ x mInherit members) = + text "exception" <+> pretty x <+> prettyInherit mInherit <+> scope members <> semi + +instance Pretty (Partial a) where + pretty (PartialInterface _ x members) = + text "interface" <+> pretty x <+> scope members <> semi + pretty (PartialDictionary _ x members) = + text "dictionary" <+> pretty x <+> braces (vsep $ map pretty members) <> semi + +instance Pretty (Enum a) where + pretty (Enum _ x enums) = text "enum" <+> pretty x <+> scope enums <> semi + +instance Pretty (Dictionary a) where + pretty (Dictionary _ x mInherit members) = + text "dictionary" <+> pretty x <+> prettyInherit mInherit + <+> scope members <> semi + +scope members = braces (line <> vsep (map (indent 4 . pretty) members) <> line) + +instance Pretty (Typedef a) where + pretty (Typedef _ ty ident) = text "typedef" <+> pretty ty <+> pretty ident <> semi + +instance Pretty (ImplementsStatement a) where + pretty (ImplementsStatement _ i1 i2) = pretty i1 <+> text "implements" <+> pretty i2 <> semi + +instance Pretty Ident where + pretty (Ident x) = text x + +instance Pretty Type where + pretty (TySingleType s) = pretty s + pretty (TyUnionType ut suffix) = pretty ut <> pretty suffix + +instance Pretty SingleType where + pretty (STyNonAny t) = pretty t + pretty (STyAny suffix) = text "any" <> pretty suffix + +instance Pretty NonAnyType where + pretty (TyPrim t suffix) = pretty t <> pretty suffix + pretty (TyDOMString suffix) = text "DOMString" <> pretty suffix + pretty (TyIdent ident suffix) = pretty ident <> pretty suffix + pretty (TySequence t mNull) = text "sequence" <> angles (pretty t) <> prettyMaybe mNull pretty + pretty (TyObject suffix) = text "object" <> pretty suffix + pretty (TyDate suffix) = text "Date" <> pretty suffix + + +instance Pretty (DictionaryMember a) where + pretty (DictionaryMember _ t ident mDefault) = + pretty t <+> pretty ident <> prettyMaybe mDefault prettyDefault <> semi + +instance Pretty Default where + pretty (DefaultValue cval) = pretty cval + pretty (DefaultString s) = text (show s) + +instance Pretty ConstValue where + pretty (ConstBooleanLiteral b) = if b then text "true" else text "false" + pretty (ConstFloatLiteral d) = pretty d + pretty (ConstInteger i) = pretty i + pretty ConstNull = text "null" + +instance Pretty Null where + pretty Null = text "?" + +instance Pretty TypeSuffix where + pretty TypeSuffixArray = text "[]" + pretty TypeSuffixNullable = text "?" + pretty TypeSuffixNone = empty + +instance Pretty PrimitiveType where + pretty (PrimIntegerType t) = pretty t + pretty (PrimFloatType t) = pretty t + pretty Boolean = text "boolean" + pretty Byte = text "byte" + pretty Octet = text "octet" + +instance Pretty FloatType where + pretty (TyFloat mUnres) = prettyMaybe mUnres (\e -> pretty e <> space) <> text "float" + pretty (TyDouble mUnres) = prettyMaybe mUnres (\e -> pretty e <> space) <> text "double" + +instance Pretty Unrestricted where + pretty Unrestricted = text "unrestricted" + +instance Pretty IntegerType where + pretty (IntegerType mUns width) = prettyMaybe mUns pretty <> pretty width + +instance Pretty IntegerWidth where + pretty Short = text "short" + pretty (Long i) = hsep $ take i (repeat (text "long")) + +instance Pretty Unsigned where + pretty Unsigned = text "unsigned" + +instance Pretty UnionMemberType where + pretty (UnionTy ut suffix) = pretty ut <> pretty suffix + pretty (UnionTyNonAny t) = pretty t + pretty (UnionTyAny suffix) = text "any" <> pretty suffix + +instance Pretty EnumValue where + pretty (EnumValue s) = text s + +instance Pretty (InterfaceMember a) where + pretty (IMemConst c) = pretty c + pretty (IMemAttribute attr) = pretty attr + pretty (IMemOperation op) = pretty op + +instance Pretty (Operation a) where + pretty (Operation _ mQ retty mIdent args) = + pretty mQ <> pretty retty <+> prettyMaybe mIdent (\e -> pretty e) + <> parens (hcat (punctuate (comma <> space) (map pretty args))) <> semi + + +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 + +prettyDefault def = space <> equals <+> pretty def + +instance Pretty ArgumentName where + pretty (ArgKey key) = pretty key + pretty (ArgIdent i) = pretty i + +instance Pretty ArgumentNameKeyword where + pretty ArgAttribute = text "attribute" + pretty ArgCallback = text "callback" + pretty ArgConst = text "const" + pretty ArgCreator = text "creator" + pretty ArgDeleter = text "deleter" + pretty ArgDictionary = text "dictionary" + pretty ArgEnum = text "enum" + pretty ArgException = text "exception" + pretty ArgGetter = text "getter" + pretty ArgImplements = text "implements" + pretty ArgInherit = text "inherit" + pretty ArgInterface = text "interface" + pretty ArgLegacycaller = text "legacycaller" + pretty ArgPartial = text "partial" + pretty ArgSetter = text "setter" + pretty ArgStatic = text "static" + pretty ArgStringifier = text "stringifier" + pretty ArgTypedef = text "typedef" + pretty ArgUnrestricted = text "unrestricted" + + +instance Pretty ReturnType where + pretty (RetType t) = pretty t + pretty RetVoid = text "void" + +instance Pretty Qualifier where + pretty QuaStatic = text "static" + pretty (QSpecials specials) = hsep $ map pretty specials + +instance Pretty Special where + pretty Getter = text "getter" + pretty Setter = text "setter" + pretty Ccreator = text "ccreator" + pretty Deleter = text "deleter" + pretty Legacycaller = text "legacycaller" + + +instance Pretty (Attribute a) where + pretty (Attribute _ mInherit mReadOnly t i) = + prettyInherit mInherit <> prettyMaybe mReadOnly pretty + <> text "attribute" <+> pretty t <+> pretty i <> semi + +instance Pretty ReadOnly where + pretty ReadOnly = text "readonly" <> space + +instance Pretty Inherit where + pretty Inherit = text "inherit" <> space + +instance Pretty (Const a) where + pretty (Const _ t i v) = text "const" <+> pretty t <+> pretty i <+> equals <+> pretty v <> semi + +instance Pretty ConstType where + pretty (ConstPrim ty mNull) = pretty ty <> prettyMaybe mNull pretty + pretty (ConstIdent i mNull) = pretty i <> prettyMaybe mNull pretty + +instance Pretty (ExceptionMember a) where + pretty (ExConst _ c) = pretty c + pretty (ExField _ t i) = pretty t <+> pretty i <> semi diff --git a/src/Language/WebIDL/Parser.hs b/src/Language/WebIDL/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/WebIDL/Parser.hs @@ -0,0 +1,287 @@ +module Language.WebIDL.Parser where + +import Language.WebIDL.AST +import Prelude hiding (Enum) +import Text.ParserCombinators.Parsec +import Text.Parsec.Language (emptyDef) +import Text.Parsec (modifyState, SourcePos, getPosition, getState, putState, sourceLine) +import Control.Monad (void) +import qualified Text.Parsec.Token as Tok + +data ParserState = ParserState { + _comments :: [String] +} + +data Tagging = Tagging { + _comment :: [String], + _sourcePos :: SourcePos +} + +instance Eq Tagging where + (==) _ _ = True + +instance Show Tagging where + show (Tagging comments pos) = + let line = if length comments > 0 then take 5 (head comments) ++ "..., " else "" + in "(" ++ line ++ show (sourceLine pos) ++ ")" + +initState :: ParserState +initState = ParserState [] + +type MyParser = CharParser ParserState + +testParse :: MyParser a -> String -> Either ParseError a +testParse p = runParser p initState "webidl" + +parseIDL :: String -> Either ParseError [Definition Tagging] +parseIDL = testParse (pSpaces *> many1 (pDef <* pSpaces)) + +pDef :: MyParser (Definition Tagging) +pDef = DefInterface <$> (pExtAttrs *> pInterface) + <|> DefPartial <$> pPartial + <|> DefDictionary <$> pDictionary + <|> DefException <$> pException + <|> DefEnum <$> pEnum + <|> DefTypedef <$> pTypedef + <|> DefImplementsStatement <$> pImplementsStatement + +-- FIXME: currently we ignore extended attributes +pExtAttrs :: MyParser () +pExtAttrs = pSpaces *> void (char '[' *> (manyTill anyChar (try (char ']')))) <* pSpaces + <|> pSpaces + +pPartial :: MyParser (Partial Tagging) +pPartial = string "partial" *> pSpaces *> p + where + p = PartialInterface <$> getTag <*> (string "interface" *> pSpaces *> pIdent) + <*> braces (many pInterfaceMember) <* semi + <|> PartialDictionary <$> getTag <*> (string "dictionary" *> pSpaces *> pIdent) + <*> braces (many pDictionaryMember) <* semi + +pDictionary :: MyParser (Dictionary Tagging) +pDictionary = Dictionary <$> getTag <*> (string "dictionary" *> pSpaces *> pIdent) + <*> pInheritance <*> braces (many pDictionaryMember) <* semi + +pInterface :: MyParser (Interface Tagging) +pInterface = Interface <$> getTag <*> (string "interface" *> pSpaces *> pIdent) + <*> pInheritance <*> braces (pSpaces *> many (pInterfaceMember <* pSpaces)) <* semi + +pException :: MyParser (Exception Tagging) +pException = Exception <$> getTag <*> (string "exception" *> pSpaces *> pIdent) + <*> pInheritance <*> braces (many pExceptionMember) + +pInheritance :: MyParser (Maybe Ident) +pInheritance = optionMaybe (spaces *> char ':' *> spaces *> pIdent) + +pEnum :: MyParser (Enum Tagging) +pEnum = Enum <$> getTag <*> (string "enum" *> pSpaces *> pIdent) <*> braces pEnumValues <* semi + +pEnumValues :: MyParser [EnumValue] +pEnumValues = sepBy1 (EnumValue <$> stringLit) (char ',') + + +pTypedef :: MyParser (Typedef Tagging) +pTypedef = do + tag <- getTag + string "typedef" + pSpaces + ty <- try pType + pSpaces + ident <- pIdent + semi + return (Typedef tag ty ident) + +pImplementsStatement :: MyParser (ImplementsStatement Tagging) +pImplementsStatement = ImplementsStatement <$> getTag <*> pIdent <* pSpaces + <*> (string "implements" *> pSpaces *> pIdent <* semi) + +pDictionaryMember :: MyParser (DictionaryMember Tagging) +pDictionaryMember = DictionaryMember <$> getTag <*> pType <* pSpaces + <*> pIdent <*> optionMaybe (spaces *> pEq *> spaces *> pDefault) <* semi + +pExceptionMember :: MyParser (ExceptionMember Tagging) +pExceptionMember = ExConst <$> getTag <*> pConst + <|> ExField <$> getTag <*> pType <*> pIdent <* semi + +pMaybeIdent :: MyParser (Maybe Ident) +pMaybeIdent = optionMaybe pIdent + +pInterfaceMember :: MyParser (InterfaceMember Tagging) +pInterfaceMember = try (IMemConst <$> pConst) + <|> try (IMemAttribute <$> pAttribute) + <|> IMemOperation <$> (pExtAttrs *> pOperation) + +pConst :: MyParser (Const Tagging) +pConst = Const <$> getTag <*> (string "const" *> pSpaces *> pConstType <* pSpaces) + <*> (pIdent <* pEq) <*> (pSpaces *> pConstValue <* semi) + +pConstType :: MyParser ConstType +pConstType = ConstPrim <$> pPrimTy <*> pNull + <|> ConstIdent <$> pIdent <*> pNull + +pAttribute :: MyParser (Attribute Tagging) +pAttribute = Attribute <$> getTag <*> pModifier Inherit "inherit" + <*> pModifier ReadOnly "readonly" + <*> (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 Tagging) +pOperation = Operation <$> getTag <*> pQualifier <* spaces + <*> pReturnType <* pSpaces + <*> pMaybeIdent <* pSpaces + <*> parens (pSpaces *> sepBy (pArg <* pSpaces) (char ',' <* pSpaces)) <* semi + +pArg :: MyParser Argument +pArg = ArgOptional <$> (string "optional" *> pType <* pSpaces) <*> pArgumentName <*> pDefault + <|> ArgNonOpt <$> (pType <* pSpaces) <*> (pModifier Ellipsis "...") <*> (pSpaces *> pArgumentName) + +pArgumentName :: MyParser ArgumentName +pArgumentName = try (ArgKey <$> pArgumentNameKeyword) + <|> ArgIdent <$> pIdent + +pArgumentNameKeyword :: MyParser ArgumentNameKeyword +pArgumentNameKeyword = string "attribute" *> return ArgAttribute + <|> string "callback" *> return ArgCallback + <|> string "const" *> return ArgConst + <|> string "creator" *> return ArgCreator + <|> string "deleter" *> return ArgDeleter + <|> string "dictionary" *> return ArgDictionary + <|> string "enum" *> return ArgEnum + <|> string "exception" *> return ArgException + <|> string "getter" *> return ArgGetter + <|> string "implements" *> return ArgImplements + <|> string "inherit" *> return ArgInherit + <|> string "interface" *> return ArgInterface + <|> string "legacycaller" *> return ArgLegacycaller + <|> string "partial" *> return ArgPartial + <|> string "setter" *> return ArgSetter + <|> string "static" *> return ArgStatic + <|> string "stringifier" *> return ArgStringifier + <|> string "typedef" *> return ArgTypedef + <|> string "unrestricted" *> return ArgUnrestricted + +pDefault :: MyParser Default +pDefault = DefaultValue <$> pConstValue + <|> DefaultString <$> stringLit + + +pQualifier :: MyParser (Maybe Qualifier) +pQualifier = try (string "static" *> return (Just QuaStatic)) + <|> try (Just . QSpecials <$> many pSpecial) + <|> return Nothing + +pSpecial :: MyParser Special +pSpecial = string "getter" *> return Getter + <|> string "setter" *> return Setter + <|> string "ccreator" *> return Ccreator + <|> string "deleter" *> return Deleter + <|> string "legacycaller" *> return Legacycaller + +pReturnType :: MyParser ReturnType +pReturnType = string "void" *> return RetVoid + <|> RetType <$> pType + +pConstValue :: MyParser ConstValue +pConstValue = ConstBooleanLiteral <$> pBool + <|> try (ConstFloatLiteral <$> pFloat) + <|> ConstInteger <$> pInt + <|> string "null" *> return ConstNull + +pBool :: MyParser Bool +pBool = string "true" *> return True + <|> string "false" *> return False + + +pNull :: MyParser (Maybe Null) +pNull = optionMaybe (char '?' *> return Null) + +pPrimTy :: MyParser PrimitiveType +pPrimTy = try (string "boolean" *> return Boolean) + <|> try (string "byte" *> return Byte) + <|> try (string "octet" *> return Octet) + <|> try (PrimIntegerType <$> pIntegerType) + <|> PrimFloatType <$> pFloatType + +pIntegerType :: MyParser IntegerType +pIntegerType = IntegerType <$> pUnsigned <* pSpaces <*> pIntegerWidth + +pUnsigned :: MyParser (Maybe Unsigned) +pUnsigned = optionMaybe (string "unsigned" *> return Unsigned) + +pIntegerWidth = string "short" *> return Short + <|> Long . length <$> many1 (string "long" <* pSpaces) + +pFloatType :: MyParser FloatType +pFloatType = try (TyFloat <$> pModifier Unrestricted "unrestricted" <* spaces <* string "float") + <|> TyDouble <$> pModifier Unrestricted "unrestricted" <* spaces <* string "double" + +pType :: MyParser Type +pType = TySingleType <$> pSingleType + <|> TyUnionType <$> pUnionType <*> pTypeSuffix + +pSingleType :: MyParser SingleType +pSingleType = STyAny <$> (string "any" *> pTypeSuffix) + <|> STyNonAny <$> pNonAnyType + +pNonAnyType :: MyParser NonAnyType +pNonAnyType = try (TyPrim <$> pPrimTy <*> pTypeSuffix) + <|> TySequence <$> (string "sequence" *> pSpaces *> angles pType) <*> pNull + <|> TyObject <$> (string "object" *> pTypeSuffix) + <|> try (TyDOMString <$> (string "DOMString" *> pTypeSuffix)) + <|> TyDate <$> (string "Date" *> pTypeSuffix) + <|> TyIdent <$> pIdent <*> pTypeSuffix + +pTypeSuffix :: MyParser TypeSuffix +pTypeSuffix = try (string "[]" *> return TypeSuffixArray) + <|> try (char '?' *> return TypeSuffixNullable) + <|> return TypeSuffixNone + +-- FIXME: Not working correctly currently +pUnionType :: MyParser UnionType +pUnionType = parens (sepBy1 pUnionMemberType (string "or")) + +pUnionMemberType :: MyParser UnionMemberType +pUnionMemberType = UnionTy <$> pUnionType <*> pTypeSuffix + <|> UnionTyNonAny <$> pNonAnyType + <|> UnionTyAny <$> (string "any []" *> pTypeSuffix) + +lexer = Tok.makeTokenParser emptyDef + +parens = Tok.parens lexer +braces = Tok.braces lexer +angles = Tok.angles lexer +reserved = Tok.reserved lexer +reservedOp = Tok.reservedOp lexer +whiteSpace = Tok.whiteSpace lexer +pIdent = Ident <$> Tok.identifier lexer +pInt = Tok.integer lexer +pFloat = Tok.float lexer +semi = Tok.semi lexer +stringLit = Tok.stringLiteral lexer +pEq = char '=' + +pSpaces = try (skipMany (spaces *> pComment <* spaces) <* spaces) + <|> spaces + +pComment = try pLineComment <|> pBlockComment + +pLineComment = do + string "//" + comment <- manyTill anyChar (try newline) + modifyState (\ps -> ParserState { _comments = _comments ps ++ [comment]}) + +pBlockComment = do + string "/*" + comment <- manyTill anyChar (try (string "*/")) + modifyState (\ps -> ParserState { _comments = _comments ps ++ lines comment}) + + +getTag :: MyParser Tagging +getTag = do + pos <- getPosition + ParserState comments <- getState + putState $ ParserState [] + return $ Tagging comments pos + diff --git a/src/PPrint.hs b/src/PPrint.hs deleted file mode 100644 --- a/src/PPrint.hs +++ /dev/null @@ -1,200 +0,0 @@ -module PPrint where - -import AST -import Prelude hiding (Enum) -import Text.PrettyPrint.Leijen - -instance Pretty (Definition a) where - pretty (DefInterface x) = pretty x - pretty (DefPartial x) = pretty x - pretty (DefDictionary x) = pretty x - pretty (DefException x) = pretty x - pretty (DefEnum x) = pretty x - pretty (DefTypedef x) = pretty x - pretty (DefImplementsStatement x) = pretty x - -instance Pretty (Interface a) where - pretty (Interface _ x mInherit members) = - text "interface" <+> pretty x <+> prettyInherit mInherit <+> braces (prettyList members) <> semi - -prettyMaybe Nothing _ = empty -prettyMaybe (Just x) f = f x - -prettyInherit x = prettyMaybe x (\e -> colon <+> pretty e) - -instance Pretty (Exception a) where - pretty (Exception _ x mInherit members) = - text "exception" <+> pretty x <+> prettyInherit mInherit <+> braces (prettyList members) <> semi - -instance Pretty (Partial a) where - pretty (PartialInterface _ x members) = - text "interface" <+> pretty x <+> braces (prettyList members) <> semi - pretty (PartialDictionary _ x members) = - text "dictionary" <+> pretty x <+> braces (prettyList members) <> semi - -instance Pretty (Enum a) where - pretty (Enum _ x enums) = text "enum" <+> pretty x <+> braces (prettyList enums) <> semi - -instance Pretty (Dictionary a) where - pretty (Dictionary _ x mInherit members) = - text "dictionary" <+> pretty x <+> prettyInherit mInherit <+> braces (prettyList members) <> semi - -instance Pretty (Typedef a) where - pretty (Typedef _ ty ident) = text "typedef" <+> pretty ty <+> pretty ident <> semi - -instance Pretty (ImplementsStatement a) where - pretty (ImplementsStatement _ i1 i2) = pretty i1 <+> text "implements" <+> pretty i2 <> semi - -instance Pretty Ident where - pretty (Ident x) = text x - -instance Pretty Type where - pretty (TySingleType s) = pretty s - pretty (TyUnionType ut suffix) = pretty ut <> pretty suffix - -instance Pretty SingleType where - pretty (STyNonAny t) = pretty t - pretty (STyAny suffix) = text "any" <> pretty suffix - -instance Pretty NonAnyType where - pretty (TyPrim t suffix) = pretty t <> pretty suffix - pretty (TyDOMString suffix) = text "DOMString" <> pretty suffix - pretty (TyIdent ident suffix) = pretty ident <> pretty suffix - pretty (TySequence t mNull) = pretty t <> prettyMaybe mNull pretty - pretty (TyObject suffix) = text "object" <> pretty suffix - pretty (TyDate suffix) = text "Date" <> pretty suffix - - -instance Pretty (DictionaryMember a) where - pretty (DictionaryMember _ t ident mDefault) = - pretty t <+> pretty ident <> prettyMaybe mDefault prettyDefault <> semi - -instance Pretty Default where - pretty (DefaultValue cval) = pretty cval - pretty (DefaultString s) = text (show s) - -instance Pretty ConstValue where - pretty (ConstBooleanLiteral b) = if b then text "true" else text "false" - pretty (ConstFloatLiteral d) = pretty d - pretty (ConstInteger i) = pretty i - pretty ConstNull = text "null" - -instance Pretty Null where - pretty Null = text "null" - -instance Pretty TypeSuffix where - pretty TypeSuffixArray = text "[]" - pretty TypeSuffixNullable = text "?" - pretty TypeSuffixNone = empty - -instance Pretty PrimitiveType where - pretty (PrimIntegerType t) = pretty t - pretty (PrimFloatType t) = pretty t - pretty Boolean = text "boolean" - pretty Byte = text "byte" - pretty Octet = text "octet" - -instance Pretty FloatType where - pretty (TyFloat mUnres) = text "float" <> prettyMaybe mUnres (\e -> space <> pretty e) - pretty (TyDouble mUnres) = text "double" <> prettyMaybe mUnres (\e -> space <> pretty e) - -instance Pretty Unrestricted where - pretty Unrestricted = text "unrestricted" - -instance Pretty IntegerType where - pretty (IntegerType mUns width) = prettyMaybe mUns (\e -> pretty e <> space) <> pretty width - -instance Pretty IntegerWidth where - pretty Short = text "short" - pretty (Long i) = foldr (<+>) empty $ take i (repeat (text "long")) - -instance Pretty Unsigned where - pretty Unsigned = text "unsigned" - -instance Pretty UnionMemberType where - pretty (UnionTy ut suffix) = pretty ut <> pretty suffix - pretty (UnionTyNonAny t) = pretty t - pretty (UnionTyAny suffix) = text "any" <> pretty suffix - -instance Pretty EnumValue where - pretty (EnumValue s) = text s - -instance Pretty (InterfaceMember a) where - pretty (IMemConst c) = pretty c - pretty (IMemAttribute attr) = pretty attr - pretty (IMemOperation op) = pretty op - -instance Pretty (Operation a) where - pretty (Operation _ mQ retty mIdent args) = - pretty mQ <> pretty retty <+> prettyMaybe mIdent (\e -> pretty e <> space) - <+> encloseSep lparen rparen (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 - -prettyDefault def = space <> equals <+> pretty def - -instance Pretty ArgumentName where - pretty (ArgKey key) = pretty key - pretty (ArgIdent i) = pretty i - -instance Pretty ArgumentNameKeyword where - pretty ArgAttribute = text "attribute" - pretty ArgCallback = text "callback" - pretty ArgConst = text "const" - pretty ArgCreator = text "creator" - pretty ArgDeleter = text "deleter" - pretty ArgDictionary = text "dictionary" - pretty ArgEnum = text "enum" - pretty ArgException = text "exception" - pretty ArgGetter = text "getter" - pretty ArgImplements = text "implements" - pretty ArgInherit = text "inherit" - pretty ArgInterface = text "interface" - pretty ArgLegacycaller = text "legacycaller" - pretty ArgPartial = text "partial" - pretty ArgSetter = text "setter" - pretty ArgStatic = text "static" - pretty ArgStringifier = text "stringifier" - pretty ArgTypedef = text "typedef" - pretty ArgUnrestricted = text "unrestricted" - - -instance Pretty ReturnType where - pretty (RetType t) = pretty t - pretty RetVoid = text "void" - -instance Pretty Qualifier where - pretty QuaStatic = text "static" - pretty (QSpecials specials) = prettyList specials - -instance Pretty Special where - pretty Getter = text "getter" - pretty Setter = text "setter" - pretty Ccreator = text "ccreator" - pretty Deleter = text "deleter" - pretty Legacycaller = text "legacycaller" - - -instance Pretty (Attribute a) where - pretty (Attribute _ mInherit mReadOnly t i) = - prettyInherit mInherit <+> prettyMaybe mReadOnly pretty <+> pretty t <+> pretty i - -instance Pretty ReadOnly where - pretty ReadOnly = text "readonly" - -instance Pretty Inherit where - pretty Inherit = text "inherit" - -instance Pretty (Const a) where - pretty (Const _ t i v) = pretty t <+> pretty i <+> equals <+> pretty v <> semi - -instance Pretty ConstType where - pretty (ConstPrim ty mNull) = pretty ty <> prettyMaybe mNull pretty - pretty (ConstIdent i mNull) = pretty i <> prettyMaybe mNull pretty - -instance Pretty (ExceptionMember a) where - pretty (ExConst _ c) = pretty c - pretty (ExField _ t i) = pretty t <+> pretty i <> semi diff --git a/src/Parser.hs b/src/Parser.hs deleted file mode 100644 --- a/src/Parser.hs +++ /dev/null @@ -1,284 +0,0 @@ -module Parser where - -import AST -import Prelude hiding (Enum) -import Text.ParserCombinators.Parsec -import Text.Parsec.Language (emptyDef) -import Text.Parsec (modifyState, SourcePos, getPosition, getState, putState, sourceLine) -import Control.Monad (void) -import qualified Text.Parsec.Token as Tok - -data ParserState = ParserState { - _comments :: [String] -} - -data Tagging = Tagging { - _comment :: [String], - _sourcePos :: SourcePos -} - -instance Show Tagging where - show (Tagging comments pos) = - let line = if length comments > 0 then take 5 (head comments) ++ "..., " else "" - in "(" ++ line ++ show (sourceLine pos) ++ ")" - -initState :: ParserState -initState = ParserState [] - -type MyParser = CharParser ParserState - -testParse :: MyParser a -> String -> Either ParseError a -testParse p = runParser p initState "webidl" - -parseIDL :: String -> Either ParseError [Definition Tagging] -parseIDL = testParse (pSpaces *> many1 (pDef <* pSpaces)) - -pDef :: MyParser (Definition Tagging) -pDef = DefInterface <$> (pExtAttrs *> pInterface) - <|> DefPartial <$> pPartial - <|> DefDictionary <$> pDictionary - <|> DefException <$> pException - <|> DefEnum <$> pEnum - <|> DefTypedef <$> pTypedef - <|> DefImplementsStatement <$> pImplementsStatement - --- FIXME: currently we ignore extended attributes -pExtAttrs :: MyParser () -pExtAttrs = pSpaces *> void (char '[' *> (manyTill anyChar (try (char ']')))) <* pSpaces - <|> pSpaces - -pPartial :: MyParser (Partial Tagging) -pPartial = string "partial" *> pSpaces *> p - where - p = PartialInterface <$> getTag <*> (string "interface" *> pSpaces *> pIdent) - <*> braces (many pInterfaceMember) <* semi - <|> PartialDictionary <$> getTag <*> (string "dictionary" *> pSpaces *> pIdent) - <*> braces (many pDictionaryMember) <* semi - -pDictionary :: MyParser (Dictionary Tagging) -pDictionary = Dictionary <$> getTag <*> (string "dictionary" *> pSpaces *> pIdent) - <*> pInheritance <*> braces (many pDictionaryMember) <* semi - -pInterface :: MyParser (Interface Tagging) -pInterface = Interface <$> getTag <*> (string "interface" *> pSpaces *> pIdent) - <*> pInheritance <*> braces (pSpaces *> many (pInterfaceMember <* pSpaces)) <* semi - -pException :: MyParser (Exception Tagging) -pException = Exception <$> getTag <*> (string "exception" *> pSpaces *> pIdent) - <*> pInheritance <*> braces (many pExceptionMember) - -pInheritance :: MyParser (Maybe Ident) -pInheritance = optionMaybe (spaces *> char ':' *> spaces *> pIdent) - -pEnum :: MyParser (Enum Tagging) -pEnum = Enum <$> getTag <*> (string "enum" *> pSpaces *> pIdent) <*> braces pEnumValues <* semi - -pEnumValues :: MyParser [EnumValue] -pEnumValues = sepBy1 (EnumValue <$> stringLit) (char ',') - - -pTypedef :: MyParser (Typedef Tagging) -pTypedef = do - tag <- getTag - string "typedef" - pSpaces - ty <- try pType - pSpaces - ident <- pIdent - semi - return (Typedef tag ty ident) - -pImplementsStatement :: MyParser (ImplementsStatement Tagging) -pImplementsStatement = ImplementsStatement <$> getTag <*> pIdent <* pSpaces - <*> (string "implements" *> pSpaces *> pIdent <* semi) - -pDictionaryMember :: MyParser (DictionaryMember Tagging) -pDictionaryMember = DictionaryMember <$> getTag <*> pType <* pSpaces - <*> pIdent <*> optionMaybe (spaces *> pEq *> spaces *> pDefault) <* semi - -pExceptionMember :: MyParser (ExceptionMember Tagging) -pExceptionMember = ExConst <$> getTag <*> pConst - <|> ExField <$> getTag <*> pType <*> pIdent <* semi - -pMaybeIdent :: MyParser (Maybe Ident) -pMaybeIdent = optionMaybe pIdent - -pInterfaceMember :: MyParser (InterfaceMember Tagging) -pInterfaceMember = try (IMemConst <$> pConst) - <|> try (IMemAttribute <$> pAttribute) - <|> IMemOperation <$> (pExtAttrs *> pOperation) - -pConst :: MyParser (Const Tagging) -pConst = Const <$> getTag <*> (string "const" *> pSpaces *> pConstType <* pSpaces) - <*> (pIdent <* pEq) <*> (pSpaces *> pConstValue <* semi) - -pConstType :: MyParser ConstType -pConstType = ConstPrim <$> pPrimTy <*> pNull - <|> ConstIdent <$> pIdent <*> pNull - -pAttribute :: MyParser (Attribute Tagging) -pAttribute = Attribute <$> getTag <*> pModifier Inherit "inherit" - <*> pModifier ReadOnly "readonly" - <*> (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 Tagging) -pOperation = Operation <$> getTag <*> pQualifier <* spaces - <*> pReturnType <* pSpaces - <*> pMaybeIdent <* pSpaces - <*> parens (pSpaces *> sepBy (pArg <* pSpaces) (char ',' <* pSpaces)) <* semi - -pArg :: MyParser Argument -pArg = ArgOptional <$> (string "optional" *> pType <* pSpaces) <*> pArgumentName <*> pDefault - <|> ArgNonOpt <$> (pType <* pSpaces) <*> (pModifier Ellipsis "...") <*> (pSpaces *> pArgumentName) - -pArgumentName :: MyParser ArgumentName -pArgumentName = try (ArgKey <$> pArgumentNameKeyword) - <|> ArgIdent <$> pIdent - -pArgumentNameKeyword :: MyParser ArgumentNameKeyword -pArgumentNameKeyword = string "attribute" *> return ArgAttribute - <|> string "callback" *> return ArgCallback - <|> string "const" *> return ArgConst - <|> string "creator" *> return ArgCreator - <|> string "deleter" *> return ArgDeleter - <|> string "dictionary" *> return ArgDictionary - <|> string "enum" *> return ArgEnum - <|> string "exception" *> return ArgException - <|> string "getter" *> return ArgGetter - <|> string "implements" *> return ArgImplements - <|> string "inherit" *> return ArgInherit - <|> string "interface" *> return ArgInterface - <|> string "legacycaller" *> return ArgLegacycaller - <|> string "partial" *> return ArgPartial - <|> string "setter" *> return ArgSetter - <|> string "static" *> return ArgStatic - <|> string "stringifier" *> return ArgStringifier - <|> string "typedef" *> return ArgTypedef - <|> string "unrestricted" *> return ArgUnrestricted - -pDefault :: MyParser Default -pDefault = DefaultValue <$> pConstValue - <|> DefaultString <$> stringLit - - -pQualifier :: MyParser (Maybe Qualifier) -pQualifier = try (string "static" *> return (Just QuaStatic)) - <|> try (Just . QSpecials <$> many pSpecial) - <|> return Nothing - -pSpecial :: MyParser Special -pSpecial = string "getter" *> return Getter - <|> string "setter" *> return Setter - <|> string "ccreator" *> return Ccreator - <|> string "deleter" *> return Deleter - <|> string "legacycaller" *> return Legacycaller - -pReturnType :: MyParser ReturnType -pReturnType = string "void" *> return RetVoid - <|> RetType <$> pType - -pConstValue :: MyParser ConstValue -pConstValue = ConstBooleanLiteral <$> pBool - <|> try (ConstFloatLiteral <$> pFloat) - <|> ConstInteger <$> pInt - <|> string "null" *> return ConstNull - -pBool :: MyParser Bool -pBool = string "true" *> return True - <|> string "false" *> return False - - -pNull :: MyParser (Maybe Null) -pNull = optionMaybe (char '?' *> return Null) - -pPrimTy :: MyParser PrimitiveType -pPrimTy = try (string "boolean" *> return Boolean) - <|> try (string "byte" *> return Byte) - <|> try (string "octet" *> return Octet) - <|> try (PrimIntegerType <$> pIntegerType) - <|> PrimFloatType <$> pFloatType - -pIntegerType :: MyParser IntegerType -pIntegerType = IntegerType <$> pUnsigned <* pSpaces <*> pIntegerWidth - -pUnsigned :: MyParser (Maybe Unsigned) -pUnsigned = optionMaybe (string "unsigned" *> return Unsigned) - -pIntegerWidth = string "short" *> return Short - <|> Long . length <$> many1 (string "long" <* pSpaces) - -pFloatType :: MyParser FloatType -pFloatType = try (TyFloat <$> pModifier Unrestricted "unrestricted" <* spaces <* string "float") - <|> TyDouble <$> pModifier Unrestricted "unrestricted" <* spaces <* string "double" - -pType :: MyParser Type -pType = TySingleType <$> pSingleType - <|> TyUnionType <$> pUnionType <*> pTypeSuffix - -pSingleType :: MyParser SingleType -pSingleType = STyAny <$> (string "any" *> pTypeSuffix) - <|> STyNonAny <$> pNonAnyType - -pNonAnyType :: MyParser NonAnyType -pNonAnyType = try (TyPrim <$> pPrimTy <*> pTypeSuffix) - <|> TySequence <$> (string "sequence" *> pSpaces *> angles pType) <*> pNull - <|> TyObject <$> (string "object" *> pTypeSuffix) - <|> try (TyDOMString <$> (string "DOMString" *> pTypeSuffix)) - <|> TyDate <$> (string "Date" *> pTypeSuffix) - <|> TyIdent <$> pIdent <*> pTypeSuffix - -pTypeSuffix :: MyParser TypeSuffix -pTypeSuffix = try (string "[]" *> return TypeSuffixArray) - <|> try (char '?' *> return TypeSuffixNullable) - <|> return TypeSuffixNone - --- FIXME: Not working correctly currently -pUnionType :: MyParser UnionType -pUnionType = parens (sepBy1 pUnionMemberType (string "or")) - -pUnionMemberType :: MyParser UnionMemberType -pUnionMemberType = UnionTy <$> pUnionType <*> pTypeSuffix - <|> UnionTyNonAny <$> pNonAnyType - <|> UnionTyAny <$> (string "any []" *> pTypeSuffix) - -lexer = Tok.makeTokenParser emptyDef - -parens = Tok.parens lexer -braces = Tok.braces lexer -angles = Tok.angles lexer -reserved = Tok.reserved lexer -reservedOp = Tok.reservedOp lexer -whiteSpace = Tok.whiteSpace lexer -pIdent = Ident <$> Tok.identifier lexer -pInt = Tok.integer lexer -pFloat = Tok.float lexer -semi = Tok.semi lexer -stringLit = Tok.stringLiteral lexer -pEq = char '=' - -pSpaces = try (skipMany (spaces *> pComment <* spaces) <* spaces) - <|> spaces - -pComment = try pLineComment <|> pBlockComment - -pLineComment = do - string "//" - comment <- manyTill anyChar (try newline) - modifyState (\ps -> ParserState { _comments = _comments ps ++ [comment]}) - -pBlockComment = do - string "/*" - comment <- manyTill anyChar (try (string "*/")) - modifyState (\ps -> ParserState { _comments = _comments ps ++ lines comment}) - - -getTag :: MyParser Tagging -getTag = do - pos <- getPosition - ParserState comments <- getState - putState $ ParserState [] - return $ Tagging comments pos -