working off a Yesod example file, need help lifting values from one monad into another. (and probably other things too).

28 Mar 2011

I'm working off of a example file from Yesod, ajax.lhs
I've made an important change in types, and this has resulted in
having to make the old code conform to the change. I will point out
the specifics, then present my question. In the event I failed to
include important information, I will paste in my code as well as the
prototype.

[Original]
...
getHomeR :: Handler ()
getHomeR = do
  Ajax pages _ <- getYesod
  let first = head pages
  redirect RedirectTemporary $ PageR $ pageSlug first
[Changed]
...
getHomeR :: Handler ()
getHomeR = do
  Tframe pages _ <- getYesod
  let first = head pages
  redirect RedirectTemporary $ PageR $ pageSlug first
Error Message

test.lhs:62:4:
    Constructor `Tframe' should have 2 arguments, but has been given 1
    In the pattern: Tframe pages
    In a stmt of a 'do' expression: Tframe pages <- getYesod   ****
This is not what I wrote *****
    In the expression:
        do { Tframe pages <- getYesod;
             content <- widgetToPageContent widget;
             hamletToRepHtml
               (hamlet-0.7.1:Text.Hamlet.Quasi.toHamletValue
                  (do { (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
                       . preEscapedString)
                          "<!DOCTYPE html><html><head><title>";
                        (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
                       . Text.Blaze.toHtml)
                          (Main.pageTitle content);
                        .... })) }

As far as I can tell, I only made a cosmetic change. I don't know
what's going on here.

[Original]
...
data Page = Page
  { pageName :: String
  , pageSlug :: String
  , pageContent :: String     ******** I'm going to change this **********
  }
[Changed]
...
data Page = Page
      { pageTitle :: String
      , pageSlug :: String -- ^ used in the URL
      , pageContent :: IO String           ******** This is the change *******
      }
Here's where I run into trouble

[Original]
...
json page = jsonMap
      [ ("name", jsonScalar $ pageName page)
      , ("content", jsonScalar $ pageContent page)   ******** I'm going to change this ********
      ]
[My changes]
...
json page = jsonMap
      [ ("name", jsonScalar $ Main.pageTitle page)
      , ("content", jsonScalar $ liftIO $ pageContent page) ******* This is the change ***********
      ]
Here's the compiler error

test.lhs:107:35:
    Couldn't match expected type `Char' against inferred type `[Char]'
      Expected type: String
      Inferred type: [String]
    In the second argument of `($)', namely `liftIO $ pageContent page'
    In the expression: jsonScalar $ liftIO $ pageContent page
Failed, modules loaded: none.

I'd appreciate a discussion about why this is wrong, and perhaps clues
as to what is right.

Last problem, stemming from the change in type to IO String. I don't
have a clue as to what change I should make.

test.lhs:100:25:
    No instance for (Text.Blaze.ToHtml (IO String))
      arising from a use of `Text.Blaze.toHtml'
                   at test.lhs:(100,25)-(103,3)
    Possible fix:
      add an instance declaration for (Text.Blaze.ToHtml (IO String))
    In the second argument of `(.)', namely `Text.Blaze.toHtml'
    In a stmt of a 'do' expression:
        (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
       . Text.Blaze.toHtml)
          (pageContent page)
    In the first argument of
`hamlet-0.7.1:Text.Hamlet.Quasi.toHamletValue', nam

                          ely
        `do { (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . preEscapedString)
                "<h1>";
              (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . Text.Blaze.toHtml)
                (Main.pageTitle page);
              (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . preEscapedString)
                "</h1><article>";
              (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . Text.Blaze.toHtml)
                (pageContent page);
              .... }'

And finally, both files can be found below, if it is necessary to look at them.

[Original]

We're going to write a very simple AJAX application. It will be a
simple site with a few pages and a navbar; when you have Javascript,
clicking on the links will load the pages via AJAX. Otherwise, it will
use static HTML.

