~ben/yesod-text-markdown

ref: 7d7e35b97d50360197a6139df8354d9926ede8a8 yesod-text-markdown/Yesod/Text/Markdown.hs -rw-r--r-- 1.7 KiB
7d7e35b9 — Arash Rouhani Merge pull request #11 from MaxGabriel/documentMarkdownField 7 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Text.Markdown where

import Yesod.Core (RenderMessage)
import Text.Hamlet (hamlet)
import Yesod.Form
import Yesod.Core (HandlerSite)
import Yesod.Core.Widget
import Yesod.Persist
import Data.Text (Text)
import Data.Text.Lazy (toStrict, fromStrict)
import Text.Markdown (Markdown (Markdown))
import Database.Persist.Sql
import Control.Applicative ((<$>))
import Control.Monad (mzero)
import Data.Aeson

instance PersistField Markdown where
  toPersistValue (Markdown t) = PersistText $ toStrict t
  fromPersistValue (PersistText t) = Right $ Markdown $ fromStrict t
  fromPersistValue _ = Left "Not a PersistText value"

instance PersistFieldSql Markdown where
    sqlType _ = SqlString

instance ToJSON Markdown where
  toJSON (Markdown text) = object ["markdown" .= text]

instance FromJSON Markdown where
  parseJSON (Object v) = Markdown <$> v .: "markdown"
  parseJSON _ = mzero

-- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Markdown' newtype; see 'Markdown' for details.
markdownField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Markdown
markdownField = Field
    { fieldParse = parseHelper $ Right . Markdown . fromStrict
    , fieldView = \theId name attrs val isReq -> toWidget
        [hamlet|$newline never
<textarea id="#{theId}" name="#{name}" :isReq:required="" *{attrs}>#{either id extractStrict val}
|]
   , fieldEnctype = UrlEncoded -- I choose UrlEncoded because textareaField is
     }
     where
        extractStrict :: Markdown -> Text
        extractStrict (Markdown lt) = toStrict lt