Skip to content

Instantly share code, notes, and snippets.

@joefiorini

joefiorini/error.txt

Last active August 29, 2015 14:04
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save joefiorini/df6813cdf6ac560c1ede to your computer and use it in GitHub Desktop.
Save joefiorini/df6813cdf6ac560c1ede to your computer and use it in GitHub Desktop.
Download ZIP
Raw
error.txt
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") [] []) }'
Raw
main.hs
{-# 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 ())
@stepcut
Copy link

stepcut commented Jul 23, 2014 

{-# 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