We're going to use jQuery for the Javascript, though anything would
work just fine. Also, the AJAX responses will be served as JSON. Let's
get started.
...
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses #-}
import Yesod
import Yesod.Helpers.Static
import Data.Monoid (mempty)
Like the blog example, we'll define some data first.
...
data Page = Page
 { pageName :: String
 , pageSlug :: String
 , pageContent :: String
 }
...
loadPages :: IO [Page]
loadPages = return
 [ Page "Page 1" "page-1" "My first page"
 , Page "Page 2" "page-2" "My second page"
 , Page "Page 3" "page-3" "My third page"
 ]
loadPages :: IO [Page]
 loadPages = do
...
data Ajax = Ajax
 { ajaxPages :: [Page]
 , ajaxStatic :: Static
 }
type Handler = GHandler Ajax Ajax
Next we'll generate a function for each file in our static folder.
This way, we get a compiler warning when trying to using a file which
does not exist.
...
staticFiles "static/yesod/ajax"
Now the routes; we'll have a homepage, a pattern for the pages, and
use a static subsite for the Javascript and CSS files.
...
mkYesod "Ajax" [$parseRoutes|
/ HomeR GET
/page/#String PageR GET
/static StaticR Static ajaxStatic
|]
That third line there is the syntax for a subsite: Static is the
datatype for the subsite argument; siteStatic returns the site itself
(parse, render and dispatch functions); and ajaxStatic gets the
subsite argument from the master argument.

<p>Now, we'll define the Yesod instance. We'll still use a dummy
approot value, but we're also going to define a default layout.</p>
...
instance Yesod Ajax where
  approot _ = ""
  defaultLayout widget = do
  Ajax pages _ <- getYesod
  content <- widgetToPageContent widget
  hamletToRepHtml [$hamlet|
\<!DOCTYPE html>
<html>
  <head>
    <title>#{pageTitle content}
    <link rel="stylesheet" href="@{StaticR style_css}">
    <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js">
    <script src="@{StaticR script_js}">
    \^{pageHead content}
  <body>
    <ul id="navbar">
      $forall page <- pages
        <li>
          <a href="@{PageR (pageSlug page)}">#{pageName page}
    <div id="content">
      \^{pageBody content}
|]
<p>The Hamlet template refers to style_css and style_js; these were
generated by the call to staticFiles above.  There's nothing
Yesod-specific about the <a
href="/static/yesod/ajax/style.css">style.css</a> and <a
href="/static/yesod/ajax/script.js">script.js</a> files, so I won't
describe them here.</p>

<p>Now we need our handler functions. We'll have the homepage simply
redirect to the first page, so:</p>
...
getHomeR :: Handler ()
getHomeR = do
  Ajax pages _ <- getYesod
  let first = head pages
  redirect RedirectTemporary $ PageR $ pageSlug first
And now the cool part: a handler that returns either HTML or JSON
data, depending on the request headers.
...
getPageR :: String -> Handler RepHtmlJson
getPageR slug = do
  Ajax pages _ <- getYesod
  case filter (\e -> pageSlug e == slug) pages of
      [] -> notFound
      page:_ -> defaultLayoutJson (do
          setTitle $ string $ pageName page
          addHamlet $ html page
          ) (json page)
 where
  html page = [$hamlet|
<h1>#{pageName page}
<article>#{pageContent page}
|]
  json page = jsonMap
      [ ("name", jsonScalar $ pageName page)
      , ("content", jsonScalar $ pageContent page)
      ]
<p>We first try and find the appropriate Page, returning a 404 if it's
not there. We then use the applyLayoutJson function, which is really
the heart of this example. It allows you an easy way to create
responses that will be either HTML or JSON, and which use the default
layout in the HTML responses. It takes four arguments: 1) the title of
the HTML page, 2) some value, 3) a function from that value to a
Hamlet value, and 4) a function from that value to a Json value.</p>

