how do I modify inputText to use inputCheckbox - haskell

I am trying to do something similar to this, where for an element in list of strings, I have a checkbox next to it and figure out which checkbox is checked or not. Using examples from the internet, I was able to get an example running
{-# LANGUAGE OverloadedStrings #-}
import Data.Monoid
import Data.String
import Data.List
import qualified Data.Text as T
import Web.Spock.Safe
import Web.Spock.Digestive
import Text.Blaze (ToMarkup(..))
import Text.Blaze.Html5 hiding (html, param, main)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Digestive
import Text.Digestive.Blaze.Html5
import System.Directory
import Control.Monad.IO.Class
import Control.Monad (forM_)
gen :: Html -> [Html] -> Html
gen title elts = H.html $ do
H.head $
H.title title
H.body $
H.ul $ mapM_ H.li elts
data CheckBox = CheckBox { postTitle :: T.Text }
checkboxForm = CheckBox
<$> "title" .: Text.Digestive.text Nothing
renderForm :: View Html -> Html
renderForm v = do
Text.Digestive.Blaze.Html5.form v "POST" $ do
H.p $ do
Text.Digestive.Blaze.Html5.label "title" v "Post title: "
inputText "text" v
inputSubmit "Submit Post"
main :: IO ()
main =
runSpock 8080 $ spockT Prelude.id $ do
get root $ do
listing <- liftIO $ getDirectoryContents "/home/hasenov/mydir"
let filteredListing = filter (\l -> not $ isPrefixOf "." l) listing
(view, result) <- runForm "checkboxForm" checkboxForm
case result of
Nothing -> lazyBytes $ renderHtml (renderForm view)
Just newCheckbox -> lazyBytes $ renderHtml (renderForm view)
-- lazyBytes $ renderHtml (gen "My Blog" (Data.List.map fromString filteredListing))
-- get ("hello" <//> var) $ \name ->
-- text ("Hello " <> name <> "!")
However, in the function renderForm, when I change inputText to something like inputCheckbox "True", I get the error True does not exist. I am not able to find an example where inputCheckbox is used, I was hoping someone would help me adapt filteredString so it would display checkboxes next to it, and I can run the form properly. Also, in previous link I posted, I don't know what the function inputCheckBox, since I could only find inputCheckbox. Perhaps this is an outdated function?

I'm answering my own question since I figured out how to get inputCheckbox instead of inputText. Actually, this example helped alot. It was the only one I could find which uses inputCheckbox. What I needed to do was change
data CheckBox = CheckBox { postTitle :: T.Text }
to
data CheckBox = CheckBox Bool
Then I could just initialized
checkboxForm = CheckBox
<$> "title" .: bool (Just False)
Here is the full source:
{-# LANGUAGE OverloadedStrings #-}
import Data.Monoid
import Data.String
import Data.List
import qualified Data.Text as T
import Web.Spock.Safe
import Web.Spock.Digestive
import Text.Blaze (ToMarkup(..))
import Text.Blaze.Html5 hiding (html, param, main)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Digestive
import Text.Digestive.Blaze.Html5
import System.Directory
import Control.Monad.IO.Class
import Control.Monad (forM_)
gen :: Html -> [Html] -> Html
gen title elts = H.html $ do
H.head $
H.title title
H.body $
H.ul $ mapM_ H.li elts
data CheckBox = CheckBox Bool
checkboxForm = CheckBox
<$> "title" .: bool (Just False)
renderForm :: View Html -> [Html] -> Html
renderForm v strings = do
Text.Digestive.Blaze.Html5.form v "POST" $ do
H.p $ mapM_ (\string -> do
inputCheckbox "title" v
Text.Digestive.Blaze.Html5.label "title" v string
H.br) strings
inputSubmit "Submit Post"
main :: IO ()
main =
runSpock 8080 $ spockT Prelude.id $ do
get root $ do
listing <- liftIO $ getDirectoryContents "/home/ecks/btsync-gambino"
let filteredListing = filter (\l -> not $ isPrefixOf "." l) listing
(view, result) <- runForm "checkboxForm" checkboxForm
case result of
Nothing -> lazyBytes $ renderHtml (renderForm view (Data.List.map fromString filteredListing))
Just newCheckbox -> lazyBytes $ renderHtml (renderForm view (Data.List.map fromString filteredListing))
-- lazyBytes $ renderHtml (gen "My Blog" (Data.List.map fromString filteredListing))
-- get ("hello" <//> var) $ \name ->
-- text ("Hello " <> name <> "!")

Related

How to find definition of Haskell function in VSCode?

I'm learning Haskell, and some functions like text aren't easy to google. Look at this example:
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Web.Spock
import Web.Spock.Config
import Control.Monad.Trans
import Data.IORef
import qualified Data.Text as T
data MySession = EmptySession
data MyAppState = DummyAppState (IORef Int)
main :: IO ()
main =
do ref <- newIORef 0
spockCfg <- defaultSpockCfg EmptySession PCNoDatabase (DummyAppState ref)
runSpock 8080 (spock spockCfg app)
app :: SpockM () MySession MyAppState ()
app =
do get root $ text "Hello World!"
get ("hello" <//> var) $ \name ->
do (DummyAppState ref) <- getState
visitorNumber <- liftIO $ atomicModifyIORef' ref $ \i -> (i+1, i+1)
text ("Hello " <> name <> ", you are visitor number " <> T.pack (show visitorNumber))
do get root $ text "Hello World!"
Normally, on VSCode, with any language, I would click on text with the rigth button, and "go to defintion". How do I find the definition of a function in VSCode?
I installed the haskell.haskell extension, and it didn't add this functionality.

Haskell web routes example with Happstack and blaze is not showing two different URLs

I've already done the the Happstack crash course and had working reform and web routes examples. I'm trying to combine the two like so, but showURL Home and showURL Login show the same URL for my example application.
Here is the example application
, GeneralizedNewtypeDeriving
, TemplateHaskell
, TypeOperators
, GADTs
, OverloadedStrings
, TypeFamilies
#-}
module Main where
import Data.Data
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Text.Blaze
import Text.Blaze.Html
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Reform
import Text.Reform.Happstack
import Text.Reform.Blaze.Text
import Happstack.Server
import Web.Routes
import Web.Routes.TH
import Web.Routes.Happstack
import Web.Routes.Boomerang
import Text.Boomerang.TH
import Text.Boomerang.HStack
import Text.Boomerang.Texts ()
import Data.Text
data Sitemap
= Login
| Home
deriving (Eq, Ord, Read, Show, Data, Typeable)
-- $(derivePathInfo ''Sitemap)
$(makeBoomerangs ''Sitemap)
sitemap :: Router () (Sitemap :- ())
sitemap = rLogin
<> rHome
site :: Site Sitemap (ServerPartT IO Response)
site =
setDefault Login $ boomerangSiteRouteT route sitemap
route :: Sitemap -> RouteT Sitemap (ServerPartT IO) Response
route Login = loginPage
route Home = homePage
appTemplate :: String
-> [H.Html]
-> H.Html
-> H.Html
appTemplate title headers body =
H.html $ do
H.head $ do
H.title $ toHtml title
sequence_ headers
H.body $ do
body
data LoginData = LoginData
{ username :: Text
, password :: Text
}
renderLoginData :: LoginData -> H.Html
renderLoginData loginData = H.dl $ do H.dt $ "name: "
H.dd $ (text . username) loginData
H.dt $ "password: "
H.dd $ (text . password) loginData
data AppError
= AppCFE (CommonFormError [Input])
deriving Show
instance FormError AppError where
type ErrorInputType AppError = [Input]
commonFormError = AppCFE
loginForm :: Form (ServerPartT IO) [Input] AppError Html () LoginData
loginForm = LoginData
<$> label (Data.Text.pack "username:") ++> inputText (Data.Text.pack "") <++ br
<*> label (Data.Text.pack "password: ") ++> inputPassword <++ br
<* inputSubmit "post"
homePage :: RouteT Sitemap (ServerPartT IO) Response
homePage = ok $ toResponse $
H.html $ do
H.body $ do
H.p "You have logged in successfully"
loginPage :: RouteT Sitemap (ServerPartT IO) Response
loginPage =
do homeURL <- showURL Home
loginURL <- showURL Login
-- formHTML <- lift $ reform (form homeURL) "loginPage" displayMessage Nothing loginForm
ok $ toResponse $
H.html $ do
H.head $ do
H.title "Hello Form"
H.body $ do
-- formHTML
H.span $ toHtml homeURL
H.br
H.span $ toHtml loginURL
where
displayMessage :: LoginData -> ServerPartT IO H.Html
displayMessage loginData = return $ appTemplate "Form validation result" [] $ renderLoginData loginData
main :: IO ()
main = simpleHTTP nullConf $
msum [ implSite "http://localhost:8000" "" site
]
The homeURL and loginURL in the loginPage are equal, when they should have their own paths. When I did the Happstack crash course and when I refer to it, Sitemap's Home and UserOverview constructors receive their own URLs, so I'm not sure why my example script's Sitemap's constructors Login and Home are not receiving different URLs.
I found that it was a subtle issue in the imports. I needed to include these imports/
import Prelude hiding (head, id, (.))
import Control.Category (id, (.))
I will need to identify the difference between Prelude's composition (.) operator and Control.Category's composition (.) operator.
After adding the imports, I was able to change sitemap to
sitemap :: Router () (Sitemap :- ())
sitemap = rLogin
<> lit (Data.Text.pack "home") .rHome
where before it complained when using Prelude's composition operator.

Digestive functors: multiple file upload field?

I'm trying to recreate fairly standard image / file upload functionality whereby a given field allows the uploading of one or more files / images with something like an "add another file" button and/or the ability to replace existing files.
I have file uploads working and I have multiple subforms working, but I can't get multiple subforms working with file input.
I have created an example (shown below) heavily based on examples/dynamic-list.hs which highlights the problem, which appears to be that postForm returns an appropriate FilePath in the view but does not return it in the "result".
Another problem with dynamic-list.hs is that it only shows a trivial use case using static data. Having an actual dynamic form where the data changes in response to user input is significantly more complicated, so I'm hoping that I can hammer out a more comprehensive version of dynamic-list.hs which would be (much) more helpful to beginners.
My code so far:
{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections, ScopedTypeVariables, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
module Handler.Test where
import Prelude hiding (div, span)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Maybe
import Data.Text hiding (unlines, intercalate, concat)
import Data.Text.Encoding
import Snap.Core hiding (method)
import Snap.Snaplet
------------------------------------------------------------------------------
import Heist.Splices.Html
import Text.Digestive
import Text.Digestive.Snap
import Text.Digestive.Heist
import Text.Blaze.Html5 as H
import Text.Digestive.Blaze.Html5 as DH
import qualified Text.Blaze.Html5.Attributes as A
import Text.Digestive.Form
import Text.Digestive.Util
import Text.Blaze.Renderer.XmlHtml
import Data.List as L
------------------------------------------------------------------------------
import Application
import Helpers.Forms
import Helpers.Theme
import Debug.Trace
------------------------------------------------------------------------------
handleEntityTest :: Handler App App ()
handleEntityTest = undefined
type Product = Text
type Quantity = Int
--------------------------------------------------------------------------------
data Order = Order {
orderName :: Text
, orderItems :: [OrderItem]
} deriving (Show)
data OrderItem = OrderItem
{ orderProduct :: Text
, orderQuantity :: Quantity
, orderFile :: Maybe FilePath
} deriving (Show)
--------------------------------------------------------------------------------
orderForm :: Monad m => Order -> Form Html m Order
orderForm order = Order
<$> "orderName" .: text (Just $ orderName order)
<*> "orderItems" .: listOf orderItemForm (Just $ orderItems order)
orderItemForm :: Monad m => Formlet Html m OrderItem
orderItemForm def = OrderItem
<$> "product" .: text (orderProduct <$> def)
<*> "quantity" .: stringRead "Can't parse quantity" (orderQuantity <$> def)
<*> "file" .: file
--------------------------------------------------------------------------------
orderView :: View H.Html -> H.Html
orderView view = do
DH.form view "" $ do
DH.label "name" view "Order name: "
DH.inputText "orderName" view
H.br
DH.label "orderItems.indices" view "(Usually hidden) Indices: "
DH.inputText "orderItems.indices" view
H.br
mapM_ orderItemView $ listSubViews "orderItems" view
H.br
DH.inputSubmit "Submit"
orderItemView :: View H.Html -> H.Html
orderItemView view = do
childErrorList "" view
DH.label "product" view "Product: "
DH.inputText "product" view
H.br
DH.label "quantity" view "Quantity: "
DH.inputText "quantity" view
H.br
DH.label "file" view "file"
DH.inputFile "file" view
H.br
-------------------------------------------------------
handleTest :: Handler App App ()
handleTest = do
r <- runFormWith defaultFormConfig "test" $ orderForm $ Order "test form" [(OrderItem "" 0 Nothing)]
case r of
(view, Nothing) -> do
-- GET
renderPageHtml "Initial form view" $ toHtml $ orderView $ debugForm view
-- POST
(view, Just order) -> do
s <- runFormWith (defaultFormConfig { method = Just Get }) "test" $ orderForm $ order {orderItems = ((orderItems order) ++ [(OrderItem "" 0 Nothing)]) }
case s of
(view', Nothing) -> do
renderPageHtml "Subsequent form view" $ html
where
html = do
p $ do
mapM_ div [ br, br, br
, orderView $ debugForm view'
, toHtml $ show order
]
(view', Just order) -> do
renderPageHtml "Subsequent form view" $ p "This shouldn't ever happen"
------------------------------------------------------------
debugForm :: View Html -> View Html
debugForm v = trace (t) v
where
showTuple (path,input) = ("path : " ++ (show path) ++ "=" ++ (show input))
t = unlines $ [
(""), ("")
, ("viewName : " ++ (unpack $ viewName v) )
, ("viewMethod : " ++ (show $ viewMethod v) )
, ("viewContext : " ++ (show $ viewContext v) )
--, ("viewInput : " ++ (unlines $ fmap (\(path, input) -> (show path) ++ "=" ++ (show input) ) $ viewInput v ))
, ("viewInput : " ++ (unlines $ fmap showTuple $ viewInput v ))
, ("debugViews : " ++ (unlines $ fmap show $ debugViewPaths v) )
]

Is there a way how to enumerate all functions in a module using Template Haskell?

While I can use reify to get information about most other syntactic constructs, I couldn't find anything that would give some information about a module.
Unfortunately Template Haskell currently has no such capabilities. All the solutions involve parsing of the module's source-code. However the location and loc_filename functions of TH make it easy to locate the module with the calling splice.
Here is a solution extracted from the source code of one of my projects:
{-# LANGUAGE LambdaCase, TupleSections #-}
import Language.Haskell.TH
import qualified Data.Attoparsec.Text as AP
import qualified Data.Text.IO as Text
import qualified Data.Text as Text
import qualified Data.Char as Char
import Data.Maybe
import Data.List
import Control.Applicative
import Data.Traversable
import Prelude hiding (mapM)
reifyLocalFunctions :: Q [(Name, Type)]
reifyLocalFunctions =
listTopLevelFunctionLikeNames >>=
mapM (\name -> reifyFunction name >>= mapM (return . (name, ))) >>=
return . catMaybes
where
listTopLevelFunctionLikeNames = do
loc <- location
text <- runIO $ Text.readFile $ loc_filename loc
return $ map (mkName . Text.unpack) $ nub $ parse text
where
parse text =
either (error . ("Local function name parsing failure: " ++)) id $
AP.parseOnly parser text
where
parser =
AP.sepBy (optional topLevelFunctionP <* AP.skipWhile (not . AP.isEndOfLine))
AP.endOfLine >>=
return . catMaybes
where
topLevelFunctionP = do
head <- AP.satisfy Char.isLower
tail <- many (AP.satisfy (\c -> Char.isAlphaNum c || c `elem` ['_', '\'']))
return $ Text.pack $ head : tail
reifyFunction :: Name -> Q (Maybe Type)
reifyFunction name = do
tryToReify name >>= \case
Just (VarI _ t _ _) -> return $ Just $ t
_ -> return Nothing
tryToReify :: Name -> Q (Maybe Info)
tryToReify n = recover (return Nothing) (fmap Just $ reify n)

Haskell. MongoDB driver or Aeson charset problem

Good day, i have mongodb database filled with some data, i ensured that data stored in correct charset, to fetch data i use following snippet:
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Data.Enumerator (Iteratee (..))
import Data.Either (either)
import Control.Monad (join)
import Data.Maybe (fromMaybe)
import Network.HTTP.Types (statusOK, status404)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Char8 (unpack)
import Data.ByteString.Lazy.Char8 (pack)
import qualified Data.Text.Lazy as T
import Data.Text (Text(..))
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Aeson (encode)
import qualified Data.Map as Map
import qualified Database.MongoDB as DB
application dbpipe req = do
case unpack $ rawPathInfo req of
"/items" -> itemsJSON dbpipe req
_ -> return $ responseLBS status404 [("Content-Type", "text/plain")] "404"
indexPage :: Iteratee B.ByteString IO Response
indexPage = do
page <- liftIO $ processTemplate "templates/index.html" []
return $ responseLBS statusOK [("Content-Type", "text/html; charset=utf-8")] page
processTemplate f attrs = do
page <- L.readFile f
return page
itemsJSON :: DB.Pipe -> Request -> Iteratee B.ByteString IO Response
itemsJSON dbpipe req = do
dbresult <- liftIO $ rundb dbpipe $ DB.find (DB.select [] $ tu "table") >>= DB.rest
let docs = either (const []) id dbresult
-- liftIO $ L.putStrLn $ encode $ show $ map docToMap docs
return $ responseLBS statusOK [("Content-Type", "text/plain; charset=utf-8")]
(encode $ map docToMap docs)
docToMap doc = Map.fromList $ map (\f -> (T.dropAround (== '"') $ T.pack $ show $ DB.label f, T.dropAround (== '"') $ T.pack $ show $ DB.value f)) doc
main = do
pipe <- DB.runIOE $ DB.connect $ DB.host "127.0.0.1"
run 3000 $ application pipe
rundb pipe act = DB.access pipe DB.master database act
tu :: B.ByteString -> UString
tu = DB.u . C8.unpack
Then the result is suprprising, DB.label works well, but DB.value giving me native characters as some escape codes, so the result is look like:
curl http://localhost:3000/items gives:
[{"Марка": "\1058\1080\1087 \1087\1086\1076",
"Model": "BD-W LG BP06LU10 Slim \1058\1080\1087 \1087\1086\1076\1082\1083\1102\1095\1077\1085\1080\1103"},
...
]
This happens in case i trying to print data and also in case i return data encoded as JSON
Any idea how correctly extract values from MongoDB driver ?
The following line confirms that aeson's encoding works properly (using the utf8-string library to read utf8 data off the lazy bytestring back to a haskell string:
> putStrLn $ Data.ByteString.Lazy.UTF8.toString $ encode $ ("\1058\1080\1087 \1087\1086\1076",12)
["Тип под",12]
Looking at your code more closely I see the real problem. You're calling T.pack $ show $ DB.value -- this will render out as literal codepoints, and then pack those into a text object. The fix is to switch from show to something smarter. Look at this (untested)
smartShow :: DB.Value -> Text
smartShow (String s) = Data.Text.Encoding.decodeUtf8 $ Data.CompactString.UTF8.toByteString s
smartShow x = T.pack $ show x
Obviously to handle the recursive cases, etc. you need to be smarter than that, but that's the general notion...
In fact, the "best" thing to do is to write a function of BSON -> JSON directly, rather than go through any intermediate structures at all.
Everything is working as expected -- only your expectations are wrong. =)
What you're seeing there are not raw Strings; they are String's which have been escaped to exist purely in the printable ASCII range by the show function, called by print:
print = putStrLn . show
Never fear: in memory, the string that prints as "\1058" is in fact a single Unicode codepoint long. You can observe this by printing the length of one of the Strings you're interested in and comparing that to the number of Unicode codepoints you expect.

Resources