packages feed

xml-basic 0.0.1 → 0.1.3.3

raw patch · 12 files changed

Files

src/Text/HTML/Basic/Character.hs view
@@ -6,6 +6,7 @@    unicode, refC, refE,    asciiFromUnicode,    asciiFromUnicodeInternetExploder,+   minimalRefFromUnicode,    reduceRef,    validCharRef, switchUnicodeRuns,    isLower, isUpper, toLower, toUpper,
+ src/Text/HTML/Basic/String.hs view
@@ -0,0 +1,16 @@+module Text.HTML.Basic.String (Encoded, decode, ) where++import Text.XML.Basic.String (Encoded, )+import qualified Text.XML.Basic.String as XMLString+import qualified Text.HTML.Basic.Character as HTMLChar+import qualified Text.HTML.Basic.Entity as HTMLEnt++{- |+Invalid references are silently skipped.+-}+decode ::+   (Encoded -> String) ->+   [HTMLChar.T] ->+   String+decode =+   XMLString.decodeGen HTMLEnt.mapNameToChar
src/Text/HTML/Basic/Tag.hs view
@@ -6,33 +6,40 @@ -} module Text.HTML.Basic.Tag (    Tag.Name(..),-   Tag.doctype, Tag.doctypeString,-   Tag.cdata, Tag.cdataString,+   Tag.doctype, Tag.doctypeName, Tag.doctypeString,+   Tag.cdata,   Tag.cdataName,   Tag.cdataString,    isEmpty, isSloppy, isInnerOf, closes,+   maybeMetaHTTPHeader, maybeMetaEncoding, maybeMetaCharset,+   encodingFromContentType,    ) where   import Text.XML.Basic.Tag (Name, )  import qualified Text.XML.Basic.Tag as Tag+import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name as Name  import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Tuple.HT (mapFst, ) +import qualified Data.List.Reverse.StrictElement as ListRev+import qualified Data.Char as Char+import           Data.Tuple.HT (mapFst, )+import           Control.Monad (guard, liftM2, ) + {- | Check whether a HTML tag is empty. -}-isEmpty :: (Name.Tag name, Ord name) =>+isEmpty :: (Name.Tag name) =>    Name name -> Bool isEmpty = flip Set.member emptySet  {- | Set of empty HTML tags. -}-emptySet :: (Name.Tag name, Ord name) =>+emptySet :: (Name.Tag name) =>    Set.Set (Name name) emptySet =    nameSet $@@ -57,7 +64,7 @@ We close them implicitly, if another tag closes and ignore non-matching closing tags. -}-isSloppy ::  (Name.Tag name, Ord name) =>+isSloppy ::  (Name.Tag name) =>    Name name -> Bool isSloppy = flip Set.member sloppySet @@ -66,7 +73,7 @@ http://extremetracking.com/open;unique?login=crsucks -} -sloppySet :: (Name.Tag name, Ord name) =>+sloppySet :: (Name.Tag name) =>    Set.Set (Name name) sloppySet =    nameSet $@@ -82,14 +89,14 @@    []  -isInnerOf :: (Name.Tag name, Ord name) =>+isInnerOf :: (Name.Tag name) =>    Name name -> Name name -> Bool isInnerOf outer inner =    maybe False (Set.member inner) $    Map.lookup outer innerMap  -innerMap :: (Name.Tag name, Ord name) =>+innerMap :: (Name.Tag name) =>    Map.Map (Name name) (Set.Set (Name name)) innerMap =    nameMap $@@ -114,7 +121,7 @@    []  -closes :: (Name.Tag name, Ord name) =>+closes :: (Name.Tag name) =>    Name name -> Name name -> Bool closes closing opening =    (not (Name.match "option" closing) && Name.match "select" opening) ||@@ -123,7 +130,7 @@     Map.lookup closing closesMap)  -closesMap :: (Name.Tag name, Ord name) =>+closesMap :: (Name.Tag name) =>    Map.Map (Name name) (Set.Set (Name name)) closesMap =    nameMap $@@ -158,20 +165,64 @@    []  -nameMap :: (Name.Tag name, Ord name) => [(String,a)] -> Map.Map (Name name) a+nameMap :: (Name.Tag name) => [(String,a)] -> Map.Map (Name name) a nameMap = Map.fromList . map (mapFst Name.fromString) -nameSet :: (Name.Tag name, Ord name) => [String] -> Set.Set (Name name)+nameSet :: (Name.Tag name) => [String] -> Set.Set (Name name) nameSet = Set.fromList . map Name.fromString -nameSingle :: (Name.Tag name, Ord name) => String -> Set.Set (Name name)+nameSingle :: (Name.Tag name) => String -> Set.Set (Name name) nameSingle = Set.singleton . Name.fromString  pSet, dtdSet, thdSet, thdrSet, liSet, headingSet ::-   (Name.Tag name, Ord name) => Set.Set (Name name)+   (Name.Tag name) => Set.Set (Name name) pSet       = nameSet ["p"] dtdSet     = nameSet ["dt","dd"] thdSet     = nameSet ["th","td"] thdrSet    = nameSet ["th","td","tr"] liSet      = nameSet ["li"] headingSet = nameSet ["h1","h2","h3","h4","h5","h6","p" {- not "div" -}]+++++maybeMetaHTTPHeader ::+   (Name.Tag name, Name.Attribute name) =>+   Tag.Name name -> [Attr.T name string] -> Maybe (string, string)+maybeMetaHTTPHeader name attrs =+   do guard (Name.match "meta" name)+      liftM2 (,)+         (Attr.lookupLit "http-equiv" attrs)+         (Attr.lookupLit "content" attrs)+++{- |+Extract charset from Content-Type declaration.++> encodingFromContentType "text/html; charset=UTF-8" == "utf-8"++The routine does not perform any syntax check.+-}+encodingFromContentType :: String -> String+encodingFromContentType = map Char.toLower . ListRev.takeWhile ('='/=)++{- |+A simple routine that does not check for valid syntax+of the Content-Type specification.++In future we might use a distinct @Encoding@ type instead of plain String.+-}+maybeMetaEncoding ::+   (Name.Tag name, Name.Attribute name) =>+   Tag.Name name -> [Attr.T name String] -> Maybe String+maybeMetaEncoding name attrs =+   do (headerName, content) <- maybeMetaHTTPHeader name attrs+      guard (("content-type"==) . map Char.toLower $ headerName)+      return $ encodingFromContentType content++maybeMetaCharset ::+   (Name.Tag name, Name.Attribute name) =>+   Tag.Name name -> [Attr.T name string] -> Maybe string+maybeMetaCharset name attrs =+   do guard (Name.match "meta" name)+      Attr.lookupLit "charset" attrs
src/Text/XML/Basic/Attribute.hs view
@@ -77,8 +77,8 @@   -mapName :: (name0 -> name1) -> T name0 string -> T name1 string-mapName f (Cons (Name n) v) = Cons (Name $ f n) v+mapName :: (Name name0 -> Name name1) -> T name0 string -> T name1 string+mapName f (Cons n v) = Cons (f n) v   @@ -93,6 +93,20 @@    toString = Name.attributeToString . unname  +versionName :: (Name.Attribute name) => Name name+versionName = Name.fromString versionString++encodingName :: (Name.Attribute name) => Name name+encodingName = Name.fromString encodingString+++versionString :: String+versionString = "version"++encodingString :: String+encodingString = "encoding"++ -- * attribute lists  mapValues ::@@ -130,7 +144,7 @@   insert ::-   (Name.Attribute name, Eq name) =>+   (Name.Attribute name) =>    Name name ->    string ->    ([T name string] -> [T name string])@@ -143,7 +157,7 @@ The function name is analogous to Data.Map. -} insertWith ::-   (Name.Attribute name, Eq name) =>+   (Name.Attribute name) =>    (string -> string -> string) ->    Name name ->    string ->@@ -158,7 +172,7 @@ -- * match attributes  match ::-   (Name.Attribute name, Eq name, Eq string) =>+   (Name.Attribute name, Eq string) =>    String -> string -> T name string -> Bool match n v attr =    Name.match n (name_ attr) && v == value_ attr@@ -170,21 +184,21 @@ The values are handled case-sensitive. -} matchAnyValue ::-   (Name.Attribute name, Eq name, Eq string) =>+   (Name.Attribute name, Eq string) =>    String -> [string] -> T name string -> Bool matchAnyValue n vs attr =    Name.match n (name_ attr) && elem (value_ attr) vs   lookup ::-   (Name.Attribute name, Eq name) =>+   (Name.Attribute name) =>    Name name -> [T name string] -> Maybe string lookup n =    fmap value_ .    List.find ((n==) . name_)  lookupLit ::-   (Name.Attribute name, Eq name) =>+   (Name.Attribute name) =>    String -> [T name string] -> Maybe string lookupLit n =    fmap value_ .@@ -202,12 +216,12 @@   anyLit ::-   (Eq name, Name.Attribute name, Eq string) =>+   (Name.Attribute name, Eq string) =>    String -> string -> [T name string] -> Bool anyLit n v = any (match n v)  anyNameLit ::-   (Eq name, Name.Attribute name) =>+   (Name.Attribute name) =>    String -> [T name string] -> Bool anyNameLit n = anyName (Name.match n)
src/Text/XML/Basic/Character.hs view
@@ -17,7 +17,7 @@    maybeUnicode, maybeCharRef, maybeEntityRef,    isUnicode, isCharRef, isEntityRef, isRef,    unicode, refC, refE,-   asciiFromUnicode, asciiFromUnicodeGen,+   asciiFromUnicode, asciiFromUnicodeGen, minimalRefFromUnicode,    reduceRef, reduceRefGen,    validCharRef, switchUnicodeRuns,    ) where@@ -112,7 +112,9 @@   {-|-Convert unicode character to XML Char.+Convert unicode character to XML Char,+where Unicode constructor is only used for ASCII characters.+This is achieved by the following decision: If there is a entity reference, use this. If it is ASCII, represent it as Char. Otherwise use a character reference.@@ -131,6 +133,20 @@    Map.lookup c dict  +{- |+Generate XML character from Unicode character+with minimal use of references.+The only references used are the XML entity references+@&apos;@, @&quot;@, @&amp;@, @&lt;@, @&gt;@.+-}+minimalRefFromUnicode :: Char -> T+minimalRefFromUnicode c =+   maybe+      (fromUnicode c)+      fromEntityRef $+   Map.lookup c Ent.mapCharToName++ -- * shortcuts for making the output of the Show instance valid  unicode :: Char -> T@@ -175,12 +191,17 @@   instance Fmt.C T where-   run (Unicode c) = (c:)+   run (Unicode c) = showChar c    run (CharRef n) = Fmt.amp . Fmt.sharp . shows n . Fmt.semicolon-   run (EntityRef n) = Fmt.amp . (n++) . Fmt.semicolon+   run (EntityRef n) = Fmt.amp . showString n . Fmt.semicolon   +{- |+Reduce the use of references.+Represent as much as possible characters as Unicode characters,+that is, using the Unicode constructor.+-} reduceRef :: T -> T reduceRef = reduceRefGen Ent.mapNameToChar
src/Text/XML/Basic/Entity.hs view
@@ -8,7 +8,9 @@ import qualified Data.Map as Map import qualified Data.Char as Char import Control.Monad.Exception.Synchronous (Exceptional, assert, throw, )+import Control.Monad.HT ((<=<), ) import Data.Monoid (Monoid(mempty, mappend), mconcat, )+import Data.Semigroup (Semigroup((<>)), ) import Data.Tuple.HT (swap, )  @@ -36,7 +38,8 @@       ds       -> readBounded 10 Char.isDigit    ds  {- |-We fail on leading zeros in order to prevent infinite loop on @repeat '0'@.+We fail on too many leading zeros+in order to prevent infinite loop on @repeat '0'@. This function assumes that @16 * ord maxBound@ is always representable as @Int@. -} readBounded :: Int -> (Char -> Bool) -> String -> Exceptional String Int@@ -45,26 +48,27 @@       ""  -> throw "empty number string"       "0" -> return 0       _ ->-         let m digit =+         let m pos digit =                Update $ \mostSig ->                   let n = mostSig*base + Char.digitToInt digit                   in  assert ("invalid character "++show digit)                          (validChar digit) >>-                      assert "leading zero not allowed for security reasons"-                         (not (mostSig==0 && digit=='0')) >>+                      assert "too many leading zeros forbidden in order to prevent denial of service"+                         (not (pos>=8 && digit=='0')) >>                       assert "number too big"                          (n <= Char.ord maxBound) >>                       return n-         in  evalUpdate (mconcat $ map m str) 0+         in  evalUpdate (mconcat $ zipWith m [(0::Int)..] str) 0   newtype Update e a = Update {evalUpdate :: a -> Exceptional e a} +instance Semigroup (Update e a) where+   Update x <> Update y = Update (y <=< x)+ instance Monoid (Update e a) where    mempty = Update return-   mappend (Update x) (Update y) =-      Update (\a -> x a >>= y)---      Update (x>=>y)+   mappend = (<>)
src/Text/XML/Basic/Format.hs view
@@ -1,6 +1,8 @@ module Text.XML.Basic.Format where  import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.Entity as Ent+import qualified Data.Map as Map  import Prelude hiding (quot) @@ -9,7 +11,18 @@    run :: object -> ShowS  instance C Char where+   run c =+      maybe+         (showChar c)+         (\n -> amp . showString n . semicolon) $+      Map.lookup c Ent.mapCharToName++{- that one causes cyclic module dependencies+   run = run . XMLChar.minimalRefFromUnicode+-}+{- that one is too simple - we always have to emit valid XML code    run = showChar+-}  instance C object => C [object] where    run = many run
src/Text/XML/Basic/Name.hs view
@@ -2,13 +2,12 @@ We provide a type class for tag and attribute names. Instances can be names that preserve case, names with lowercase letters as canonical representation.-To do: Qualified names. -} module Text.XML.Basic.Name where  -- * types and classes -class C name where+class Ord name => C name where    fromString :: String -> name    toString :: name -> String @@ -18,11 +17,11 @@ because DOCTYPE as tag name must be written upper case, whereas as attribute name it may be written either way. -}-class Tag ident where+class Ord ident => Tag ident where    tagFromString :: String -> ident    tagToString :: ident -> String -class Attribute ident where+class Ord ident => Attribute ident where    attributeFromString :: String -> ident    attributeToString :: ident -> String @@ -30,8 +29,8 @@  -- * convenience functions -match :: (C name, Eq name) => String -> name -> Bool+match :: (C name) => String -> name -> Bool match proto = (fromString proto ==) -matchAny :: (C name, Eq name) => [String] -> name -> Bool+matchAny :: (C name) => [String] -> name -> Bool matchAny proto = flip elem (map fromString proto)
src/Text/XML/Basic/ProcessingInstruction.hs view
@@ -8,7 +8,7 @@ import qualified Text.XML.Basic.Name as Name import qualified Text.XML.Basic.Format as Fmt -import Data.Monoid (Monoid, mempty, )+import Data.Monoid (mempty, )  import Data.Foldable (Foldable(foldMap), ) import Data.Traversable (Traversable(sequenceA), traverse, )@@ -18,9 +18,21 @@ data T name string =      Known [Attr.T name string]    | Unknown String-     deriving (Show, Eq, Ord)+     deriving (Eq, Ord {- , Show -} )  +{-+JHC cannot generate this instance automatically,+since it fails to generate the (Name.Attribute name) constraint.+-}+instance (Name.Attribute name, Show string) => Show (T name string) where+   showsPrec p x =+      showParen (p>10) $+      case x of+         Known attrs -> showString "Known " . showsPrec 11 attrs+         Unknown str -> showString "Unknown " . shows str++ instance (Name.Attribute name, Fmt.C string) => Fmt.C (T name string) where    run p =       case p of@@ -46,8 +58,11 @@          Known attrs  -> liftA Known $ traverse sequenceA attrs          Unknown text -> pure $ Unknown text -mapName :: (name0 -> name1) -> T name0 string -> T name1 string-mapName f = mapAttributes (map (Attr.mapName f))+mapName ::+   (Attr.Name name0 -> Attr.Name name1) ->+   T name0 string -> T name1 string+mapName f =+   mapAttributes (map (Attr.mapName f))   mapAttributes ::
+ src/Text/XML/Basic/String.hs view
@@ -0,0 +1,46 @@+module Text.XML.Basic.String where++import qualified Text.XML.Basic.Character as XMLChar+import qualified Text.XML.Basic.Entity as XMLEnt+import qualified Data.Map as Map+import qualified Data.Char as Char+++-- | should be [Word8]+type Encoded  = String++{- |+Decode encoded characters and XML references.+Invalid references are silently skipped.+-}+decode ::+   (Encoded -> String) ->+   [XMLChar.T] ->+   String+decode =+   decodeGen XMLEnt.mapNameToChar++decodeGen ::+   Map.Map XMLEnt.Name Char ->+   (Encoded -> String) ->+   [XMLChar.T] ->+   String+decodeGen mapNameToChar decoder =+   foldr ($) [] .+   XMLChar.switchUnicodeRuns+      ((++) . decoder)+      (\n ->+         if XMLChar.validCharRef n+           then (Char.chr n :)+           else id)+      (\n ->+         maybe id (:) $+         Map.lookup n mapNameToChar)+++{-+type Reference = Either Int String++data T = Cons String Reference R+data R = R Reference R | S T+-}
src/Text/XML/Basic/Tag.hs view
@@ -6,11 +6,16 @@ -} module Text.XML.Basic.Tag (    Name(..),-   doctype, doctypeString,-   cdata, cdataString,+   doctype, doctypeName, doctypeString,+   cdata, cdataName, cdataString,+   xmlName, xmlString,+   maybeXMLEncoding,    ) where -import Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.ProcessingInstruction as PI+import qualified Text.XML.Basic.Attribute as Attr+import Control.Monad (guard, )   newtype Name ident = Name {unname :: ident}@@ -26,15 +31,39 @@   +{-# DEPRECATED doctype "use doctypeName instead" #-} doctype :: (Name.Tag name) => Name name-doctype = Name.fromString doctypeString+doctype = doctypeName +{-# DEPRECATED cdata "use cdataName instead" #-} cdata :: (Name.Tag name) => Name name-cdata = Name.fromString cdataString+cdata = cdataName  +doctypeName :: (Name.Tag name) => Name name+doctypeName = Name.fromString doctypeString++cdataName :: (Name.Tag name) => Name name+cdataName = Name.fromString cdataString++xmlName :: (Name.Tag name) => Name name+xmlName = Name.fromString xmlString++ doctypeString :: String doctypeString = "DOCTYPE"  cdataString :: String cdataString = "[CDATA["++xmlString :: String+xmlString = "xml"+++maybeXMLEncoding ::+   (Name.Tag name, Name.Attribute name) =>+   Name name -> PI.T name string -> Maybe string+maybeXMLEncoding name instr =+   do guard (xmlName == name)+      let (PI.Known attrs) = instr+      Attr.lookup Attr.encodingName attrs
xml-basic.cabal view
@@ -1,10 +1,10 @@+Cabal-Version:    2.2 Name:             xml-basic-Version:          0.0.1-License:          BSD3+Version:          0.1.3.3+License:          BSD-3-Clause License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de> Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>-Homepage:         http://www.haskell.org/haskellwiki/XML-Basic Category:         XML Synopsis:         Basics for XML/HTML representation and processing Description:@@ -14,9 +14,8 @@   We also provide information about exceptional HTML tags,   like self-closing tags.   This package provides common functionality-  that is both needed in list (tagsoup-ht) and tree (wraxml) representations of XML.-Tested-With:       GHC==6.8.2-Cabal-Version:     >=1.6+  that is both needed in list (tagchup) and tree (wraxml) representations of XML.+Tested-With:       GHC==6.8.2, GHC==6.10.4, JHC==0.7.3 Build-Type:        Simple Source-Repository head   type:     darcs@@ -25,25 +24,26 @@ Source-Repository this   type:     darcs   location: http://code.haskell.org/~thielema/xml-basic/-  tag:      0.0.1--Flag splitBase-  description: Choose the new smaller, split-up base package.+  tag:      0.1.3.3  Library   Build-Depends:-    explicit-exception >=0.1.3 && <0.2,+    explicit-exception >=0.1.3 && <0.3,     data-accessor >=0.2 && <0.3,-    utility-ht >=0.0.4 && <0.1-  If flag(splitBase)-    Build-Depends: base >= 2, containers >=0.1 && <0.3-  Else-    Build-Depends: base >= 1.0 && < 2, special-functors >=1.0 && <1.1+    semigroups >=0.1 && <1.0,+    utility-ht >=0.0.13 && <0.1,+    containers >=0.1 && <0.8,+    base >= 2 && <5+  If impl(jhc)+    Build-Depends:+      applicative >=1.0 && <1.1    GHC-Options:      -Wall+  Default-Language: Haskell98   Hs-Source-Dirs:   src   Exposed-Modules:     Text.HTML.Basic.Tag+    Text.HTML.Basic.String     Text.HTML.Basic.Character     Text.HTML.Basic.Entity     Text.XML.Basic.Tag@@ -54,6 +54,7 @@     Text.XML.Basic.Name.LowerCase     Text.XML.Basic.Name.Qualified     Text.XML.Basic.Position+    Text.XML.Basic.String     Text.XML.Basic.Character     Text.XML.Basic.Entity     Text.XML.Basic.Format