Last active

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist
View error.txt
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 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
main.hs:136:7:
Couldn't match expected type `Data.Text.Internal.Lazy.Text'
with actual type `StringType m1'
The type variable `m1' is ambiguous
Possible fix: add a type signature that fixes these type variable(s)
In the second argument of `($)', namely
`template
"Home"
()
(genElement
(Nothing, fromStringLit "div")
[]
[asChild
((genElement
(Nothing, fromStringLit "h1")
[]
[asChild (fromStringLit "Welcome to the Happstack CMS!")])),
asChild
((genElement
(Nothing, fromStringLit "p")
[]
[asChild
(fromStringLit
"This is a demo CMS written in Happstack. Cool stuff, eh?")])),
asChild
((genElement
(Nothing, fromStringLit "a")
[asAttr (fromStringLit "href" := fromStringLit "/announcements")]
[asChild (fromStringLit "Announcements")]))])'
In the expression:
ok <$> toResponse
$ template
"Home"
()
(genElement
(Nothing, fromStringLit "div")
[]
[asChild
((genElement
(Nothing, fromStringLit "h1")
[]
[asChild (fromStringLit "Welcome to the Happstack CMS!")])),
asChild
((genElement
(Nothing, fromStringLit "p")
[]
[asChild
(fromStringLit
"This is a demo CMS written in Happstack. Cool stuff, eh?")])),
asChild
((genElement
(Nothing, fromStringLit "a")
[asAttr (fromStringLit "href" := fromStringLit "/announcements")]
[asChild (fromStringLit "Announcements")]))])
In an equation for `homePage':
homePage
= ok <$> toResponse
$ template
"Home"
()
(genElement
(Nothing, fromStringLit "div")
[]
[asChild
((genElement
(Nothing, fromStringLit "h1")
[]
[asChild (fromStringLit "Welcome to the Happstack CMS!")])),
asChild
((genElement
(Nothing, fromStringLit "p")
[]
[asChild
(fromStringLit
"This is a demo CMS written in Happstack. Cool stuff, eh?")])),
asChild
((genElement
(Nothing, fromStringLit "a")
[asAttr (fromStringLit "href" := fromStringLit "/announcements")]
[asChild (fromStringLit "Announcements")]))])
 
main.hs:148:20:
Couldn't match expected type `Data.Text.Internal.Lazy.Text'
with actual type `StringType m0'
The type variable `m0' is ambiguous
Possible fix: add a type signature that fixes these type variable(s)
In the expression:
defaultTemplate
"Announcements"
()
(genElement
(Nothing, fromStringLit "div")
[]
[asChild
((genElement
(Nothing, fromStringLit "p")
[]
[asChild
(fromStringLit "\"There are no announcements in the system\"")])),
asChild
((genElement
(Nothing, fromStringLit "form")
[asAttr (fromStringLit "method" := fromStringLit "post"),
asAttr (fromStringLit "action" := fromStringLit "/new")]
[asChild
((genElement (Nothing, fromStringLit "button") [...] [...]))]))])
In a case alternative:
[]
-> defaultTemplate
"Announcements"
()
(genElement
(Nothing, fromStringLit "div")
[]
[asChild
((genElement
(Nothing, fromStringLit "p")
[]
[asChild
(fromStringLit "\"There are no announcements in the system\"")])),
asChild
((genElement
(Nothing, fromStringLit "form")
[asAttr (fromStringLit "method" := fromStringLit "post"), ....]
[asChild ((genElement ... ... ...))]))])
In the second argument of `($)', namely
`case announcements of {
[]
-> defaultTemplate
"Announcements"
()
(genElement
(Nothing, fromStringLit "div")
[]
[asChild ((genElement (Nothing, fromStringLit "p") [] [...])),
asChild
((genElement (Nothing, fromStringLit "form") [...] [...]))])
_ -> defaultTemplate
"Announcements"
()
(genElement (Nothing, fromStringLit "div") [] []) }'
View error.txt
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 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts,
GeneralizedNewtypeDeriving, MultiParamTypeClasses,
TemplateHaskell, TypeFamilies, RecordWildCards,
OverloadedStrings, ScopedTypeVariables, OverlappingInstances, NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -F -pgmFhsx2hs #-}
 
module Main where
 
import Control.Applicative ((<$>), optional)
import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text as DText
import Data.Text (unpack)
import Data.Data (Data, Typeable)
import Data.IxSet as IxSet
import Happstack.Server
( Happstack, HasRqData, Method(GET, POST), Request(rqMethod)
, Response
, ServerPartT(..), ServerPart, WebMonad, FilterMonad, ServerMonad
, askRq, decodeBody, dir, defaultBodyPolicy, lookText
, mapServerPartT, nullConf, nullDir, ok, simpleHTTP
, seeOther, method
, toResponse
)
import Control.Exception (bracket)
 
import Data.Monoid
 
import HSP
import HSP.Monad
import Happstack.Server.HSP.HTML
import Happstack.Server.XMLGenT
 
import HSP.HTML4
 
import Data.Time (UTCTime)
import Data.Time.Clock (getCurrentTime)
 
