packages feed

hsp 0.4 → 0.4.4

raw patch · 22 files changed

+1062/−848 lines, 22 filesdep ~HJScriptdep ~hsx

Dependency ranges changed: HJScript, hsx

Files

− HSP.hs 
@@ -1,28 +0,0 @@-module HSP (
-        -- module HSP.Monad
-        HSP, runHSP, evalHSP,
-        getParam, getIncNumber, doIO, catch,
-        
-        -- module HSP.Env
-        module HSP.Env,
-        
-        -- module HSP.XML[.PCDATA]
-        module HSP.XML,
-        module HSP.XML.PCDATA,
-        
-        -- module HSP.XMLGenerator
-        module HSP.XMLGenerator,
-        
-        -- module HSP.HJScript
-        module HSP.HJScript
-
-    ) where
-
-import Prelude hiding (catch)
-
-import HSP.Monad
-import HSP.Env hiding (mkSimpleEnv)
-import HSP.XML hiding (Name)
-import HSP.XML.PCDATA
-import HSP.XMLGenerator
-import HSP.HJScript
− 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
− HSP/Env/NumberGen.hs 
@@ -1,3 +0,0 @@-module HSP.Env.NumberGen where
-
-data NumberGen = NumberGen { incNumber :: IO Int }
− 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
− HSP/Exception.hs 
@@ -1,32 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- 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-import Control.Exception (throwDyn)--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)---- Internal funcion that throws a dynamic exception particular to HSP.-throwHSP :: Exception -> a-throwHSP = throwDyn-
− HSP/HJScript.hs 
@@ -1,110 +0,0 @@-module HSP.HJScript where
-
-import HSP
-import HJScript
-
-import qualified HSX.XMLGenerator as HSX
-
-instance IsXMLs (Block ()) where
-  toXMLs b = toXMLs $
-    <script language="JavaScript">
-      <% cdata (show b) %>
-    </script>
-
-instance IsXMLs (HJScript ()) where
-  toXMLs script = toXMLs . snd $ evalHJScript script 0
-
-instance IsAttrValue (HJScript ()) where
-  toAttrValue script = do
-    let block = snd $ evalHJScript script 0
-    return . Value $ "javascript:" ++ show block
-
-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 :: (HSX.SetAttr m xml, HSX.EmbedAsAttr (Attr String v) (HSX.XMLGenT m (HSX.Attribute m))) 
-        => xml -> v -> HSX.XMLGenT m (HSX.XML m)
-setId x v = x `set` ("id" := v)
-
-
-
--- Generel method for adding 'onEvent' attributes to XML elements.
---onEvent :: SetAttr xml (Attr String (HJScript ())) => Event -> xml -> HJScript () -> SetResult xml
-onEvent :: (HSX.SetAttr m xml, HSX.EmbedAsAttr (Attr String (HJScript ())) (HSX.XMLGenT m (HSX.Attribute m)))
-        => Event -> xml -> HJScript () -> HSX.XMLGenT m (HSX.XML 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 :: 
-    (HSX.SetAttr m xml, HSX.EmbedAsAttr (Attr String (HJScript ())) (HSX.XMLGenT m (HSX.Attribute m)))
-        => xml -> HJScript () -> HSX.XMLGenT m (HSX.XML 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
− HSP/Monad.hs 
@@ -1,95 +0,0 @@-{-# OPTIONS_GHC -fallow-overlapping-instances #-}-{-# OPTIONS_GHC -fallow-undecidable-instances #-}-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- 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, HSP',-	runHSP, evalHSP,-        unsafeRunHSP,  -- dangerous!!-	-- * Functions-	getParam, getIncNumber, doIO, catch-	) where---- Monad imports-import Control.Monad.Reader (ReaderT(..), ask, lift)-import Control.Monad.Trans (MonadIO(..))--import Prelude hiding (catch)---- Exceptions-import Control.Exception (catchDyn)-import HSP.Exception--import HSP.Env--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'---- do NOT export this in the final version-dummyEnv :: HSPEnv-dummyEnv = undefined---- | 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 :: HSP a -> HSPEnv -> IO a-runHSP = runReaderT . unXMLGenT--evalHSP :: HSP a -> IO a-evalHSP hsp = mkSimpleEnv >>= runHSP hsp ---- | 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 a-unsafeRunHSP hspf = runHSP hspf dummyEnv---- | Execute an IO computation within the HSP monad.-doIO :: IO a -> HSP a-doIO = liftIO--------------------------------------------------------------------- Environment stuff---- | Supplíes the HSP environment.-getEnv :: HSP HSPEnv-getEnv = lift ask--getRequest :: HSP Request-getRequest = fmap getReq getEnv--getParam :: String -> HSP (Maybe String)-getParam s = getRequest >>= \req -> return $ getParameter req s--getIncNumber :: HSP Int-getIncNumber = getEnv >>= doIO . incNumber . getNG------------------------------------------------------------------------------ Exception handling---- | Catch a user-caused exception.-catch :: HSP a -> (Exception -> HSP a) -> HSP a-catch (XMLGenT (ReaderT f)) handler = XMLGenT $ ReaderT $ \e ->-	f e `catchDyn` (\ex -> (let (XMLGenT (ReaderT g)) = handler ex-				 in g e))
− HSP/XML.hs 
@@ -1,128 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  HSP.XML--- Copyright   :  (c) Niklas Broberg 2008--- License     :  BSD-style (see the file LICENSE.txt)--- --- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se--- Stability   :  experimental--- Portability :  Haskell 98------ Datatypes and type classes comprising the basic model behind--- the scenes of Haskell Server Pages tags.-------------------------------------------------------------------------------module HSP.XML (-	-- * The 'XML' datatype-	XML(..), -	Domain, -	Name, -	Attributes, -	Children,-	pcdata,-	cdata,-	-- * The Attribute type-	Attribute,-	AttrValue(..),-	attrVal, pAttrVal,-	-- * Functions-	renderXML,-	isElement, isCDATA-	) where--import Data.List (intersperse)--import HSP.XML.PCDATA (escape)------------------------------------------------------------------- Data types--type Domain = Maybe String-type Name = (Domain, String)-type Attributes = [Attribute]-type Children = [XML]---- | The XML datatype representation. Is either an Element or CDATA.-data XML = Element Name Attributes Children-	 | CDATA String-  deriving Show--{- instance Show XML where- show = renderXML -}---- | Test whether an XML value is an Element or CDATA-isElement, isCDATA :: XML -> Bool-isElement (Element {}) = True-isElement _ = False-isCDATA = not . isElement---- | Embeds a string as a CDATA XML value.-cdata , pcdata :: String -> XML-cdata  = CDATA-pcdata = cdata . escape-------------------------------------------------------------------- Attributes--type Attribute = (Name, AttrValue)---- | Represents an attribue value.-newtype AttrValue = Value String---- | Create an attribue value from a string.-attrVal, pAttrVal :: String -> AttrValue-attrVal  = Value-pAttrVal = attrVal . escape--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 cd) = showString 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 = -	let (start,end) = case typ of-			   Open   -> (showChar '<', showChar '>')-		     	   Close  -> (showString "</", showChar '>')-		     	   Single -> (showChar '<', showString "/>")-	    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 (nam, (Value val)) = showName nam . showChar '=' . renderAttrVal 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 ' ')-
− HSP/XML/PCDATA.hs 
@@ -1,52 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  HSP.XML.PCDATA--- Copyright   :  (c) Niklas Broberg 2008--- License     :  BSD-style (see the file LICENSE.txt)--- --- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se--- Stability   :  experimental--- Portability :  Haskell 98------ Escaping between CDATA <=> PCDATA-------------------------------------------------------------------------------module HSP.XML.PCDATA (-	  escape	-- :: String -> String-	, unescape	-- :: String -> String-	) where----- | Take a normal string and transform it to PCDATA by escaping special characters.-escape :: String -> String-escape [] = ""-escape (c:cs) = pChar c ++ escape cs--pChar :: Char -> String-pChar c = case lookup c escapeChars of-	   Nothing -> [c]-	   Just s  -> '&' : s ++ ";"---- This list should be extended.-escapeChars :: [(Char, String)]-escapeChars = [-	('&',	"amp"	),-	('\"',	"quot"	),-	('\'',	"apos"	),-	('<',	"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.-unescape :: String -> String-unescape = reverse . unE ""-  where unE acc "" = acc-  	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))
− HSP/XMLGenerator.hs 
@@ -1,310 +0,0 @@-module HSP.XMLGenerator (
-        -- * Type classes
-        IsXML(..), 
-        IsXMLs(..), 
-        IsAttrValue(..),
-        IsAttribute(..),
-        
-        extract,
-        
-        module HSX.XMLGenerator, HSX.genElement, HSX.genEElement
-
-    ) where
-
-import HSP.Monad
-import HSP.XML hiding (Name)
-
-import HSX.XMLGenerator hiding (XMLGenerator(..))
-import qualified HSX.XMLGenerator as HSX (XMLGenerator(..))
-
-
----------------------------------------------
--- Instantiating XMLGenerator for the HSP monad.
-
-
--- | We can use literal XML syntax to generate values of type XML in the HSP monad.
-instance HSX.XMLGenerator HSP' where
- type HSX.XML HSP' = XML
- type HSX.Attribute HSP' = Attribute 
- type HSX.Child HSP' = XML
- genElement = element
- genEElement = eElement
-
-instance (IsXMLs a) => EmbedAsChild a (HSP [XML]) where
- asChild = 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 IsXMLs a where
- toXMLs :: a -> HSP [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 IsXMLs 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 IsXMLs String where
- toXMLs s = do xml <- toXML s
-               return [xml]
-
--- | 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 a) => IsXMLs [a] where
- toXMLs as = do xmlss <- mapM toXMLs as
-                return $ concat xmlss
-
--- | An IO computation returning something that can be represented
--- as a list of XML can be lifted into an analogous HSP computation.
-instance (IsXMLs a) => IsXMLs (IO a) where
- toXMLs ioa = doIO ioa >>= toXMLs
-
--- | 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 x, TypeCast (m x) (HSP' x)) => IsXMLs (XMLGenT m x) where
- toXMLs (XMLGenT x) = (XMLGenT $ typeCast x) >>= toXMLs
-
--- | Of the base types, () stands out as a type that can only be
--- represented as a (empty) list of XML.
-instance IsXMLs () where
- toXMLs _ = return []
-
--- | Maybe types are handy for cases where you might or might not want
--- to generate XML, such as null values from databases
-instance (IsXMLs a) => IsXMLs (Maybe a) where
- toXMLs Nothing = return []
- toXMLs (Just a) = toXMLs a
-
----------------
--- IsAttrValue
-
--- | Instantiate this class to enable values of the given type
--- to appear as XML attribute values.
-class IsAttrValue a where
- toAttrValue :: a -> HSP AttrValue
--- fromAttrValue :: AttrValue -> a
-
--- | An AttrValue is trivial.
-instance IsAttrValue AttrValue where
- toAttrValue = return
-
--- | Strings can be directly represented as values.
-instance IsAttrValue String where
- toAttrValue = return . pAttrVal
-
--- | Anything that can be shown can always fall back on
--- that as a default behavior.
-instance Show a => IsAttrValue a where
- toAttrValue = toAttrValue . show
-
--- | An IO computation returning something that can be represented
--- as an attribute value can be lifted into an analogous HSP computation.
-instance (IsAttrValue a) => IsAttrValue (IO a) where
- toAttrValue = toAttrValue . doIO 
-
--- | 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 a) => IsAttrValue (HSP a) where
- toAttrValue hspa = hspa >>= toAttrValue
-
--- | The common way to present list data in attributes is as
--- a comma separated, unbracketed sequence
---instance (IsAttrValue a) => IsAttrValue [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 IsAttribute a where
- toAttribute :: a -> HSP Attribute
-
--- | Attributes can represent attributes. 
-instance IsAttribute Attribute where
- toAttribute = return
-
--- | Values of the Attr type, constructed with :=, can represent attributes.
-instance (IsName n, IsAttrValue a) => IsAttribute (Attr n a) where
- toAttribute (n := a) = do av <- toAttrValue a
-                           return (toName n, av)
-
--- | Attributes can be the result of an HSP computation.
-instance (IsAttribute a) => IsAttribute (HSP a) where
- toAttribute hspa = hspa >>= toAttribute
-
--- | ... or of an IO computation.
-instance (IsAttribute a) => IsAttribute (IO a) where
- toAttribute ioa = doIO ioa >>= toAttribute
-
--- | Anything that can represent an attribute can also be embedded as attributes
--- using the literal XML syntax.
-instance (IsAttribute a) => EmbedAsAttr a (HSP Attribute) where
- asAttr = toAttribute
-
--- | Set an attribute to something in an XML element.
---set :: (IsXML a, IsAttribute at) => a -> at -> HSP XML
---set x a = setAll x [a]
-
------------------------------------------
--- SetAttr and AppendChild
-
--- | Set attributes.
-instance SetAttr HSP' XML where
- setAll xml hats = do
-        attrs <- hats
-        case xml of
-         CDATA _         -> return xml
-         Element n as cs -> return $ Element n (foldr insert as attrs) cs
-
-
-instance TypeCast (m x) (HSP' XML)
-                => SetAttr HSP' (XMLGenT m x) where
- setAll (XMLGenT hxml) ats = (XMLGenT $ typeCast hxml) >>= \xml -> setAll xml ats
-
--- | Append children.
-instance AppendChild HSP' XML where
- appAll xml children = do
-        chs <- children
-        case xml of
-         CDATA _         -> return xml
-         Element n as cs -> return $ Element n as (cs ++ chs)
-
-instance TypeCast (m x) (HSP' XML) 
-                => AppendChild HSP' (XMLGenT m x) where
- appAll (XMLGenT hxml) chs = (XMLGenT $ typeCast hxml) >>= (flip appAll) chs
- 
----------------
--- GetAttrValue
-
--- | Instantiate this class to enable values of the given type
--- to be retrieved through attribute patterns.
-class GetAttrValue a where
- fromAttrValue :: AttrValue -> a
-
--- | An AttrValue is trivial.
-instance GetAttrValue AttrValue where
- fromAttrValue = id
-
--- | 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
-
--- | 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
-
--- | 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 str) = case str of
-        [/ v1+, (/ ',', vs@:_+ /)+ /] -> 
-                map (fromAttrValue . Value) (v1:vs)
-        _ -> [fromAttrValue v]
-
--- All that for these two functions
-extract :: (GetAttrValue a) => Name -> Attributes -> (Maybe a, Attributes)
-extract _ [] = (Nothing, [])
-extract name (p@(n, v):as) 
-        | name == n = (Just $ fromAttrValue v, as)
-        | otherwise = let (val, attrs) = extract name as
-                       in (val, p:attrs)
-
-
---------------------------------------------------------------------
--- The base XML generation, corresponding to the use of the literal
--- XML syntax.
-
---  | Generate an XML element from its components.
-element :: (IsName n, IsXMLs xmls, IsAttribute at) => n -> [at] -> xmls -> HSP XML
-element n attrs xmls = do
-        cxml <- toXMLs xmls
-        attribs <- mapM toAttribute attrs
-        return $ Element (toName n) 
-                   (foldr insert eAttrs attribs)
-                   (flattenCDATA 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 s1, CDATA s2) -> flP (CDATA (s1++s2) : xs) bs
-                           _ -> flP (y:xs) (x:bs)
-
-eAttrs :: Attributes
-eAttrs = []
-insert :: Attribute -> Attributes -> Attributes
-insert = (:)
-
--- | Generate an empty XML element.
-eElement :: (IsName n, IsAttribute at) => n -> [at] -> HSP XML
-eElement n attrs = element n attrs ([] :: [XML])
-
hsp.cabal view
@@ -1,8 +1,8 @@ Name:                   hsp-Version:                0.4+Version:                0.4.4 License:                BSD3 License-File:           LICENSE-Author:                 Niklas Broberg, Joel Björnson+Author:                 Niklas Broberg, Joel Bjornson Maintainer:             Niklas Broberg <nibro@cs.chalmers.se>  Stability:              Experimental@@ -20,14 +20,15 @@                         For details on usage, please see the website, and the author's thesis. Homepage:               http://code.google.com/p/hsp -Build-Depends:          base>3, mtl, harp, hsx, HJScript+Build-Depends:          base>3, mtl, harp, hsx>=0.4.4, HJScript>=0.4.4 Build-Type:             Simple Tested-With:            GHC==6.8.3 -Exposed-Modules:        HSP.XML, HSP.XML.PCDATA, HSP.Env, HSP.Env.Request, HSP.Env.NumberGen, HSP.HJScript, HSP+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 -GHC-Options:            -F -pgmFtrhsx -Wall+GHC-Options:            -F -pgmFtrhsx -Wall -fno-warn-orphans Extensions:             MultiParamTypeClasses,                         FunctionalDependencies,                         TypeFamilies,
+ src/HSP.hs view
@@ -0,0 +1,32 @@+module HSP (
+        -- module HSP.Monad
+        HSP, HSPT, HSPT', runHSP, evalHSP, runHSPT, evalHSPT, getEnv,
+        getParam, getIncNumber, doIO, catch,
+        
+        -- 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 hiding (catch)
+
+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 view
@@ -0,0 +1,29 @@+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 view
@@ -0,0 +1,3 @@+module HSP.Env.NumberGen where
+
+data NumberGen = NumberGen { incNumber :: IO Int }
+ src/HSP/Env/Request.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------
+-- |
+-- 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 view
@@ -0,0 +1,32 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- 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+import Control.Exception (throwDyn)++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)++-- Internal funcion that throws a dynamic exception particular to HSP.+throwHSP :: Exception -> a+throwHSP = throwDyn+
+ src/HSP/HJScript.hs view
@@ -0,0 +1,113 @@+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 => EmbedAsChild (HSPT' m) (HJScript ()) where
+  asChild script = asChild . snd $ evalHJScript script
+
+instance Monad m => IsAttrValue m (Block t) where
+  toAttrValue block = return . Value $ "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
+
+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 :: (HSX.SetAttr m xml, HSX.EmbedAsAttr m (Attr String v)) 
+        => xml -> v -> HSX.XMLGenT m (HSX.XML m)
+setId e v = e `set` ("id" := v)
+
+-- Generel method for adding 'onEvent' attributes to XML elements.
+onEvent :: (HSX.SetAttr m xml, HSX.EmbedAsAttr m (Attr String (HJScript t)))
+        => Event -> xml -> HJScript t -> HSX.XMLGenT m (HSX.XML 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 :: 
+    (HSX.SetAttr m xml, HSX.EmbedAsAttr m (Attr String (HJScript t)))
+        => xml -> HJScript t -> HSX.XMLGenT m (HSX.XML 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 view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- 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 XML as well-formed HTML 4.01:+--  * no short tags are used, e.g., <script></script> instead of <script />+--  * 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+--  * optional end tags are always rendered+--+-- Currently no validation is performed.+-----------------------------------------------------------------------------+module HSP.HTML (+                 -- * Functions+                 renderAsHTML+                ) where++import Data.List+import HSP.XML+import HSP.XML.PCDATA(unescape)++-- | Pretty-prints HTML values.+-- FIXME: also verify that the domain is correct+-- FIXME: what to do if a namespace is encountered+--+-- 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.+renderAsHTML :: XML -> String+renderAsHTML xml = renderAsHTML' 0 xml ""++data TagType = Open | Close++renderAsHTML' :: Int -> XML -> ShowS+renderAsHTML' _ (CDATA cd) = showString 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"    = renderTagCDATA children+    | nm == "style"     = renderTagCDATA children+    where+      renderTagEmpty [] = renderTag Open n name attrs+      renderTagEmpty _ = renderElement n elm -- ^ this case should not happen in valid HTML+      renderTagCDATA :: Children -> ShowS+      renderTagCDATA children =+        let open  = renderTag Open n name attrs +            cs    = renderChildrenCDATA 0 children +            close = renderTag Close n name []+        in+          open . cs .close+      renderChildrenCDATA :: Int -> Children -> ShowS+      renderChildrenCDATA n' cs = foldl (.) id $ map (renderChildCDATA (n'+2)) cs+      renderChildCDATA n (CDATA cd) = showString (unescape cd)+      renderChildCDATA n e = renderElement n e  -- ^ this case should not happen in valid HTML+renderAsHTML' n e = renderElement n e++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++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 val))) = showName nam . showChar '=' . renderAttrVal 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 ' ')
+ src/HSP/Monad.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_GHC -fallow-overlapping-instances #-}+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- 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+        ) where++-- Monad imports+import Control.Monad.Reader (ReaderT(..), ask, lift)+import Control.Monad.Trans (MonadIO(..))++import Prelude hiding (catch)++-- Exceptions+import Control.Exception (catchDyn)+import HSP.Exception++import HSP.Env++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 = ReaderT HSPEnv m+type HSPT  m = XMLGenT (HSPT' m)++-- do NOT export this in the final version+dummyEnv :: HSPEnv+dummyEnv = undefined++-- | 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 :: HSP a -> HSPEnv -> IO a+runHSP = runReaderT . unXMLGenT++runHSPT :: HSPT m a -> HSPEnv -> m a+runHSPT = runReaderT . unXMLGenT++evalHSPT :: MonadIO m => HSPT m a -> m a+evalHSPT hsp = liftIO mkSimpleEnv >>= runHSPT hsp++evalHSP :: HSP a -> IO a+evalHSP hsp = mkSimpleEnv >>= runHSP hsp ++-- | 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 a+unsafeRunHSP hspf = runHSP hspf dummyEnv++-- | Execute an IO computation within the HSP monad.+doIO :: IO a -> HSP a+doIO = liftIO++----------------------------------------------------------------+-- Environment stuff++-- | Supplíes the HSP environment.+getEnv :: HSP HSPEnv+getEnv = lift ask++getRequest :: HSP Request+getRequest = fmap getReq getEnv++getParam :: String -> HSP (Maybe String)+getParam s = getRequest >>= \req -> return $ getParameter req s++getIncNumber :: HSP Int+getIncNumber = getEnv >>= doIO . incNumber . getNG++++-----------------------------------------------------------------------+-- Exception handling++-- | Catch a user-caused exception.+catch :: HSP a -> (Exception -> HSP a) -> HSP a+catch (XMLGenT (ReaderT f)) handler = XMLGenT $ ReaderT $ \e ->+        f e `catchDyn` (\ex -> (let (XMLGenT (ReaderT g)) = handler ex+                                 in g e))
+ src/HSP/XML.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  HSP.XML+-- Copyright   :  (c) Niklas Broberg 2008+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se+-- Stability   :  experimental+-- Portability :  Haskell 98+--+-- Datatypes and type classes comprising the basic model behind+-- the scenes of Haskell Server Pages tags.+-----------------------------------------------------------------------------+module HSP.XML (+        -- * The 'XML' datatype+        XML(..), +        Domain, +        Name, +        Attributes, +        Children,+        pcdata,+        cdata,+        -- * The Attribute type+        Attribute(..),+        AttrValue(..),+        attrVal, pAttrVal,+        -- * Functions+        renderXML,+        isElement, isCDATA+        ) where++import Data.List (intersperse)++import HSP.XML.PCDATA (escape)+---------------------------------------------------------------+-- Data types++type Domain = Maybe String+type Name = (Domain, String)+type Attributes = [Attribute]+type Children = [XML]++-- | The XML datatype representation. Is either an Element or CDATA.+data XML = Element Name Attributes Children+         | CDATA String+  deriving Show++{- instance Show XML where+ show = renderXML -}++-- | Test whether an XML value is an Element or CDATA+isElement, isCDATA :: XML -> Bool+isElement (Element {}) = True+isElement _ = False+isCDATA = not . isElement++-- | Embeds a string as a CDATA XML value.+cdata , pcdata :: String -> XML+cdata  = CDATA+pcdata = cdata . escape++---------------------------------------------------------------+-- Attributes++newtype Attribute = MkAttr (Name, AttrValue)+  deriving Show++-- | Represents an attribue value.+newtype AttrValue = Value String++-- | Create an attribue value from a string.+attrVal, pAttrVal :: String -> AttrValue+attrVal  = Value+pAttrVal = attrVal . escape++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 cd) = showString 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 = +        let (start,end) = case typ of+                           Open   -> (showChar '<', showChar '>')+                           Close  -> (showString "</", showChar '>')+                           Single -> (showChar '<', showString "/>")+            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 val))) = showName nam . showChar '=' . renderAttrVal 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 ' ')+
+ src/HSP/XML/PCDATA.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  HSP.XML.PCDATA+-- Copyright   :  (c) Niklas Broberg 2008+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se+-- Stability   :  experimental+-- Portability :  Haskell 98+--+-- Escaping between CDATA <=> PCDATA+-----------------------------------------------------------------------------+module HSP.XML.PCDATA (+	  escape	-- :: String -> String+	, unescape	-- :: String -> String+	) where+++-- | Take a normal string and transform it to PCDATA by escaping special characters.+escape :: String -> String+escape [] = ""+escape (c:cs) = pChar c ++ escape cs++pChar :: Char -> String+pChar c = case lookup c escapeChars of+	   Nothing -> [c]+	   Just s  -> '&' : s ++ ";"++-- This list should be extended.+escapeChars :: [(Char, String)]+escapeChars = [+	('&',	"amp"	),+	('\"',	"quot"	),+	('\'',	"apos"	),+	('<',	"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.+unescape :: String -> String+unescape = reverse . unE ""+  where unE acc "" = acc+  	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
@@ -0,0 +1,375 @@+module HSP.XMLGenerator (
+        -- * Type classes
+--        IsXML(..), 
+--        IsXMLs(..), 
+        IsAttrValue(..),
+--        IsAttribute(..),
+        
+        extract,
+        
+        module HSX.XMLGenerator, HSX.genElement, HSX.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 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 => HSX.XMLGen (HSPT' m) where
+ type HSX.XML (HSPT' m) = XML
+ newtype HSX.Attribute (HSPT' m) = HSPAttr Attribute 
+ newtype HSX.Child     (HSPT' m) = HSPChild XML
+ xmlToChild = HSPChild
+ 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]
+
+instance Monad m => EmbedAsChild (HSPT' m) String where
+ asChild = asChild . pcdata
+
+instance Monad m => EmbedAsChild (HSPT' m) Char where
+ asChild = asChild . (:[])
+
+{-
+-- | 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
+-}
+
+-- | 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 (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
+-}
+
+-- | 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 []
+
+instance Monad m => EmbedAsChild (HSPT' m) () where
+  asChild () = return []
+
+
+-- | 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
+
+instance (Monad m, EmbedAsChild (HSPT' m) a) => EmbedAsChild (HSPT' m) (Maybe a) where
+  asChild Nothing  = return []
+  asChild (Just a) = asChild a
+
+{-
+instance Monad m => IsXMLs m (HSX.Child (HSPT' m)) where
+ toXMLs (HSPChild x) = toXMLs x
+-}
+
+-- 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
+ asChild = return . return . HSX.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 Int where
+ toAttrValue = toAttrValue . show
+
+-- 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"
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+{-- | 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 Monad m => EmbedAsAttr (HSPT' m) Attribute where
+  asAttr = return . return . HSPAttr
+
+
+-- | 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 (IsName n, IsAttrValue m a) => EmbedAsAttr (HSPT' m) (Attr n a) where
+  asAttr (n := a) = do
+            av <- toAttrValue a
+            asAttr $ MkAttr (toName n, av)
+
+{-
+-- | Attributes can be the result of an HSP computation.
+instance IsAttribute m a => IsAttribute m (HSPT m a) where
+ toAttribute hspa = hspa >>= toAttribute
+-}
+
+-- | ... or of an IO computation.
+--instance IsAttribute IO a => IsAttribute IO (IO a) where
+-- toAttribute ma = lift (lift ma) >>= toAttribute
+
+instance (EmbedAsAttr (HSPT' IO) a) => EmbedAsAttr (HSPT' IO) (IO a) where
+  asAttr ma = lift (lift ma) >>= asAttr
+
+{-
+instance Monad m => IsAttribute m (HSX.Attribute (HSPT' m)) where
+ toAttribute (HSPAttr a) = toAttribute a
+
+-- | 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 and AppendChild
+
+-- | 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
+
+{-
+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
+-}
+
+-- | 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))
+
+{-
+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
+
+-- | Instantiate this class to enable values of the given type
+-- to be retrieved through attribute patterns.
+class GetAttrValue a where
+ fromAttrValue :: AttrValue -> a
+
+-- | An AttrValue is trivial.
+instance GetAttrValue AttrValue where
+ fromAttrValue = id
+
+-- | 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
+
+-- | 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
+
+-- | 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 str) = case str of
+        [ v1+, (| ',', vs@:(_+) |)+ ] -> 
+                map (fromAttrValue . Value) (v1:vs)
+        _ -> [fromAttrValue v]
+
+-- 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)
+
+--------------------------------------------------------------------
+-- The base XML generation, corresponding to the use of the literal
+-- XML syntax.
+
+--  | 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 s1, CDATA s2) -> flP (CDATA (s1++s2) : xs) bs
+                           _ -> flP (y:xs) (x:bs)
+
+stripAttr :: HSX.Attribute (HSPT' m) -> Attribute
+stripAttr  (HSPAttr a) = a
+stripChild :: HSX.Child (HSPT' m) -> XML
+stripChild (HSPChild c) = c
+
+eAttrs :: Attributes
+eAttrs = []
+insert :: Attribute -> Attributes -> Attributes
+insert = (:)
+
+-- | 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])