hsp 0.7.3 → 0.8.0
raw patch · 13 files changed
+568/−1001 lines, 13 filesdep −HJScriptdep −harpdep −hsxdep ~base
Dependencies removed: HJScript, harp, hsx
Dependency ranges changed: base
Files
- hsp.cabal +16/−11
- src/HSP.hs +0/−31
- src/HSP/Env.hs +0/−29
- src/HSP/Env/NumberGen.hs +0/−3
- src/HSP/Env/Request.hs +0/−56
- src/HSP/Exception.hs +0/−43
- src/HSP/HJScript.hs +0/−115
- src/HSP/HTML.hs +0/−163
- src/HSP/HTML4.hs +169/−0
- src/HSP/Monad.hs +65/−108
- src/HSP/XML.hs +84/−74
- src/HSP/XML/PCDATA.hs +38/−24
- src/HSP/XMLGenerator.hs +196/−344
hsp.cabal view
@@ -1,5 +1,5 @@ Name: hsp-Version: 0.7.3+Version: 0.8.0 License: BSD3 License-File: LICENSE Author: Niklas Broberg, Joel Bjornson@@ -18,27 +18,32 @@ * A cgi-handler utility (as a separate package, hsp-cgi) . For details on usage, please see the website, and the author's thesis.-Homepage: http://hub.darcs.net/nibro/hsp+Homepage: http://patch-tag.com/r/nibro/hsp Build-Type: Simple Cabal-Version: >= 1.6 Tested-With: GHC==6.8.3, GHC==6.10, GHC==7.0.2 source-repository head type: darcs- location: http://hub.darcs.net/nibro/hsp+ location: http://patch-tag.com/r/nibro/hsp -Flag base46+Flag base4 Library- Build-Depends: base >4 && < 5, mtl, harp, hsx>=0.10.2 && < 0.11, HJScript>=0.6.1, text- if flag(base46)- Build-depends: base >= 4.6 && < 5- cpp-options: -DBASE46+ Build-Depends: base >3 && < 5,+ mtl,+ text+ if flag(base4)+ Build-depends: base >= 4 && < 5+ cpp-options: -DBASE4 else- Build-depends: base >= 4 && < 4.6+ Build-depends: base >= 3 && < 4 Hs-Source-Dirs: src- Exposed-Modules: HSP.XML, HSP.XML.PCDATA, HSP.HTML, HSP.Env, HSP.Env.Request, HSP.Env.NumberGen, HSP.HJScript, HSP- Other-Modules: HSP.Exception, HSP.Monad, HSP.XMLGenerator+ Exposed-Modules: HSP.XMLGenerator+ HSP.XML+ HSP.XML.PCDATA+ HSP.HTML4+ HSP.Monad GHC-Options: -Wall -fno-warn-orphans Extensions: MultiParamTypeClasses,
− src/HSP.hs
@@ -1,31 +0,0 @@-module HSP ( - -- module HSP.Monad - HSP, HSPT, HSPT', runHSP, evalHSP, runHSPT, evalHSPT, getEnv, - getParam, getIncNumber, doIO, catch, setMetaData, withMetaData, - - -- module HSP.Env - module HSP.Env, - - -- module HSP.XML[.PCDATA] - module HSP.XML, - module HSP.XML.PCDATA, - - -- module HSP.HTML - module HSP.HTML, - - -- module HSP.XMLGenerator - module HSP.XMLGenerator, - - -- module HSP.HJScript - module HSP.HJScript - - ) where - -import Prelude () -import HSP.Monad -import HSP.Env hiding (mkSimpleEnv) -import HSP.XML hiding (Name) -import HSP.XML.PCDATA -import HSP.HTML -import HSP.XMLGenerator -import HSP.HJScript
− src/HSP/Env.hs
@@ -1,29 +0,0 @@-module HSP.Env ( - module HSP.Env.Request, - module HSP.Env.NumberGen, - - HSPEnv(..), - - mkSimpleEnv - ) where - -import HSP.Env.Request -import HSP.Env.NumberGen - -import Data.IORef - --- | The runtime environment for HSP pages. -data HSPEnv = HSPEnv { - getReq :: Request -- In CGI mode we only support Request --- , getResp :: Rp.Response - , getNG :: NumberGen - } - - - -mkSimpleEnv :: IO HSPEnv -mkSimpleEnv = do - x <- newIORef 0 - let req = Request (const []) [] - num = NumberGen (atomicModifyIORef x (\a -> (a+1,a))) - return $ HSPEnv req num
− src/HSP/Env/NumberGen.hs
@@ -1,3 +0,0 @@-module HSP.Env.NumberGen where - -data NumberGen = NumberGen { incNumber :: IO Int }
− src/HSP/Env/Request.hs
@@ -1,56 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : HSP.Env.Request --- Copyright : (c) Niklas Broberg 2006, --- License : BSD-style (see the file LICENSE.txt) --- --- Maintainer : Niklas Broberg, nibro@cs.chalmers.se --- Stability : experimental --- Portability : Haskell 98 --- --- An interface to a request object as held in the HSP environment. ------------------------------------------------------------------------------ - -module HSP.Env.Request ( - Request(..), - getParameter, - getParameter_, - readParameter, - readParameterL, - readParameter_ - ) where - -import HSP.Exception (throwHSP, Exception(..)) - --- | A record representing an interface to an HTTP request. This allows us to use --- many different underlying types for these requests, all we need is to supply --- conversions to this interface. This is useful for when we run as CGI, or when --- we run inside a server app. -data Request = Request { - getParameterL :: String -> [String] - , getHeaders :: [(String, String)] - } - --- | Get a parameter from the request query string (GET) or body (POST). --- | Returns @Nothing@ if the parameter is not set. -getParameter :: Request -> String -> Maybe String -getParameter r k = case getParameterL r k of - (v:_) -> Just v - _ -> Nothing - --- | Unsafe version of getParameter, essentially fromJust.(getParameter r) but throws --- a ParameterLookupFailed exception if the parameter is not set. -getParameter_ :: Request -> String -> String -getParameter_ r s = maybe (throwHSP $ ParameterLookupFailed s) id $ getParameter r s - --- | Return a value instead of a string. -readParameter :: Read a => Request -> String -> Maybe a -readParameter r s = fmap read $ getParameter r s - --- | Return a list of values read from their string representations. -readParameterL :: Read a => Request -> String -> [a] -readParameterL r s = map read $ getParameterL r s - --- | Unsafe version of readParameter -readParameter_ :: Read a => Request -> String -> a -readParameter_ r s = read $ getParameter_ r s
− src/HSP/Exception.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : HSP.Exception--- Copyright : (c) Niklas Broberg 2008--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, nibro@cs.chalmers.se--- Stability : experimental--- Portability : needs dynamic exceptions and deriving Typeable------ Defines a datatype for runtime exceptions that may arise during--- the evaluation of a HSP page.-------------------------------------------------------------------------------module HSP.Exception (- Exception(..),- throwHSP - ) where--import Data.Typeable-#ifdef BASE46-import qualified Control.Exception (Exception, throw)-#else-import Control.OldException (throwDyn)-#endif-data Exception- = ParameterLookupFailed String -- ^ User tried to do an irrefutable parameter lookup- -- that failed.- -- | ... I'm sure there should be more exceptions, we'll add them when we get to them.- deriving (Eq, Show, Typeable)--#ifdef BASE46-instance Control.Exception.Exception Exception-#endif---- Internal funcion that throws a dynamic exception particular to HSP.-throwHSP :: Exception -> a-#ifdef BASE46-throwHSP = Control.Exception.throw-#else-throwHSP = throwDyn-#endif-
− src/HSP/HJScript.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} -{-# OPTIONS_GHC -F -pgmFtrhsx #-} -module HSP.HJScript where - -import HSP.Monad -import HSP.XML -import HSP.XMLGenerator -import HJScript -- hiding (( := )(..), genElement, genEElement, asAttr, asChild) - -import {- qualified -} HSX.XMLGenerator -- as HSX - -instance Monad m => EmbedAsChild (HSPT' m) (Block t) where - asChild b = asChild $ - <script type="text/javascript"> - <% show b %> - </script> - -instance Monad m => IsAttrValue m (Block t) where - toAttrValue block = return . attrVal $ "javascript:" ++ show block - -instance Monad m => IsAttrValue m (HJScript ()) where - toAttrValue script = toAttrValue . snd $ evalHJScript script - -instance Monad m => IsAttrValue m (HJScript (Exp t)) where - toAttrValue script = toAttrValue $ evaluateHJScript script - -scriptAsChild :: (EmbedAsChild m (Block ())) => HJScript () -> XMLGenT m [ChildType m] -scriptAsChild script = asChild $ snd $ evalHJScript script - -newGlobalVar :: HSP (Var t, Block ()) -newGlobalVar = do - varName <- newGlobVarName - let block = toBlock $ VarDecl varName - return (JVar varName, block) - -newGlobalVarWith :: Exp t -> HSP (Var t, Block ()) -newGlobalVarWith e = do - varName <- newGlobVarName - let block = toBlock $ VarDeclAssign varName e - return (JVar varName, block) - -newGlobVarName :: HSP String -newGlobVarName = do - r <- getIncNumber - return $ "global_" ++ (show r) - - -type ElemRef = String -{- --- This should be done Soon (TM), but we --- need to look over things like getElementById, --- so it'll have to wait until the next version. - -newtype ElemRef = ElemRef String - -instance IsAttrValue ElemRef where - toAttrValue (ElemRef s) = toAttrValue s - -instance ToAttrNodeValue ElemRef where - toAttrNodeValue (ElemRef s) = toAttrValue s --} - -genId :: HSP ElemRef -genId = do - r <- getIncNumber - return $ "elemId_" ++ (show r) - -ref :: HSP XML -> HSP (ElemRef, XML) -ref xml = do - i <- genId - xml' <- xml `setId` i - return (i, xml') - - -------------------------------------------------- --- Settting properties -------------------------------------------------- - -setId :: (SetAttr m xml, EmbedAsAttr m (Attr String v)) - => xml -> v -> XMLGenT m (XMLType m) -setId e v = e `set` ("id" := v) - --- Generel method for adding 'onEvent' attributes to XML elements. -onEvent :: (SetAttr m xml, EmbedAsAttr m (Attr String (HJScript t))) - => Event -> xml -> HJScript t -> XMLGenT m (XMLType m) -onEvent event xml script = xml `set` (showEvent event := script) - -onAbort, onBlur, onChange, onClick, onDblClick, onError, - onFocus, onKeyDown, onKeyPress, onKeyUp, onLoad, onMouseDown, - onMouseMove, onMouseOut, onMouseOver, onMouseUp, onReset, - onResize, onSelect, onSubmit, onUnload :: - (SetAttr m xml, EmbedAsAttr m (Attr String (HJScript t))) - => xml -> HJScript t -> XMLGenT m (XMLType m) - -onAbort = onEvent OnAbort -onBlur = onEvent OnBlur -onChange = onEvent OnChange -onClick = onEvent OnClick -onDblClick = onEvent OnDblclick -onError = onEvent OnError -onFocus = onEvent OnFocus -onKeyDown = onEvent OnKeyDown -onKeyPress = onEvent OnKeyPress -onKeyUp = onEvent OnKeyUp -onLoad = onEvent OnLoad -onMouseDown = onEvent OnMouseDown -onMouseMove = onEvent OnMouseMove -onMouseOut = onEvent OnMouseOut -onMouseOver = onEvent OnMouseOver -onMouseUp = onEvent OnMouseUp -onReset = onEvent OnReset -onResize = onEvent OnResize -onSelect = onEvent OnSelect -onSubmit = onEvent OnSubmit -onUnload = onEvent OnUnload
− src/HSP/HTML.hs
@@ -1,163 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.HTML--- Copyright : (c) Niklas Broberg, Jeremy Shaw 2008--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, nibro@cs.chalmers.se--- Stability : experimental--- Portability : Haskell 98------ Attempt to render XHTML as well-formed HTML 4.01:------ 1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>------ 2. the end tag is forbidden for some elements, for these we:------ * render only the open tag, e.g., \<br\>------ * throw an error if the tag contains children------ 3. optional end tags are always rendered------ Currently no validation is performed.-------------------------------------------------------------------------------module HSP.HTML (- -- * Functions- renderAsHTML- , htmlEscapeChars- -- * Predefined XMLMetaData- , html4Strict- , html4StrictFrag- ) where--import Data.List-import HSP.XML-import HSP.XML.PCDATA(escaper)---- | Pretty-prints HTML values.------ Error Handling:------ Some tags (such as img) can not contain children in HTML. However,--- there is nothing to stop the caller from passing in XML which--- contains an img tag with children. There are three basic ways to--- handle this:------ 1. drop the bogus children silently------ 2. call 'error' \/ raise an exception------ 3. render the img tag with children -- even though it is invalid------ Currently we are taking approach #3, since no other attempts to--- validate the data are made in this function. Instead, you can run--- the output through a full HTML validator to detect the errors.------ #1 seems like a poor choice, since it makes is easy to overlook the--- fact that data went missing.------ We could raising errors, but you have to be in the IO monad to--- catch them. Also, you have to use evaluate if you want to check for--- errors. This means you can not start sending the page until the--- whole page has been rendered. And you have to store the whole page--- in RAM at once. Similar problems occur if we return Either--- instead. We mostly care about catching errors and showing them in--- the browser during testing, so perhaps this can be configurable.------ Another solution would be a compile time error if an empty-only--- tag contained children.------ FIXME: also verify that the domain is correct------ FIXME: what to do if a namespace is encountered-renderAsHTML :: XML -> String-renderAsHTML xml = renderAsHTML' 0 xml ""--data TagType = Open | Close--renderAsHTML' :: Int -> XML -> ShowS-renderAsHTML' _ (CDATA needsEscape cd) = showString (if needsEscape then (escaper htmlEscapeChars cd) else cd)-renderAsHTML' n elm@(Element name@(Nothing,nm) attrs children) - | nm == "area" = renderTagEmpty children- | nm == "base" = renderTagEmpty children- | nm == "br" = renderTagEmpty children- | nm == "col" = renderTagEmpty children- | nm == "hr" = renderTagEmpty children- | nm == "img" = renderTagEmpty children- | nm == "input" = renderTagEmpty children- | nm == "link" = renderTagEmpty children- | nm == "meta" = renderTagEmpty children- | nm == "param" = renderTagEmpty children- | nm == "script" = renderElement n (Element name attrs (map asCDATA children))- | nm == "style" = renderElement n (Element name attrs (map asCDATA children))- where- renderTagEmpty [] = renderTag Open n name attrs- renderTagEmpty _ = renderElement n elm -- this case should not happen in valid HTML- -- for and script\/style, render text in element as CDATA not PCDATA- asCDATA :: XML -> XML- asCDATA (CDATA _ cd) = (CDATA False cd)- asCDATA o = o -- this case should not happen in valid HTML-renderAsHTML' n e = renderElement n e--renderElement :: Int -> XML -> String -> String-renderElement n (Element name attrs children) =- let open = renderTag Open n name attrs - cs = renderChildren n children - close = renderTag Close n name []- in open . cs . close- where renderChildren :: Int -> Children -> ShowS- renderChildren n' cs = foldl (.) id $ map (renderAsHTML' (n'+2)) cs-renderElement _ _ = error "internal error: renderElement only suports the Element constructor."---renderTag :: TagType -> Int -> Name -> Attributes -> ShowS -renderTag typ n name attrs = - let (start,end) = case typ of- Open -> (showChar '<', showChar '>')- Close -> (showString "</", showChar '>')- nam = showName name- as = renderAttrs attrs- in start . nam . as . end-- where renderAttrs :: Attributes -> ShowS- renderAttrs [] = nl- renderAttrs attrs' = showChar ' ' . ats . nl- where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'--- renderAttr :: Attribute -> ShowS- renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else val)-- renderAttrVal :: String -> ShowS- renderAttrVal s = showChar '\"' . showString s . showChar '\"'-- showName (Nothing, s) = showString s- showName (Just d, s) = showString d . showChar ':' . showString s-- nl = showChar '\n' . showString (replicate n ' ')---- This list should be extended.-htmlEscapeChars :: [(Char, String)]-htmlEscapeChars = [- ('&', "amp" ),- ('\"', "quot" ),- ('<', "lt" ),- ('>', "gt" )- ]---- * Pre-defined XMLMetaData--html4Strict :: Maybe XMLMetaData-html4Strict = Just $- XMLMetaData { doctype = (True, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")- , contentType = "text/html;charset=utf-8"- , preferredRenderer = renderAsHTML- }--html4StrictFrag :: Maybe XMLMetaData-html4StrictFrag = Just $- XMLMetaData { doctype = (False, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")- , contentType = "text/html;charset=utf-8"- , preferredRenderer = renderAsHTML- }
+ src/HSP/HTML4.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : HSP.HTML4+-- Copyright : (c) Niklas Broberg, Jeremy Shaw 2008-2012+-- License : BSD-style (see the file LICENSE.txt)+--+-- Maintainer : Niklas Broberg, niklas.broberg@gmail.com+-- Stability : experimental+-- Portability : Haskell 98+--+-- Attempt to render XHTML as well-formed HTML 4.01:+--+-- 1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>+--+-- 2. the end tag is forbidden for some elements, for these we:+--+-- * render only the open tag, e.g., \<br\>+--+-- * throw an error if the tag contains children+--+-- 3. optional end tags are always rendered+--+-- Currently no validation is performed.+-----------------------------------------------------------------------------+module HSP.HTML4+ ( -- * Functions+ renderAsHTML+ , htmlEscapeChars+ -- * Predefined XMLMetaData+ , html4Strict+ , html4StrictFrag+ ) where++import Data.List (intersperse)+import Data.Monoid ((<>), mconcat)+import Data.String (fromString)+import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText)+import Data.Text.Lazy (Text)+import HSP.XML ( Attribute(..), Attributes, AttrValue(..), Children+ , Name, XML(..), XMLMetaData(..))+import HSP.XML.PCDATA (escaper)++data TagType = Open | Close++-- This list should be extended.+htmlEscapeChars :: [(Char, Builder)]+htmlEscapeChars = [+ ('&', fromString "amp" ),+ ('\"', fromString "quot" ),+ ('<', fromString "lt" ),+ ('>', fromString "gt" )+ ]++renderTag :: TagType -> Int -> Name -> Attributes -> Builder+renderTag typ n name attrs =+ let (start,end) = case typ of+ Open -> (singleton '<', singleton '>')+ Close -> (fromString "</", singleton '>')+ nam = showName name+ as = renderAttrs attrs+ in mconcat [start, nam, as, end]++ where renderAttrs :: Attributes -> Builder+ renderAttrs [] = nl+ renderAttrs attrs' = singleton ' ' <> mconcat ats <> nl+ where ats = intersperse (singleton ' ') $ fmap renderAttr attrs'+++ renderAttr :: Attribute -> Builder+ renderAttr (MkAttr (nam, (Value needsEscape val))) =+ showName nam <> singleton '=' <> renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else fromLazyText val)++ renderAttrVal :: Builder -> Builder+ renderAttrVal s = singleton '\"' <> s <> singleton '\"'++ showName (Nothing, s) = fromLazyText s+ showName (Just d, s) = fromLazyText d <> singleton ':' <> fromLazyText s++ nl = singleton '\n' <> fromString (replicate n ' ')++renderElement :: Int -> XML -> Builder+renderElement n (Element name attrs children) =+ let open = renderTag Open n name attrs+ cs = renderChildren n children+ close = renderTag Close n name []+ in open <> cs <> close+ where renderChildren :: Int -> Children -> Builder+ renderChildren n' cs = mconcat $ map (renderAsHTML' (n'+2)) cs+renderElement _ _ = error "internal error: renderElement only suports the Element constructor."++renderAsHTML' :: Int -> XML -> Builder+renderAsHTML' _ (CDATA needsEscape cd) = if needsEscape then (escaper htmlEscapeChars cd) else fromLazyText cd+renderAsHTML' n elm@(Element name@(Nothing,nm) attrs children)+ | nm == "area" = renderTagEmpty children+ | nm == "base" = renderTagEmpty children+ | nm == "br" = renderTagEmpty children+ | nm == "col" = renderTagEmpty children+ | nm == "hr" = renderTagEmpty children+ | nm == "img" = renderTagEmpty children+ | nm == "input" = renderTagEmpty children+ | nm == "link" = renderTagEmpty children+ | nm == "meta" = renderTagEmpty children+ | nm == "param" = renderTagEmpty children+ | nm == "script" = renderElement n (Element name attrs (map asCDATA children))+ | nm == "style" = renderElement n (Element name attrs (map asCDATA children))+ where+ renderTagEmpty [] = renderTag Open n name attrs+ renderTagEmpty _ = renderElement n elm -- this case should not happen in valid HTML+ -- for and script\/style, render text in element as CDATA not PCDATA+ asCDATA :: XML -> XML+ asCDATA (CDATA _ cd) = (CDATA False cd)+ asCDATA o = o -- this case should not happen in valid HTML+renderAsHTML' n e = renderElement n e++-- | Pretty-prints HTML values.+--+-- Error Handling:+--+-- Some tags (such as img) can not contain children in HTML. However,+-- there is nothing to stop the caller from passing in XML which+-- contains an img tag with children. There are three basic ways to+-- handle this:+--+-- 1. drop the bogus children silently+--+-- 2. call 'error' \/ raise an exception+--+-- 3. render the img tag with children -- even though it is invalid+--+-- Currently we are taking approach #3, since no other attempts to+-- validate the data are made in this function. Instead, you can run+-- the output through a full HTML validator to detect the errors.+--+-- #1 seems like a poor choice, since it makes is easy to overlook the+-- fact that data went missing.+--+-- We could raising errors, but you have to be in the IO monad to+-- catch them. Also, you have to use evaluate if you want to check for+-- errors. This means you can not start sending the page until the+-- whole page has been rendered. And you have to store the whole page+-- in RAM at once. Similar problems occur if we return Either+-- instead. We mostly care about catching errors and showing them in+-- the browser during testing, so perhaps this can be configurable.+--+-- Another solution would be a compile time error if an empty-only+-- tag contained children.+--+-- FIXME: also verify that the domain is correct+--+-- FIXME: what to do if a namespace is encountered+renderAsHTML :: XML -> Text+renderAsHTML xml = toLazyText $ renderAsHTML' 0 xml++-- * Pre-defined XMLMetaData++html4Strict :: Maybe XMLMetaData+html4Strict = Just $+ XMLMetaData { doctype = (True, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")+ , contentType = "text/html;charset=utf-8"+ , preferredRenderer = renderAsHTML' 0+ }++html4StrictFrag :: Maybe XMLMetaData+html4StrictFrag = Just $+ XMLMetaData { doctype = (False, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")+ , contentType = "text/html;charset=utf-8"+ , preferredRenderer = renderAsHTML' 0+ }
src/HSP/Monad.hs view
@@ -1,126 +1,83 @@-{-# LANGUAGE CPP, OverlappingInstances, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module : HSP.Data--- Copyright : (c) Niklas Broberg 2008--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, nibro@cs.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances, and forall in datatypes------ Datatypes and type classes comprising the basic model behind--- the scenes of Haskell Server Pages tags.--------------------------------------------------------------------------------module HSP.Monad (- -- * The 'HSP' Monad- HSP, HSPT, HSPT',- runHSP, evalHSP, runHSPT, evalHSPT, getEnv,- unsafeRunHSP, -- dangerous!!- -- * Functions- getParam, getIncNumber, doIO, catch,- setMetaData, withMetaData- ) where---- Monad imports--- import Control.Monad.Reader (ReaderT(..), ask, lift)-import Control.Monad.RWS (RWST(..), ask, put)-import Control.Monad.Trans (MonadIO(..), lift)--import Prelude hiding (catch)---- Exceptions-#ifdef BASE46-import qualified Control.Exception (catch)-#else-import Control.OldException (catchDyn)-#endif-import HSP.Exception--import HSP.Env--import HSP.XML-import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)------------------------------------------------------------------- The HSP Monad---- | The HSP monad is a reader wrapper around--- the IO monad, but extended with an XMLGenerator wrapper.---type HSP' = ReaderT HSPEnv IO---type HSP = XMLGenT HSP'--type HSP = HSPT IO--type HSPT' m = RWST HSPEnv () (Maybe XMLMetaData) m-type HSPT m = XMLGenT (HSPT' m)+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, OverlappingInstances, MultiParamTypeClasses, TypeFamilies #-}+module HSP.Monad where --- do NOT export this in the final version-dummyEnv :: HSPEnv-dummyEnv = undefined+import Control.Applicative (Applicative, Alternative, (<$>))+import Control.Monad.Cont (MonadCont)+import Control.Monad.Error (MonadError)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Reader (MonadReader)+import Control.Monad.Writer (MonadWriter)+import Control.Monad.State (MonadState)+import Control.Monad.Trans (MonadIO, MonadTrans(lift))+import Data.String (fromString)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as Text+import HSP.XMLGenerator (AppendChild(..), Attr(..), EmbedAsAttr(..), EmbedAsChild(..), IsName(toName), SetAttr(..), XMLGen(..), XMLGenerator)+import HSP.XML (Attribute(..), XML(..), pAttrVal, pcdata) --- | Runs a HSP computation in a particular environment. Since HSP wraps the IO monad,--- the result of running it will be an IO computation.-runHSP :: Maybe XMLMetaData -> HSP a -> HSPEnv -> IO (Maybe XMLMetaData, a)-runHSP xmd hsp hspEnv = runRWST (unXMLGenT hsp) hspEnv xmd >>= \(a,md,()) -> return (md, a)+newtype HSPT xml m a = HSPT { unHSPT :: m a }+ deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadReader r, MonadWriter w, MonadState s, MonadCont, MonadError e, MonadFix) -runHSPT :: (Monad m) => Maybe XMLMetaData -> HSPT m a -> HSPEnv -> m (Maybe XMLMetaData, a)-runHSPT xmd hsp hspEnv = runRWST (unXMLGenT hsp) hspEnv xmd >>= \(a,md,()) -> return (md, a)+instance MonadTrans (HSPT xml) where+ lift = HSPT -evalHSPT :: MonadIO m => Maybe XMLMetaData -> HSPT m a -> m (Maybe XMLMetaData, a)-evalHSPT xmd hsp = liftIO mkSimpleEnv >>= \env -> runHSPT xmd hsp env +instance (Functor m, Monad m) => (XMLGen (HSPT XML m)) where+ type XMLType (HSPT XML m) = XML+ newtype ChildType (HSPT XML m) = HSPChild { unHSPChild :: XML }+ newtype AttributeType (HSPT XML m) = HSPAttr { unHSPAttr :: Attribute }+ genElement n attrs childr =+ do as <- (map unHSPAttr . concat) <$> sequence attrs+ cs <- (map unHSPChild . concat) <$> sequence childr+ return (Element n as cs)+ xmlToChild = HSPChild+ pcdataToChild str = HSPChild (pcdata str) -evalHSP :: Maybe XMLMetaData -> HSP a -> IO (Maybe XMLMetaData, a)-evalHSP xmd hsp = mkSimpleEnv >>= \env -> runHSP xmd hsp env+instance (Functor m, Monad m) => SetAttr (HSPT XML m) XML where+ setAll xml hats =+ do attrs <- hats+ case xml of+ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n (foldr (:) as (map unHSPAttr attrs)) cs --- | Runs a HSP computation without an environment. Will work if the page in question does--- not touch the environment. Not sure about the usefulness at this stage though...-unsafeRunHSP :: HSP a -> IO (Maybe XMLMetaData, a)-unsafeRunHSP hspf = runHSP Nothing hspf dummyEnv+instance (Functor m, Monad m) => AppendChild (HSPT XML m) XML where+ appAll xml children =+ do chs <- children+ case xml of+ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n as (cs ++ (map unHSPChild chs)) --- | Execute an IO computation within the HSP monad.-doIO :: IO a -> HSP a-doIO = liftIO+instance (Functor m, Monad m) => EmbedAsChild (HSPT XML m) XML where+ asChild = return . (:[]) . HSPChild -setMetaData :: (Monad m) => (Maybe XMLMetaData) -> HSPT m ()-setMetaData xmd = lift (put xmd)+instance (Functor m, Monad m) => EmbedAsChild (HSPT XML m) [XML] where+ asChild = return . map HSPChild -withMetaData :: (Monad m) => Maybe XMLMetaData -> HSPT m a -> HSPT m a-withMetaData xmd h = do- x <- h- setMetaData xmd- return x+instance (Functor m, Monad m) => EmbedAsChild (HSPT XML m) String where+ asChild = return . (:[]) . HSPChild . pcdata . Text.pack -------------------------------------------------------------------- Environment stuff+instance (Functor m, Monad m) => EmbedAsChild (HSPT XML m) Text where+ asChild = return . (:[]) . HSPChild . pcdata --- | Supplies the HSP environment.-getEnv :: HSP HSPEnv-getEnv = lift ask+instance (Functor m, Monad m) => EmbedAsChild (HSPT XML m) Char where+ asChild = return . (:[]) . pcdataToChild . Text.singleton -getRequest :: HSP Request-getRequest = fmap getReq getEnv+instance (Functor m, Monad m) => EmbedAsChild (HSPT XML m) () where+ asChild = return . const [] -getParam :: String -> HSP (Maybe String)-getParam s = getRequest >>= \req -> return $ getParameter req s+instance (Monad m, Functor m) => EmbedAsAttr (HSPT XML m) (Attr Text Char) where+ asAttr (n := c) = asAttr (n := Text.singleton c) -getIncNumber :: HSP Int-getIncNumber = getEnv >>= doIO . incNumber . getNG+instance (Monad m, Functor m) => EmbedAsAttr (HSPT XML m) Attribute where+ asAttr = return . (:[]) . HSPAttr +instance (Functor m, Monad m) => EmbedAsAttr (HSPT XML m) (Attr Text Bool) where+ asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal $ fromString "true")+ asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal $ fromString "false") +instance (Functor m, Monad m) => EmbedAsAttr (HSPT XML m) (Attr Text Int) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal $ fromString (show i)) --------------------------------------------------------------------------- Exception handling+instance (Functor m, Monad m) => EmbedAsAttr (HSPT XML m) (Attr Text Text) where+ asAttr (n := txt) = asAttr $ MkAttr (toName n, pAttrVal txt) --- | Catch a user-caused exception.-catch :: HSP a -> (Exception -> HSP a) -> HSP a-catch (XMLGenT (RWST f)) handler = XMLGenT $ RWST $ \e s ->- f e s-#ifdef BASE46- `Control.Exception.catch`-#else- `catchDyn`-#endif- (\ex -> (let (XMLGenT (RWST g)) = handler ex- in g e s))+instance (Functor m, Monad m) => XMLGenerator (HSPT XML m)
src/HSP/XML.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : HSP.XML--- Copyright : (c) Niklas Broberg 2008+-- Copyright : (c) Niklas Broberg 2008-2012 -- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, nibro@cs.chalmers.se+--+-- Maintainer : Niklas Broberg, niklas.broberg@gmail.com -- Stability : experimental -- Portability : Haskell 98 --@@ -13,11 +13,11 @@ ----------------------------------------------------------------------------- module HSP.XML ( -- * The 'XML' datatype- XML(..), + XML(..), XMLMetaData(..),- Domain, - Name, - Attributes, + Domain,+ Name,+ Attributes, Children, pcdata, cdata,@@ -30,32 +30,61 @@ isElement, isCDATA ) where -import Data.List (intersperse)+import Data.List (intersperse)+import Data.Monoid ((<>), mconcat)+import Data.String (fromString)+import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as Text+import HSP.XML.PCDATA (escape) -import HSP.XML.PCDATA (escape) ------------------------------------------------------------------ Data types+-- Domain/Name -type Domain = Maybe String-type Name = (Domain, String)+type Domain = Maybe Text+type Name = (Domain, Text)++---------------------------------------------------------------+-- Attributes+newtype Attribute = MkAttr (Name, AttrValue)+ deriving Show++-- | Represents an attribue value.+data AttrValue = Value Bool Text++-- | Create an attribue value from a string.+attrVal, pAttrVal :: Text -> AttrValue+attrVal = Value False+pAttrVal = Value True++instance Show AttrValue where+ show (Value _ txt) = Text.unpack txt+ type Attributes = [Attribute]-type Children = [XML] +---------------------------------------------------------------+-- XML -- | The XML datatype representation. Is either an Element or CDATA.-data XML = Element Name Attributes Children- | CDATA Bool String- deriving Show+data XML+ = Element Name Attributes Children+ | CDATA Bool Text+ deriving Show +type Children = [XML]++---------------------------------------------------------------+-- XMLMetaData+ -- |The XMLMetaData datatype--- +-- -- Specify the DOCTYPE, content-type, and preferred render for XML data. -- -- See also: 'HSP.Monad.setMetaData' and 'HSP.Monad.withMetaData' data XMLMetaData = XMLMetaData- { doctype :: (Bool, String) -- ^ (show doctype when rendering, DOCTYPE string)- , contentType :: String- , preferredRenderer :: XML -> String- } + { doctype :: (Bool, Text) -- ^ (show doctype when rendering, DOCTYPE string)+ , contentType :: Text+ , preferredRenderer :: XML -> Builder+ } {- instance Show XML where show = renderXML -}@@ -67,75 +96,56 @@ isCDATA = not . isElement -- | Embeds a string as a CDATA XML value.-cdata , pcdata :: String -> XML+cdata , pcdata :: Text -> XML cdata = CDATA False pcdata = CDATA True ------------------------------------------------------------------- Attributes--newtype Attribute = MkAttr (Name, AttrValue)- deriving Show---- | Represents an attribue value.-data AttrValue = Value Bool String---- | Create an attribue value from a string.-attrVal, pAttrVal :: String -> AttrValue-attrVal = Value False-pAttrVal = Value True--instance Show AttrValue where- show (Value _ str) = str- ------------------------------------------------------------------ -- Rendering --- TODO: indents are incorrectly calculated---- | Pretty-prints XML values.-renderXML :: XML -> String-renderXML xml = renderXML' 0 xml ""- data TagType = Open | Close | Single -renderXML' :: Int -> XML -> ShowS-renderXML' _ (CDATA needsEscape cd) = showString (if needsEscape then escape cd else cd)-renderXML' n (Element name attrs []) = renderTag Single n name attrs-renderXML' n (Element name attrs children) =- let open = renderTag Open n name attrs - cs = renderChildren n children - close = renderTag Close n name []- in open . cs . close-- where renderChildren :: Int -> Children -> ShowS- renderChildren n' cs = foldl (.) id $ map (renderXML' (n'+2)) cs-- -renderTag :: TagType -> Int -> Name -> Attributes -> ShowS -renderTag typ n name attrs = +renderTag :: TagType -> Int -> Name -> Attributes -> Builder+renderTag typ n name attrs = let (start,end) = case typ of- Open -> (showChar '<', showChar '>')- Close -> (showString "</", showChar '>')- Single -> (showChar '<', showString "/>")+ Open -> (singleton '<', singleton '>')+ Close -> (fromString "</", singleton '>')+ Single -> (singleton '<', fromString "/>") nam = showName name as = renderAttrs attrs- in start . nam . as . end+ in mconcat [start, nam, as, end] - where renderAttrs :: Attributes -> ShowS+ where renderAttrs :: Attributes -> Builder renderAttrs [] = nl- renderAttrs attrs' = showChar ' ' . ats . nl- where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'+ renderAttrs attrs' = singleton ' ' <> mconcat ats <> nl+ where ats = intersperse (singleton ' ') $ fmap renderAttr attrs' + renderAttr :: Attribute -> Builder+ renderAttr (MkAttr (nam, (Value needsEscape val))) =+ showName nam <> singleton '=' <> renderAttrVal (if needsEscape then escape val else fromLazyText val) - renderAttr :: Attribute -> ShowS- renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal (if needsEscape then escape val else val)+ renderAttrVal :: Builder -> Builder+ renderAttrVal txt = singleton '\"' <> txt <> singleton '\"' - renderAttrVal :: String -> ShowS- renderAttrVal s = showChar '\"' . showString s . showChar '\"'+ showName (Nothing, s) = fromLazyText s+ showName (Just d, s) = fromLazyText d <> singleton ':' <> fromLazyText s - showName (Nothing, s) = showString s- showName (Just d, s) = showString d . showChar ':' . showString s+ nl = singleton '\n' <> fromString (replicate n ' ') - nl = showChar '\n' . showString (replicate n ' ')+renderXML' :: Int -> XML -> Builder+renderXML' _ (CDATA needsEscape cd) = if needsEscape then escape cd else fromLazyText cd+renderXML' n (Element name attrs []) = renderTag Single n name attrs+renderXML' n (Element name attrs children) =+ let open = renderTag Open n name attrs+ cs = renderChildren n children+ close = renderTag Close n name []+ in open <> cs <> close + where renderChildren :: Int -> Children -> Builder+ renderChildren n' cs = mconcat $ map (renderXML' (n'+2)) cs++-- TODO: indents are incorrectly calculated++-- | Pretty-prints XML values.+renderXML :: XML -> Text+renderXML xml = toLazyText $ renderXML' 0 xml
src/HSP/XML/PCDATA.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : HSP.XML.PCDATA--- Copyright : (c) Niklas Broberg 2008+-- Copyright : (c) Niklas Broberg 2008-2012 -- License : BSD-style (see the file LICENSE.txt)--- +-- -- Maintainer : Niklas Broberg, nibro@cs.chalmers.se -- Stability : experimental -- Portability : Haskell 98@@ -11,38 +12,50 @@ -- Escaping between CDATA <=> PCDATA ----------------------------------------------------------------------------- module HSP.XML.PCDATA (- escape -- :: String -> String- , unescape -- :: String -> String+ escape+-- , unescape , escaper- , unescaper+-- , unescaper , xmlEscapeChars ) where +import Data.Monoid ((<>), mempty)+import Data.Text.Lazy (Text, uncons)+import qualified Data.Text.Lazy as Text+import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton) -- | Take a normal string and transform it to PCDATA by escaping special characters. -- calls 'escaper' with 'xmlEscapeChars' -- See also: 'escaper'-escape :: String -> String+escape :: Text -> Builder escape = escaper xmlEscapeChars -- | Take a normal string and transform it to PCDATA by escaping special characters. -- See also: 'escape', 'xmlEscapeChars'-escaper :: [(Char, String)] -- ^ table of escape characters- -> String -- ^ String to escape- -> String -- ^ Escaped String-escaper _ [] = ""-escaper escapeChars (c:cs) = pChar escapeChars c ++ escaper escapeChars cs+escaper :: [(Char, Builder)] -- ^ table of escape characters+ -> Text -- ^ String to escape+ -> Builder -- ^ Escaped String+escaper escapeTable = go+ where+ escapeChars = map fst escapeTable+ go txt | Text.null txt = mempty+ go txt =+ case Text.break (`elem` escapeChars) txt of+ (hd,tl) ->+ case uncons tl of+ Nothing -> fromLazyText hd+ (Just (c, tl')) -> fromLazyText hd <> pChar escapeTable c <> go tl' -pChar :: [(Char, String)] -- ^ table of escape characters- -> Char -- ^ character to escape- -> String -- ^ escaped character-pChar escapeChars c = +pChar :: [(Char, Builder)] -- ^ table of escape characters+ -> Char -- ^ character to escape+ -> Builder -- ^ escaped character+pChar escapeChars c = case lookup c escapeChars of- Nothing -> [c]- Just s -> '&' : s ++ ";"+ Nothing -> singleton c+ Just s -> singleton '&' <> s <> singleton ';' -- This list should be extended.-xmlEscapeChars :: [(Char, String)]+xmlEscapeChars :: [(Char, Builder)] xmlEscapeChars = [ ('&', "amp" ), ('\"', "quot" ),@@ -50,7 +63,7 @@ ('<', "lt" ), ('>', "gt" ) ]-+{- -- | Take a PCDATA string and translate all escaped characters in it to the normal -- characters they represent. -- Does no error checking of input string, will fail if input is not valid PCDATA.@@ -63,16 +76,17 @@ -- characters they represent. -- Does no error checking of input string, will fail if input is not valid PCDATA. -- See also: 'unescape', 'xmlEscapeChars'-unescaper :: [(Char, String)] -- ^ table of escape characters- -> String -- ^ String to unescape- -> String -- ^ unescaped String+unescaper :: [(Char, Builder)] -- ^ table of escape characters+ -> Text -- ^ String to unescape+ -> Builder -- ^ unescaped String unescaper escapeChars = reverse . unE "" where unE acc "" = acc- unE acc (c:cs) = + unE acc (c:cs) = case c of '&' -> let (esc, ';':rest) = break (==';') cs Just ec = revLookup esc escapeChars in unE (ec:acc) rest _ -> unE (c:acc) cs- + revLookup e = lookup e . map (\(a,b) -> (b,a))+-}
src/HSP/XMLGenerator.hs view
@@ -1,392 +1,244 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverlappingInstances, PatternGuards, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} -{-# OPTIONS_GHC -F -pgmFtrhsx #-} -module HSP.XMLGenerator ( - -- * Type classes --- IsXML(..), --- IsXMLs(..), - IsAttrValue(..), --- IsAttribute(..), - - extract, - - module HSX.XMLGenerator, genElement, genEElement - - ) where - -import HSP.Monad -import HSP.XML hiding (Name) - -import HSX.XMLGenerator --hiding (XMLGen(..)) ---import qualified HSX.XMLGenerator as HSX (XMLGen(..)) - ---import Control.Monad (liftM) -import Control.Monad.Trans (lift) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - ---import Data.List (intersperse) - ---------------------------------------------- --- Instantiating XMLGenerator for the HSP monad. - --- | We can use literal XML syntax to generate values of type XML in the HSP monad. -instance Monad m => XMLGen (HSPT' m) where - type XMLType (HSPT' m) = XML - newtype AttributeType (HSPT' m) = HSPAttr Attribute - newtype ChildType (HSPT' m) = HSPChild XML - xmlToChild = HSPChild - pcdataToChild = xmlToChild . pcdata - genElement = element - genEElement = eElement - -instance Monad m => XMLGenerator (HSPT' m) - -{- -instance (Monad m, m c) => EmbedAsChild (HSPT' m) c where - asChild = liftM (map HSX.xmlToChild) . toXMLs --} -------------------------------------------------------------------- --- Type classes - -------------- --- IsXML -{- --- | Instantiate this class to enable values of the given type --- to appear as XML elements. -class IsXML a where - toXML :: a -> HSP XML - --- | XML can naturally be represented as XML. -instance IsXML XML where - toXML = return - --- | Strings should be represented as PCDATA. -instance IsXML String where - toXML = return . pcdata - --- | Anything that can be shown can always fall back on --- that as a default behavior. -instance (Show a) => IsXML a where - toXML = toXML . show - --- | An IO computation returning something that can be represented --- as XML can be lifted into an analogous HSP computation. -instance (IsXML a) => IsXML (IO a) where - toXML = toXML . doIO - --- | An HSP computation returning something that can be represented --- as XML simply needs to turn the produced value into XML. -instance (IsXML a) => IsXML (HSP a) where - toXML hspa = hspa >>= toXML - --} -------------- --- IsXMLs -{- --- | Instantiate this class to enable values of the given type --- to be represented as a list of XML elements. Note that for --- any given type, only one of the two classes IsXML and IsXMLs --- should ever be instantiated. Values of types that instantiate --- IsXML can automatically be represented as a (singleton) list --- of XML children. -class Monad m => IsXMLs m a where - toXMLs :: a -> HSPT m [XML] - --- | Anything that can be represented as a single XML element --- can of course be represented as a (singleton) list of XML --- elements. ---instance (IsXML a) => IsXMLs a where --- toXMLs a = do xml <- toXML a --- return [xml] - --- | XML can naturally be represented as XML. -instance Monad m => IsXMLs m XML where - toXMLs = return . return --} - --- | We must specify an extra rule for Strings even though the previous --- rule would apply, because the rule for [a] would also apply and --- would be more specific. ---instance Monad m => IsXMLs m String where --- toXMLs s = return [pcdata s] +{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, + FlexibleContexts, FlexibleInstances, UndecidableInstances, + TypeSynonymInstances, GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : HSX.XMLGenerator +-- Copyright : (c) Niklas Broberg 2008 +-- License : BSD-style (see the file LICENSE.txt) +-- +-- Maintainer : Niklas Broberg, niklas.broberg@chalmers.se +-- Stability : experimental +-- Portability : requires newtype deriving and MPTCs with fundeps +-- +-- The class and monad transformer that forms the basis of the literal XML +-- syntax translation. Literal tags will be translated into functions of +-- the GenerateXML class, and any instantiating monads with associated XML +-- types can benefit from that syntax. +----------------------------------------------------------------------------- +module HSP.XMLGenerator where --- instance Monad m => EmbedAsChild (HSPT' m) String where --- asChild = asChild . pcdata +import Control.Applicative (Applicative, Alternative) +import Control.Monad.Trans (MonadTrans(lift), MonadIO) +import Control.Monad.Cont (MonadCont) +import Control.Monad.Error (MonadError) +import Control.Monad.Reader(MonadReader) +import Control.Monad.Writer(MonadWriter) +import Control.Monad.State (MonadState) +import Control.Monad.RWS (MonadRWS) +import Control.Monad (MonadPlus(..),liftM) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as Text -instance Monad m => EmbedAsChild (HSPT' m) Char where - asChild = asChild . (:[]) +---------------------------------------------- +-- General XML Generation -instance (Monad m, Functor m) => (EmbedAsChild (HSPT' m) TL.Text) where - asChild = asChild . TL.unpack +-- | The monad transformer that allows a monad to generate XML values. +newtype XMLGenT m a = XMLGenT (m a) + deriving (Applicative, Alternative, Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r, + MonadState s, MonadRWS r w s, MonadCont, MonadError e) -instance (Monad m, Functor m) => (EmbedAsChild (HSPT' m) T.Text) where - asChild = asChild . T.unpack +-- | un-lift. +unXMLGenT :: XMLGenT m a -> m a +unXMLGenT (XMLGenT ma) = ma -{- --- | If something can be represented as a list of XML, then a list of --- that something can also be represented as a list of XML. -instance (IsXMLs m a, Monad m) => IsXMLs m [a] where - toXMLs as = do xmlss <- mapM toXMLs as - return $ concat xmlss --} +-- | map the inner monad +mapXMLGenT :: (m a -> n b) -> XMLGenT m a -> XMLGenT n b +mapXMLGenT f (XMLGenT m) = XMLGenT (f m) --- | An IO computation returning something that can be represented --- as a list of XML can be lifted into an analogous HSP computation. ---instance (IsXMLs IO a) => IsXMLs IO (IO a) where --- toXMLs ma = lift (lift ma) >>= toXMLs +instance MonadTrans XMLGenT where + lift = XMLGenT -instance (EmbedAsChild (HSPT' IO) a) => EmbedAsChild (HSPT' IO) (IO a) where - asChild ma = lift (lift ma) >>= asChild -{- --- | Any child elements that arise through the use of literal syntax should be of the same --- type as the parent element, unless explicitly given a different type. We use TypeCast --- to accomplish this. This also captures the case when the embedded value is an HSP computation. -instance (IsXMLs m1 x, TypeCast (m x) (HSPT' m1 x)) => IsXMLs m1 (XMLGenT m x) where - toXMLs (XMLGenT x) = (XMLGenT $ typeCast x) >>= toXMLs --} +type Name = (Maybe Text, Text) --- | Of the base types, () stands out as a type that can only be --- represented as a (empty) list of XML. ---instance Monad m => IsXMLs m () where --- toXMLs _ = return [] +-- | Generate XML values in some XMLGenerator monad. +class Monad m => XMLGen m where + type XMLType m + data ChildType m + data AttributeType m + genElement :: Name -> [XMLGenT m [AttributeType m]] -> [XMLGenT m [ChildType m]] -> XMLGenT m (XMLType m) + genEElement :: Name -> [XMLGenT m [AttributeType m]] -> XMLGenT m (XMLType m) + genEElement n ats = genElement n ats [] + xmlToChild :: XMLType m -> ChildType m + pcdataToChild :: Text -> ChildType m -instance Monad m => EmbedAsChild (HSPT' m) () where - asChild () = return [] +-- | Type synonyms to avoid writing out the XMLnGenT all the time +type GenXML m = XMLGenT m (XMLType m) +type GenXMLList m = XMLGenT m [XMLType m] +type GenChild m = XMLGenT m (ChildType m) +type GenChildList m = XMLGenT m [ChildType m] +type GenAttribute m = XMLGenT m (AttributeType m) +type GenAttributeList m = XMLGenT m [AttributeType m] +-- | Embed values as child nodes of an XML element. The parent type will be clear +-- from the context so it is not mentioned. +class XMLGen m => EmbedAsChild m c where + asChild :: c -> GenChildList m --- | Maybe types are handy for cases where you might or might not want --- to generate XML, such as null values from databases ---instance (IsXMLs m a, Monad m) => IsXMLs m (Maybe a) where --- toXMLs Nothing = return [] --- toXMLs (Just a) = toXMLs a +#if __GLASGOW_HASKELL__ >= 610 +instance (EmbedAsChild m c, m ~ n) => EmbedAsChild m (XMLGenT n c) where + asChild m = asChild =<< m +#else +instance (EmbedAsChild m c, TypeCastM m1 m) => EmbedAsChild m (XMLGenT m1 c) where + asChild (XMLGenT m1a) = do + a <- XMLGenT $ typeCastM m1a + asChild a +#endif -instance (Monad m, EmbedAsChild (HSPT' m) a) => EmbedAsChild (HSPT' m) (Maybe a) where - asChild Nothing = return [] - asChild (Just a) = asChild a +instance EmbedAsChild m c => EmbedAsChild m [c] where + asChild = liftM concat . mapM asChild -{- -instance Monad m => IsXMLs m (HSX.Child (HSPT' m)) where - toXMLs (HSPChild x) = toXMLs x --} +instance XMLGen m => EmbedAsChild m (ChildType m) where + asChild = return . return --- This instance should already be there, probably doesn't work due --- to type families not being fully supported yet. -instance Monad m => EmbedAsChild (HSPT' m) XML where +#if __GLASGOW_HASKELL__ >= 610 +instance (XMLGen m, XMLType m ~ x) => EmbedAsChild m x where +#else +instance (XMLGen m) => EmbedAsChild m (XMLType m) where +#endif asChild = return . return . xmlToChild ---------------- --- IsAttrValue --- | Instantiate this class to enable values of the given type --- to appear as XML attribute values. -class Monad m => IsAttrValue m a where - toAttrValue :: a -> HSPT m AttrValue - --- | An AttrValue is trivial. -instance Monad m => IsAttrValue m AttrValue where - toAttrValue = return - --- | Strings can be directly represented as values. -instance Monad m => IsAttrValue m String where - toAttrValue = return . pAttrVal - -instance (Monad m) => IsAttrValue m T.Text where - toAttrValue = toAttrValue . T.unpack - -instance (Monad m) => IsAttrValue m TL.Text where - toAttrValue = toAttrValue . TL.unpack - -instance Monad m => IsAttrValue m Int where - toAttrValue = toAttrValue . show +instance XMLGen m => EmbedAsChild m String where + asChild = return . return . pcdataToChild . Text.pack --- Yeah yeah, map toLower . show, but I'm too --- lazy to go import Data.Char -instance Monad m => IsAttrValue m Bool where - toAttrValue True = toAttrValue "true" - toAttrValue False = toAttrValue "false" +instance XMLGen m => EmbedAsChild m Text where + asChild = return . return . pcdataToChild --- | Anything that can be shown can always fall back on --- that as a default behavior. ---instance (Monad m, Show a) => IsAttrValue m a where --- toAttrValue = toAttrValue . show +instance XMLGen m => EmbedAsChild m () where + asChild _ = return [] --- | An IO computation returning something that can be represented --- as an attribute value can be lifted into an analogous HSP computation. -instance IsAttrValue IO a => IsAttrValue IO (IO a) where - toAttrValue ma = lift (lift ma) >>= toAttrValue +data Attr n a = n := a + deriving Show --- | An HSP computation returning something that can be represented --- as a list of XML simply needs to turn the produced value into --- a list of XML. -instance IsAttrValue m a => IsAttrValue m (HSPT m a) where - toAttrValue hspa = hspa >>= toAttrValue +-- | Similarly embed values as attributes of an XML element. +class XMLGen m => EmbedAsAttr m a where + asAttr :: a -> GenAttributeList m -{-- | The common way to present list data in attributes is as --- a comma separated, unbracketed sequence -instance (Monad m, IsAttrValue m a) => IsAttrValue m [a] where - toAttrValue as = do [/ (Value vs)* /] <- mapM toAttrValue as - return . Value $ concat $ intersperse "," vs --} ------------------------------------------------------------------------ --- Manipulating attributes -{- --- | Just like with XML children, we want to conveniently allow values of various --- types to appear as attributes. -class Monad m => IsAttribute m a where - toAttribute :: a -> HSPT m Attribute --} --- | Attributes can represent attributes. ---instance Monad m => IsAttribute m Attribute where --- toAttribute = return +instance (XMLGen m, EmbedAsAttr m a) => EmbedAsAttr m (XMLGenT m a) where + asAttr ma = ma >>= asAttr -instance Monad m => EmbedAsAttr (HSPT' m) Attribute where - asAttr = return . return . HSPAttr +instance (EmbedAsAttr m (Attr a v), TypeCastM m1 m) => EmbedAsAttr m (Attr a (XMLGenT m1 v)) where + asAttr (a := (XMLGenT m1a)) = do + v <- XMLGenT $ typeCastM m1a + asAttr (a := v) +instance XMLGen m => EmbedAsAttr m (AttributeType m) where + asAttr = return . return --- | Values of the Attr type, constructed with :=, can represent attributes. ---instance (IsName n, IsAttrValue m a) --- => IsAttribute m (Attr n a) where --- toAttribute (n := a) = do av <- toAttrValue a --- return $ MkAttr (toName n, av) +instance EmbedAsAttr m a => EmbedAsAttr m [a] where + asAttr = liftM concat . mapM asAttr -instance (IsName n, IsAttrValue m a) => EmbedAsAttr (HSPT' m) (Attr n a) where - asAttr (n := a) = do - av <- toAttrValue a - asAttr $ MkAttr (toName n, av) +class ( XMLGen m + , SetAttr m (XMLType m) + , AppendChild m (XMLType m) + , EmbedAsChild m (XMLType m) + , EmbedAsChild m [XMLType m] + , EmbedAsChild m Text + , EmbedAsChild m Char -- for overlap purposes + , EmbedAsChild m () + , EmbedAsAttr m (Attr Text Text) + , EmbedAsAttr m (Attr Text Int) + , EmbedAsAttr m (Attr Text Bool) + ) => XMLGenerator m {- --- | Attributes can be the result of an HSP computation. -instance IsAttribute m a => IsAttribute m (HSPT m a) where - toAttribute hspa = hspa >>= toAttribute +-- This is certainly true, but we want the various generators to explicitly state it, +-- in order to get the error messages right. +instance ( XMLGen m + , SetAttr m (XMLType m) + , AppendChild m (XMLType m) + , EmbedAsChild m (XMLType m) + , EmbedAsChild m [XMLType m] + , EmbedAsChild m Text + , EmbedAsChild m Char + , EmbedAsChild m () + , EmbedAsAttr m (Attr Text Text) + , EmbedAsAttr m (Attr Text Int) + , EmbedAsAttr m (Attr Text Bool) + ) => XMLGenerator m -} --- | ... or of an IO computation. ---instance IsAttribute IO a => IsAttribute IO (IO a) where --- toAttribute ma = lift (lift ma) >>= toAttribute +------------------------------------- +-- Setting attributes -instance (EmbedAsAttr (HSPT' IO) a) => EmbedAsAttr (HSPT' IO) (IO a) where - asAttr ma = lift (lift ma) >>= asAttr +-- | Set attributes on XML elements +class XMLGen m => SetAttr m elem where + setAttr :: elem -> GenAttribute m -> GenXML m + setAll :: elem -> GenAttributeList m -> GenXML m + setAttr e a = setAll e $ liftM return a -{- -instance Monad m => IsAttribute m (HSX.Attribute (HSPT' m)) where - toAttribute (HSPAttr a) = toAttribute a +(<@), set :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> attr -> GenXML m +set xml attr = setAll xml (asAttr attr) +(<@) = set --- | Anything that can represent an attribute can also be embedded as attributes --- using the literal XML syntax. -instance (IsAttribute m a) => EmbedAsAttr (HSPT' m) a where - asAttr = fmap HSPAttr . toAttribute +(<<@) :: (SetAttr m elem, EmbedAsAttr m a) => elem -> [a] -> GenXML m +xml <<@ ats = setAll xml (liftM concat $ mapM asAttr ats) --} ------------------------------------------ --- SetAttr and AppendChild +instance (TypeCastM m1 m, SetAttr m x) => + SetAttr m (XMLGenT m1 x) where + setAll (XMLGenT m1x) ats = (XMLGenT $ typeCastM m1x) >>= (flip setAll) ats --- | Set attributes. -instance Monad m => SetAttr (HSPT' m) XML where - setAll xml hats = do - attrs <- hats - case xml of - CDATA _ _ -> return xml - Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs +------------------------------------- +-- Appending children -{- -instance (Monad m1, TypeCast (m x) (HSPT' m1 XML)) - => SetAttr (HSPT' m1) (XMLGenT m x) where - setAll (XMLGenT hxml) ats = (XMLGenT $ typeCast hxml) >>= \xml -> setAll xml ats --} +class XMLGen m => AppendChild m elem where + appChild :: elem -> GenChild m -> GenXML m + appAll :: elem -> GenChildList m -> GenXML m + appChild e c = appAll e $ liftM return c --- | Append children. -instance Monad m => AppendChild (HSPT' m) XML where - appAll xml children = do - chs <- children - case xml of - CDATA _ _ -> return xml - Element n as cs -> return $ Element n as (cs ++ (map stripChild chs)) +(<:), app :: (AppendChild m elem, EmbedAsChild m c) => elem -> c -> GenXML m +app xml c = appAll xml $ asChild c +(<:) = app -{- -instance (Monad m1, TypeCast (m x) (HSPT' m1 XML)) - => AppendChild (HSPT' m1) (XMLGenT m x) where - appAll (XMLGenT hxml) chs = (XMLGenT $ typeCast hxml) >>= (flip appAll) chs --} ---------------- --- GetAttrValue +(<<:) :: (AppendChild m elem, EmbedAsChild m c) => elem -> [c] -> GenXML m +xml <<: chs = appAll xml (liftM concat $ mapM asChild chs) --- | Instantiate this class to enable values of the given type --- to be retrieved through attribute patterns. -class GetAttrValue a where - fromAttrValue :: AttrValue -> a +instance (AppendChild m x, TypeCastM m1 m) => + AppendChild m (XMLGenT m1 x) where + appAll (XMLGenT m1x) chs = (XMLGenT $ typeCastM m1x) >>= (flip appAll) chs --- | An AttrValue is trivial. -instance GetAttrValue AttrValue where - fromAttrValue = id +------------------------------------- +-- Names --- | Strings can be directly taken from values. -instance GetAttrValue String where - fromAttrValue (Value _ s) = s - --- | Anything that can be read can always fall back on --- that as a default behavior. -instance (Read a) => GetAttrValue a where - fromAttrValue = read . fromAttrValue +-- | Names can be simple or qualified with a domain. We want to conveniently +-- use both simple strings or pairs wherever a Name is expected. +class Show n => IsName n where + toName :: n -> Name --- | An IO computation returning something that can be represented --- as an attribute value can be lifted into an analogous HSP computation. ---instance (GetAttrValue a, Monad m) => GetAttrValue (m a) where --- fromAttrValue = return . fromAttrValue +-- | Names can represent names, of course. +instance IsName Name where + toName = id --- | The common way to present list data in attributes is as --- a comma separated, unbracketed sequence -instance (GetAttrValue a) => GetAttrValue [a] where - fromAttrValue v@(Value needsEscape str) = case str of - [ v1+, (| ',', vs@:(_+) |)+ ] -> - map (fromAttrValue . Value needsEscape) (v1:vs) - _ -> [fromAttrValue v] +-- | Strings can represent names, meaning a simple name with no domain. +instance IsName String where + toName s = (Nothing, Text.pack s) --- All that for these two functions -extract :: (GetAttrValue a) => Name -> Attributes -> (Maybe a, Attributes) -extract _ [] = (Nothing, []) -extract name (p@(MkAttr (n, v)):as) - | name == n = (Just $ fromAttrValue v, as) - | otherwise = let (val, attrs) = extract name as - in (val, p:attrs) +-- | Pairs of strings can represent names, meaning a name qualified with a domain. +instance IsName (String, String) where + toName (ns, s) = (Just $ Text.pack ns, Text.pack s) --------------------------------------------------------------------- --- The base XML generation, corresponding to the use of the literal --- XML syntax. +-- | Strings can represent names, meaning a simple name with no domain. +instance IsName Text where + toName s = (Nothing, s) --- | Generate an XML element from its components. -element :: (IsName n, - EmbedAsChild (HSPT' m) xmls, - EmbedAsAttr (HSPT' m) at) - => n -> [at] -> xmls -> HSPT m XML -element n attrs xmls = do - cxml <- asChild xmls - attribs <- asAttr attrs - return $ Element (toName n) - (foldr insert eAttrs $ map stripAttr attribs) - (flattenCDATA $ map stripChild cxml) - - where flattenCDATA :: [XML] -> [XML] - flattenCDATA cxml = - case flP cxml [] of - [] -> [] - [CDATA _ ""] -> [] - xs -> xs - flP :: [XML] -> [XML] -> [XML] - flP [] bs = reverse bs - flP [x] bs = reverse (x:bs) - flP (x:y:xs) bs = case (x,y) of - (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs - _ -> flP (y:xs) (x:bs) +-- | Pairs of strings can represent names, meaning a name qualified with a domain. +instance IsName (Text, Text) where + toName (ns, s) = (Just $ ns, s) -stripAttr :: AttributeType (HSPT' m) -> Attribute -stripAttr (HSPAttr a) = a -stripChild :: ChildType (HSPT' m) -> XML -stripChild (HSPChild c) = c +--------------------------------------- +-- TypeCast, in lieu of ~ constraints -eAttrs :: Attributes -eAttrs = [] -insert :: Attribute -> Attributes -> Attributes -insert = (:) +-- literally lifted from the HList library +class TypeCast a b | a -> b, b -> a where typeCast :: a -> b +class TypeCast' t a b | t a -> b, t b -> a where typeCast' :: t->a->b +class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b +instance TypeCast' () a b => TypeCast a b where typeCast x = typeCast' () x +instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast'' +instance TypeCast'' () a a where typeCast'' _ x = x --- | Generate an empty XML element. -eElement :: (IsName n, Monad m, EmbedAsAttr (HSPT' m) at) => n -> [at] -> HSPT m XML -eElement n attrs = element n attrs ([] :: [XML]) +class TypeCastM ma mb | ma -> mb, mb -> ma where typeCastM :: ma x -> mb x +class TypeCastM' t ma mb | t ma -> mb, t mb -> ma where typeCastM' :: t -> ma x -> mb x +class TypeCastM'' t ma mb | t ma -> mb, t mb -> ma where typeCastM'' :: t -> ma x -> mb x +instance TypeCastM' () ma mb => TypeCastM ma mb where typeCastM mx = typeCastM' () mx +instance TypeCastM'' t ma mb => TypeCastM' t ma mb where typeCastM' = typeCastM'' +instance TypeCastM'' () ma ma where typeCastM'' _ x = x