import Data.Acid (AcidState, Query, Update, makeAcidic, openLocalState)
import Data.Acid.Advanced (query', update')
import Data.Acid.Local (createCheckpointAndClose)
import Data.SafeCopy (base, deriveSafeCopy, SafeCopy)
 
newtype ContentItemId = ContentItemId { itemId' :: Integer }
deriving (Eq, Ord, Data, Show, Enum, Read, Typeable, SafeCopy)
 
newtype ContentItemSlug = ContentItemSlug { itemSlug :: String }
deriving (Eq, Ord, Data, Show, Read, Typeable, SafeCopy)
 
data ContentItemType = Announcement | Event | Offer
deriving (Eq, Ord, Show, Data, Read, Typeable)
 
$(deriveSafeCopy 0 'base ''ContentItemType)
 
data ContentItem = ContentItem {
itemId :: ContentItemId,
itemType :: ContentItemType,
title :: Text,
description :: Text,
slug :: Maybe ContentItemSlug,
publishAt :: UTCTime,
createdAt :: UTCTime,
updatedAt :: UTCTime
} deriving (Eq, Ord, Read, Show, Data, Typeable)
 
$(deriveSafeCopy 0 'base ''ContentItem)
 
{- Need to also index by itemType, so I can query by itemType in the UI -}
 
instance Indexable ContentItem where
empty = ixSet
[ ixFun $ \item -> [ itemId item ],
ixFun $ \item -> [ slug item ],
ixFun $ \item -> [ itemType item ]
]
 
data ContentCollection = ContentCollection {
nextContentItemId :: ContentItemId,
contentItems :: IxSet ContentItem
} deriving (Data, Typeable)
 
$(deriveSafeCopy 0 'base ''ContentCollection)
 
initialContentState :: ContentCollection
initialContentState =
ContentCollection { nextContentItemId = ContentItemId 1,
contentItems = IxSet.empty
}
 
newContentItem :: UTCTime -> Update ContentCollection ContentItem
newContentItem pubDate = do
c@ContentCollection{..} <- get
let contentItem = ContentItem { itemId = nextContentItemId,
title = DText.empty,
description = DText.empty,
slug = Nothing,
publishAt = pubDate,
itemType = Announcement,
createdAt = pubDate,
updatedAt = pubDate }
put $ c { nextContentItemId = succ nextContentItemId,
contentItems = IxSet.insert contentItem contentItems }
return contentItem
 
allAnnouncements :: Query ContentCollection [ContentItem]
allAnnouncements = do
ContentCollection{..} <- ask
let items' = IxSet.toList $ contentItems @= Announcement
return items'
 
$(makeAcidic ''ContentCollection
[ 'newContentItem
, 'allAnnouncements
])
main :: IO ()
main = do bracket (openLocalState initialContentState)
(createCheckpointAndClose)
(\acid ->
simpleHTTP nullConf (myApp acid))
 
myApp :: AcidState ContentCollection -> ServerPart Response
myApp acid = msum
[ dir "announcements" $ announcements acid,
dir "new" $ newAnnouncement acid,
homePage ]
 
template = defaultTemplate
 
homePage :: ServerPart Response
homePage =
ok <$> toResponse $ template "Home"
()
<div>
<h1>Welcome to the Happstack CMS!</h1>
<p>This is a demo CMS written in Happstack. Cool stuff, eh?</p>
<a href="/announcements">Announcements</a>
</div>
 
announcements :: AcidState ContentCollection -> ServerPart Response
announcements acid = do
announcements <- query' acid (AllAnnouncements)
ok <$> toResponse $
case announcements of
[] -> defaultTemplate "Announcements"
()
<div>
<p>"There are no announcements in the system"</p>
<form method="post" action="/new">
<button type="submit">New Announcement</button>
</form>
</div>
_ -> defaultTemplate "Announcements" () <div></div>
-- H.ol $ mapM_ announcement' announcements
-- where
-- announcement' ContentItem{..} =
-- H.h3 (H.toHtml $ show title)
 
newAnnouncement :: AcidState ContentCollection -> ServerPart Response
newAnnouncement acid = do
method POST
now <- liftIO $ getCurrentTime
item <- update' acid (NewContentItem now)
let url = "/edit?id=" ++ show (itemId' $ itemId item)
seeOther url (toResponse ())
{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts,
  GeneralizedNewtypeDeriving, MultiParamTypeClasses,
  TemplateHaskell, TypeFamilies, RecordWildCards,
  OverloadedStrings, ScopedTypeVariables, OverlappingInstances, NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -F -pgmFhsx2hs #-}

module Main where

import Control.Applicative ((<$>), optional)
import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text as DText
import Data.Text (unpack)
import qualified Data.Text.Lazy as TL
import Data.Data (Data, Typeable)
import Data.IxSet as IxSet
import Happstack.Server
    ( Happstack, HasRqData, Method(GET, POST), Request(rqMethod)
    , Response
    , ServerPartT(..), ServerPart, WebMonad, FilterMonad, ServerMonad
    , askRq, decodeBody, dir, defaultBodyPolicy, lookText
    , mapServerPartT, nullConf, nullDir, ok, simpleHTTP
    , seeOther, method
    , toResponse
    )
import Control.Exception (bracket)

import Data.Monoid

import HSP
import HSP.Monad
import HSP.ServerPartT
import Happstack.Server.HSP.HTML
import Happstack.Server.XMLGenT

import HSP.HTML4

import Data.Time (UTCTime)
import Data.Time.Clock (getCurrentTime)

import Data.Acid (AcidState, Query, Update, makeAcidic, openLocalState)
import Data.Acid.Advanced (query', update')
import Data.Acid.Local (createCheckpointAndClose)
import Data.SafeCopy (base, deriveSafeCopy, SafeCopy)

newtype ContentItemId = ContentItemId { itemId' :: Integer }
  deriving (Eq, Ord, Data, Show, Enum, Read, Typeable)

deriveSafeCopy 0 'base ''ContentItemId

newtype ContentItemSlug = ContentItemSlug { itemSlug :: String }
  deriving (Eq, Ord, Data, Show, Read, Typeable)

deriveSafeCopy 0 'base ''ContentItemSlug
data ContentItemType = Announcement | Event | Offer
  deriving (Eq, Ord, Show, Data, Read, Typeable)

$(deriveSafeCopy 0 'base ''ContentItemType)

data ContentItem = ContentItem {
  itemId :: ContentItemId,
  itemType :: ContentItemType,
  title :: Text,
  description :: Text,
  slug :: Maybe ContentItemSlug,
  publishAt :: UTCTime,
  createdAt :: UTCTime,
  updatedAt :: UTCTime
} deriving (Eq, Ord, Read, Show, Data, Typeable)

$(deriveSafeCopy 0 'base ''ContentItem)

{- Need to also index by itemType, so I can query by itemType in the UI -}

instance Indexable ContentItem where
  empty = ixSet
    [ ixFun $ \item -> [ itemId item ],
      ixFun $ \item -> [ slug item ],
      ixFun $ \item -> [ itemType item ]
    ]

data ContentCollection = ContentCollection {
  nextContentItemId :: ContentItemId,
  contentItems :: IxSet ContentItem
} deriving (Data, Typeable)

$(deriveSafeCopy 0 'base ''ContentCollection)

initialContentState :: ContentCollection
initialContentState =
  ContentCollection { nextContentItemId = ContentItemId 1,
                      contentItems = IxSet.empty
  }

newContentItem :: UTCTime -> Update ContentCollection ContentItem
newContentItem pubDate = do
  c@ContentCollection{..} <- get
  let contentItem = ContentItem { itemId = nextContentItemId,
                                  title = DText.empty,
                                  description = DText.empty,
                                  slug = Nothing,
                                  publishAt = pubDate,
                                  itemType = Announcement,
                                  createdAt = pubDate,
                                  updatedAt = pubDate }
  put $ c { nextContentItemId = succ nextContentItemId,
            contentItems = IxSet.insert contentItem contentItems }
  return contentItem

allAnnouncements :: Query ContentCollection [ContentItem]
allAnnouncements = do
  ContentCollection{..} <- ask
  let items' = IxSet.toList $ contentItems @= Announcement
  return items'

$(makeAcidic ''ContentCollection
  [ 'newContentItem
  , 'allAnnouncements
  ])
main :: IO ()
main = do bracket (openLocalState initialContentState)
               (createCheckpointAndClose)
               (\acid ->
                    simpleHTTP nullConf (myApp acid))

myApp :: AcidState ContentCollection -> ServerPart Response
myApp acid = msum
  [ -- dir "announcements" $ announcements acid,
    -- dir "new" $ newAnnouncement acid,
    homePage ]

template :: ( EmbedAsChild (ServerPartT IO) headers
            , EmbedAsChild (ServerPartT IO) body
            ) =>
            TL.Text
         -> headers
         -> body
         -> ServerPartT IO XML
template = defaultTemplate

homePage :: ServerPart Response
homePage =
    ok . toResponse =<< template "Home"
          ()
          (<div>
            <h1>Welcome to the Happstack CMS!</h1>
            <p>This is a demo CMS written in Happstack. Cool stuff, eh?</p>
            <a href="/announcements">Announcements</a>
          </div>)

announcements :: AcidState ContentCollection -> ServerPart Response
announcements acid = do
  announcements <- query' acid (AllAnnouncements)
  ok . toResponse =<<
    case announcements of
      [] -> template "Announcements"
              ()
              <div>
                <p>"There are no announcements in the system"</p>
                <form method="post" action="/new">
                  <button type="submit">New Announcement</button>
                </form>
              </div>
      _ -> template "Announcements" () <div></div>
            -- H.ol $ mapM_ announcement' announcements
    -- where
    --   announcement' ContentItem{..} =
    --     H.h3 (H.toHtml $ show title)

newAnnouncement :: AcidState ContentCollection -> ServerPart Response
newAnnouncement acid = do
  method POST
  now <- liftIO $ getCurrentTime
  item <- update' acid (NewContentItem now)
  let url = "/edit?id=" ++ show (itemId' $ itemId item)
  seeOther url (toResponse ())
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.