The example in Purescript by Example section 8.17 Mutable State:
https://leanpub.com/purescript/read#leanpub-auto-mutable-state
is a simulate function:
import Prelude
import Control.Monad.Eff (Eff, forE)
import Control.Monad.ST (ST, newSTRef, readSTRef, modifySTRef)
simulate :: forall eff h. Number -> Number -> Int -> Eff (st :: ST h | eff) Number
simulate x0 v0 time = do
ref <- newSTRef { x: x0, v: v0 }
forE 0 (time * 1000) \_ -> do
modifySTRef ref \o ->
{ v: o.v - 9.81 * 0.001
, x: o.x + o.v * 0.001
}
pure unit
final <- readSTRef ref
pure final.x
The function itself works fine. Say it needs to be modified to stop movement of the particle at some value of x. This:
import Prelude
import Control.MonadPlus (guard)
import Control.Monad.Eff (Eff, forE)
import Control.Monad.ST (ST, newSTRef, readSTRef, modifySTRef)
simulate :: forall eff h. Number -> Number -> Int -> Eff (st :: ST h | eff) Number
simulate x0 v0 time = do
ref <- newSTRef { x: x0, v: v0 }
forE 0 (time * 1000) \_ -> do
o <- readSTRef ref
let v = o.v - 9.81 * 0.001
let x = o.x + o.v * 0.001
guard (x < 100.0)
modifySTRef ref \o ->
{ v: v
, x: x
}
pure unit
final <- readSTRef ref
pure final.x
results in the following error:
No type class instance was found for
Control.MonadZero.MonadZero (Eff
( "st" :: ST h3
| eff4
)
)
...
Does this mean guard cannot be used in Eff monad at all? How would one write the code with the same intention in idiomatic purescript?
You can't use guard, but you can use when, which works with any Monad:
when (x < 100.0) $
modifySTRef ref \o ->
{ v: v
, x: x
}
Related
I have a sum type of possible outcomes, and in every outcome there is a certain "Result" that I want to focus on. I know how to get that "Result" from each of the outcomes (I have a bunch of prisms for that), but I don't know how to combine these prisms so that I can grab the "Result" from the whole sumtype, without worrying which case I'm on.
Simplified example:
type OneAnother = Either Int Int
exampleOneAnother :: OneAnother
exampleOneAnother = Left 10
_one :: Prism' OneAnother Int
_one = _Left
_another :: Prism' OneAnother Int
_another = _Right
_result :: Lens' OneAnother Int
_result = ???
-- How can I combine _one and _another to get result regardless whether its left or right ?
Once a prism comes to focus, it loses the context. So I don't see a way to define _result in terms of _one and _another. But you can certainly do better than resorting to unsafePartial:
import Data.Lens.Lens (Lens', lens)
import Data.Profunctor.Choice ((|||), (+++))
type OneAnother = Either Int Int
_result :: Lens' OneAnother Int
_result = lens getter setter
where
getter = identity ||| identity
setter e x = (const x +++ const x) e
Stole this from the profunctor-lens repository:
-- | Converts a lens into the form that `lens'` accepts.
lensStore :: forall s t a b . ALens s t a b -> s -> Tuple a (b -> t)
lensStore l = withLens l (lift2 Tuple)
It isn't exported somehow. With that help, the following solution should be generic enough:
import Prelude
import Control.Apply (lift2)
import Data.Lens.Common
import Data.Lens.Lens
import Data.Lens.Prism
import Data.Profunctor.Choice ((|||), (+++))
import Data.Tuple
_result :: Lens' OneAnother Int
_result = lens getter setter
where
getter = identity ||| identity
setter e x = (const x +++ const x) e
lensStore :: forall s t a b . ALens s t a b -> s -> Tuple a (b -> t)
lensStore l = withLens l (lift2 Tuple)
data ABC
= A Int
| B (Tuple Boolean Int)
| C OneAnother
lensABCInt :: Lens' ABC Int
lensABCInt = lens' case _ of
A i -> map A <$> lensStore identity i
B i -> map B <$> lensStore _2 i
C i -> map C <$> lensStore _result i
Here ABC is your target sum type. As long as its each variant has a lens, you have a lens for it as a whole.
This is the best I've got so far. Yes, unsafePartial, explicit case matching ... Really hope there is something better.
_result :: Lens' OneAnother Int
_result = lens getter setter
where
getter :: OneAnother -> Int
getter x#(Left _) = unsafePartial $ fromJust $ preview _one x
getter x#(Right _) = unsafePartial $ fromJust $ preview _another x
setter :: OneAnother -> Int -> OneAnother
setter (Left _) x = review _one x
setter (Right _) x = review _another x
I'm building a game in Purescript, using purescript-signal, which includes movement. The user presses the left/right key to move left/right. Minimal code is below.
It looks like purescript is evaluating the signal over "from the beginning of time" every step, which is baffling me. For example, if I keep pressing the right key at the beginning, the output is
m: 0
m: 0
m: 1
m: 0
m: 1
m: 2
m: 0
m: 1
m: 2
m: 3
rather than
m: 0
m: 1
m: 2
m: 3
as I would expect. How do I fix this?
module SimpleMove where
import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Functor
import Data.Int
import Signal (Signal, runSignal, foldp, sampleOn, map2)
import Signal.DOM (keyPressed)
import Signal.Time (Time, second, every)
import Partial.Unsafe (unsafePartial)
--MODEL
type Model = Int
step :: forall e. Partial => Int -> Eff (console :: CONSOLE | e) Model -> Eff (console :: CONSOLE| e) Model
step dir m' =
do
m <- m'
log ("m: " <> (show m))
pure (m + dir)
--SIGNALS
inputDir :: Eff _ (Signal Int)
inputDir =
let
f = \l r -> if l
then -1
else if r
then 1
else 0
in
map2 f <$> (keyPressed 37) <*> (keyPressed 39)
input :: Eff _ (Signal Int)
input = sampleOn (every second) <$> inputDir
--MAIN
main :: Eff _ Unit
main =
unsafePartial do
dirSignal <- input
let game = foldp step (pure 0) dirSignal
runSignal (map void game)
If you change your main and step like this you'll get the expected result:
main :: Eff _ Unit
main = do
dirSignal <- input
let game = foldp step 0 dirSignal
runSignal (map render game)
step :: forall e. Int -> Model -> Model
step dir m = m + dir
render :: forall e. Model -> Eff (console :: CONSOLE| e) Unit
render m = logShow m
I'm trying to use the STStrMap purescript module to maintain a map for a long running server application. It's a very simple String map. Here is what I have so far:
import Data.StrMap.ST (new, STStrMap, poke)
import Control.Monad.ST (ST, runST)
type MyMap = forall h e. Eff ( st :: ST h | e) (STStrMap h String)
myMap :: MyMap
myMap = new
-- pokeAString :: String -> String -> MyMap ??
pokeAString k v = poke k v myMap
The signature of MyMap is Eff, but poke expects a STStrMap as the first parameter. I'm not sure how to code this correctly. Note: I'm a newbie to purescript.
The STStrMap you initialize has side effects tracked by the Eff monad, so we have to use its instance of bind to run our computations (e.g. peek, poke), which has the type:
forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
In psci you can see how this works:
import Prelude
import Data.StrMap.ST
let myMap = new
let myPoke x = x >>= (\m -> poke m "key" "value")
let myPeek x = x >>= (\m -> peek m "key")
myPeek $ myPoke myMap
So your code becomes something like:
import Prelude
import Data.StrMap.ST (new, STStrMap, poke)
import Control.Monad.ST (ST)
import Control.Monad.Eff (Eff)
type MyMap = forall h e. Eff ( st :: ST h | e) (STStrMap h String)
myMap :: MyMap
myMap = new
pokeAString :: String -> String -> MyMap
pokeAString k v = do
a <- myMap
poke a k v
As an exercise, I took these Scala and Java examples of Akka to port to Frege. While it works fine, it runs slower(11s) than Scala(540ms) counterpart.
module mmhelloworld.akkatutorialfregecore.Pi where
import mmhelloworld.akkatutorialfregecore.Akka
data PiMessage = Calculate |
Work {start :: Int, nrOfElements :: Int} |
Result {value :: Double} |
PiApproximation {pi :: Double, duration :: Duration}
data Worker = private Worker where
calculatePiFor :: Int -> Int -> Double
calculatePiFor !start !nrOfElements = loop start nrOfElements 0.0 f where
loop !curr !n !acc f = if n == 0 then acc
else loop (curr + 1) (n - 1) (f acc curr) f
f !acc !i = acc + (4.0 * fromInt (1 - (i `mod` 2) * 2) / fromInt (2 * i + 1))
onReceive :: Mutable s UntypedActor -> PiMessage -> ST s ()
onReceive actor Work{start=start, nrOfElements=nrOfElements} = do
sender <- actor.sender
self <- actor.getSelf
sender.tellSender (Result $ calculatePiFor start nrOfElements) self
data Master = private Master {
nrOfWorkers :: Int,
nrOfMessages :: Int,
nrOfElements :: Int,
listener :: MutableIO ActorRef,
pi :: Double,
nrOfResults :: Int,
workerRouter :: MutableIO ActorRef,
start :: Long } where
initMaster :: Int -> Int -> Int -> MutableIO ActorRef -> MutableIO UntypedActor -> IO Master
initMaster nrOfWorkers nrOfMessages nrOfElements listener actor = do
props <- Props.forUntypedActor Worker.onReceive
router <- RoundRobinRouter.new nrOfWorkers
context <- actor.getContext
workerRouter <- props.withRouter router >>= (\p -> context.actorOf p "workerRouter")
now <- currentTimeMillis ()
return $ Master nrOfWorkers nrOfMessages nrOfElements listener 0.0 0 workerRouter now
onReceive :: MutableIO UntypedActor -> Master -> PiMessage -> IO Master
onReceive actor master Calculate = do
self <- actor.getSelf
let tellWorker start = master.workerRouter.tellSender (work start) self
work start = Work (start * master.nrOfElements) master.nrOfElements
forM_ [0 .. master.nrOfMessages - 1] tellWorker
return master
onReceive actor master (Result newPi) = do
let (!newNrOfResults, !pi) = (master.nrOfResults + 1, master.pi + newPi)
when (newNrOfResults == master.nrOfMessages) $ do
self <- actor.getSelf
now <- currentTimeMillis ()
duration <- Duration.create (now - master.start) TimeUnit.milliseconds
master.listener.tellSender (PiApproximation pi duration) self
actor.getContext >>= (\context -> context.stop self)
return master.{pi=pi, nrOfResults=newNrOfResults}
data Listener = private Listener where
onReceive :: MutableIO UntypedActor -> PiMessage -> IO ()
onReceive actor (PiApproximation pi duration) = do
println $ "Pi approximation: " ++ show pi
println $ "Calculation time: " ++ duration.toString
actor.getContext >>= ActorContext.system >>= ActorSystem.shutdown
calculate nrOfWorkers nrOfElements nrOfMessages = do
system <- ActorSystem.create "PiSystem"
listener <- Props.forUntypedActor Listener.onReceive >>= flip system.actorOf "listener"
let constructor = Master.initMaster nrOfWorkers nrOfMessages nrOfElements listener
newMaster = StatefulUntypedActor.new constructor Master.onReceive
factory <- UntypedActorFactory.new newMaster
masterActor <- Props.fromUntypedFactory factory >>= flip system.actorOf "master"
masterActor.tell Calculate
getLine >> return () --Not to exit until done
main _ = calculate 4 10000 10000
Am I doing something wrong with Akka or is it something to do with laziness in Frege for being slow? For example, when I initially had fold(strict fold) in place of loop in Worker.calculatePiFor, it took 27s.
Dependencies:
Akka native definitions for Frege: Akka.fr
Java helper to extend Akka classes since we cannot extend a class in
Frege: Actors.java
I am not exactly familiar with Actors, but assuming that the tightest loop is indeed loop you could avoid passing function f as argument.
For one, applications of passed functions cannot take advantage of the strictness of the actual passed function. Rather, code generation must assume conservatively that the passed function takes its arguments lazily and returns a lazy result.
Second, in our case you use f really just once here, so one can inline it. (This is how it is done in the scala code in the article you linked.)
Look at the code generated for the tail recursion in the following sample code that mimics yours:
test b c = loop 100 0 f
where
loop 0 !acc f = acc
loop n !acc f = loop (n-1) (acc + f (acc-1) (acc+1)) f -- tail recursion
f x y = 2*x + 7*y
We get there:
// arg2$f is the accumulator
arg$2 = arg$2f + (int)frege.runtime.Delayed.<java.lang.Integer>forced(
f_3237.apply(PreludeBase.INum_Int._minusƒ.apply(arg$2f, 1)).apply(
PreludeBase.INum_Int._plusƒ.apply(arg$2f, 1)
).result()
);
You see here that f is called lazily which causes all the argument expressios to also be computed lazily. Note the number of method calls this requires!
In your case the code should still be something like:
(double)Delayed.<Double>forced(f.apply(acc).apply(curr).result())
This means, two closures are build with the boxed values acc and curr and then the result is computed, i.e. the function f gets called with the unboxed arguments, and the result gets again boxed, just to get unboxed again (forced) for the next loop.
Now compare the following, where we just do not pass f but call it directly:
test b c = loop 100 0
where
loop 0 !acc = acc
loop n !acc = loop (n-1) (acc + f (acc-1) (acc+1))
f x y = 2*x + 7*y
We get:
arg$2 = arg$2f + f(arg$2f - 1, arg$2f + 1);
Much better!
Finally, in the case above we can do without a function call at all:
loop n !acc = loop (n-1) (acc + f) where
f = 2*x + 7*y
x = acc-1
y = acc+1
And this gets:
final int y_3236 = arg$2f + 1;
final int x_3235 = arg$2f - 1;
...
arg$2 = arg$2f + ((2 * x_3235) + (7 * y_3236));
Please try this out and let us know what happens. The main boost in performance should come from not passing f, whereas the inlining will probably be done in the JIT anyway.
The additional cost with fold is probably because you also had to create some list before applying it.
After reading this I tried
{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
module Login (
fbUrl,
fbEmail
) where
-- package http://hackage.haskell.org/package/fb
import qualified Facebook as FB
import Network.HTTP.Conduit (withManager)
app :: FB.Credentials
app = FB.Credentials "localhost" "249348058430770" "..."
url :: FB.RedirectUrl
url = "http://localhost/fb"
perms :: [FB.Permission]
perms = ["user_about_me", "email"]
--fbUrl :: Monad m => FB.FacebookT FB.Auth m Text
fbUrl :: IO Text
fbUrl = withManager $ \manager -> FB.runFacebookT app manager $ FB.getUserAccessTokenStep1 url perms
--fbEmail :: Monad m => (ByteString, ByteString) -> FB.FacebookT FB.Auth m (Maybe Text)
--fbEmail :: (ByteString, ByteString) -> IO (Maybe Text)
fbEmail c = withManager $ \manager -> FB.runFacebookT app manager $ do
t <- FB.getUserAccessTokenStep2 url [c]
u <- FB.getUser "me" [] (Just t)
return $ FB.userEmail u
module Main (
main
) where
import Login
import qualified Data.ByteString.Char8 as C
import Control.Exception
main :: IO ()
main = do
let a = ("code","test")
e <- fbEmail $ (\(x,y) -> (C.pack x, C.pack y)) a
case e of
Nothing -> print "doh!"
Just e -> print e
I get haskell-facebook: FacebookException {fbeType = "invalid_code", fbeMessage = "Invalid verification code format."} instead of doh!
With e <- try (fbEmail $ (\(x,y) -> (C.pack x, C.pack y)) a) i get
Couldn't match expected type `Either
e0 (Maybe Data.Text.Internal.Text)'
with actual type `Maybe t0'
In the pattern: Nothing
In a case alternative: Nothing -> print "doh!"
In a stmt of a 'do' block:
case e of {
Nothing -> print "doh!"
Just e -> print e }
#Daniel Fischer
let a = ("code","test")
e <- try (fbEmail $ (\(x,y) -> (C.pack x, C.pack y)) a)
case e of
Left x -> print "doh!"
Right e -> print "ok"
Ambiguous type variable `e0' in the constraint:
(Exception e0) arising from a use of `try'
Probable fix: add a type signature that fixes these type variable(s)
In a stmt of a 'do' block:
e <- try (fbEmail $ (\ (x, y) -> (C.pack x, C.pack y)) a)
In the expression:
do { let a = ...;
e <- try (fbEmail $ (\ (x, y) -> (C.pack x, C.pack y)) a);
case e of {
Left x -> print "doh!"
Right e -> print "ok" } }
In an equation for `main':
main
= do { let a = ...;
e <- try (fbEmail $ (\ (x, y) -> (C.pack x, C.pack y)) a);
case e of {
Left x -> print "doh!"
Right e -> print "ok" } }
When I add a type signature fbEmail :: Monad m => (ByteString, ByteString) -> FB.FacebookT FB.Auth m (Maybe Text) I get
Could not deduce (monad-control-0.3.1.3:Control.Monad.Trans.Control.MonadBaseControl
IO m,
resourcet-0.3.2.2:Control.Monad.Trans.Resource.MonadUnsafeIO m,
Control.Monad.IO.Class.MonadIO m,
resourcet-0.3.2.2:Control.Monad.Trans.Resource.MonadThrow
(FB.FacebookT FB.Auth m))
arising from a use of `withManager'
from the context (Monad m)
bound by the type signature for
fbEmail :: Monad m =>
(ByteString, ByteString) -> FB.FacebookT FB.Auth m (Maybe Text)
at src/Login.hs:(25,1)-(28,27)
Possible fix:
add (monad-control-0.3.1.3:Control.Monad.Trans.Control.MonadBaseControl
IO m,
resourcet-0.3.2.2:Control.Monad.Trans.Resource.MonadUnsafeIO m,
Control.Monad.IO.Class.MonadIO m,
resourcet-0.3.2.2:Control.Monad.Trans.Resource.MonadThrow
(FB.FacebookT FB.Auth m)) to the context of
the type signature for
fbEmail :: Monad m =>
(ByteString, ByteString) -> FB.FacebookT FB.Auth m (Maybe Text)
or add instance declarations for
(monad-control-0.3.1.3:Control.Monad.Trans.Control.MonadBaseControl
IO m,
resourcet-0.3.2.2:Control.Monad.Trans.Resource.MonadThrow
(FB.FacebookT FB.Auth m))
In the expression: withManager
In the expression:
withManager
$ \ manager
-> FB.runFacebookT app manager
$ do { t <- FB.getUserAccessTokenStep2 url [...];
u <- FB.getUser "me" [] (Just t);
.... }
In an equation for `fbEmail':
fbEmail c
= withManager
$ \ manager
-> FB.runFacebookT app manager
$ do { t <- FB.getUserAccessTokenStep2 url ...;
.... }
When I add fbEmail :: (ByteString, ByteString) -> IO (Maybe Text) I get
Ambiguous type variable `e0' in the constraint:
(Exception e0) arising from a use of `try'
Probable fix: add a type signature that fixes these type variable(s)
In a stmt of a 'do' block:
e <- try (fbEmail $ (\ (x, y) -> (C.pack x, C.pack y)) a)
In the expression:
do { couchTest;
u <- fbUrl;
print u;
let a = ...;
.... }
In an equation for `main':
main
= do { couchTest;
u <- fbUrl;
print u;
.... }
try adds another layer on top of your result. To make this example simple, I'm catching all exceptions by using the catch-all SomeException.
To make it a bit more clear, here are the result types with type signatured added:
e :: Maybe Text <- fbEmail $ (\(x,y) -> (C.pack x, C.pack y)) a
Compared to this use of try with the exception type equal to SomeException:
e :: Either SomeException (Maybe Text) <- fbEmail $ (\(x,y) -> (C.pack x, C.pack y)) a
It's simple to deal with these more complex types using pattern matching as Daniel mentioned in his comments:
{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
module Main where
import Control.Exception
import qualified Data.ByteString.Char8 as C
import Data.Text
import Network.HTTP.Conduit (withManager)
import qualified Facebook as FB
app :: FB.Credentials
app = FB.Credentials "localhost" "249348058430770" "..."
url :: FB.RedirectUrl
url = "http://localhost/fb"
perms :: [FB.Permission]
perms = ["user_about_me", "email"]
fbUrl :: IO Text
fbUrl = withManager $ \manager -> FB.runFacebookT app manager $ FB.getUserAccessTokenStep1 url perms
fbEmail :: FB.Argument -> IO (Maybe Text)
fbEmail c = withManager $ \manager -> FB.runFacebookT app manager $ do
t <- FB.getUserAccessTokenStep2 url [c]
u <- FB.getUser "me" [] (Just t)
return $ FB.userEmail u
main :: IO ()
main = do
let a = ("code","test")
e <- try . fbEmail $ (\(x,y) -> (C.pack x, C.pack y)) a
case e of
Left e -> print $ "error: " ++ show (e :: SomeException)
Right Nothing -> print "doh!"
Right (Just e) -> print e