{-# LANGUAGE CPP, FlexibleContexts #-}
module WeekDaze.Data.Subject(
Topic,
Knowledge,
Subject(
getTopic,
getLevel
),
tag,
levelTag,
topicTag,
#ifdef USE_HDBC
mkSubjectFromSql,
#endif
mkSubject
) where
import qualified Control.Arrow
import Control.Arrow((&&&))
import qualified Control.DeepSeq
import qualified Data.Set
import qualified Text.XHtml.Strict
import Text.XHtml.Strict((+++), (<<))
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.SelfValidate
import qualified WeekDaze.Text.XHTML as Text.XHTML
#ifdef USE_HDBC
import qualified Data.Convertible
import qualified Data.Maybe
import qualified Database.HDBC
mkSubjectFromSql
:: (Data.Convertible.Convertible Database.HDBC.SqlValue level, Show level)
=> Database.HDBC.SqlValue
-> Database.HDBC.SqlValue
-> Subject level
mkSubjectFromSql topicSql = mkSubject (
Data.Maybe.fromMaybe (
error $ "WeekDaze.Data.Subject.mkSubjectFromSql:\tnull " ++ show topicTag ++ "."
) $ Database.HDBC.fromSql topicSql
) . Data.Maybe.fromMaybe (
error $ "WeekDaze.Data.Subject.mkSubjectFromSql:\tnull " ++ show levelTag ++ "."
) . Database.HDBC.fromSql
#endif /* USE_HDBC */
tag :: String
tag = "subject"
levelTag :: String
levelTag = "level"
topicTag :: String
topicTag = "topic"
type Topic = String
data Subject level = MkSubject {
getTopic :: Topic,
getLevel :: level
} deriving (Eq, Ord)
instance (Read level, Show level) => Read (Subject level) where
readsPrec _ = map (Control.Arrow.first $ uncurry mkSubject) . reads
instance Show level => Show (Subject level) where
showsPrec _ = shows . (getTopic &&& getLevel)
instance Text.XHtml.Strict.HTML level => Text.XHtml.Strict.HTML (Subject level) where
toHtml subject = Text.XHTML.mkXHTMLSpan tag << (
Text.XHTML.mkXHTMLSpan topicTag << getTopic subject +++ Text.XHtml.Strict.spaceHtml +++ getLevel subject
)
instance (HXT.XmlPickler level, Show level) => HXT.XmlPickler (Subject level) where
xpickle = HXT.xpElem tag . HXT.xpWrap (
uncurry mkSubject,
getTopic &&& getLevel
) $ HXT.xpTextAttr topicTag `HXT.xpPair` HXT.xpickle
instance Control.DeepSeq.NFData level => Control.DeepSeq.NFData (Subject level) where
rnf = Control.DeepSeq.rnf . (getTopic &&& getLevel)
instance Show level => ToolShed.SelfValidate.SelfValidator (Subject level) where
getErrors subject = ToolShed.SelfValidate.extractErrors [(null $ getTopic subject, "null " ++ show topicTag ++ "; " ++ show subject)]
mkSubject :: Show level => Topic -> level -> Subject level
mkSubject topic level
| ToolShed.SelfValidate.isValid subject = subject
| otherwise = error $ "WeekDaze.Data.Subject.mkSubject:\t" ++ ToolShed.SelfValidate.getFirstError subject ++ "."
where
subject = MkSubject topic level
type Knowledge level = Data.Set.Set (Subject level)