diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs
index 5ec42cc3..235ff927 100644
--- a/Data/Object/Html.hs
+++ b/Data/Object/Html.hs
@@ -3,8 +3,10 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
--- | An 'Html' data type and associated 'HtmlObject'. This has useful
--- conversions in web development:
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- | An 'Html' data type and associated 'ConvertSuccess' instances. This has
+-- useful conversions in web development:
--
-- * Automatic generation of simple HTML documents from 'HtmlObject' (mostly
-- useful for testing, you would never want to actually show them to an end
@@ -58,16 +60,31 @@ newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text }
type HtmlObject = Object String Html
-toHtmlObject :: ToObject x String Html => x -> HtmlObject
-toHtmlObject = toObject
+toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject
+toHtmlObject = cs
-fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x
-fromHtmlObject = fromObject
+fromHtmlObject :: ConvertAttempt HtmlObject x => HtmlObject -> Attempt x
+fromHtmlObject = ca
instance ConvertSuccess String Html where
convertSuccess = Text . cs
instance ConvertSuccess Text Html where
convertSuccess = Text
+$(deriveAttempts
+ [ (''String, ''Html)
+ , (''Text, ''Html)
+ ])
+
+showAttribs :: [(String, String)] -> Text
+showAttribs = TL.concat . map helper where
+ helper :: (String, String) -> Text
+ helper (k, v) = TL.concat
+ [ cs " "
+ , encodeHtml $ cs k
+ , cs "=\""
+ , encodeHtml $ cs v
+ , cs "\""
+ ]
instance ConvertSuccess Html Text where
convertSuccess (Html t) = t
@@ -90,6 +107,9 @@ instance ConvertSuccess Html Text where
]
convertSuccess (HtmlList l) = TL.concat $ map cs l
+instance ConvertSuccess Html String where
+ convertSuccess = cs . (cs :: Html -> Text)
+
instance ConvertSuccess Html HtmlDoc where
convertSuccess h = HtmlDoc $ TL.concat
[ cs "HtmlDoc (autogenerated)"
@@ -119,25 +139,22 @@ instance ConvertSuccess HtmlObject JsonObject where
instance ConvertSuccess HtmlObject JsonDoc where
convertSuccess = cs . (cs :: HtmlObject -> JsonObject)
-instance ToObject Html String Html where
- toObject = Scalar
+$(deriveAttempts
+ [ (''Html, ''String)
+ , (''Html, ''Text)
+ , (''Html, ''HtmlDoc)
+ , (''Html, ''JsonScalar)
+ ])
+
+$(deriveSuccessConvs ''String ''Html
+ [''String, ''Text]
+ [''Html, ''String, ''Text])
instance ToSElem HtmlObject where
toSElem (Scalar h) = STR $ TL.unpack $ cs h
toSElem (Sequence hs) = LI $ map toSElem hs
toSElem (Mapping pairs) = SM $ Map.fromList $ map (second toSElem) pairs
-showAttribs :: [(String, String)] -> Text
-showAttribs = TL.concat . map helper where
- helper :: (String, String) -> Text
- helper (k, v) = TL.concat
- [ cs " "
- , encodeHtml $ cs k
- , cs "=\""
- , encodeHtml $ cs v
- , cs "\""
- ]
-
#if TEST
caseHtmlToText :: Assertion
caseHtmlToText = do
@@ -183,7 +200,3 @@ testSuite = testGroup "Data.Object.Html"
]
#endif
-
-instance ToObject Char String Html where
- toObject c = Scalar $ Text $ cs [c]
- listToObject = Scalar . Text . cs
diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs
index 337acffd..a608b2b8 100644
--- a/Yesod/Resource.hs
+++ b/Yesod/Resource.hs
@@ -44,10 +44,9 @@ import Language.Haskell.TH
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import Data.Attempt -- for failure stuff
-import Data.Convertible.Text
import Data.Object.Text
import Control.Monad ((<=<))
-import Text.Yaml
+import Data.Object.Yaml
#if TEST
import Control.Monad (replicateM)
@@ -181,23 +180,22 @@ data VerbMap = AllVerbs String | Verbs [(Verb, String)]
deriving (Show, Eq)
instance ConvertAttempt YamlDoc [RPNode] where
convertAttempt = fromTextObject <=< ca
-instance FromObject RPNode Text Text where
- fromObject = error "fromObject RPNode Text Text"
- listFromObject = mapM helper <=< fromMapping where
+instance ConvertAttempt TextObject [RPNode] where
+ convertAttempt = mapM helper <=< fromMapping where
helper :: (Text, TextObject) -> Attempt RPNode
helper (rp, rest) = do
verbMap <- fromTextObject rest
let rp' = cs (cs rp :: String)
return $ RPNode rp' verbMap
-instance FromObject VerbMap Text Text where
- fromObject (Scalar s) = return $ AllVerbs $ cs s
- fromObject (Mapping m) = Verbs `fmap` mapM helper m where
+instance ConvertAttempt TextObject VerbMap where
+ convertAttempt (Scalar s) = return $ AllVerbs $ cs s
+ convertAttempt (Mapping m) = Verbs `fmap` mapM helper m where
helper :: (Text, TextObject) -> Attempt (Verb, String)
helper (v, Scalar f) = do
v' <- ca (cs v :: String)
return (v', cs f)
helper (_, x) = failure $ VerbMapNonScalar x
- fromObject o = failure $ VerbMapSequence o
+ convertAttempt o = failure $ VerbMapSequence o
data RPNodeException = VerbMapNonScalar TextObject
| VerbMapSequence TextObject
deriving (Show, Typeable)
diff --git a/yesod.cabal b/yesod.cabal
index dcec0e08..137fa631 100644
--- a/yesod.cabal
+++ b/yesod.cabal
@@ -36,7 +36,7 @@ library
bytestring >= 0.9.1.4 && < 0.10,
web-encodings >= 0.2.0 && < 0.3,
data-object >= 0.2.0 && < 0.3,
- yaml >= 0.2.0 && < 0.3,
+ data-object-yaml >= 0.0.0 && < 0.1,
enumerable >= 0.0.3 && < 0.1,
directory >= 1 && < 1.1,
transformers >= 0.1.4.0 && < 0.2,
@@ -44,7 +44,7 @@ library
control-monad-attempt >= 0.0.0 && < 0.1,
syb,
text >= 0.5 && < 0.6,
- convertible-text >= 0.0.1 && < 0.1,
+ convertible-text >= 0.2.0 && < 0.3,
clientsession >= 0.0.1 && < 0.1,
zlib >= 0.5.2.0 && < 0.6,
containers >= 0.2.0.1 && < 0.3,