hsp 0.4.4 → 0.4.5

raw patch · 8 files changed

+158/−72 lines, 8 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hsp.cabal +4/−3
• src/HSP.hs +1/−1
• src/HSP/HJScript.hs +2/−1
• src/HSP/HTML.hs +58/−26
• src/HSP/Monad.hs +29/−16
• src/HSP/XML.hs +21/−9
• src/HSP/XML/PCDATA.hs +35/−9
• src/HSP/XMLGenerator.hs +8/−7

@@ -1,5 +1,5 @@ Name:                   hsp-Version:                0.4.4+Version:                0.4.5 License:                BSD3 License-File:           LICENSE Author:                 Niklas Broberg, Joel Bjornson@@ -20,15 +20,16 @@                         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>=0.4.4, HJScript>=0.4.4+Build-Depends:          base >3 && < 4, mtl, harp, hsx>=0.4.4, HJScript>=0.4.4 Build-Type:             Simple+Cabal-Version:          >= 1.2.3 Tested-With:            GHC==6.8.3  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 -fno-warn-orphans+GHC-Options:            -Wall -fno-warn-orphans Extensions:             MultiParamTypeClasses,                         FunctionalDependencies,                         TypeFamilies,

@@ -1,7 +1,7 @@ module HSP (
         -- module HSP.Monad
         HSP, HSPT, HSPT', runHSP, evalHSP, runHSPT, evalHSPT, getEnv,
-        getParam, getIncNumber, doIO, catch,
+        getParam, getIncNumber, doIO, catch, setMetaData, withMetaData,
         
         -- module HSP.Env
         module HSP.Env,

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}
 module HSP.HJScript where
 
 import HSP.Monad
@@ -17,7 +18,7 @@   asChild script = asChild . snd $ evalHJScript script
 
 instance Monad m => IsAttrValue m (Block t) where
-  toAttrValue block = return . Value $ "javascript:" ++ show block
+  toAttrValue block = return . attrVal $ "javascript:" ++ show block
 
 instance Monad m => IsAttrValue m (HJScript ()) where
   toAttrValue script = toAttrValue . snd $ evalHJScript script

@@ -8,27 +8,34 @@ -- 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>+-- 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---  * optional end tags are always rendered --+--  3. optional end tags are always rendered+-- -- Currently no validation is performed. ----------------------------------------------------------------------------- module HSP.HTML (                  -- * Functions-                 renderAsHTML+                  renderAsHTML+                , htmlEscapeChars+                 -- * Predefined XMLMetaData+                , html4Strict+                , html4StrictFrag                 ) where  import Data.List import HSP.XML-import HSP.XML.PCDATA(unescape)+import HSP.XML.PCDATA(escaper)  -- | Pretty-prints HTML values.--- FIXME: also verify that the domain is correct--- FIXME: what to do if a namespace is encountered -- -- Error Handling: --@@ -38,7 +45,9 @@ -- handle this: -- --  1. drop the bogus children silently---  2. call 'error' / raise an exception+--+--  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@@ -58,13 +67,17 @@ -- -- 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 cd) = showString cd+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@@ -76,24 +89,18 @@     | nm == "link"      = renderTagEmpty children     | nm == "meta"      = renderTagEmpty children     | nm == "param"     = renderTagEmpty children-    | nm == "script"    = renderTagCDATA children-    | nm == "style"     = renderTagCDATA 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-      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+      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 @@ -118,7 +125,7 @@           renderAttr :: Attribute -> ShowS-        renderAttr (MkAttr (nam, (Value val))) = showName nam . showChar '=' . renderAttrVal val+        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 '\"'@@ -127,3 +134,28 @@         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+                }

