mirror of
https://github.com/chrisdone-archive/duet.git
synced 2024-10-06 06:07:13 +03:00
WIP
This commit is contained in:
Chris Done
parent
60600261e3
commit
2d0731647f
247
web/Main.hs
247
web/Main.hs
@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Control.Monad.Catch.Pure
|
||||
import Control.Monad.Fix
|
||||
@ -11,6 +13,7 @@ import Control.Monad.Trans
|
||||
import Data.List
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
@ -36,38 +39,41 @@ main = do
|
||||
(pure 500)
|
||||
(pure 250)
|
||||
(pure defaultSource)
|
||||
let result =
|
||||
let process src =
|
||||
case parseText "<input box>" (T.pack src) of
|
||||
Left e -> Left (show e)
|
||||
Right bindings ->
|
||||
case runCatch
|
||||
(do (specialSigs, specialTypes, bindGroups, signatures) <-
|
||||
runTypeChecker bindings
|
||||
e0 <- lookupNameByString "main" bindGroups
|
||||
fix
|
||||
(\loop e xs -> do
|
||||
e' <-
|
||||
expandDeepSeq specialSigs signatures e bindGroups
|
||||
if e' /= e && length xs < 100
|
||||
then loop e' (e : xs)
|
||||
else pure (reverse (e : xs)))
|
||||
e0
|
||||
[]) of
|
||||
Left e -> Left (displayException e)
|
||||
Right v -> Right v
|
||||
processedSource =
|
||||
fmap
|
||||
(\source ->
|
||||
case parseText "<input box>" (T.pack source) of
|
||||
Left e -> Left (show e)
|
||||
Right bindings ->
|
||||
case runCatch
|
||||
(do (specialSigs, specialTypes, bindGroups) <-
|
||||
runTypeChecker bindings
|
||||
e0 <- lookupNameByString "main" bindGroups
|
||||
fix
|
||||
(\loop e xs -> do
|
||||
e' <- expand specialSigs e bindGroups
|
||||
if e' /= e && length xs < 100
|
||||
then loop e' (e : xs)
|
||||
else pure (reverse (e : xs)))
|
||||
e0
|
||||
[]) of
|
||||
Left e -> Left (displayException e)
|
||||
Right v -> Right v)
|
||||
process
|
||||
(Snappy.eventToDynamic defaultSource (Snappy.textboxChange source))
|
||||
Snappy.textbox
|
||||
snap
|
||||
(pure 20)
|
||||
(pure 290)
|
||||
(pure 300)
|
||||
(pure 500)
|
||||
(pure 250)
|
||||
(fmap
|
||||
(\case
|
||||
Left err -> err
|
||||
Right steps -> unlines (map (printExpression (const Nothing)) steps))
|
||||
result)
|
||||
Right steps ->
|
||||
unlines (map (printExpression (const Nothing)) steps))
|
||||
processedSource)
|
||||
pure ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -76,12 +82,23 @@ main = do
|
||||
data CheckerException
|
||||
= RenamerException (SpecialTypes Name) RenamerException
|
||||
| InferException (SpecialTypes Name) InferException
|
||||
| StepException StepException
|
||||
deriving (Typeable, Show)
|
||||
instance Exception CheckerException where
|
||||
displayException =
|
||||
\case
|
||||
RenamerException specialTypes e -> displayRenamerException specialTypes e
|
||||
InferException specialTypes e -> displayInferException specialTypes e
|
||||
StepException s -> displayStepperException () s
|
||||
|
||||
displayStepperException :: a -> StepException -> String
|
||||
displayStepperException _ =
|
||||
\case
|
||||
CouldntFindName n -> "Not in scope: " ++ curlyQuotes (printit n)
|
||||
CouldntFindNameByString n ->
|
||||
"The starter variable isn't defined: " ++
|
||||
curlyQuotes n ++
|
||||
"\nPlease define a variable called " ++ curlyQuotes n
|
||||
|
||||
displayInferException :: SpecialTypes Name -> InferException -> [Char]
|
||||
displayInferException specialTypes =
|
||||
@ -112,66 +129,88 @@ displayInferException specialTypes =
|
||||
displayRenamerException :: SpecialTypes Name -> RenamerException -> [Char]
|
||||
displayRenamerException _specialTypes =
|
||||
\case
|
||||
IdentifierNotInScope scope name ->
|
||||
"Not in scope " ++ curlyQuotes (printit name) ++ "\n" ++
|
||||
"Current scope:\n\n" ++ unlines (map printit (M.keys scope))
|
||||
IdentifierNotInVarScope scope name ->
|
||||
"Not in variable scope " ++ curlyQuotes (printit name) ++ "\n" ++
|
||||
"Current scope:\n\n" ++ unlines (map printit (M.elems scope))
|
||||
IdentifierNotInConScope scope name ->
|
||||
"Not in constructors scope " ++ curlyQuotes (printit name) ++ "\n" ++
|
||||
"Current scope:\n\n" ++ unlines (map printit (M.elems scope))
|
||||
|
||||
runTypeChecker
|
||||
:: (MonadThrow m, MonadCatch m)
|
||||
=> [BindGroup Identifier l]
|
||||
-> m (SpecialSigs Name, SpecialTypes Name, [BindGroup Name (TypeSignature Name l)])
|
||||
runTypeChecker bindings =
|
||||
evalSupplyT
|
||||
(do specialTypes <- defaultSpecialTypes
|
||||
theShow <- supplyTypeName "Show"
|
||||
(specialSigs, signatures) <- builtInSignatures theShow specialTypes
|
||||
let signatureSubs =
|
||||
M.fromList
|
||||
(map
|
||||
(\(TypeSignature name@(ValueName _ ident) _) ->
|
||||
(Identifier ident, name))
|
||||
signatures)
|
||||
(renamedBindings, _) <-
|
||||
catch
|
||||
(renameBindGroups signatureSubs bindings)
|
||||
(\e ->
|
||||
throwM (RenamerException specialTypes e))
|
||||
env <- setupEnv theShow specialTypes mempty
|
||||
bindGroups <-
|
||||
lift
|
||||
(catch
|
||||
(typeCheckModule env signatures specialTypes renamedBindings)
|
||||
=> [Decl FieldType Identifier l]
|
||||
-> m (SpecialSigs Name, SpecialTypes Name, [BindGroup Name (TypeSignature Name l)], [TypeSignature Name Name])
|
||||
runTypeChecker decls =
|
||||
let bindings =
|
||||
mapMaybe
|
||||
(\case
|
||||
BindGroupDecl d -> Just d
|
||||
_ -> Nothing)
|
||||
decls
|
||||
types =
|
||||
mapMaybe
|
||||
(\case
|
||||
DataDecl d -> Just d
|
||||
_ -> Nothing)
|
||||
decls
|
||||
in evalSupplyT
|
||||
(do specialTypes <- defaultSpecialTypes
|
||||
theShow <- supplyTypeName "Show"
|
||||
(specialSigs, signatures0) <- builtInSignatures theShow specialTypes
|
||||
sigs' <-
|
||||
renameDataTypes specialTypes types >>=
|
||||
mapM (dataTypeSignatures specialTypes)
|
||||
let signatures = signatures0 ++ concat sigs'
|
||||
{-liftIO
|
||||
(mapM_ (putStrLn . printTypeSignature specialTypes) (concat sigs'))-}
|
||||
let signatureSubs =
|
||||
M.fromList
|
||||
(map
|
||||
(\(TypeSignature name _) ->
|
||||
case name of
|
||||
ValueName _ ident -> (Identifier ident, name)
|
||||
ConstructorName _ ident -> (Identifier ident, name))
|
||||
signatures)
|
||||
(renamedBindings, _) <-
|
||||
catch
|
||||
(renameBindGroups signatureSubs bindings)
|
||||
(\e ->
|
||||
throwM (InferException specialTypes e)))
|
||||
return (specialSigs, specialTypes, bindGroups))
|
||||
[0 ..]
|
||||
throwM (RenamerException specialTypes e))
|
||||
env <- setupEnv theShow specialTypes mempty
|
||||
bindGroups <-
|
||||
lift
|
||||
(catch
|
||||
(typeCheckModule env signatures specialTypes renamedBindings)
|
||||
(throwM . InferException specialTypes))
|
||||
return (specialSigs, specialTypes, bindGroups, signatures))
|
||||
[0 ..]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Default environment
|
||||
|
||||
defaultSource :: String
|
||||
defaultSource =
|
||||
unlines
|
||||
[ "compose = \\f g x -> f (g x)"
|
||||
, "id = \\x -> x"
|
||||
, "and = \\x y -> if x\n\
|
||||
\ then if y\n\
|
||||
\ then True\n\
|
||||
\ else False\n\
|
||||
\ else False"
|
||||
, "main = id (if and True False"
|
||||
, " then \"Yay!\""
|
||||
, " else id id \"Nay!\")"
|
||||
]
|
||||
|
||||
"data List a = Nil | Cons a (List a)\n\
|
||||
\id = \\x -> x\n\
|
||||
\not = \\p -> if p\n\
|
||||
\ then False\n\
|
||||
\ else True\n\
|
||||
\map = \\f l ->\n\
|
||||
\ case l of\n\
|
||||
\ Nil -> Nil\n\
|
||||
\ Cons a xs -> Cons (f a) (map f xs)\n\
|
||||
\main = map not (Cons True (Cons False Nil))"
|
||||
|
||||
-- | Built-in pre-defined functions.
|
||||
builtInSignatures
|
||||
:: Monad m
|
||||
:: MonadThrow m
|
||||
=> Name -> SpecialTypes Name -> SupplyT Int m (SpecialSigs Name, [TypeSignature Name Name])
|
||||
builtInSignatures theShow specialTypes = do
|
||||
the_show <- supplyValueName "show"
|
||||
the_True <- supplyValueName "True"
|
||||
the_False <- supplyValueName "False"
|
||||
sigs <- dataTypeSignatures specialTypes (specialTypesBool specialTypes)
|
||||
the_True <- getSig "True" sigs
|
||||
the_False <- getSig "False" sigs
|
||||
return
|
||||
( SpecialSigs {specialSigsTrue = the_True, specialSigsFalse = the_False}
|
||||
, [ TypeSignature
|
||||
@ -181,18 +220,65 @@ builtInSignatures theShow specialTypes = do
|
||||
(Qualified
|
||||
[IsIn theShow [(GenericType 0)]]
|
||||
(GenericType 0 --> specialTypesString specialTypes)))
|
||||
, TypeSignature
|
||||
the_True
|
||||
(Forall [] (Qualified [] (specialTypesBool specialTypes)))
|
||||
, TypeSignature
|
||||
the_False
|
||||
(Forall [] (Qualified [] (specialTypesBool specialTypes)))
|
||||
])
|
||||
] ++
|
||||
sigs)
|
||||
where
|
||||
getSig ident sigs =
|
||||
case listToMaybe
|
||||
(mapMaybe
|
||||
(\case
|
||||
(TypeSignature n@(ValueName _ i) _)
|
||||
| i == ident -> Just n
|
||||
(TypeSignature n@(ConstructorName _ i) _)
|
||||
| i == ident -> Just n
|
||||
_ -> Nothing)
|
||||
sigs) of
|
||||
Nothing -> throwM (BuiltinNotDefined ident)
|
||||
Just sig -> pure sig
|
||||
(-->) :: Type Name -> Type Name -> Type Name
|
||||
a --> b =
|
||||
ApplicationType (ApplicationType (specialTypesFunction specialTypes) a) b
|
||||
|
||||
dataTypeSignatures
|
||||
:: Monad m
|
||||
=> SpecialTypes Name -> DataType Type Name -> m [TypeSignature Name Name]
|
||||
dataTypeSignatures specialTypes dt@(DataType _ vs cs) = mapM construct cs
|
||||
where
|
||||
construct (DataTypeConstructor cname fs) =
|
||||
pure
|
||||
(TypeSignature
|
||||
cname
|
||||
(let varsGens = map (second GenericType) (zip vs [0 ..])
|
||||
in Forall
|
||||
(map typeVariableKind vs)
|
||||
(Qualified
|
||||
[]
|
||||
(foldr
|
||||
makeArrow
|
||||
(foldl
|
||||
ApplicationType
|
||||
(dataTypeConstructor dt)
|
||||
(map snd varsGens))
|
||||
(map (varsToGens varsGens) fs)))))
|
||||
where
|
||||
varsToGens :: [(TypeVariable Name, Type Name)] -> Type Name -> Type Name
|
||||
varsToGens varsGens = go
|
||||
where
|
||||
go =
|
||||
\case
|
||||
v@(VariableType tyvar) ->
|
||||
case lookup tyvar varsGens of
|
||||
Just gen -> gen
|
||||
Nothing -> v
|
||||
ApplicationType t1 t2 -> ApplicationType (go t1) (go t2)
|
||||
g@GenericType {} -> g
|
||||
c@ConstructorType {} -> c
|
||||
makeArrow :: Type Name -> Type Name -> Type Name
|
||||
a `makeArrow` b =
|
||||
ApplicationType
|
||||
(ApplicationType (specialTypesFunction specialTypes) a)
|
||||
b
|
||||
|
||||
-- | Setup the class environment.
|
||||
setupEnv
|
||||
:: MonadThrow m
|
||||
@ -211,10 +297,21 @@ setupEnv theShow specialTypes env =
|
||||
addInstance [] (IsIn theShow [specialTypesInteger specialTypes])
|
||||
lift (update env)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Built-in types
|
||||
|
||||
-- | Special types that Haskell uses for pattern matching and literals.
|
||||
defaultSpecialTypes :: Monad m => SupplyT Int m (SpecialTypes Name)
|
||||
defaultSpecialTypes = do
|
||||
theBool <- supplyTypeName "Bool"
|
||||
boolDataType <-
|
||||
do name <- supplyTypeName "Bool"
|
||||
true <- supplyConstructorName "True"
|
||||
false <- supplyConstructorName "False"
|
||||
pure
|
||||
(DataType
|
||||
name
|
||||
[]
|
||||
[DataTypeConstructor true [], DataTypeConstructor false []])
|
||||
theArrow <- supplyTypeName "(->)"
|
||||
theChar <- supplyTypeName "Char"
|
||||
theString <- supplyTypeName "String"
|
||||
@ -223,7 +320,7 @@ defaultSpecialTypes = do
|
||||
theFractional <- supplyTypeName "Fractional"
|
||||
return
|
||||
(SpecialTypes
|
||||
{ specialTypesBool = ConstructorType (TypeConstructor theBool StarKind)
|
||||
{ specialTypesBool = boolDataType
|
||||
, specialTypesChar = ConstructorType (TypeConstructor theChar StarKind)
|
||||
, specialTypesString = ConstructorType (TypeConstructor theString StarKind)
|
||||
, specialTypesFunction =
|
||||
|
||||
26
web/Snap.hs
26
web/Snap.hs
@ -416,6 +416,15 @@ transform a (Matrix m) = do
|
||||
|
||||
newtype Textbox = Textbox JSVal
|
||||
|
||||
class Removable a where
|
||||
remove :: a -> IO ()
|
||||
|
||||
instance Removable Textbox where
|
||||
remove (Textbox j) = js_remove j
|
||||
|
||||
instance Removable Text where
|
||||
remove (Text j) = js_remove j
|
||||
|
||||
-- | Create a text box for the user to write into.
|
||||
textbox :: Snap -> Double -> Double -> Double -> Double -> String -> IO Textbox
|
||||
textbox (Snap _ e) x y w h t = do
|
||||
@ -460,13 +469,13 @@ change (Textbox j) cont = do
|
||||
js_change j callback
|
||||
|
||||
setAttrInt :: Textbox -> String -> Double -> IO ()
|
||||
setAttrInt (Textbox j) key val = do
|
||||
setAttrInt (Textbox j) key val' = do
|
||||
k' <- toJSVal key
|
||||
js_setAttrInt j k' val
|
||||
js_setAttrInt j k' val'
|
||||
|
||||
setAttrStr :: Textbox -> String -> IO ()
|
||||
setAttrStr (Textbox j) val = do
|
||||
val' <- toJSVal val
|
||||
setAttrStr (Textbox j) val0 = do
|
||||
val' <- toJSVal val0
|
||||
js_setAttrStr j val'
|
||||
|
||||
#ifdef __GHCJS__
|
||||
@ -478,6 +487,15 @@ js_textbox :: JSVal -> Double -> Double -> Double -> Double -> JSVal -> IO JSVal
|
||||
js_textbox = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$1.remove()"
|
||||
js_remove :: JSVal -> IO ()
|
||||
#else
|
||||
js_remove :: JSVal -> IO ()
|
||||
js_remove = undefined
|
||||
#endif
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Generalized constrained heterogeneity
|
||||
|
||||
|
||||
107
web/Snappy.hs
107
web/Snappy.hs
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@ -11,9 +11,11 @@ module Snappy where
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
import Data.IORef
|
||||
import Data.IORef
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String
|
||||
import qualified Data.Text as T
|
||||
import Data.Tuple
|
||||
import qualified Snap
|
||||
import System.IO.Unsafe
|
||||
|
||||
@ -22,7 +24,7 @@ import System.IO.Unsafe
|
||||
|
||||
data Event a = forall origin s. Event
|
||||
{ eventSubscribers :: IORef [origin -> IO ()]
|
||||
, eventFromOrigin :: s -> origin -> (Maybe a,s)
|
||||
, eventFromOrigin :: s -> origin -> ([a],s)
|
||||
, eventState :: s
|
||||
}
|
||||
|
||||
@ -43,7 +45,7 @@ zipEvents f e1 e2 =
|
||||
(do subscribersRef <- newIORef mempty
|
||||
tvar1 <- newEmptyMVar
|
||||
tvar2 <- newEmptyMVar
|
||||
let !ev = Event subscribersRef (\s (a, b) -> (Just (f a b), s)) ()
|
||||
let !ev = Event subscribersRef (\s (a, b) -> (pure (f a b), s)) ()
|
||||
let listen e us them pair =
|
||||
bindEvent
|
||||
e
|
||||
@ -65,18 +67,33 @@ scanEvent f nil (Event subscribers fromOrigin oldState) =
|
||||
subscribers
|
||||
(\s origin ->
|
||||
let (a, _) = fromOrigin oldState origin
|
||||
s' = fmap (f s) a
|
||||
in (s', fromMaybe s s'))
|
||||
in swap
|
||||
(mapAccumL
|
||||
(\s0 a0 ->
|
||||
let r = f s0 a0
|
||||
in (r, r))
|
||||
s
|
||||
a))
|
||||
nil
|
||||
{-# INLINE scanEvent #-}
|
||||
|
||||
explodeEvent :: Event [a] -> Event a
|
||||
explodeEvent (Event subscribers fromOrigin oldState) =
|
||||
Event
|
||||
subscribers
|
||||
(\s origin ->
|
||||
let (a, s') = fromOrigin s origin
|
||||
in (concat a, s'))
|
||||
oldState
|
||||
{-# INLINE explodeEvent #-}
|
||||
|
||||
mapMaybeEvent :: (a -> Maybe b) -> Event a -> Event b
|
||||
mapMaybeEvent f (Event subscribers fromOrigin oldState) =
|
||||
Event
|
||||
subscribers
|
||||
(\s origin ->
|
||||
let (a, s') = fromOrigin s origin
|
||||
in (a >>= f, s'))
|
||||
in (mapMaybe f a, s'))
|
||||
oldState
|
||||
{-# INLINE mapMaybeEvent #-}
|
||||
|
||||
@ -87,6 +104,7 @@ filterEvent p =
|
||||
if p a
|
||||
then Just a
|
||||
else Nothing)
|
||||
{-# INLINE filterEvent #-}
|
||||
|
||||
bindEvent :: Event a -> (a -> IO ()) -> IO ()
|
||||
bindEvent Event {..} m = do
|
||||
@ -96,9 +114,7 @@ bindEvent Event {..} m = do
|
||||
(++ [ \v -> do
|
||||
s <- readIORef stateRef
|
||||
let (v', s') = eventFromOrigin s v
|
||||
case v' of
|
||||
Nothing -> return ()
|
||||
Just v'' -> m v''
|
||||
mapM_ m v'
|
||||
writeIORef stateRef s'
|
||||
])
|
||||
|
||||
@ -110,6 +126,9 @@ data Dynamic a = Dynamic
|
||||
, dynEvent :: Maybe (Event a)
|
||||
}
|
||||
|
||||
instance IsString str => IsString (Dynamic str) where
|
||||
fromString = pure . fromString
|
||||
|
||||
instance Functor Dynamic where
|
||||
fmap f (Dynamic def event) =
|
||||
Dynamic (f def) (fmap (fmap f) event)
|
||||
@ -152,7 +171,11 @@ scanDynamic f nil e =
|
||||
,dynEvent = Just (scanEvent f nil e)}
|
||||
|
||||
bindDynamic :: Dynamic a -> (a -> IO ()) -> IO ()
|
||||
bindDynamic (Dynamic _ event) m =
|
||||
bindDynamic (Dynamic val event) m = do
|
||||
void
|
||||
(forkIO
|
||||
(do yield
|
||||
m val))
|
||||
maybe
|
||||
(return ())
|
||||
(\e ->
|
||||
@ -168,6 +191,26 @@ dynamicDef (Dynamic def _) = def
|
||||
eventToDynamic :: a -> Event a -> Dynamic a
|
||||
eventToDynamic d e = Dynamic {dynDefault = d, dynEvent = Just e}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Removable elements
|
||||
|
||||
class Removable (elem :: * -> *) where
|
||||
remove :: elem a -> IO ()
|
||||
|
||||
removable
|
||||
:: forall void elem.
|
||||
Removable elem
|
||||
=> (forall t. IO (elem t, Event void)) -> IO ()
|
||||
removable create = do
|
||||
(v, end) <- create
|
||||
bindEvent end (\_ -> remove v)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- List of elements
|
||||
|
||||
list :: Event (IO a) -> IO ()
|
||||
list d = bindEvent d (\m -> void m)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Drag event
|
||||
|
||||
@ -208,7 +251,7 @@ dragEvent d = do
|
||||
pure
|
||||
(Event
|
||||
{ eventSubscribers = subscribersRef
|
||||
, eventFromOrigin = \s origin -> (Just origin, s)
|
||||
, eventFromOrigin = \s origin -> (pure origin, s)
|
||||
, eventState = st
|
||||
})
|
||||
|
||||
@ -217,26 +260,23 @@ changeEvent d = do
|
||||
subscribersRef <- newIORef mempty
|
||||
Snap.change
|
||||
d
|
||||
(\text -> do
|
||||
(\text' -> do
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> subscriber text) subscribers)
|
||||
threadRef <- newIORef Nothing
|
||||
mapM_ (\subscriber -> subscriber text') subscribers)
|
||||
goahead <- newMVar ()
|
||||
Snap.keyup
|
||||
d
|
||||
(\k text -> do
|
||||
mthreadId <- readIORef threadRef
|
||||
maybe (return ()) killThread mthreadId
|
||||
threadId <-
|
||||
forkIO
|
||||
(do threadDelay (1000 * 50)
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> subscriber (T.unpack text)) subscribers)
|
||||
atomicWriteIORef threadRef (Just threadId))
|
||||
(\_k text' -> do
|
||||
() <- takeMVar goahead
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> subscriber (T.unpack text')) subscribers
|
||||
void (forkIO (do threadDelay (1000 * 50)
|
||||
putMVar goahead ())))
|
||||
st <- newIORef ()
|
||||
pure
|
||||
(Event
|
||||
{ eventSubscribers = subscribersRef
|
||||
, eventFromOrigin = \s origin -> (Just origin, s)
|
||||
, eventFromOrigin = \s origin -> (pure origin, s)
|
||||
, eventState = st
|
||||
})
|
||||
|
||||
@ -279,7 +319,7 @@ clickEvent d = do
|
||||
pure
|
||||
(Event
|
||||
{ eventSubscribers = subscribersRef
|
||||
, eventFromOrigin = \s origin -> (Just origin, s)
|
||||
, eventFromOrigin = \s origin -> (pure origin, s)
|
||||
, eventState = st
|
||||
})
|
||||
|
||||
@ -350,12 +390,15 @@ rect snap xdynamic ydynamic wdynamic hdynamic fdynamic = do
|
||||
--------------------------------------------------------------------------------
|
||||
-- Text object
|
||||
|
||||
data Text = Text
|
||||
data Text t = Text
|
||||
{ textObject :: Snap.Text
|
||||
, textClicked :: Event ClickEvent
|
||||
}
|
||||
|
||||
text :: Snap.Snap -> Dynamic Double -> Dynamic Double -> Dynamic String -> IO Text
|
||||
instance Removable Text where
|
||||
remove (Text s _) = Snap.remove s
|
||||
|
||||
text :: Snap.Snap -> Dynamic Double -> Dynamic Double -> Dynamic String -> IO (Text t)
|
||||
text snap xdynamic ydynamic tdynamic = do
|
||||
let x = dynamicDef xdynamic
|
||||
y = dynamicDef ydynamic
|
||||
@ -384,11 +427,14 @@ text snap xdynamic ydynamic tdynamic = do
|
||||
--------------------------------------------------------------------------------
|
||||
-- Textbox object
|
||||
|
||||
data Textbox = Textbox
|
||||
data Textbox t = Textbox
|
||||
{ textboxObject :: Snap.Textbox
|
||||
, textboxChange :: Event String
|
||||
}
|
||||
|
||||
instance Removable Textbox where
|
||||
remove (Textbox s _) = Snap.remove s
|
||||
|
||||
textbox
|
||||
:: Snap.Snap
|
||||
-> Dynamic Double
|
||||
@ -396,14 +442,13 @@ textbox
|
||||
-> Dynamic Double
|
||||
-> Dynamic Double
|
||||
-> Dynamic String
|
||||
-> IO Textbox
|
||||
-> IO (Textbox t)
|
||||
textbox snap xdynamic ydynamic wdynamic hdynamic tdynamic = do
|
||||
let x = dynamicDef xdynamic
|
||||
y = dynamicDef ydynamic
|
||||
w = dynamicDef wdynamic
|
||||
h = dynamicDef hdynamic
|
||||
c <- Snap.textbox snap x y w h (dynamicDef tdynamic)
|
||||
t <- Snap.newMatrix
|
||||
bindDynamic
|
||||
xdynamic
|
||||
(\x' -> Snap.setAttrInt c "left" x')
|
||||
|
||||
Loading…
Reference in New Issue
Block a user