hsp-0.2: HSP/Data.hs

{-# OPTIONS -fallow-overlapping-instances -fallow-undecidable-instances -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  HSP.Data
-- Copyright   :  (c) Niklas Broberg 2004,
-- License     :  BSD-style (see the file LICENSE.txt)
-- 
-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se
-- Stability   :  experimental
-- Portability :  requires undecidable and overlapping instances
--
-- Datatypes and type classes comprising the basic model behind
-- the scenes of Haskell Server Pages tags.
-----------------------------------------------------------------------------

module HSP.Data (
	-- * The 'XML' datatype
	XML(..), 
	Domain, 
	Name, 
	Attributes, 
	Attribute,
	AttrValue(..),
	Children,
	isTag, isCdata,
	-- * The 'HSP' Monad
	HSP,
	HSPEnv,
	runHSP,
        unsafeRunHSP,  -- dangerous!!
	doIO, 
	-- * Type classes
	IsXML(..), 
	IsXMLs(..), 
	IsAttrValue(..),
        IsStyleValue(..),
        IsStyle(..),
	-- * Functions
	renderXML,
	mkTag,
	genTag,
	mkETag,
	genETag,
	pcdata,
	cdata,
	extract,

	-- * Accessing the environment
	getApplication,
	getRequest,
	getSession,
	getResponse,

	-- * Attribute manipulation
	set,
	Attr(..),
	IsAttribute(..),
	IsName,

        -- * 'CSS' combinators
        (<:>),
        (<+>),
        cssId,
        cssClass,
        cssElem,
        pc,
        css,

	-- * Exceptions
	throwHSP,
	catch
	) where

import Prelude hiding (catch)

import HSP.Exception
import Control.Exception (catchDyn, throwDyn)
import Control.Monad.Reader (ReaderT(..), ask, lift, runReaderT)
import Control.Monad.Trans (MonadIO(..))

import Data.Typeable
import Data.List (intersperse)

import HSP.Data.XML
import HSP.Data.PCDATA
import HSP.Data.CSS
import qualified HSP.Data.RequestEnv as Rq
import qualified HSP.Data.Response as Rp
import qualified HSP.Data.Application as A
import qualified HSP.Data.Session as S

--------------------------------------------------------------
-- The HSP Monad

-- | The HSP monad is simply a reader wrapper around
-- the IO monad.
data HSP a = MkHSP {baseC :: ReaderT HSPEnv IO a}

-- | 
type HSPEnv = (A.Application, S.Session, Rq.RequestEnv, Rp.Response)

-- do NOT export this in the final version
dummyEnv :: HSPEnv
dummyEnv = undefined

instance Monad HSP where
 return = MkHSP . return
 c1 >>= k = MkHSP $ do
 		a <- baseC c1
 		baseC $ k a

instance MonadIO HSP where
  liftIO c = doIO c

runHSP :: HSP a -> HSPEnv -> IO a
runHSP = runReaderT . baseC

unsafeRunHSP :: HSP a -> IO a
unsafeRunHSP hspf = runHSP hspf dummyEnv

doIO :: IO a -> HSP a
doIO = MkHSP . lift

getEnv :: HSP HSPEnv
getEnv = MkHSP ask


-----------------------------------------------------------------
-- 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 ioa = toXML $ doIO ioa

-- | 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

-- | CSS can appear as PCDATA of a style tag.
instance IsXML CSS where
    toXML (CSS entries) = <style type="text/css">
                          <% unlines (map show entries) %>
                          </style>

-------------
-- 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]

-- | 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 = toXMLs . 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 (IsXMLs a) => IsXMLs (HSP a) where
 toXMLs hspa = hspa >>= 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 . Value . toPCDATA

-- | Anything that can be shown and read can always fall back on
-- that as a default behavior.
instance (Show a, Read 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

---------------
-- 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)

---------------
-- IsStyleValue

-- | Instantiate this class to enable values of the given type
-- to appear as CSS attribute values.
-- Instances mirroring the relevant ones of IsAttrValue are supplied
class IsStyleValue a where
    toStyleValue :: a -> HSP StyleValue

-- | A StyleValue is trivial.
instance IsStyleValue StyleValue where
    toStyleValue = return

-- | Strings can be directly represented as values.
instance IsStyleValue String where
    toStyleValue = return . StyleValue

-- | Anything that can be shown and read can always fall back on
-- that as a default behavior.
instance (Show a, Read a) => IsStyleValue a where
    toStyleValue = toStyleValue . show

-- | An IO computation returning something that can be represented
-- as a style value can be lifted into an analogous HSP computation.
instance (IsStyleValue a) => IsStyleValue (IO a) where
    toStyleValue = toStyleValue . doIO

-- | An HSP computation returning something that can be represented
-- as a style value simply needs to turn the produced value into 
-- a style value.
instance (IsStyleValue a) => IsStyleValue (HSP a) where
    toStyleValue hspa = hspa >>= toStyleValue

-- | An Int is chosen to represent a value in pixels.
instance IsStyleValue Int where
    toStyleValue x = toStyleValue $ show x ++ "px"

-- | A Float is chosen to represent a value in percent.
-- E.g. 0.33 yields 33%.
instance IsStyleValue Float where
    toStyleValue x = toStyleValue $ show (round (x*100)) ++ "%"

-------------
-- IsStyle

