diff --git a/HSP.hs b/HSP.hs deleted file mode 100644 --- a/HSP.hs +++ /dev/null @@ -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 diff --git a/HSP/Env.hs b/HSP/Env.hs deleted file mode 100644 --- a/HSP/Env.hs +++ /dev/null @@ -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 diff --git a/HSP/Env/NumberGen.hs b/HSP/Env/NumberGen.hs deleted file mode 100644 --- a/HSP/Env/NumberGen.hs +++ /dev/null @@ -1,3 +0,0 @@ -module HSP.Env.NumberGen where - -data NumberGen = NumberGen { incNumber :: IO Int } diff --git a/HSP/Env/Request.hs b/HSP/Env/Request.hs deleted file mode 100644 --- a/HSP/Env/Request.hs +++ /dev/null @@ -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 diff --git a/HSP/Exception.hs b/HSP/Exception.hs deleted file mode 100644 --- a/HSP/Exception.hs +++ /dev/null @@ -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 - diff --git a/HSP/HJScript.hs b/HSP/HJScript.hs deleted file mode 100644 --- a/HSP/HJScript.hs +++ /dev/null @@ -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 $ - - -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 diff --git a/HSP/Monad.hs b/HSP/Monad.hs deleted file mode 100644 --- a/HSP/Monad.hs +++ /dev/null @@ -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)) diff --git a/HSP/XML.hs b/HSP/XML.hs deleted file mode 100644 --- a/HSP/XML.hs +++ /dev/null @@ -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 "') - 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 ' ') - diff --git a/HSP/XML/PCDATA.hs b/HSP/XML/PCDATA.hs deleted file mode 100644 --- a/HSP/XML/PCDATA.hs +++ /dev/null @@ -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)) diff --git a/HSP/XMLGenerator.hs b/HSP/XMLGenerator.hs deleted file mode 100644 --- a/HSP/XMLGenerator.hs +++ /dev/null @@ -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]) - diff --git a/hsp.cabal b/hsp.cabal --- a/hsp.cabal +++ b/hsp.cabal @@ -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 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, diff --git a/src/HSP.hs b/src/HSP.hs new file mode 100644 --- /dev/null +++ b/src/HSP.hs @@ -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 diff --git a/src/HSP/Env.hs b/src/HSP/Env.hs new file mode 100644 --- /dev/null +++ b/src/HSP/Env.hs @@ -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 diff --git a/src/HSP/Env/NumberGen.hs b/src/HSP/Env/NumberGen.hs new file mode 100644 --- /dev/null +++ b/src/HSP/Env/NumberGen.hs @@ -0,0 +1,3 @@ +module HSP.Env.NumberGen where + +data NumberGen = NumberGen { incNumber :: IO Int } diff --git a/src/HSP/Env/Request.hs b/src/HSP/Env/Request.hs new file mode 100644 --- /dev/null +++ b/src/HSP/Env/Request.hs @@ -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 diff --git a/src/HSP/Exception.hs b/src/HSP/Exception.hs new file mode 100644 --- /dev/null +++ b/src/HSP/Exception.hs @@ -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 + diff --git a/src/HSP/HJScript.hs b/src/HSP/HJScript.hs new file mode 100644 --- /dev/null +++ b/src/HSP/HJScript.hs @@ -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 $ + + +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 diff --git a/src/HSP/HTML.hs b/src/HSP/HTML.hs new file mode 100644 --- /dev/null +++ b/src/HSP/HTML.hs @@ -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., instead of