Under the scenes, the Json monad is really just using the Hamlet
monad, so it gets all of the benefits thereof, namely interleaved IO
and enumerator output. It is pretty straight-forward to generate JSON
output by using the three functions jsonMap, jsonList and jsonMap. One
thing to note: the input to jsonScalar must be HtmlContent; this helps
avoid cross-site scripting attacks, by ensuring that any HTML entities
will be escaped.

<p>And now our typical main function. We need two parameters to build
our Ajax value: the pages, and the static loader. We'll load up from a
local directory.</p>
...
main :: IO ()
main = do
pages <- loadPages
  let s = static "static/yesod/ajax"
  warpDebug 3000 $ Ajax pages s
[My changes]
...
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
 #-}
import Yesod
import Yesod.Helpers.Static
import System.Environment
import System.IO
import System.Directory
import System.FilePath.Posix
import Control.Applicative
import Data.List.Split
...
data Page = Page
      { pageTitle :: String
      , pageSlug :: String -- ^ used in the URL
      , pageContent :: IO String
      }
...
loadPage :: IO [Page]
loadPage = do
 let directoryPath = "/home/mlitchard/playground/webTests/files"
 let processedPath = map (directoryPath ) . filter (`notElem` [".",".."])
 pageFileNames <- processedPath <$> getDirectoryContents directoryPath
 let pageFiles = map readFile pageFileNames
 return $ zipWith popEntries pageFileNames pageFiles
-- >  return $ zipWith popEntries
...
popEntries :: FilePath -> IO String -> Page
popEntries pageFileName pageFile =
  let pageT = last $ splitOn "/" pageFileName
      pageS = "Job" ++ pageT
  in  Page { Main.pageTitle=pageT,
             pageSlug=pageS,
             pageContent=pageFile }
...
data Tframe = Tframe
  { tframePages :: [Page]
  , tframeStatic :: Static
  }
...
type Handler = GHandler Tframe Tframe
...
staticFiles "static/yesod/ajax"
Routes
...
mkYesod "Tframe" [$parseRoutes|
/                    HomeR   GET
/page/#String        PageR   GET
/static              StaticR Static tframeStatic
|]
defining the Yesod instance
...
instance Yesod Tframe where
  approot _ = ""
  defaultLayout widget = do
  Tframe pages <- getYesod
  content <- widgetToPageContent widget
  hamletToRepHtml [$hamlet|
\<!DOCTYPE html>
<html>
  <head>
    <title>#{Main.pageTitle content}
    <link rel="stylesheet" href="@{StaticR style_css}">
    <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js">
    <script src="@{StaticR script_js}">
    \^{pageHead content}
  <body>
    <ul id="navbar">
      $forall page <- pages
        <li>
          <a href="@{PageR (pageSlug page)}">#{Main.pageTitle page}
    <div id="content">
      \^{pageBody content}
|]
...
getHomeR :: Handler ()
getHomeR = do
  Tframe pages _ <- getYesod
  let first = head pages
  redirect RedirectTemporary $ PageR $ pageSlug first
...
getPageR :: String -> Handler RepHtmlJson
getPageR slug = do
  Tframe pages _ <- getYesod
  case filter (\e -> pageSlug e == slug) pages of
      [] -> notFound
      page:_ -> defaultLayoutJson (do
          setTitle $ string $ Main.pageTitle page
          addHamlet $ html page
          ) (json page)
 where
  html page = [$hamlet|
<h1>#{Main.pageTitle page}
<article>#{pageContent page}
|]
...
json page = jsonMap
      [ ("name", jsonScalar $ Main.pageTitle page)
      , ("content", jsonScalar $ liftIO $ pageContent page)
      ]
...
main :: IO ()
main = do
pages <- loadPage
  let s = static "static/yesod/ajax"
  warpDebug 3000 $ Tframe pages s
If you've read to the bottom, thanks for your patience. I appreciate
any illumination you can send my way.

Michael

Michael Litchard

Luke Palmer

Michael Litchard

Christopher Done

tags

participants (3)