-- | Instantiate this class to enable values of the given type
-- to appear as styles and be combined with other styles.
class IsStyle s where
    toStyle :: s -> HSP Style

-- | A Style is trivial
instance IsStyle Style where
    toStyle = return

-- | An IO computation returning something that can be represented
-- as a style can be lifted into an analogous HSP computation.
instance (IsStyle a) => IsStyle (IO a) where
    toStyle = toStyle . doIO

-- | An HSP computation returning something that can be represented
-- as a style simply needs to turn the produced value into 
-- a style.
instance (IsStyle a) => IsStyle (HSP a) where
    toStyle hspa = hspa >>= toStyle


-----------------------------------------------------------------------
-- Manipulating attributes

data Attr = forall n a . (IsName n, IsAttrValue a) => n := a

class IsName n where
 toName :: n -> Name

instance IsName Name where
 toName = id

instance IsName String where
 toName s = (Nothing, s)

instance IsName (String, String) where
 toName (ns, s) = (Just ns, s)

class IsAttribute a where
 toAttribute :: a -> HSP Attribute
 
instance IsAttribute Attribute where
 toAttribute = return

instance IsAttribute Attr where
 toAttribute (n := a) = do av <- toAttrValue a
 			   return (toName n, av)

instance (IsAttribute a) => IsAttribute (HSP a) where
 toAttribute hspa = hspa >>= toAttribute

instance (IsAttribute a) => IsAttribute (IO a) where
 toAttribute ioa = doIO ioa >>= toAttribute

instance IsAttribute Style where
    toAttribute s = toAttribute $ "style" := show s

set :: (IsXML a, IsAttribute at) => a -> at -> HSP XML
set x a = setAll x [a]

setAll :: (IsXML a, IsAttribute at) => a -> [at] -> HSP XML
setAll isxml ats = do
	xml   <- toXML isxml
	attrs <- mapM toAttribute ats
	case xml of
	 CDATA _     -> return xml
	 Tag n ats cs -> return $ Tag n (foldr insert ats attrs) cs


--------------------------------------------------------------------
-- CSS combinators

(<:>) :: IsStyleValue sv => String -> sv -> HSP Style
name <:> svc = do sv <- toStyleValue svc
                  return $ Style [(name, sv)]

(<+>) :: (IsStyle a, IsStyle b) => a -> b -> HSP Style
sc1 <+> sc2 = do Style set1 <- toStyle sc1
                 Style set2 <- toStyle sc2
                 return $ Style (set1 ++ set2)

cssId = CSSId
cssClass = CSSClass
cssElem = CSSElem
pc = CSSPseudoClass

css :: [HSP CSSEntry] -> HSP CSS
css ecs = do es <- sequence ecs
             return $ CSS es	


--------------------------------------------------------------------
-- Generation

--  | Generate a Tag from its components.  
mkTag :: (IsName n, IsXMLs xmls, IsAttribute at) => n -> [at] -> xmls -> HSP XML
mkTag n attrs xmls = do
	cxml <- toXMLs xmls
	attribs <- mapM toAttribute attrs
	return $ Tag (toName n) 
		   (foldr insert eAttrs attribs)
		   (flattenCDATA cxml)
	
  where flattenCDATA :: [XML] -> [XML]
  	flattenCDATA xmls = 
  		case flP xmls [] 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)

genTag :: Name -> [HSP Attribute] -> [HSP [XML]] -> HSP XML
genTag = mkTag


-- | Generate a Tag with no children from its components
mkETag :: (IsName n, IsAttribute at) => n -> [at] -> HSP XML
mkETag n attrs = mkTag n attrs ([] :: [XML])

genETag :: Name -> [HSP Attribute] -> HSP XML
genETag = mkETag


eAttrs :: Attributes
eAttrs = []

insert :: Attribute -> Attributes -> Attributes
insert = (:)


-----------------------------------------------------------------------
-- Exception handling

-- | Catch a user-caused exception
catch :: HSP a -> (Exception -> HSP a) -> HSP a
catch (MkHSP (ReaderT f)) handler = MkHSP $ ReaderT $ \e ->
	f e `catchDyn` (\ex -> (let (MkHSP (ReaderT g)) = handler ex
				 in g e))

-- Will not be exported to the user
throwHSP :: Exception -> a
throwHSP = throwDyn

-----------------------------------------------------------------------
-- The Application object

-- Will not be exported
getApp :: HSP A.Application
getApp = do (app, _s, _rq, _rp) <- getEnv
	    return app

-- | Fetch the user-defined data held within the Application object
-- in the HSP environment.
getApplication :: Typeable a => HSP a
getApplication = do app <- getApp
		    case A.fromApplication app of
		     Nothing -> throwHSP WrongApplicationType
		     Just a -> return a

-----------------------------------------------------------------------
-- The Session object

-- Will not be exported
getSession :: HSP S.Session
getSession = do (_a, sess, _rq, _rp) <- getEnv
		return sess


-----------------------------------------------------------------------
-- The Request object

-- Will not be exported
getRequest :: HSP Rq.RequestEnv
getRequest = do (_a, _s, req, _rp) <- getEnv
		return req


-----------------------------------------------------------------------
-- The Response object

-- Will not be exported
getResponse :: HSP Rp.Response
getResponse = do (_a, _s, _rq, resp) <- getEnv
		 return resp