@@ -21,11 +21,14 @@         runHSP, evalHSP, runHSPT, evalHSPT, getEnv,         unsafeRunHSP,  -- dangerous!!         -- * Functions-        getParam, getIncNumber, doIO, catch+        getParam, getIncNumber, doIO, catch,+        setMetaData, withMetaData         ) where  -- Monad imports-import Control.Monad.Reader (ReaderT(..), ask, lift)+-- import Control.Monad.Reader (ReaderT(..), ask, lift)+import Control.Monad.RWS (RWST(..), ask, lift, put)+import Control.Monad.State import Control.Monad.Trans (MonadIO(..))  import Prelude hiding (catch)@@ -36,6 +39,7 @@  import HSP.Env +import HSP.XML import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)  --------------------------------------------------------------@@ -48,7 +52,7 @@  type HSP =  HSPT IO -type HSPT' m = ReaderT HSPEnv m+type HSPT' m = RWST HSPEnv () (Maybe XMLMetaData) m type HSPT  m = XMLGenT (HSPT' m)  -- do NOT export this in the final version@@ -57,27 +61,36 @@  -- | 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+runHSP :: Maybe XMLMetaData -> HSP a -> HSPEnv -> IO (Maybe XMLMetaData, a)+runHSP xmd hsp hspEnv = runRWST (unXMLGenT hsp) hspEnv xmd >>= \(a,md,()) -> return (md, a) -runHSPT :: HSPT m a -> HSPEnv -> m a-runHSPT = runReaderT . unXMLGenT+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) -evalHSPT :: MonadIO m => HSPT m a -> m a-evalHSPT hsp = liftIO mkSimpleEnv >>= runHSPT hsp+evalHSPT :: MonadIO m => Maybe XMLMetaData -> HSPT m a -> m (Maybe XMLMetaData, a)+evalHSPT xmd hsp = liftIO mkSimpleEnv >>= \env -> runHSPT xmd hsp env  -evalHSP :: HSP a -> IO a-evalHSP hsp = mkSimpleEnv >>= runHSP hsp +evalHSP :: Maybe XMLMetaData -> HSP a -> IO (Maybe XMLMetaData, a)+evalHSP xmd hsp = mkSimpleEnv >>= \env -> runHSP xmd hsp env  -- | 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+unsafeRunHSP :: HSP a -> IO (Maybe XMLMetaData, a)+unsafeRunHSP hspf = runHSP Nothing hspf dummyEnv  -- | Execute an IO computation within the HSP monad. doIO :: IO a -> HSP a doIO = liftIO +setMetaData :: (Monad m) => (Maybe XMLMetaData) -> HSPT m ()+setMetaData xmd = lift (put xmd)++withMetaData :: (Monad m) => Maybe XMLMetaData -> HSPT m a -> HSPT m a+withMetaData xmd h = do+  x <- h+  setMetaData xmd+  return x+ ---------------------------------------------------------------- -- Environment stuff @@ -101,6 +114,6 @@  -- | 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))+catch (XMLGenT (RWST f)) handler = XMLGenT $ RWST $ \e s ->+        f e s `catchDyn` (\ex -> (let (XMLGenT (RWST g)) = handler ex+                                 in g e s))

@@ -14,6 +14,7 @@ module HSP.XML (         -- * The 'XML' datatype         XML(..), +        XMLMetaData(..),         Domain,          Name,          Attributes, @@ -42,9 +43,20 @@  -- | The XML datatype representation. Is either an Element or CDATA. data XML = Element Name Attributes Children-         | CDATA String+         | CDATA Bool String   deriving Show +-- |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+  } + {- instance Show XML where  show = renderXML -} @@ -56,8 +68,8 @@  -- | Embeds a string as a CDATA XML value. cdata , pcdata :: String -> XML-cdata  = CDATA-pcdata = cdata . escape+cdata  = CDATA False+pcdata = CDATA True  --------------------------------------------------------------- -- Attributes@@ -66,15 +78,15 @@   deriving Show  -- | Represents an attribue value.-newtype AttrValue = Value String+data AttrValue = Value Bool String  -- | Create an attribue value from a string. attrVal, pAttrVal :: String -> AttrValue-attrVal  = Value-pAttrVal = attrVal . escape+attrVal  = Value False+pAttrVal = Value True  instance Show AttrValue where- show (Value str) = str+ show (Value _ str) = str  ------------------------------------------------------------------ -- Rendering@@ -88,7 +100,7 @@ data TagType = Open | Close | Single  renderXML' :: Int -> XML -> ShowS-renderXML' _ (CDATA cd) = showString cd+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 @@ -117,7 +129,7 @@           renderAttr :: Attribute -> ShowS-        renderAttr (MkAttr (nam, (Value val))) = showName nam . showChar '=' . renderAttrVal val+        renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal  (if needsEscape then escape val else val)          renderAttrVal :: String -> ShowS         renderAttrVal s = showChar '\"' . showString s . showChar '\"'

@@ -13,22 +13,37 @@ module HSP.XML.PCDATA ( 	  escape	-- :: String -> String 	, unescape	-- :: String -> String+        , escaper+        , unescaper+        , xmlEscapeChars 	) where   -- | Take a normal string and transform it to PCDATA by escaping special characters.+-- calls 'escaper' with 'xmlEscapeChars'+-- See also: 'escaper' escape :: String -> String-escape [] = ""-escape (c:cs) = pChar c ++ escape cs+escape = escaper xmlEscapeChars -pChar :: Char -> String-pChar c = case lookup c escapeChars of-	   Nothing -> [c]-	   Just s  -> '&' : s ++ ";"+-- | 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 +pChar :: [(Char, String)] -- ^ table of escape characters+      -> Char -- ^ character to escape+      -> String -- ^ escaped character+pChar escapeChars c = +    case lookup c escapeChars of+      Nothing -> [c]+      Just s  -> '&' : s ++ ";"+ -- This list should be extended.-escapeChars :: [(Char, String)]-escapeChars = [+xmlEscapeChars :: [(Char, String)]+xmlEscapeChars = [ 	('&',	"amp"	), 	('\"',	"quot"	), 	('\'',	"apos"	),@@ -39,8 +54,19 @@ -- | 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.+-- calls 'unescaper' with 'xmlEscapeChars'+-- See also: 'unescaper' unescape :: String -> String-unescape = reverse . unE ""+unescape = unescaper xmlEscapeChars++-- | 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.+-- See also: 'unescape', 'xmlEscapeChars'+unescaper :: [(Char, String)] -- ^ table of escape characters+          -> String -- ^ String to unescape+          -> String -- ^ unescaped String+unescaper escapeChars = reverse . unE ""   where unE acc "" = acc   	unE acc (c:cs) =    	  case c of

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}
 module HSP.XMLGenerator (
         -- * Type classes
 --        IsXML(..), 
@@ -267,7 +268,7 @@  setAll xml hats = do
         attrs <- hats
         case xml of
-         CDATA _         -> return xml
+         CDATA _ _       -> return xml
          Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs
 
 {-
@@ -281,7 +282,7 @@  appAll xml children = do
         chs <- children
         case xml of
-         CDATA _         -> return xml
+         CDATA _ _       -> return xml
          Element n as cs -> return $ Element n as (cs ++ (map stripChild chs))
 
 {-
@@ -303,7 +304,7 @@ 
 -- | Strings can be directly taken from values.
 instance GetAttrValue String where
- fromAttrValue (Value s) = s
+ fromAttrValue (Value _ s) = s
  
 -- | Anything that can be read can always fall back on
 -- that as a default behavior.
@@ -318,9 +319,9 @@ -- | 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
+ fromAttrValue v@(Value needsEscape str) = case str of
         [ v1+, (| ',', vs@:(_+) |)+ ] -> 
-                map (fromAttrValue . Value) (v1:vs)
+                map (fromAttrValue . Value needsEscape) (v1:vs)
         _ -> [fromAttrValue v]
 
 -- All that for these two functions
@@ -351,13 +352,13 @@         flattenCDATA cxml = 
                 case flP cxml [] of
                  [] -> []
-                 [CDATA ""] -> []
+                 [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
+                           (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs
                            _ -> flP (y:xs) (x:bs)
 
 stripAttr :: HSX.Attribute (HSPT' m) -> Attribute