packages feed

text-xml-qq (empty) → 0.1

raw patch · 4 files changed

+372/−0 lines, 4 filesdep +basedep +parsecdep +template-haskellsetup-changed

Dependencies added: base, parsec, template-haskell, xml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Oscar Finnsson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Oscar Finnsson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/XML/QQ.hs view
@@ -0,0 +1,271 @@+{-# OPTIONS_GHC -fglasgow-exts -XTemplateHaskell -XQuasiQuotes -XUndecidableInstances #-}+++-- | The XML quasiquoter.+--    +--    Given the variables+--    +--      >  url = "google.se"+--      >  elem = "gmail"+--      >  attrNs = "something"+--      >  attrName = "Pelle"+--      >  attrValue = "Arne"+--      >  elemCont = CRef "testing"+--      >  cont1 = Elem $ element { elName = qname "hej" }+--      >  cont2 = CRef "other test"+--    +--    the code+--    +--      >   [$xmlQQ|+--      >   <{url}:{elem} {attrNs}:{attrName}={attrValue} attr="cool">+--      >     <elem ns1:elem1="1" ns2:elem2="2"><<elemCont>></elem>+--      >     <elem />+--      >     <el />+--      >     <<cont1>>+--      >     <<cont2>>+--      >   </{url}:{elem}>+--      >   |]+--    +--    will generate the data structure+--    +--      >   element {+--      >     elName = QName elem Nothing (Just url),+--      >     elAttribs = [Attr (QName attrName Nothing (Just attrNs)) attrValue,+--      >                  Attr (qname "attr") "cool"],+--      >     elContent = [+--      >       (Elem $ element { elName = qname "elem",+--      >                         elAttribs = [Attr (QName "elem1" Nothing (Just "ns1")) "1",+--      >                                      Attr (QName "elem2" Nothing (Just "ns2")) "2"],+--      >                         elContent = [elemCont]+--      >                        }),+--      >        (Elem $ element { elName = qname "elem" }),+--      >        (Elem $ element { elName = qname "el" }),+--      >        cont1,+--      >        cont2]+--      >   }+module Text.XML.QQ (xmlQQ) where++-- import Text.XML.Light+import qualified Text.XML.Light.Types as XT+import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Data.Data+import Data.Maybe++-- import Data.Ratio+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Error+++xmlQQ :: QuasiQuoter+xmlQQ = QuasiQuoter xmlExp xmlPat++xmlPat = undefined++xmlExp :: String -> ExpQ+xmlExp txt =+  case parsed' of +    Left err -> error $ "Error in jsonExp: " ++ show err+    Right val -> return $ elementToExp val+  where+    parsed' = parse xmlElementParser "txt" txt++-- Data types to Exp++elementToExp :: ElementMeta -> Exp+elementToExp (Element name attribs contents line) =+  AppE (AppE (AppE (AppE (ConE nElement) name') attr') contents') (ConE nNothing)+  where+    name' = qnameToExp name+    attr' = ListE $ map attrToExp attribs+    contents' = ListE $ map contentToExp contents++qnameToExp :: QNameMeta -> Exp+qnameToExp (QName name uri prefix) =+  AppE (AppE (AppE (ConE nQName) name') (ConE nNothing)) prefix'+  where+    prefix' = maybe (ConE nNothing) (\p -> (AppE (ConE nJust) (stringmetaToExp p))) prefix+    name' = stringmetaToExp name++stringmetaToExp :: StringMeta -> Exp+stringmetaToExp (StringMetaNormal s) = (LitE (StringL s))+stringmetaToExp (StringMetaVar s) = VarE $ mkName s++attrToExp :: AttrMeta -> Exp+attrToExp (Attr name val) =+  AppE (AppE (ConE nAttr) name') val' -- (LitE (StringL val))+  where+    name' = qnameToExp name+    val' = stringmetaToExp val++contentToExp :: ContentMeta -> Exp+contentToExp (Elem e) = AppE (ConE nElem) (elementToExp e)+contentToExp (CRef s) = AppE (ConE nCRef) (LitE (StringL s))+contentToExp (ContentVar v) = VarE $ mkName v+contentToExp _ = error "Case Text in contentToExp is not implemented yet."++nElem = mkName "Text.XML.Light.Types.Elem"+nText = mkName "Text.XML.Light.Types.Text"+nCRef = mkName "Text.XML.Light.Types.CRef"+nElement = mkName "Text.XML.Light.Types.Element"+nAttr = mkName "Text.XML.Light.Types.Attr"+nQName = mkName "Text.XML.Light.Types.QName"+nNothing = mkName "Data.Maybe.Nothing"+nJust = mkName "Data.Maybe.Just"+nList = mkName "[]"++blank_meta_element :: ElementMeta+blank_meta_element = Element (QName (StringMetaNormal "") Nothing Nothing) [] [] Nothing+++-- Data types++data AttrMeta =+  Attr {+    attrKey :: QNameMeta,+    attrVal :: StringMeta+  }++data ElementMeta = +  Element {+    elName :: QNameMeta,+    elAttribs :: [AttrMeta],+    elContent :: [ContentMeta],+    elLine :: Maybe Line+  }++data QNameMeta = +  QName	{ +    qName :: StringMeta,+    qURI :: Maybe String,+    qPrefix :: Maybe StringMeta+  }++data StringMeta =+  StringMetaNormal String+  | StringMetaVar String++getStringMeta :: StringMeta -> String+getStringMeta (StringMetaNormal n) = n+getStringMeta (StringMetaVar n) = "{" ++ n ++ "}"++data ContentMeta =+  Elem ElementMeta +  | Text CDataMeta+  | CRef String+  | ContentVar String++data CDataMeta =+  CData	{+    cdVerbatim :: XT.CDataKind,+    cdData :: String,+    cdLine :: Maybe Line+  }+  ++-- Parser++xmlElementParser :: Parser ElementMeta+xmlElementParser = do+  spaces+  char '<'+  name <- nameParser+  spaces+  attrs <- many $ try attrParser+  spaces+  -- string "/>"+  contents <- closeTag <|> (openCloseTag name)+  spaces+  return $ Element name attrs contents Nothing+  +closeTag :: Parser [ContentMeta]+closeTag = do+  string "/>"+  return []++openCloseTag :: QNameMeta -> Parser [ContentMeta]+openCloseTag (QName name Nothing ns) = do+  -- string ">"+  contents <- between (string ">") (string "</") (many contentParser)+  string $ (ns' ++ name') ++ ">"+  return contents+  where+    name' = getStringMeta name+    ns' = maybe "" (\n -> (getStringMeta n) ++ ":") ns+ +attrParser :: Parser AttrMeta+attrParser = do+  spaces+  name <- nameParser+  char '='+  value <- metaStringParser --between (string "\"") (string "\"") (chars)+  return $ Attr name value++contentParser :: Parser ContentMeta+contentParser = do+  spaces+  content <- (try contentVarParser) <|> (try xmlElementParser >>= return . Elem) <|> (crefParser >>= return . CRef)+  spaces+  return content++contentVarParser :: Parser ContentMeta+contentVarParser = do+  string "<<"+  s <- symbol+  string ">>"+  return $ ContentVar s++crefParser :: Parser String+crefParser = many1 (noneOf "><")++nameParser :: Parser QNameMeta -- (String,Maybe String)+nameParser = do+  name1 <- metaSymbolParser -- symbol+  name2 <- optionMaybe (+    do+      char ':'+      metaSymbolParser)+      -- symbol)+  let+    ns = maybe Nothing (\n -> Just ( name1)) name2+    name = maybe name1 (\n -> n) name2+  return $ QName ( name) Nothing ns -- (name, ns)+++-- helpers++metaStringParser :: Parser StringMeta+metaStringParser = do+  metaNormalStringParser <|> metaVarSymbolParser++metaNormalStringParser :: Parser StringMeta+metaNormalStringParser = do+  char '"'+  s <- chars+  char '"'+  return $ StringMetaNormal s++metaSymbolParser :: Parser StringMeta+metaSymbolParser = do+  metaNormalSymbolParser <|> metaVarSymbolParser++metaNormalSymbolParser :: Parser StringMeta  +metaNormalSymbolParser = do+  s <- symbol+  return $ StringMetaNormal s++metaVarSymbolParser :: Parser StringMeta+metaVarSymbolParser = do+  char '{'+  s <- symbol+  char '}'+  return $ StringMetaVar s++symbol :: CharParser () String+symbol = many1 (noneOf "{}\\ \"/:;><$=")++chars :: CharParser () String+chars = many (noneOf "\"")++
+ text-xml-qq.cabal view
@@ -0,0 +1,69 @@+-- text-xml-qq.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name:                text-xml-qq++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.1++-- A short (one-line) description of the package.+Synopsis:            Quasiquoter for xml. XML DSL in Haskell.++-- A longer description of the package.+Description:         +    XML quasiquoter. Can convert XML code into Haskell data structures compile time.+    .+    At the moment only Text.XML.Light (xml-package) backend.+    .+    Supports namespaces, attributes, embedding Haskell variables etc.+    .+    See github for more information and examples of usage.++-- URL for the project homepage or repository.+Homepage:            http://www.github.com/finnsson/text-xml-qq++-- The license under which the package is released.+License:             BSD3++-- The file containing the license text.+License-file:        LICENSE++-- The package author(s).+Author:              Oscar Finnsson++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          oscar dot finnsson at gmail dot com++-- A copyright notice.+-- Copyright:           ++Category:            Text++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.2++hs-source-dirs: src++-- Library+  -- Modules exported by the library.+Exposed-modules:     Text.XML.QQ+  +  -- Packages needed in order to build this package.+Build-depends:       xml, parsec >= 3.1, base >= 4.2 && < 5, template-haskell+  +  -- Modules not exported by this package.+  -- Other-modules:       +  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         +