LiftIO, do block, and syntax - haskell

I'm getting to grips with writing an API in Haskell using Scotty. My files are provided below. My questions are:
In the routes definition, I'm extracting from liftIO whatsTheTime in a do block. This works, but it seems verbose. Is there a nicer syntax?
In the whatsTheTime definition, I'm needing to do fromString. I'd have thought OverloadedString would take care of that, but that's not the case. I'd really appreciate it if somebody pointed out why it doesn't work without fromString.
In a stack project, if I need a directive like OverloadedStrings, do I need to include it every file that needs it, or just at the top of the main entrypoint?
Api.hs:
{-# LANGUAGE OverloadedStrings #-}
module Api
( whatsTheTime
) where
import Data.Time (getCurrentTime)
import Web.Scotty
import Data.String
whatsTheTime :: IO (ActionM ())
whatsTheTime = do
time <- getCurrentTime
return $ text $ fromString ("The time is now " ++ show time)
Main.hs:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Main where
import Api
import Web.Scotty
import Control.Monad.IO.Class
routes = do
get "/" $ do
res <- liftIO whatsTheTime
res
main :: IO ()
main = do
putStrLn "Starting server..."
scotty 3000 routes

(1) This:
do
res <- liftIO whatsTheTime
res
Desugars to this:
liftIO whatsTheTime >>= \ res -> res
If you look at the type of \ m -> m >>= id:
(Monad m) => m (m a) -> m a
That’s exactly the type of join (Hoogle), so you can use:
get "/" $ join $ liftIO whatsTheTime
join is a common idiom for “execute this action which returns an action, and also execute the returned action”.
(2) OverloadedStrings is for overloading of string literals. You have an overloaded literal "The time is now ", but you constrain it to be of type String by using it as an operand of (++) with a String (the result of show time). You can pack the result of show time as a Text instead using fromString or Data.Text.pack:
import Data.Monoid ((<>))
import qualified Data.Text as Text
-- ...
return $ text $ "The time is now " <> Text.pack (show time)
(3) LANGUAGE pragmas operate per file; as #mgsloan notes, you can add OverloadedStrings to the default-extensions: field of your library or executable in your .cabal file.

Related

Haskell Persistent Library - How do I get data from my database to my frontend?

Hi and thanks for your time.
I'm trying to create a website that features a button that increments a counter. I want the current counter to be persistent and if somebody goes to my page, the current counter should be displayed.
A request should be send every time I click the button to increment the counter. The request does not contain any information about the counter value. The server - in my case a warp web server - should update the counter value in the database, read the value after the update and then send it to the frontend if successful, of an error message if not.
So far, only the updating works, since I did not manage to figure out how to get the data from the database to the frontend.
Here is the code from my Repository module that should do the updating:
{-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving#-}
{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell, TypeFamilies, DataKinds, FlexibleInstances#-}
{-# LANGUAGE DerivingStrategies, StandaloneDeriving, UndecidableInstances #-}
module Repository (increaseCounter) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runStderrLoggingT)
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Control.Monad.Reader
import Data.Text
import Data.Maybe
-- setting up the Counter entity with a unique key so I can use the getBy function
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Counter
counterName String
counterCount Int Maybe
UniqueCounterName counterName
deriving Show
|]
increaseCounter :: IO ()
increaseCounter =
runStderrLoggingT $ withSqliteConn "//absolute/path/database.db" $ runSqlConn $ do
runMigration migrateAll -- only for developing
updateWhere [CounterCounterName ==. "unique name"] [CounterCounterCount +=. Just 1]
counterEntity <- getBy $ UniqueCounterName name
liftIO $ print counterEntity
This compiles and actually persists the counter and updates the value every time its called. But as you can tell from the types, after update it only prints the counter value to the console.
I seem to have problems understanding how to use the data that is returned from the getBy function.
The docs say:
getBy :: (PersistUniqueRead backend, MonadIO m, PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
Is the 'backend m' basically a nested monad?
Assuming I simply want to send the value of the counter if it is Just Int and I want to return -1 if it is Nothing.
I assume I can not modify the increaseCounter function so that its type is Maybe Int. But how do I pass functions into the monad / access the value inside to send a response to the frontend?
If this question is to superficial and/or I lack too much knowledge to proceed at this point, can you recommend good sources for information? Something like a good tutorial or youtube channel or something?
Thanks!
You can ignore all the monadic parts of getBy's type signature. Provided you get your code to type check, counterEntity has type Maybe (Entity Counter), and that's all that's important here.
The counterEntity is Nothing if the query fails (i.e., no record in the table for that counter). Otherwise, it's Just an Entity Counter containing the retrieved record:
case counterEntity of
Just e -> ...
This e :: Entity Counter can be turned into a Counter via entityVal. The desired field of that Counter can be extracted with counterCounterCount. The result will be a Maybe Int because you've tagged that field as Maybe, so you'll have another layer of Maybe to unpack:
case counterEntity of
Nothing -> -1 -- no record for this counter
Just e -> case counterCounterCount (entityVal e) of
Nothing -> -1 -- record, but counter value missing
Just v -> v
You'll want to return this value from increaseCounter, so the final version will look like this:
increaseCounter :: IO Int
increaseCounter =
runStderrLoggingT $ withSqliteConn "//absolute/path/database.db" $ runSqlConn $ do
runMigration migrateAll -- only for developing
updateWhere [CounterCounterName ==. "unique name"] [CounterCounterCount +=. Just 1]
counterEntity <- getBy $ UniqueCounterName "unique name"
return $ case counterEntity of
Nothing -> -1
Just e -> case counterCounterCount . entityVal $ e of
Nothing -> -1
Just v -> v
Wherever you previously successfully used increaseCounter to increase the counter, you'll now want to write:
updatedCounterValue <- increaseCounter
and you can pass the plain old updatedCounterValue :: Int to the front end.
You might find it more sensible to use upsertBy, which can insert the counter record if it's missing and update it otherwise. It also returns the inserted/updated entity, saving you a separate getBy call. I also don't understand why you've tagged counterCount with Maybe. Why would you insert a counter into your table with no value? Wouldn't "0" be a better starting value if you wanted to indicate "no count"?
So, I'd rewrite the schema as:
Counter
counterName String
counterCount Int -- no Maybe
UniqueCounterName counterName
deriving Show
and the increaseCounter function as:
increaseCounter :: IO Int
increaseCounter =
runStderrLoggingT $ withSqliteConn "//absolute/path/database.db" $ runSqlConn $ do
runMigration migrateAll -- only for developing
let name = "unique name"
counterEntity <- upsertBy (UniqueCounterName name)
(Counter name 1)
[CounterCounterCount +=. 1]
return $ counterCounterCount (entityVal counterEntity)
To either insert a 1-count or increase an existing count.
Finally, as a general design approach, it's probably better to move the database migration and connection setup into the main function, and maybe use a pool of connections, something like:
#!/usr/bin/env stack
-- stack --resolver lts-18.0 script
-- --package warp
-- --package persistent
-- --package persisent-sqlite
{-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell, TypeFamilies, DataKinds, FlexibleInstances#-}
{-# LANGUAGE DerivingStrategies, StandaloneDeriving, UndecidableInstances #-}
import Control.Monad.Logger (runStderrLoggingT)
import Database.Persist
import Database.Persist.TH
import Database.Persist.Sqlite
import Control.Monad.Reader
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp
import qualified Data.ByteString.Lazy.Char8 as C8
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Counter
counterName String
counterCount Int
UniqueCounterName counterName
deriving Show
|]
increaseCounter :: ReaderT SqlBackend IO Int
increaseCounter = do
let name = "unique name"
counterEntity <- upsertBy (UniqueCounterName name)
(Counter name 1)
[CounterCounterCount +=. 1]
return $ counterCounterCount (entityVal counterEntity)
main :: IO ()
main = runStderrLoggingT $ withSqlitePool "some_database.db" 5 $ \pool -> do
runSqlPool (runMigration migrateAll) pool
let runDB act = runSqlPool act pool
liftIO $ run 3000 $ \req res -> do
count <- runDB $ increaseCounter
res $ responseLBS
status200
[("Content-Type", "text/plain")]
(C8.pack $ show count ++ "\n")

how to list the functions exported by a Haskell module from an .hs script?

I am aware of this thread and the agreed-upon ghci :browse command, but I am looking for something similar to run from a script.hs file:
Say I have a module that I can import into my script.hs. How do I then view the list of functions I have just gained access to?
What I've settled on for now
Adapting this thread that suggests the now-deprecated ghc-mod command-line program, I am
calling the terminal command ghc -e ':browse <module, e.g. Data.List>'
from my script.hs using Shelly.
My full script:
#!/usr/bin/env runghc
{-# LANGUAGE OverloadedStrings #-}
import Safe (headDef)
import Shelly
import System.Environment (getArgs)
import qualified Data.Text as T
mdl :: IO String
mdl = getArgs >>= return . headDef "Data.List"
runShelly :: String -> IO ()
runShelly mdl = shelly $ silently $ do
out <- run "ghc" ["-e", T.pack (":browse " ++ mdl)]
let lns = T.lines out
liftIO $ mapM_ (putStrLn .T.unpack) $ lns
main :: IO ()
main = mdl >>= runShelly
This way I can pass the module name on the command line as <script> <module> and get back the functions, one per line. It defaults to Data.List if I pass no arguments.
So that's a solution, but surely there must be handier introspection facilities than this?

How to force a list of assertions to be executed in Haskell?

I've generated a list of assertions I'd like to have run.
Here's an interesting case. In the script below, a list of pairs of strings are generated with the entries in the pairs never being equal (namePairs). An assertion should throw an error if one of the strings is a substring of the other string in the pair. I've played around with the script enough to notice that it will throw an error if you encounter foo (which happens when head is used, as shown), or an error will be shown if you replace head with last, but in this case it will occur for bar - the last string in the list). But this only works if I leave off the i =/ j guard, which is not what I want, but helped me to identify the issue. If the guard is left in, then no error is thrown since these cases were the cases where i == j.
I saw How to force evaluation in Haskell?, but despite using the BangPatterns approach described there, I've not been able to get this to work, despite the cargo-cult level of usage.
#!/usr/bin/env stack
{- stack script --nix --resolver lts-14.20
--nix-packages zlib
--no-nix-pure
--package non-empty-text
--package text
--package time
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Data.Maybe
import Data.List (isSubsequenceOf)
import Data.Text (Text)
import qualified Data.Text as DT
import qualified Data.Text.Lazy as DTL
import qualified Data.Text.IO as DTIO
entryKeys :: [Text]
entryKeys = filter (\t -> DT.length t > 0) $ DT.split (==' ')
"foo DIBBsMain DIBBsContainers DIBBs bar"
main :: IO ()
main = do
putStrLn $ show entryKeys
!_ <- entryNameCheck entryKeys
pure ()
entryNameCheck :: [Text] -> IO ()
entryNameCheck !eNames = do
putStrLn $ show namePairs
!x <- pure $ checkPair <$> namePairs
pure $ head x
where
!lStr = DT.unpack . DT.toLower
!namePairs = [(lStr i, lStr j) | i <- eNames, j <- eNames, i /= j]
errmsg !ns = "!! " <> fst ns <> " is a substring of " <> snd ns
checkPair !p = assertOrErr ((not $ isSubsequenceOf (fst p) (snd p))) (errmsg p)
assertOrErr :: Bool -> String -> ()
assertOrErr !cond !msg = if cond then () else error msg

Running Q Exp in a GhcMonad [duplicate]

Is it possible to generate and run TemplateHaskell generated code at runtime?
Using C, at runtime, I can:
create the source code of a function,
call out to gcc to compile it to a .so (linux) (or use llvm, etc.),
load the .so and
call the function.
Is a similar thing possible with Template Haskell?
Yes, it's possible. The GHC API will compile Template Haskell. A proof-of-concept is available at https://github.com/JohnLato/meta-th, which, although not very sophisticated, shows one general technique that even provides a modicum of type safety. Template Haskell expressions are build using the Meta type, which can then be compiled and loaded into a usable function.
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
module Data.Meta.Meta (
-- * Meta type
Meta (..)
-- * Functions
, metaCompile
) where
import Language.Haskell.TH
import Data.Typeable as Typ
import Control.Exception (bracket)
import System.Plugins -- from plugins
import System.IO
import System.Directory
newtype Meta a = Meta { unMeta :: ExpQ }
-- | Super-dodgy for the moment, the Meta type should register the
-- imports it needs.
metaCompile :: forall a. Typeable a => Meta a -> IO (Either String a)
metaCompile (Meta expr) = do
expr' <- runQ expr
-- pretty-print the TH expression as source code to be compiled at
-- run-time
let interpStr = pprint expr'
typeTypeRep = Typ.typeOf (undefined :: a)
let opener = do
(tfile, h) <- openTempFile "." "fooTmpFile.hs"
hPutStr h (unlines
[ "module TempMod where"
, "import Prelude"
, "import Language.Haskell.TH"
, "import GHC.Num"
, "import GHC.Base"
, ""
, "myFunc :: " ++ show typeTypeRep
, "myFunc = " ++ interpStr] )
hFlush h
hClose h
return tfile
bracket opener removeFile $ \tfile -> do
res <- make tfile ["-O2", "-ddump-simpl"]
let ofile = case res of
MakeSuccess _ fp -> fp
MakeFailure errs -> error $ show errs
print $ "loading from: " ++ show ofile
r2 <- load (ofile) [] [] "myFunc"
print "loaded"
case r2 of
LoadFailure er -> return (Left (show er))
LoadSuccess _ (fn :: a) -> return $ Right fn
This function takes an ExpQ, and first runs it in IO to create a plain Exp. The Exp is then pretty-printed into source code, which is compiled and loaded at run-time. In practice, I've found that one of the more difficult obstacles is specifying the correct imports in the generated TH code.
From what I understand you want to create and run a code at runtime which I think you can do using GHC API but I am not very sure of the scope of what you can achieve. If you want something like hot code swapping you can look at the package hotswap.

Using Parsec with Data.Text

Using Parsec 3.1, it is possible to parse several types of inputs:
[Char] with Text.Parsec.String
Data.ByteString with Text.Parsec.ByteString
Data.ByteString.Lazy with Text.Parsec.ByteString.Lazy
I don't see anything for the Data.Text module. I want to parse Unicode content without suffering from the String inefficiencies. So I've created the following module based on the Text.Parsec.ByteString module:
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Parsec.Text
( Parser, GenParser
) where
import Text.Parsec.Prim
import qualified Data.Text as T
instance (Monad m) => Stream T.Text m Char where
uncons = return . T.uncons
type Parser = Parsec T.Text ()
type GenParser t st = Parsec T.Text st
Does it make sense to do so?
It this compatible with the rest of the Parsec API?
Additional comments:
I had to add {-# LANGUAGE NoMonomorphismRestriction #-} pragma in my parse modules to make it work.
Parsing Text is one thing, building an AST with Text is another thing. I will also need to pack my String before return:
module TestText where
import Data.Text as T
import Text.Parsec
import Text.Parsec.Prim
import Text.Parsec.Text
input = T.pack "xxxxxxxxxxxxxxyyyyxxxxxxxxxp"
parser = do
x1 <- many1 (char 'x')
y <- many1 (char 'y')
x2 <- many1 (char 'x')
return (T.pack x1, T.pack y, T.pack x2)
test = runParser parser () "test" input
Since Parsec 3.1.2 support of Data.Text is built-in!
See http://hackage.haskell.org/package/parsec-3.1.2
If you are stuck with older version, the code snippets in other answers are helpful, too.
That looks like exactly what you need to do.
It should be compatible with the rest of Parsec, include the Parsec.Char parsers.
If you're using Cabal to build your program, please put an upper bound of parsec-3.1 in your package description, in case the maintainer decides to include that instance in a future version of Parsec.
I added a function parseFromUtf8File to help reading UTF-8 encoded files in an efficient fashion. Works flawlessly with umlaut characters. Function type matches parseFromFile from Text.Parsec.ByteString. This version uses strict ByteStrings.
-- A derivate work from
-- http://stackoverflow.com/questions/4064532/using-parsec-with-data-text
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Parsec.Text
( Parser, GenParser, parseFromUtf8File
) where
import Text.Parsec.Prim
import qualified Data.Text as T
import qualified Data.ByteString as B
import Data.Text.Encoding
import Text.Parsec.Error
instance (Monad m) => Stream T.Text m Char where
uncons = return . T.uncons
type Parser = Parsec T.Text ()
type GenParser t st = Parsec T.Text st
-- | #parseFromUtf8File p filePath# runs a strict bytestring parser
-- #p# on the input read from #filePath# using
-- 'ByteString.readFile'. Returns either a 'ParseError' ('Left') or a
-- value of type #a# ('Right').
--
-- > main = do{ result <- parseFromFile numbers "digits.txt"
-- > ; case result of
-- > Left err -> print err
-- > Right xs -> print (sum xs)
-- > }
parseFromUtf8File :: Parser a -> String -> IO (Either ParseError a)
parseFromUtf8File p fname = do
raw <- B.readFile fname
let input = decodeUtf8 raw
return (runP p () fname input)

Resources