diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dennis Gosnell (c) 2017 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ + +Text.XML.QQ and Text.HTML.QQ +============================ + +[![Build Status](https://secure.travis-ci.org/cdepillabout/xml-html-qq.svg)](http://travis-ci.org/cdepillabout/xml-html-qq) +[![Hackage](https://img.shields.io/hackage/v/xml-html-qq.svg)](https://hackage.haskell.org/package/xml-html-qq) +[![Stackage LTS](http://stackage.org/package/xml-html-qq/badge/lts)](http://stackage.org/lts/package/xml-html-qq) +[![Stackage Nightly](http://stackage.org/package/xml-html-qq/badge/nightly)](http://stackage.org/nightly/package/xml-html-qq) +![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) + +`xml-html-qq` provides quasi-quoters for XML and HTML `Document`s. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/HTML/QQ.hs b/src/Text/HTML/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/QQ.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : Text.HTML.QQ + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +Stability : experimental +Portability : unknown + +This module provides a quasi-quoter for HTML 'Document's. See the 'html' +function for some examples. + +See "Text.XML.QQ" for an explanation of the difference between "Text.HTML.QQ" +and "Text.XML.QQ". +-} + +module Text.HTML.QQ + ( html + , htmlRaw + -- * Types + , Document + ) where + +import Data.Text.Lazy (pack) +import Language.Haskell.TH (appE) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.Syntax (lift) +import Text.Blaze.Renderer.Text (renderMarkup) +import Text.Heterocephalus (compileFromString, textSetting) +import Text.HTML.DOM (parseLT) +import Text.XML (Document) + +import Text.XMLHTML.Internal (createExpQuasiQuoter) + +-- $setup +-- >>> :set -XQuasiQuotes +-- >>> :set -XTemplateHaskell + + +-- | This 'QuasiQuoter' produces HTML 'Document's. +-- +-- This 'QuasiQuoter' produces expressions of type 'Document'. +-- +-- Here's a simple example of using it: +-- +-- >>> [html||] +-- Document {documentPrologue = Prologue {prologueBefore = [], prologueDoctype = Nothing, prologueAfter = []}, documentRoot = Element {elementName = Name {nameLocalName = "html", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = fromList [], elementNodes = []}, documentEpilogue = []} +-- +-- Internally, this function is using the +-- package. +-- This means you can use variable interpolation, as well as @forall@, @if@, +-- and @case@ control statements. Checkout the +-- for +-- more info. +-- +-- >>> let a = "hello world" +-- >>> [html|#{a}|] +-- Document ... +-- +-- Even invalid HTML will still parse. +-- +-- >>> [html||] +-- Document ... +-- +-- Here's an example of a template that can be parsed as an HTML 'Document', but +-- not as an XML 'Document': +-- +-- >>> [html|
|] +-- Document ... +html :: QuasiQuoter +html = + createExpQuasiQuoter $ \string -> + appE [|parseLT . renderMarkup|] $ compileFromString textSetting string + +-- | This function is the same as 'html', but doesn't allow variable +-- interpolation or control statements. It also produces expressions of type +-- 'Document'. +htmlRaw :: QuasiQuoter +htmlRaw = createExpQuasiQuoter $ lift . parseLT . pack diff --git a/src/Text/XML/QQ.hs b/src/Text/XML/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/QQ.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : Text.XML.QQ + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +Stability : experimental +Portability : unknown + +This module provides a quasi-quoter for XML 'Document's. See the 'xml' +function for some examples. + +The difference between "Text.XML.QQ" and "Text.HTML.QQ" is the function that is +used to parse the input 'String' into a 'Document'. + +'Text.XML.QQ.xml' uses 'Text.XML.parseText' to parse the input 'String'. +'Text.XML.parseText' returns an error on a malformed document. This is +generally what you want for XML documents. + +'Text.HTML.QQ.html' uses 'Text.HTML.DOM'.parseLT' to parse the input 'String'. +'Text.HTML.DOM.parseLT' will parse any HTML document, skipping parts of the +document that are malformed. This is generally what you want for HTML +documents. +-} + +module Text.XML.QQ + ( xml + , xmlUnsafe + , xmlRaw + -- * Types + , Document + , SomeException + ) where + +import Control.Exception (SomeException) +import Control.FromSum (fromEither) +import Data.Default (def) +import Data.Text.Lazy (pack) +import Language.Haskell.TH (appE) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.Syntax (lift) +import Text.Blaze.Renderer.Text (renderMarkup) +import Text.Heterocephalus (compileFromString, textSetting) +import Text.XML (Document(..), parseText) + +import Text.XMLHTML.Internal + (createExpQuasiQuoter, handleParseDocErr) + +-- $setup +-- >>> :set -XQuasiQuotes +-- >>> :set -XTemplateHaskell + + +-- | This 'QuasiQuoter' produces XML 'Document's. +-- +-- This 'QuasiQuoter' produces expressions of type +-- @'Either' 'SomeException' 'Document'@. It produces a +-- @'Left' 'SomeException'@ when the input string cannot be parsed into an XML +-- 'Document'. +-- +-- Here's a simple example of using it: +-- +-- >>> [xml||] +-- Right (Document {documentPrologue = Prologue {prologueBefore = [], prologueDoctype = Nothing, prologueAfter = []}, documentRoot = Element {elementName = Name {nameLocalName = "html", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = fromList [], elementNodes = []}, documentEpilogue = []}) +-- +-- Internally, this function is using the +-- package. +-- This means you can use variable interpolation, as well as @forall@, @if@, +-- and @case@ control statements. Checkout the +-- for +-- more info. +-- +-- >>> let a = "hello world" +-- >>> [xml|#{a}|] +-- Right ... +-- +-- Here's an example of invalue XML that will produce a 'Left' value: +-- +-- >>> [xml||] +-- Left ... +-- +-- Here's an example of a template that can be parsed as an HTML 'Document', but +-- not as an XML 'Document': +-- +-- >>> [xml|
|] +-- Left ... +xml :: QuasiQuoter +xml = + createExpQuasiQuoter $ \string -> + appE [|parseText def . renderMarkup|] $ compileFromString textSetting string + +-- | This function is just like 'xml', but produces expressions of type +-- 'Document'. +-- +-- If your input string cannot be parsed into a valid 'Document', an error will +-- be thrown at runtime with 'error'. +-- +-- This function is nice to use in GHCi or tests, but should not be used in +-- production code. +xmlUnsafe :: QuasiQuoter +xmlUnsafe = + createExpQuasiQuoter $ \string -> + appE + [|fromEither (handleParseDocErr "XML" "Text.XML.parseText" string) . + parseText def . renderMarkup|] + (compileFromString textSetting string) + +-- | This function is similar to 'xml', but doesn't allow variable interpolation +-- or control statements. It produces expressions of type 'Document'. +-- +-- An error will be thrown at compile-time if the input string cannot be parsed +-- into a 'Document'. +xmlRaw :: QuasiQuoter +xmlRaw = + createExpQuasiQuoter $ \string -> + let eitherDoc = parseText def $ pack string + in either + (handleParseDocErr "XML" "Text.XML.parseText" string) + lift + eitherDoc diff --git a/src/Text/XMLHTML/Internal.hs b/src/Text/XMLHTML/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/XMLHTML/Internal.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- | +Module : Text.XMLHTML.Internal + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +Stability : experimental +Portability : unknown + +-} + +module Text.XMLHTML.Internal where + +import Control.Exception (SomeException) +import Instances.TH.Lift () +import Language.Haskell.TH (Q, Exp) +import Language.Haskell.TH.Lift (deriveLiftMany) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Text.XML + (Doctype(..), Document(..), Element(..), ExternalID(..), + Instruction(..), Miscellaneous(..), Name(..), Node(..), + Prologue(..)) + +$(deriveLiftMany + [ ''ExternalID + , ''Node + , ''Name + , ''Instruction + , ''Doctype + , ''Element + , ''Miscellaneous + , ''Prologue + , ''Document + ]) + +-- | Create a 'QuasiQuoter' for 'Exp's. +createExpQuasiQuoter + :: (String -> Q Exp) + -- ^ The function to use for 'QuasiQuoter's 'quoteExp'. + -> QuasiQuoter +createExpQuasiQuoter f = + QuasiQuoter + { quoteExp = f + , quotePat = error "not used" + , quoteType = error "not used" + , quoteDec = error "not used" + } + +-- | This function handles errors that occur when a 'Document' can't be parsed. +-- +-- This function throws an 'error' with an explanation of what happened. +handleParseDocErr + :: String + -- ^ The type of a document that was being parsed. Should either be + -- @\"XML\"@ or @\"HTML\"@. + -> String + -- ^ The name of the function that was being used to parse the document. + -- Should probably either be @\"Text.XML.parseText\"@ or + -- @\"Text.HTML.DOM.parseLT\"@ depending on whether you're parsing XML or + -- HTML. + -> String + -- ^ The actual XML or HTML string that you were trying to parse into a + -- 'Document'. + -> SomeException + -- ^ The exception that occurred when trying to parse the 'Document'. + -> a +handleParseDocErr docType parseFunction string exception = + let msg = + "ERROR: Trying to parse a string into an " `mappend` + docType `mappend` + " Document,\n" `mappend` + "but got the following error from " `mappend` + parseFunction `mappend` + ":\n" `mappend` + show exception `mappend` + "\n" `mappend` + "attempting to parse the following document:\n" `mappend` + string + in error msg diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,40 @@ + +module Main (main) where + +import Prelude + +import Data.Monoid ((<>)) +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doDocTest + +doDocTest :: [String] -> IO () +doDocTest options = doctest $ options <> ghcExtensions + +ghcExtensions :: [String] +ghcExtensions = + [ + -- "-XConstraintKinds" + -- , "-XDataKinds" + "-XDeriveDataTypeable" + , "-XDeriveGeneric" + -- , "-XEmptyDataDecls" + , "-XFlexibleContexts" + -- , "-XFlexibleInstances" + -- , "-XGADTs" + -- , "-XGeneralizedNewtypeDeriving" + -- , "-XInstanceSigs" + -- , "-XMultiParamTypeClasses" + -- , "-XNoImplicitPrelude" + , "-XOverloadedStrings" + -- , "-XPolyKinds" + -- , "-XRankNTypes" + -- , "-XRecordWildCards" + , "-XScopedTypeVariables" + -- , "-XStandaloneDeriving" + -- , "-XTupleSections" + -- , "-XTypeFamilies" + -- , "-XTypeOperators" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Data.Text (Text) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) +import Text.XML + (Document(..), Element(..), Name(..), Node(..), Prologue(..)) + +import Text.XML.QQ (xmlRaw, xmlUnsafe) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "tests" [xmlTests] + +xmlTests :: TestTree +xmlTests = testGroup "xml" [xmlUnsafeTests, xmlRawTests] + +xmlUnsafeTests :: TestTree +xmlUnsafeTests = testGroup "xmlUnsafe" [xmlUnsafeWorksCorrectly] + +xmlUnsafeWorksCorrectly :: TestTree +xmlUnsafeWorksCorrectly = testCase "works correctly" $ doc @?= expectedDoc + where + doc :: Document + doc = + let a = "hello" :: Text + in [xmlUnsafe|#{a}|] + + expectedDoc :: Document + expectedDoc = + Document + { documentPrologue = + Prologue + {prologueBefore = [], prologueDoctype = Nothing, prologueAfter = []} + , documentRoot = + Element + { elementName = + Name + { nameLocalName = "html" + , nameNamespace = Nothing + , namePrefix = Nothing + } + , elementAttributes = mempty + , elementNodes = [NodeContent "hello"] + } + , documentEpilogue = [] + } + +xmlRawTests :: TestTree +xmlRawTests = testGroup "xmlRaw" [xmlRawWorksCorrectly] + +xmlRawWorksCorrectly :: TestTree +xmlRawWorksCorrectly = testCase "works correctly" $ doc @?= expectedDoc + where + doc :: Document + doc = [xmlRaw||] + + expectedDoc :: Document + expectedDoc = + Document + { documentPrologue = + Prologue + {prologueBefore = [], prologueDoctype = Nothing, prologueAfter = []} + , documentRoot = + Element + {elementName = "html", elementAttributes = mempty, elementNodes = []} + , documentEpilogue = [] + } diff --git a/xml-html-qq.cabal b/xml-html-qq.cabal new file mode 100644 --- /dev/null +++ b/xml-html-qq.cabal @@ -0,0 +1,63 @@ +name: xml-html-qq +version: 0.1.0.0 +synopsis: Quasi-quoters for XML and HTML Documents +description: Please see . +homepage: https://github.com/cdepillabout/xml-html-qq +license: BSD3 +license-file: LICENSE +author: Dennis Gosnell +maintainer: cdep.illabout@gmail.com +copyright: 2017 Dennis Gosnell +category: Text +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Text.HTML.QQ + , Text.XML.QQ + , Text.XMLHTML.Internal + build-depends: base >= 4.8 && < 5 + , blaze-markup + , conduit + , data-default + , from-sum + , heterocephalus >= 1.0.4.0 + , html-conduit + , resourcet + , template-haskell + , text + , th-lift + , th-lift-instances + , xml-conduit + default-language: Haskell2010 + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction + other-extensions: TemplateHaskell + +test-suite xml-html-qq-doctest + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: test + build-depends: base + , doctest + , Glob + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +test-suite xml-html-qq-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + build-depends: base + , tasty + , tasty-hunit + , text + , xml-conduit + , xml-html-qq + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction + +source-repository head + type: git + location: git@github.com:cdepillabout/xml-html-qq.git