packages feed

peakachu 0.1 → 0.2

raw patch · 15 files changed

+773/−183 lines, 15 filesdep +TypeComposedep +derivedep +template-haskell

Dependencies added: TypeCompose, derive, template-haskell, time

Files

peakachu.cabal view
@@ -1,9 +1,10 @@ Name:                peakachu-Version:             0.1+Version:             0.2 Category:            FRP-Synopsis:            An FRP library with a GLUT backend+Synopsis:            Experiemental library for composable interactive programs Description:-  An experiemental simple FRP library.+  Experiemental library for composable interactive programs.+   GLUT backend included. License:             BSD3 License-file:        LICENSE@@ -16,9 +17,21 @@ Library   hs-Source-Dirs:      src   Extensions:-  Build-Depends:       base >= 3 && < 5, GLUT+  Build-Depends:       base >= 3 && < 5, template-haskell,+                       TypeCompose, derive,+                       GLUT, time   Exposed-modules:     FRP.Peakachu+                       FRP.Peakachu.Program+                       FRP.Peakachu.Backend+                       FRP.Peakachu.Backend.File                        FRP.Peakachu.Backend.GLUT-                       FRP.Peakachu.Internal-  ghc-options:         -Wall+                       FRP.Peakachu.Backend.GLUT.Getters+                       FRP.Peakachu.Backend.StdIO+                       FRP.Peakachu.Backend.Time+                       Control.Concurrent.MVar.YC+                       Control.FilterCategory+                       Data.ADT.Getters+                       Data.Bijection.YC+                       Data.Newtype+  ghc-options:         -O2 -Wall
+ src/Control/Concurrent/MVar/YC.hs view
@@ -0,0 +1,13 @@+module Control.Concurrent.MVar.YC (+  modifyMVarPure, writeMVar+  ) where++import Control.Applicative ()+import Control.Concurrent.MVar (MVar, modifyMVar_)++modifyMVarPure :: MVar a -> (a -> a) -> IO ()+modifyMVarPure mvar = modifyMVar_ mvar . fmap return++writeMVar :: MVar a -> a -> IO ()+writeMVar mvar = modifyMVarPure mvar . const+
+ src/Control/FilterCategory.hs view
@@ -0,0 +1,33 @@+-- | A FilterCategory is a Category that supports mapMaybeC.+--+-- In Peakachu, both Program and Backend are instances of FilterCategory.++module Control.FilterCategory+  ( FilterCategory(..)+  , genericFlattenC, mapMaybeC, filterC+  ) where++import Control.Category (Category(..))+import Control.Monad (guard)+import Data.Foldable (Foldable(..), toList)++import Prelude hiding ((.), id)++class Category cat => FilterCategory cat where+  flattenC :: cat [a] a+  arrC :: (a -> b) -> cat a b++genericFlattenC :: (FilterCategory cat, Foldable f) => cat (f a) a+genericFlattenC = flattenC . arrC toList++mapMaybeC :: FilterCategory cat => (a -> Maybe b) -> cat a b+mapMaybeC f = genericFlattenC . arrC f++filterC :: FilterCategory cat => (a -> Bool) -> cat a a+filterC cond =+  mapMaybeC f+  where+    f x = do+      guard $ cond x+      return x+
+ src/Data/ADT/Getters.hs view
@@ -0,0 +1,60 @@+-- | ADT getters generation with Template Haskell+--+-- Example:+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > data Blah a = NoBlah | YesBlah a | ManyBlah a Int+-- > $(mkADTGetters ''Blah)+--+-- Generates+--+-- > gNoBlah :: Blah a -> Maybe ()+-- > gYesBlah :: Blah a -> Maybe a+-- > gManyBlah :: Blah a -> Maybe (a, Int)+--+-- Where+--+-- > gYesBlah (YesBlah a) = Just a+-- > gYesBlah _ = Nothing+--+-- etc.++module Data.ADT.Getters+  ( mkADTGetters+  ) where++import Language.Haskell.TH.Syntax++mkADTGetters :: Name -> Q [Dec]+mkADTGetters typeName = do+  TyConI (DataD _ _ typeVars constructors _) <- reify typeName+  return $ constructors >>= mkADTGetterFunc typeName typeVars++mkADTGetterFunc :: Name -> [Name] -> Con -> [Dec]+mkADTGetterFunc typeName typeVars constructor =+  [ SigD resName+    . ForallT typeVars []+    . AppT (AppT ArrowT (foldl AppT (ConT typeName) (map VarT typeVars)))+    . AppT (ConT (mkName "Maybe"))+    $ case containedTypes of+    [] -> TupleT 0+    [x] -> x+    xs -> foldl AppT (TupleT (length xs)) xs+  , FunD resName+    [ Clause [ConP name (map VarP varNames)] clauseJust []+    , Clause [WildP] clauseNothing []+    ]+  ]+  where+    NormalC name params = constructor+    containedTypes = map snd params+    resName = mkName $ 'g' : nameBase name+    varNames = map (mkName . ('x' :) . show) [0 .. length params - 1]+    clauseJust =+      NormalB . AppE (ConE (mkName "Just"))+      $ case varNames of+      [] -> TupE []+      [x] -> VarE x+      xs -> TupE (map VarE xs)+    clauseNothing = NormalB . ConE . mkName $ "Nothing"+
+ src/Data/Bijection/YC.hs view
@@ -0,0 +1,34 @@+-- | In/with functions for bijective functions+--+-- Example:+--+-- > import Data.Bijection (Bijection(..), bimap)+-- > import Data.Bijection.YC (withBi2)+-- > import Data.Monoid (Monoid(..), Sum(..))+-- >+-- > biSum :: Num a => Bijection (->) a (Sum a)+-- > biSum = Bi Sum getSum+-- >+-- > > withBi2 (bimap biSum) mappend (Just 5) (Just 7)+-- > Just 12+-- >+-- > > withBi2 (bimap biSum) mappend Nothing (Just 7)+-- > Just 7++module Data.Bijection.YC+  ( withBi, inBi2, withBi2+  ) where++import Control.Arrow (Arrow)+import Data.Bijection (Bijection(..), inBi, inverse)++withBi :: Arrow x => Bijection x a b -> x b b -> x a a+withBi = inBi . inverse++inBi2 :: Bijection (->) a b -> (a -> a -> a) -> b -> b -> b+inBi2 bi func left right =+  biTo bi $ func (biFrom bi left) (biFrom bi right)++withBi2 :: Bijection (->) a b -> (b -> b -> b) -> a -> a -> a+withBi2 = inBi2 . inverse+
+ src/Data/Newtype.hs view
@@ -0,0 +1,95 @@+-- | In/with newtype functions generation with Template Haskell.+--+-- Example:+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > import Control.Applicative (Applicative(..), ZipList(..))+-- > import Data.Newtype (mkWithNewTypeFuncs)+-- >+-- > $(mkWithNewtypeFuncs [2] ''ZipList)+-- >+-- > > withZipList2 (<*>) [(+3), (*3)] [6, 7]+-- > [9, 21]++module Data.Newtype+  ( mkInNewtypeFuncs, mkWithNewtypeFuncs+  ) where++import Control.Applicative ((<$>), (<*>))+import Language.Haskell.TH.Syntax++nameAddSuf :: String -> Name -> Name+nameAddSuf suf name = mkName (nameBase name ++ suf)++typeAddSuf :: String -> Type -> Type+typeAddSuf suf (ForallT names cxt typ) =+  ForallT+    (nameAddSuf suf <$> names)+    (typeAddSuf suf <$> cxt)+    (typeAddSuf suf typ)+typeAddSuf suf (VarT name) = VarT (nameAddSuf suf name)+typeAddSuf suf (AppT left right) =+  AppT (typeAddSuf suf left) (typeAddSuf suf right)+typeAddSuf _ x = x++data NewtypeFunc = In | With++mkInNewtypeFuncs :: [Int] -> Name -> Q [Dec]+mkInNewtypeFuncs idx typeName = do+  info <- reify typeName+  return $ idx >>= mkNewTypeFunc info In++mkWithNewtypeFuncs :: [Int] -> Name -> Q [Dec]+mkWithNewtypeFuncs idx typeName = do+  info <- reify typeName+  return $ idx >>= mkNewTypeFunc info With++mkNewTypeFunc :: Info -> NewtypeFunc -> Int -> [Dec]+mkNewTypeFunc info whatFunc funcIdx =+  [ SigD resName+    . ForallT+      ( nameAddSuf <$> typeSuffixes <*> typeVars )+      ( typeAddSuf <$> typeSuffixes <*> context )+    . AppT (AppT ArrowT (mkFuncType inputType))+    $ mkFuncType outputType+  , FunD resName [clause]+  ]+  where+    TyConI newtypeDef = info+    NewtypeD context typeName typeVars constructor _ = newtypeDef+    (consName, inType) =+      case constructor of+        NormalC c [(_, i)] -> (c, i)+        RecC c [(_, _, i)] -> (c, i)+        _ -> undefined+    fName = mkName "f"+    xNames = mkName . ('x' :) . show <$> [0 .. funcIdx - 1]+    resName = mkName $ prefix ++ nameBase typeName ++ show funcIdx+    typeSuffixes = show <$> [0 .. funcIdx]+    fullType = foldl AppT (ConT typeName) (map VarT typeVars)+    mkFuncType base =+      foldr AppT (typeAddSuf (last typeSuffixes) base)+      $ AppT ArrowT . (`typeAddSuf` base) <$> init typeSuffixes+    withResName = mkName "res"+    (prefix, inputType, outputType, clause) =+      case whatFunc of+        In ->+          ( "in", inType, fullType+          , Clause (VarP fName : (ConP consName . return . VarP <$> xNames))+            ( NormalB+            . AppE (ConE consName)+            . foldl AppE (VarE fName)+            $ VarE <$> xNames+            ) []+          )+        With ->+          ( "with", fullType, inType+          , Clause (VarP <$> fName : xNames)+            (NormalB (VarE withResName))+            [ ValD (ConP consName [VarP withResName])+              ( NormalB+              . foldl AppE (VarE fName)+              $ AppE (ConE consName) . VarE <$> xNames+              ) []+            ]+          )
src/FRP/Peakachu.hs view
@@ -1,38 +1,60 @@-{-# OPTIONS -O2 -Wall #-}--module FRP.Peakachu (-  Event, escanl, efilter,-  edrop, ereturn, ezip, ezip'+module FRP.Peakachu+  ( runProgram   ) where -import FRP.Peakachu.Internal (Event, escanl, efilter)-import Data.Monoid (mappend, mempty)--ezip :: Event a -> Event b -> Event (Maybe a, Maybe b)-ezip as bs =-  escanl step (Nothing, Nothing) $ fmap Left as `mappend` fmap Right bs-  where-    step (_, r) (Left l) = (Just l, r)-    step (l, _) (Right r) = (l, Just r)+import FRP.Peakachu.Backend (Backend(..), Sink(..))+import FRP.Peakachu.Program (Program(..))+import Control.Concurrent.MVar.YC (writeMVar) -ezip' :: Event a -> Event b -> Event (a, b)-ezip' as bs =-  fmap m . efilter f $ ezip as bs-  where-    f (Just _, Just _) = True-    f _ = False-    m (Just l, Just r) = (l, r)-    m _ = undefined+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (newMVar, putMVar, readMVar, takeMVar)+import Control.Monad (when)+import Data.Function (fix)+import Data.Maybe (isNothing) -ereturn :: a -> Event a-ereturn x = escanl (const id) x mempty+doWhile :: Monad m => m Bool -> m ()+doWhile x = fix $ (x >>=) . flip when -edrop :: Integral i => i -> Event a -> Event a-edrop count =-  fmap snd .-  efilter ((== 0) . fst) .-  escanl step (count+1, undefined)-  where-    step (0, _) x = (0, x)-    step (i, _) x = (i-1, x)+runProgram :: Backend o i -> Program i o -> IO ()+runProgram backend program = do+  progVar <- newMVar program+  resumeVar <- newMVar True+  sinkVar <- newMVar Nothing+  let+    consumeOutput =+      doWhile $ do+        Just sink <- readMVar sinkVar+        prog@(Program vals more) <- takeMVar progVar+        case vals of+          [] -> do+            putMVar progVar prog+            when (isNothing (progMore prog)) $ do+              sinkQuitLoop sink+              writeMVar resumeVar False+            return False+          (x : xs) -> do+            putMVar progVar $ Program xs more+            sinkConsume sink x+            return True+    handleInput val = do+      prog@(Program vals maybeMore) <- takeMVar progVar+      case maybeMore of+        Nothing ->+          putMVar progVar prog+        Just more -> do+          let Program mVals mMore = more val+          putMVar progVar $ Program (vals ++ mVals) mMore+          consumeOutput+  sink <- runBackend backend handleInput+  writeMVar sinkVar (Just sink)+  sinkInit sink+  forkIO $ do+    threadDelay 300000+    consumeOutput+  case sinkMainLoop sink of+    Nothing ->+      doWhile $ do+        threadDelay 200000 -- 0.2 sec+        readMVar resumeVar+    Just mainloop -> mainloop
+ src/FRP/Peakachu/Backend.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}++module FRP.Peakachu.Backend+  ( Backend(..), Sink(..)+  ) where++import Control.FilterCategory (FilterCategory(..))+import Data.Newtype (mkInNewtypeFuncs)++import Control.Category (Category(..))+import Control.Concurrent (forkIO)+import Control.Monad (liftM2)+import Data.Generics.Aliases (orElse)+import Data.Function (on)+import Data.Monoid (Monoid(..))++import Prelude hiding ((.), id)++data Sink a = Sink+  { sinkConsume :: a -> IO ()+  , sinkInit :: IO ()+  , sinkMainLoop :: Maybe (IO ())+  , sinkQuitLoop :: IO ()+  }++combineMainLoops :: Maybe (IO ()) -> Maybe (IO ()) -> Maybe (IO ())+combineMainLoops (Just x) (Just y) = Just $ forkIO x >> y+combineMainLoops x y = orElse x y++instance Monoid (Sink a) where+  mempty = Sink (const (return ())) (return ()) Nothing (return ())+  mappend a b =+    Sink+    { sinkConsume = on (liftM2 (>>)) sinkConsume a b+    , sinkInit = on (>>) sinkInit a b+    , sinkMainLoop = on combineMainLoops sinkMainLoop a b+    , sinkQuitLoop = on (>>) sinkQuitLoop a b+    }++newtype Backend progToBack backToProg =+  Backend+  { runBackend :: (backToProg -> IO ()) -> IO (Sink progToBack)+  } -- if Monoid m => Monoid (IO m)+  -- then could use GeneralizedNewtypeDeriving for Monoid++$(mkInNewtypeFuncs [1,2] ''Backend)++instance Monoid (Backend p2b b2p) where+  mempty = Backend . return . return $ mempty+  mappend = inBackend2 . liftM2 . liftM2 $ mappend++instance Functor (Backend p2b) where+  fmap =+    inBackend1 . arg . arg+    where+      arg = flip (.)++instance Category Backend where+  id =+    Backend f+    where+      f handler =+        return mempty { sinkConsume = handler }+  Backend left . Backend right =+    Backend f+    where+      f handler = do+        sinkLeft <- left handler+        sinkRight <- right . sinkConsume $ sinkLeft+        return sinkRight+          { sinkInit =+              sinkInit sinkLeft >> sinkInit sinkRight+          , sinkMainLoop =+              combineMainLoops+              (sinkMainLoop sinkLeft) (sinkMainLoop sinkRight)+          , sinkQuitLoop =+              sinkQuitLoop sinkLeft >> sinkQuitLoop sinkRight+          }++instance FilterCategory Backend where+  flattenC = Backend (runBackend id . mapM_)+  arrC = (`fmap` id)+
+ src/FRP/Peakachu/Backend/File.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}++module FRP.Peakachu.Backend.File+  ( FileToProgram(..), ProgramToFile(..), fileB+  , gFileData, gFileError+  ) where++import Data.ADT.Getters (mkADTGetters)+import FRP.Peakachu.Backend (Backend(..), Sink(..))++import Control.Monad (join)+import Data.Function (fix)+import Data.Monoid (Monoid(..))+import System.IO (IOMode(ReadMode), openFile, hClose, hGetChar)+import System.IO.Error (try, isEOFError)++data FileToProgram a+  = FileData String a+  | FileError a+$(mkADTGetters ''FileToProgram)++data ProgramToFile a+  = ReadFile FilePath a+  | WriteFile FilePath String a++maybeIO :: (IOError -> Bool) -> IO a -> IO (Maybe a)+maybeIO isExpected =+  join . fmap f . try+  where+    f (Right x) = return $ Just x+    f (Left err)+      | isExpected err = return Nothing+      | otherwise = ioError err++-- Lazy IO forbidden because imho it is horrible+strictReadFile :: FilePath -> IO String+strictReadFile filename = do+  file <- openFile filename ReadMode+  contents <- fix $ \rest -> do+    mc <- maybeIO isEOFError $ hGetChar file+    case mc of+      Nothing -> return ""+      Just c -> fmap (c :) rest+  hClose file+  return contents++fileB :: Backend (ProgramToFile a) (FileToProgram a)+fileB =+  Backend f+  where+    f handler =+      return mempty { sinkConsume = consume }+      where+        consume (ReadFile filename tag) =+          strictReadFile filename >>=+          handler . (`FileData` tag)+        consume (WriteFile filename contents _) =+          writeFile filename contents+
src/FRP/Peakachu/Backend/GLUT.hs view
@@ -1,23 +1,29 @@-{-# OPTIONS -O2 -Wall #-}+{-# LANGUAGE TemplateHaskell #-} -module FRP.Peakachu.Backend.GLUT (-  Image(..), UI(..), run+module FRP.Peakachu.Backend.GLUT+  ( GlutToProgram(..), Image(..), ProgramToGlut(..), glut+  , gIdleEvent, gTimerEvent, gMouseMotionEvent+  , gKeyboardMouseEvent   ) where +import Control.Concurrent.MVar.YC (modifyMVarPure)+import Data.ADT.Getters (mkADTGetters)+import FRP.Peakachu.Backend (Backend(..), Sink(..))++import Control.Concurrent.MVar (newMVar, putMVar, takeMVar) import Data.Monoid (Monoid(..))-import FRP.Peakachu (ereturn)-import FRP.Peakachu.Internal (Event(..), makeCallbackEvent)-import Graphics.UI.GLUT (-  ($=), ($~), SettableStateVar, get,-  ClearBuffer(..), Key(..), KeyState(..),-  Modifiers, Position(..), GLfloat, Size(..),-  DisplayMode(..), initialDisplayMode, swapBuffers,-  createWindow, getArgsAndInitialize,-  displayCallback, keyboardMouseCallback,-  motionCallback, passiveMotionCallback,-  windowSize,-  clear, flush, mainLoop)-import Prelude hiding (repeat)+import Graphics.UI.GLUT+  ( GLfloat, ($=), ($~), get+  , ClearBuffer(..), Key(..), KeyState(..)+  , Modifiers, Position(..), Size(..), Timeout+  , DisplayMode(..), initialDisplayMode, swapBuffers+  , createWindow, getArgsAndInitialize+  , displayCallback, idleCallback+  , keyboardMouseCallback+  , motionCallback, passiveMotionCallback+  , windowSize, addTimerCallback+  , clear, flush, mainLoop, leaveMainLoop+  )  data Image = Image { runImage :: IO ()} @@ -25,54 +31,67 @@   mempty = Image $ return ()   mappend (Image a) (Image b) = Image $ a >> b -data UI = UI {-  mouseMotionEvent :: Event (GLfloat, GLfloat),-  glutKeyboardMouseEvent :: Event (Key, KeyState, Modifiers, Position)-  }--makeCallbackEvent' ::-  SettableStateVar (Maybe b) ->-  ((a -> IO ()) -> b) ->-  IO (Event a)-makeCallbackEvent' callbackVar trans = do-  (event, callback) <- makeCallbackEvent-  callbackVar $= Just (trans callback)-  return event--createUI :: IO UI-createUI = do-  Size sx sy <- get windowSize-  glutMotionEvent <- makeCallbackEvent' motionCallback id-  glutPassiveMotionEvent <- makeCallbackEvent' passiveMotionCallback id-  glutKeyboardMouseE <--    makeCallbackEvent' keyboardMouseCallback $-    \cb a b c d -> cb (a,b,c,d)-  let-    pixel2gl (Position px py) = (p2g sx px, - p2g sy py)-    p2g sa pa = 2 * fromIntegral pa / fromIntegral sa - 1-  return UI {-    glutKeyboardMouseEvent = glutKeyboardMouseE,-    mouseMotionEvent =-      mappend (ereturn (0, 0)) . -- is there a way to get the initial mouse position?-      fmap pixel2gl $-      mappend glutMotionEvent glutPassiveMotionEvent-  }+data GlutToProgram a+  = IdleEvent+  | TimerEvent a+  | MouseMotionEvent GLfloat GLfloat+  | KeyboardMouseEvent Key KeyState Modifiers Position+$(mkADTGetters ''GlutToProgram) -draw :: Image -> IO ()-draw image = do-  clear [ ColorBuffer ]-  runImage image-  swapBuffers-  flush+data ProgramToGlut a+  = DrawImage Image+  | SetTimer Timeout a -run :: (UI -> Event Image) -> IO ()-run programDesc = do-  _ <- getArgsAndInitialize-  initialDisplayMode $~ (DoubleBuffered:)-  createWindow "test"-  program <- fmap programDesc createUI-  mapM_ draw (initialValues program)-  addHandler program draw-  displayCallback $= return ()-  mainLoop+glut :: Backend (ProgramToGlut a) (GlutToProgram a)+glut =+  Backend b+  where+    b handler = do+      _ <- getArgsAndInitialize+      initialDisplayMode $~ (DoubleBuffered:)+      createWindow "test"+      displayCallback $= return ()+      -- all the OpenGL drawing must be performed from the same thread+      -- that runs the GLUT event-loop.+      -- so instead of consuming when given input, we add it to the todo-list.+      -- the next time any GLUT event comes (should be immediate),+      -- we consume all the todo-list.+      -- without this mechanism the graphics flickers.+      todoVar <- newMVar []+      let+        consume (DrawImage image) = do+          clear [ ColorBuffer ]+          runImage image+          swapBuffers+          flush+        consume (SetTimer timeout tag) =+          -- there seems to be a bug with addTimerCallback.+          -- sometimes it calls you back straight away..+          -- but doing a work around with an io-thread seems+          -- to be very slow+          addTimerCallback timeout . handler . TimerEvent $ tag+        preHandler event = do+          todo <- takeMVar todoVar+          putMVar todoVar []+          mapM_ consume . reverse $ todo+          handler event+        setCallbacks = do+          idleCallback $= Just (preHandler IdleEvent)+          keyboardMouseCallback $=+            Just (+            (fmap . fmap . fmap . fmap)+            preHandler KeyboardMouseEvent)+          motionCallback $= Just motion+          passiveMotionCallback $= Just motion+        motion (Position px py) = do+          Size sx sy <- get windowSize+          preHandler $ MouseMotionEvent (p2g sx px) (- p2g sy py)+        p2g sa pa = 2 * fromIntegral pa / fromIntegral sa - 1+      setCallbacks+      return Sink+        { sinkConsume = modifyMVarPure todoVar . (:)+        , sinkInit = handler $ MouseMotionEvent 0 0+        , sinkMainLoop = Just mainLoop+        , sinkQuitLoop = leaveMainLoop+        }
+ src/FRP/Peakachu/Backend/GLUT/Getters.hs view
@@ -0,0 +1,17 @@+-- | ADT getter functions for GLUT data types.+--+-- Useful for filtering GLUT events in the Maybe monad.++{-# LANGUAGE TemplateHaskell #-}++module FRP.Peakachu.Backend.GLUT.Getters+  ( gChar, gMouseButton, gSpecialKey, gDown, gUp+  ) where++import Data.ADT.Getters (mkADTGetters)++import Graphics.UI.GLUT (Key(..), KeyState(..))++$(mkADTGetters ''Key)+$(mkADTGetters ''KeyState)+
+ src/FRP/Peakachu/Backend/StdIO.hs view
@@ -0,0 +1,19 @@+-- | A Peakachu backend to write output to the console++module FRP.Peakachu.Backend.StdIO (stdoutB) where++import FRP.Peakachu.Backend (Backend(..), Sink(..))++import Data.Monoid (mempty)+import System.IO (hFlush, stdout)++stdoutB :: Backend String ()+stdoutB =+  Backend . const . return $ mempty+  { sinkConsume = consume+  }+  where+    consume x = do+      putStr x+      hFlush stdout+
+ src/FRP/Peakachu/Backend/Time.hs view
@@ -0,0 +1,21 @@+-- | A Peakachu backend to get the time++module FRP.Peakachu.Backend.Time+  ( getTimeB+  ) where++import Data.Monoid (Monoid(..))+import FRP.Peakachu.Backend (Backend(..), Sink(..))++import Data.Time.Clock (UTCTime, getCurrentTime)++getTimeB :: Backend a (UTCTime, a)+getTimeB =+  Backend f+  where+    f handler =+      return mempty { sinkConsume = consume }+      where+        consume tag = do+          now <- getCurrentTime+          handler (now, tag)
− src/FRP/Peakachu/Internal.hs 
@@ -1,81 +0,0 @@-{-# OPTIONS -O2 -Wall #-}--module FRP.Peakachu.Internal (-  Event(..), escanl, efilter,-  makeCallbackEvent-  ) where--import Control.Concurrent.MVar (-  newMVar, putMVar, readMVar, takeMVar)-import Control.Monad (when)-import Data.Monoid (Monoid(..))--data Event a = Event {-  addHandler :: (a -> IO ()) -> IO (),-  initialValues :: [a]-}--instance Functor Event where-  fmap func event =-    Event {-      addHandler = addHandler event . (. func),-      initialValues = map func (initialValues event)-    }--instance Monoid (Event a) where-  mempty =-    Event {-      addHandler = const (return ()),-      initialValues = []-    }-  mappend x y =-    Event {-      addHandler = \handler -> do-        addHandler x handler-        addHandler y handler,-      initialValues = initialValues x ++ initialValues y-    }--escanl :: (a -> b -> a) -> a -> Event b -> Event a-escanl step startVal event =-  Event {-    addHandler = \handler -> do-      accVar <- newMVar (last initValues)-      let-        srcHandler val = do-          prevAcc <- takeMVar accVar-          let newAcc = step prevAcc val-          putMVar accVar newAcc-          handler newAcc-      addHandler event srcHandler,-    initialValues = initValues-  }-  where-    initValues = scanl step startVal (initialValues event)--efilter :: (a -> Bool) -> Event a -> Event a-efilter cond event =-  Event {-    addHandler = \handler -> do-      let-        srcHandler val =-          when (cond val) (handler val)-      addHandler event srcHandler,-    initialValues = filter cond (initialValues event)-  }--makeCallbackEvent :: IO (Event a, a -> IO ())-makeCallbackEvent = do-  dstHandlersVar <- newMVar []-  let-    srcHandler val =-      mapM_ ($ val) =<< readMVar dstHandlersVar-    event =-      Event {-        addHandler = \handler ->-          takeMVar dstHandlersVar >>=-          putMVar dstHandlersVar . (handler :),-        initialValues = []-      }-  return (event, srcHandler)-
+ src/FRP/Peakachu/Program.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-}++module FRP.Peakachu.Program+  ( Program(..), MergeProgram(..), AppendProgram(..)+  , ProgCat(..)+  , singleValueP, lstP, lstPs, delayP+  ) where++import Control.FilterCategory (FilterCategory(..), genericFlattenC)+import Data.ADT.Getters (mkADTGetters)+import Data.Bijection.YC (withBi2)+import Data.Newtype (mkWithNewtypeFuncs)++import Control.Applicative (Applicative(..), (<$>), liftA2)+import Control.Category (Category(..))+import Control.Monad (MonadPlus(..), ap)+import Data.Bijection (Bijection(..), bimap)+import Data.Generics.Aliases (orElse)+import Data.List (genericDrop, genericTake)+import Data.Maybe (mapMaybe, catMaybes)+import Data.Monoid (Monoid(..))++import Prelude hiding ((.), id)++data Program a b = Program+  { progVals :: [b]+  , progMore :: Maybe (a -> Program a b)+  }++class FilterCategory prog => ProgCat prog where+  scanlP :: (b -> a -> b) -> b -> prog a b+  emptyP :: prog a b+  takeWhileP :: (a -> Bool) -> prog a a+  loopbackP :: prog a (Either a b) -> prog a b++singleValueP :: ProgCat prog => prog a ()+singleValueP = scanlP const () . emptyP++delayP :: (Integral i, ProgCat prog) => i -> prog a a+delayP n =+  flattenC . arrC (genericDrop n) . scanlP step []+  where+    step xs = (: genericTake n xs)++instance Category Program where+  id =+    Program [] (Just f)+    where+      f x = Program [x] (Just f)+  left . right =+    Program (catMaybes stuff >>= progVals) more+    where+      Program rightStart rightMore = right+      stuff = scanl step (Just left) rightStart+      step l valRight = do+        Program _ moreLeft <- l+        moreFunc <- moreLeft+        return $ moreFunc valRight+      more = do+        moreFunc <- rightMore+        lastStuff <- last stuff+        return $ (.) (Program [] (progMore lastStuff)) . moreFunc++instance Functor (Program a) where+  fmap f p =+    Program+    { progVals = fmap f . progVals $ p+    , progMore = (fmap . fmap . fmap) f . progMore $ p+    }++instance FilterCategory Program where+  flattenC =+    f []+    where+      f = (`Program` Just f)+  arrC = (<$> id)++$(mkADTGetters ''Either)++instance ProgCat Program where+  emptyP = Program [] Nothing+  scanlP step start =+    Program [start] $ Just (scanlP step . step start)+  takeWhileP cond =+    Program [] (Just f)+    where+      f x+        | cond x = Program [x] (Just f)+        | otherwise = Program [] Nothing+  loopbackP program =+    Program+    { progVals = stuff >>= mapMaybe gRight . progVals+    , progMore = (fmap . fmap) loopbackP . progMore . last $ stuff+    }+    where+      stuff =+        scanl step program+        . mapMaybe gLeft . progVals $ program+      step prev val =+        maybe emptyP ($ val) (progMore prev)++newtype MergeProgram a b = MergeProg+  { runMergeProg :: Program a b+  } deriving (Category, FilterCategory, Functor, ProgCat)++$(mkWithNewtypeFuncs [2] ''MergeProgram)++biMergeProg :: Bijection (->) (Program a b) (MergeProgram a b)+biMergeProg = Bi MergeProg runMergeProg++instance Monoid (MergeProgram a b) where+  mempty = emptyP+  mappend (MergeProg left) (MergeProg right) =+    MergeProg Program+    { progVals =+      mappend (progVals left) (progVals right)+    , progMore =+      withBi2 ((bimap . bimap) biMergeProg)+      mappend (progMore left) (progMore right)+    }++instance Applicative (MergeProgram a) where+  pure x =+    MergeProg Program+    { progVals = pure x+    , progMore = pure . pure . runMergeProg . pure $ x+    }+  MergeProg left <*> MergeProg right =+    MergeProg Program+    { progVals = progVals left <*> progVals right+    , progMore =+      (liftA2 . liftA2 . withMergeProgram2)+      (<*>) (progMore left) (progMore right)+    }++newtype AppendProgram a b = AppendProg+  { runAppendProg :: Program a b+  } deriving (Category, FilterCategory, Functor, ProgCat)++$(mkWithNewtypeFuncs [1,2] ''AppendProgram)++instance Monoid (AppendProgram a b) where+  mempty = emptyP+  mappend (AppendProg left) (AppendProg right) =+    AppendProg $+    case progMore left of+      Nothing -> Program+        { progVals = progVals left ++ progVals right+        , progMore = progMore right+        }+      Just more -> Program+        { progVals = progVals left+        , progMore = Just $ flip (withAppendProgram2 mappend) right <$> more+        }++instance Monad (AppendProgram a) where+  return x = AppendProg $ Program [x] Nothing+  AppendProg left >>= right =+    mconcat $ map right (progVals left) ++ [rest]+    where+      rest =+        AppendProg Program+        { progVals = []+        , progMore =+          (fmap . fmap . withAppendProgram1)+          (>>= right) (progMore left)+        }++instance MonadPlus (AppendProgram a) where+  mzero = mempty+  mplus = mappend++instance Applicative (AppendProgram a) where+  pure = return+  (<*>) = ap++lstPs :: ProgCat prog => Maybe b -> (a -> Maybe b) -> prog a b+lstPs start f =+  genericFlattenC . scanlP (flip orElse) start . arrC f++lstP :: ProgCat prog => (a -> Maybe b) -> prog a b+lstP = lstPs Nothing+