packages feed

hexpat-lens (empty) → 0.0.1

raw patch · 5 files changed

+235/−0 lines, 5 filesdep +basedep +deepseqdep +hexpatsetup-changed

Dependencies added: base, deepseq, hexpat, lens

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2013 Joseph Abrahamson++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hexpat-lens.cabal view
@@ -0,0 +1,24 @@+name:                hexpat-lens+version:             0.0.1+synopsis:            Lenses for Hexpat.+license:             MIT+license-file:        LICENSE+author:              Joseph Abrahamson+maintainer:          me@jspha.com+copyright:           (c) 2013, Joseph Abrahamson+category:            XML+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     +    Text.XML.Expat.Lens.Unqualified+    Text.XML.Expat.Lens.Names+  build-depends:       +      base >=4.6 && <4.7+    , deepseq >=1.3 && <1.4+    , hexpat >=0.20 && <0.21+    , lens >=3.9 && <3.10+  ghc-options: -Wall+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Text/XML/Expat/Lens/Names.hs view
@@ -0,0 +1,80 @@++-- |+-- Module      : Text.XML.Expat.Lens.Names+-- Copyright   : (c) 2013, Joseph Abrahamson+-- License     : MIT+-- +-- Maintainer  : me@jspha.com+-- Stability   : experimental+-- Portability : non-portable+-- +-- Isos on 'QName's and 'NName's.+-- +-- Lenses will provide the power to do very concise XML tree+-- diving. This module provides a less general interface to the Hexpat+-- datatypes via lenses.++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Text.XML.Expat.Lens.Names (++  prefix, namespace, qualified, namespaced,+  HasLocalPart (..)+  +  ) where++import Control.Applicative+import Control.Exception+import Control.Lens hiding (children)++import Text.XML.Expat.Tree++import Data.Data+import Control.DeepSeq+import System.IO.Unsafe++class HasLocalPart a where+  localPart :: Lens' (a t) t++prefix :: Lens' (QName text) (Maybe text)+prefix inj (QName pre part) = (\pre' -> QName pre' part) <$> inj pre+{-# INLINE prefix #-}++instance HasLocalPart QName where+  localPart inj (QName pre part) = (\part' -> QName pre part') <$> inj part+  {-# INLINE localPart #-}++namespace :: Lens' (NName text) (Maybe text)+namespace inj (NName ns part) = (\ns' -> NName ns' part) <$> inj ns+{-# INLINE namespace #-}++instance HasLocalPart NName where+  localPart inj (NName ns part) = (\part' -> NName ns part') <$> inj part+  {-# INLINE localPart #-}++-- | Iso between a node marked by a "stringy" name to one using a+-- qualified 'QName'.+qualified ::+  (GenericXMLString text, NodeClass n c) =>+  Iso' (n c text text) (n c (QName text) text) +qualified = iso toQualified fromQualified++-- | 'Prism' between a node marked by a qualified 'QName' name to one+-- using a namespaced 'NName'. Normally this throws an exception if+-- the namespace is non-standard, but here the 'Prism' simply fails if+-- incompatible.+namespaced ::+  ( GenericXMLString text, NodeClass n c+  , Show text, Ord text, NFData (n c (NName text) text) ) =>+  Prism' (n c (QName text) text)+         (n c (NName text) text) +namespaced = prism' fromNamespaced (muspoon . toNamespaced)++-- | It's tragic that this exists. Stop 'error's before they start!+muspoon :: NFData a => a -> Maybe a+muspoon a = unsafePerformIO $ deepseq a (Just `fmap` return a) `catches` handles+  where handles = [ Handler $ \(_ :: ErrorCall)    -> return Nothing ]+      +
+ src/Text/XML/Expat/Lens/Unqualified.hs view
@@ -0,0 +1,110 @@++-- |+-- Module      : Text.XML.Expat.Lens.Unqualified+-- Copyright   : (c) 2013, Joseph Abrahamson+-- License     : MIT+-- +-- Maintainer  : me@jspha.com+-- Stability   : experimental+-- Portability : non-portable+-- +-- A simple Hexpat lens module.+-- +-- Lenses provide power to do very concise XML tree diving. This+-- module provides a less general interface to the Hexpat datatypes+-- via lenses.++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Text.XML.Expat.Lens.Unqualified where++import Control.Applicative+import Control.Lens hiding (children)++import Text.XML.Expat.Tree++-- | Traverses the name of an 'Element'. This is as+-- an "Affine", or 0-or-1 target, 'Traversal'. In regex terms, you+-- can think of it like the @?@ suffix modifier.++name :: Traversal' (UNode t) t+name inj (Element n a c) = (\n' -> Element n' a c) <$> inj n+name inj t               = pure t+{-# INLINE name #-}++-- | Traverses to the list of attributes of an 'Element'. This is as+-- an "Affine", or 0-or-1 target, 'Traversal'. In regex terms, you+-- can think of it like the @?@ suffix modifier.++attributes :: Traversal' (UNode t) (UAttributes t)+attributes inj (Element n a c) = (\a' -> Element n a' c) <$> inj a+attributes inj t               = pure t+{-# INLINE attributes #-}++-- The @attributes@ form, effectively, a lookup table allowing us to+-- instantiate @At@. Then, we get @Ixed@, @Each@, and @Contains@ for+-- "free".++type instance Index   (UNode a) = a+type instance IxValue (UNode a) = a++-- | This forms a valid 'At' instance under the assumption that+-- there are no repeated keys in the 'Attributes' list. Since+-- @hexpat@ won't parse invalid XML this holds after parsing, so+-- this 'At' instance is valid so long as the invariants aren't+-- subverted in some other way, such as by modify the 'Attributes'+-- list directly via the 'attributes' 'Traversal'.++instance (GenericXMLString a) => At (UNode a) where+  at k f e = indexed f k (getAttribute e k) <&> \r -> alterAttribute k r e++instance (GenericXMLString a, Applicative f) => Ixed f (UNode a) where+  ix = ixAt+  +instance ( GenericXMLString a+         , Applicative f+         , Contravariant f ) => Contains f (UNode a) where+  contains = containsAt++-- | Traverses the children of an 'Element'. This is as+-- an "Affine", or 0-or-1 target, 'Traversal'. In regex terms, you+-- can think of it like the @?@ suffix modifier.++children :: Traversal' (UNode t) [UNode t]+children inj (Element n a c) = (\c' -> Element n a c') <$> inj c+children inj t               = pure t+{-# INLINE children #-}++-- | Prismatic access to the text of a 'Text' node. This is more+-- powerful than 'name', 'children', and 'attributes' since it can+-- be 'Review'ed.++text :: Prism' (UNode t) t+text = dimap go come . right' where+  go e@Element{} = Left e+  go (Text t)    = Right t+  {-# INLINE go #-}+  come (Left it) = pure it+  come (Right t) = Text <$> t+  {-# INLINE come #-}+{-# INLINE text #-}++-- We can use plated/uniplate lenses to traverse all of the elements of+-- the tree in a bottom up fashion.++-- | Produces a list of all 'UNode's in a XML tree.++allNodes :: UNode t -> [UNode t]+allNodes = universeOf (children . traverse)++-- And if we build one sort-of @Traversal@ then we'll have replicated+-- almost all of the functionality of @NodeClass@ in lenses. This uses+-- 'Control.Lens.Fold.filtered' so the caveats there apply.++-- | Traverses 'Element's which have a particular name.++named :: (Choice p, Applicative f, Eq t) => t -> Overloaded' p f (UNode t) (UNode t)+named n = filtered (isNamed n)