peakachu 0.2 → 0.3.0
raw patch · 15 files changed
+592/−510 lines, 15 filesdep +Listdep ~GLUTdep ~TypeComposedep ~derive
Dependencies added: List
Dependency ranges changed: GLUT, TypeCompose, derive
Files
- peakachu.cabal +4/−4
- src/Control/Concurrent/MVar/YC.hs +2/−2
- src/Control/FilterCategory.hs +10/−10
- src/Data/ADT/Getters.hs +43/−29
- src/Data/Bijection/YC.hs +0/−34
- src/Data/Newtype.hs +89/−58
- src/FRP/Peakachu.hs +62/−47
- src/FRP/Peakachu/Backend.hs +24/−67
- src/FRP/Peakachu/Backend/File.hs +33/−32
- src/FRP/Peakachu/Backend/GLUT.hs +82/−74
- src/FRP/Peakachu/Backend/GLUT/Getters.hs +2/−2
- src/FRP/Peakachu/Backend/Internal.hs +39/−0
- src/FRP/Peakachu/Backend/StdIO.hs +49/−10
- src/FRP/Peakachu/Backend/Time.hs +12/−11
- src/FRP/Peakachu/Program.hs +141/−130
peakachu.cabal view
@@ -1,5 +1,5 @@ Name: peakachu-Version: 0.2+Version: 0.3.0 Category: FRP Synopsis: Experiemental library for composable interactive programs Description:@@ -18,11 +18,12 @@ hs-Source-Dirs: src Extensions: Build-Depends: base >= 3 && < 5, template-haskell,- TypeCompose, derive,- GLUT, time+ List >= 0.4.0 && < 0.6.0, TypeCompose >= 0.7 && < 0.8, derive >= 2.3,+ GLUT >= 2.0 && < 3.0, time Exposed-modules: FRP.Peakachu FRP.Peakachu.Program FRP.Peakachu.Backend+ FRP.Peakachu.Backend.Internal FRP.Peakachu.Backend.File FRP.Peakachu.Backend.GLUT FRP.Peakachu.Backend.GLUT.Getters@@ -31,7 +32,6 @@ 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
@@ -1,6 +1,6 @@ module Control.Concurrent.MVar.YC (- modifyMVarPure, writeMVar- ) where+ modifyMVarPure, writeMVar+ ) where import Control.Applicative () import Control.Concurrent.MVar (MVar, modifyMVar_)
src/Control/FilterCategory.hs view
@@ -3,9 +3,9 @@ -- In Peakachu, both Program and Backend are instances of FilterCategory. module Control.FilterCategory- ( FilterCategory(..)- , genericFlattenC, mapMaybeC, filterC- ) where+ ( FilterCategory(..)+ , genericFlattenC, mapMaybeC, filterC+ ) where import Control.Category (Category(..)) import Control.Monad (guard)@@ -14,8 +14,8 @@ import Prelude hiding ((.), id) class Category cat => FilterCategory cat where- flattenC :: cat [a] a- arrC :: (a -> b) -> cat a b+ flattenC :: cat [a] a+ arrC :: (a -> b) -> cat a b genericFlattenC :: (FilterCategory cat, Foldable f) => cat (f a) a genericFlattenC = flattenC . arrC toList@@ -25,9 +25,9 @@ filterC :: FilterCategory cat => (a -> Bool) -> cat a a filterC cond =- mapMaybeC f- where- f x = do- guard $ cond x- return x+ mapMaybeC f+ where+ f x = do+ guard $ cond x+ return x
src/Data/ADT/Getters.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | ADT getters generation with Template Haskell -- -- Example:@@ -20,41 +22,53 @@ -- etc. module Data.ADT.Getters- ( mkADTGetters- ) where+ ( 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+ TyConI (DataD _ _ typeVars constructors _) <- reify typeName+ return $ constructors >>= mkADTGetterFunc typeName typeVars -mkADTGetterFunc :: Name -> [Name] -> Con -> [Dec]+#if !(MIN_VERSION_template_haskell(2,4,0))+type TyVarBndr = Name+#endif++tyVarBndrName :: TyVarBndr -> Name+#if MIN_VERSION_template_haskell(2,4,0)+tyVarBndrName (PlainTV name) = name+tyVarBndrName (KindedTV name _) = name+#else+tyVarBndrName = id+#endif++mkADTGetterFunc :: Name -> [TyVarBndr] -> 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 []+ [ SigD resName+ . ForallT typeVars []+ . AppT (AppT ArrowT (foldl AppT (ConT typeName) (map (VarT . tyVarBndrName) 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"+ 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
@@ -1,34 +0,0 @@--- | 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
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | In/with newtype functions generation with Template Haskell. -- -- Example:@@ -12,8 +14,8 @@ -- > [9, 21] module Data.Newtype- ( mkInNewtypeFuncs, mkWithNewtypeFuncs- ) where+ ( mkInNewtypeFuncs, mkWithNewtypeFuncs+ ) where import Control.Applicative ((<$>), (<*>)) import Language.Haskell.TH.Syntax@@ -21,75 +23,104 @@ nameAddSuf :: String -> Name -> Name nameAddSuf suf name = mkName (nameBase name ++ suf) +#if !(MIN_VERSION_template_haskell(2,4,0))+type TyVarBndr = Name+type Pred = Type+#endif++tyVarBndrAddSuf :: String -> TyVarBndr -> TyVarBndr+#if MIN_VERSION_template_haskell(2,4,0)+tyVarBndrAddSuf suf (PlainTV name) = PlainTV (nameAddSuf suf name)+tyVarBndrAddSuf suf (KindedTV name kind) = KindedTV (nameAddSuf suf name) kind+#else+tyVarBndrAddSuf = nameAddSuf+#endif++predAddSuf :: String -> Pred -> Pred+#if MIN_VERSION_template_haskell(2,4,0)+predAddSuf suf (ClassP name types) = ClassP name (map (typeAddSuf suf) types)+predAddSuf suf (EqualP a b) = EqualP (typeAddSuf suf a) (typeAddSuf suf b)+#else+predAddSuf = typeAddSuf+#endif++tyVarBndrName :: TyVarBndr -> Name+#if MIN_VERSION_template_haskell(2,4,0)+tyVarBndrName (PlainTV name) = name+tyVarBndrName (KindedTV name _) = name+#else+tyVarBndrName = id+#endif+ typeAddSuf :: String -> Type -> Type typeAddSuf suf (ForallT names cxt typ) =- ForallT- (nameAddSuf suf <$> names)- (typeAddSuf suf <$> cxt)- (typeAddSuf suf typ)+ ForallT+ (tyVarBndrAddSuf suf <$> names)+ (predAddSuf 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)+ 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+ 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+ 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- ) []- ]- )+ [ SigD resName+ . ForallT+ ( tyVarBndrAddSuf <$> typeSuffixes <*> typeVars )+ ( predAddSuf <$> 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 . tyVarBndrName) 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,60 +1,75 @@ module FRP.Peakachu- ( runProgram- ) where+ ( processList, processListV, runProgram+ ) where -import FRP.Peakachu.Backend (Backend(..), Sink(..))-import FRP.Peakachu.Program (Program(..))+import FRP.Peakachu.Backend (Backend (..))+import FRP.Peakachu.Backend.Internal (Sink (..), MainLoop (..), ParallelIO (..))+import FRP.Peakachu.Program (Program (..)) import Control.Concurrent.MVar.YC (writeMVar) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (newMVar, putMVar, readMVar, takeMVar)-import Control.Monad (when)-import Data.Function (fix)+import Control.Monad (liftM, when)+import Control.Monad.Trans.List.Funcs (repeatM)+import Data.List.Class (List, concat, execute, scanl, takeWhile) import Data.Maybe (isNothing)+import Prelude hiding (concat, scanl, takeWhile) +-- | "Verbose" version of 'processList'.+--+-- The program's outputs after each input are grouped together+processListV :: List l => Program a b -> l a -> l [b]+processListV program+ = liftM (progVals . snd) . takeWhile fst . scanl step (True, program)+ where+ step (_, Program _ Nothing) _ = (False, Program [] Nothing)+ step (_, Program _ (Just more)) x = (True, more x)++processList :: List l => Program a b -> l a -> l b+processList program = concat . processListV program+ doWhile :: Monad m => m Bool -> m ()-doWhile x = fix $ (x >>=) . flip when+doWhile = execute . takeWhile id . repeatM 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+ 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+ mlQuit $ sinkMainLoop 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)+ mlInit $ sinkMainLoop sink+ _ <- forkIO $ do+ threadDelay 300000+ consumeOutput+ case mlRun (sinkMainLoop sink) 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-+ doWhile $ do+ threadDelay 200000 -- 0.2 sec+ readMVar resumeVar+ Just mainloop -> runParIO mainloop
src/FRP/Peakachu/Backend.hs view
@@ -1,83 +1,40 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} module FRP.Peakachu.Backend- ( Backend(..), Sink(..)- ) where+ ( Backend(..)+ ) where import Control.FilterCategory (FilterCategory(..))-import Data.Newtype (mkInNewtypeFuncs)+import FRP.Peakachu.Backend.Internal (Sink(..)) import Control.Category (Category(..))-import Control.Concurrent (forkIO)-import Control.Monad (liftM2)-import Data.Generics.Aliases (orElse)-import Data.Function (on)+import Control.Instances () -- IO Monoids+import Data.DeriveTH (derive, makeFunctor) 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 (.)+ Backend+ { runBackend :: (backToProg -> IO ()) -> IO (Sink progToBack)+ } deriving Monoid+$(derive makeFunctor ''Backend) 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- }+ 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 . Sink (sinkConsume sinkRight) $ mappend (sinkMainLoop sinkLeft) (sinkMainLoop sinkRight) instance FilterCategory Backend where- flattenC = Backend (runBackend id . mapM_)- arrC = (`fmap` id)+ flattenC = Backend (runBackend id . mapM_)+ arrC = (`fmap` id)
src/FRP/Peakachu/Backend/File.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} module FRP.Peakachu.Backend.File- ( FileToProgram(..), ProgramToFile(..), fileB- , gFileData, gFileError- ) where+ ( FileToProgram(..), ProgramToFile(..), fileB+ , gFileData, gFileError+ ) where import Data.ADT.Getters (mkADTGetters)-import FRP.Peakachu.Backend (Backend(..), Sink(..))+import FRP.Peakachu.Backend (Backend(..))+import FRP.Peakachu.Backend.Internal (Sink(..)) import Control.Monad (join) import Data.Function (fix)@@ -15,45 +16,45 @@ import System.IO.Error (try, isEOFError) data FileToProgram a- = FileData String a- | FileError a+ = FileData String a+ | FileError a $(mkADTGetters ''FileToProgram) data ProgramToFile a- = ReadFile FilePath a- | WriteFile FilePath String 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+ 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+ 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+ 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,97 +1,105 @@ {-# LANGUAGE TemplateHaskell #-} module FRP.Peakachu.Backend.GLUT- ( GlutToProgram(..), Image(..), ProgramToGlut(..), glut- , gIdleEvent, gTimerEvent, gMouseMotionEvent- , gKeyboardMouseEvent- ) where+ ( 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 FRP.Peakachu.Backend (Backend(..))+import FRP.Peakachu.Backend.Internal+ (Sink(..), MainLoop(..), ParallelIO(..)) -import Control.Concurrent.MVar (newMVar, putMVar, takeMVar)+import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) import Data.Monoid (Monoid(..)) 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- )+ ( 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 ()} instance Monoid Image where- mempty = Image $ return ()- mappend (Image a) (Image b) = Image $ a >> b+ mempty = Image $ return ()+ mappend (Image a) (Image b) = Image $ a >> b data GlutToProgram a- = IdleEvent- | TimerEvent a- | MouseMotionEvent GLfloat GLfloat- | KeyboardMouseEvent Key KeyState Modifiers Position+ = IdleEvent+ | TimerEvent a+ | MouseMotionEvent GLfloat GLfloat+ | KeyboardMouseEvent Key KeyState Modifiers Position $(mkADTGetters ''GlutToProgram) data ProgramToGlut a- = DrawImage Image- | SetTimer Timeout a+ = DrawImage Image+ | SetTimer Timeout a -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+glutConsume :: (GlutToProgram a -> IO ()) -> ProgramToGlut a -> IO ()+glutConsume _ (DrawImage image) = do+ clear [ ColorBuffer ]+ runImage image+ swapBuffers+ flush+glutConsume handler (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++setGlutCallbacks :: MVar [ProgramToGlut a] -> (GlutToProgram a -> IO ()) -> IO ()+setGlutCallbacks todoVar handler = do+ idleCallback $= Just (preHandler IdleEvent)+ keyboardMouseCallback $=+ Just (+ (fmap . fmap . fmap . fmap)+ preHandler KeyboardMouseEvent)+ motionCallback $= Just motion+ passiveMotionCallback $= Just motion+ where 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+ todo <- takeMVar todoVar+ putMVar todoVar []+ mapM_ (glutConsume handler) . reverse $ todo+ handler event motion (Position px py) = do- Size sx sy <- get windowSize- preHandler $ MouseMotionEvent (p2g sx px) (- p2g sy py)+ 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- } +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 []+ setGlutCallbacks todoVar handler+ return Sink+ { sinkConsume = modifyMVarPure todoVar . (:)+ , sinkMainLoop =+ MainLoop+ { mlInit = handler $ MouseMotionEvent 0 0+ , mlQuit = leaveMainLoop+ , mlRun = Just $ ParIO mainLoop+ }+ }
src/FRP/Peakachu/Backend/GLUT/Getters.hs view
@@ -5,8 +5,8 @@ {-# LANGUAGE TemplateHaskell #-} module FRP.Peakachu.Backend.GLUT.Getters- ( gChar, gMouseButton, gSpecialKey, gDown, gUp- ) where+ ( gChar, gMouseButton, gSpecialKey, gDown, gUp+ ) where import Data.ADT.Getters (mkADTGetters)
+ src/FRP/Peakachu/Backend/Internal.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}++module FRP.Peakachu.Backend.Internal+ ( Sink(..), MainLoop(..), ParallelIO(..)+ ) where++import Data.Newtype (mkInNewtypeFuncs)++import Control.Concurrent (forkIO)+import Control.Instances () -- IO Monoids+import Data.DeriveTH (derive, makeMonoid)+import Data.Monoid++newtype ParallelIO = ParIO { runParIO :: IO () }+$(mkInNewtypeFuncs [1,2] ''ParallelIO)++instance Monoid ParallelIO where+ mempty = ParIO mempty+ mappend a = inParallelIO2 (>>) (inParallelIO1 ((>> return ()) . forkIO) a)++data MainLoop =+ MainLoop+ { mlInit :: IO ()+ , mlQuit :: IO ()+ , mlRun :: Maybe ParallelIO+ }+$(derive makeMonoid ''MainLoop)++data Sink a = Sink+ { sinkConsume :: a -> IO ()+ , sinkMainLoop :: MainLoop+ }++-- not using "derive" to derive Sink's Monoid because it has a bug+instance Monoid (Sink a) where+ mempty = Sink mempty mempty+ mappend (Sink x0 x1) (Sink y0 y1) =+ Sink (mappend x0 y0) (mappend x1 y1)+
src/FRP/Peakachu/Backend/StdIO.hs view
@@ -1,19 +1,58 @@ -- | A Peakachu backend to write output to the console -module FRP.Peakachu.Backend.StdIO (stdoutB) where+module FRP.Peakachu.Backend.StdIO+ ( stdoutB, interactB+ ) where -import FRP.Peakachu.Backend (Backend(..), Sink(..))+import FRP.Peakachu.Backend (Backend(..))+import FRP.Peakachu.Backend.Internal (Sink(..), MainLoop(..), ParallelIO(..))+import Control.Concurrent.MVar.YC (writeMVar) +import Control.Concurrent.MVar+ (newMVar, putMVar, readMVar, takeMVar)+import Control.Monad (when) import Data.Monoid (mempty)-import System.IO (hFlush, stdout)+import System.IO (hFlush, hReady, stdin, stdout) stdoutB :: Backend String () stdoutB =- Backend . const . return $ mempty- { sinkConsume = consume- }- where- consume x = do- putStr x- hFlush stdout+ Backend . return . return $+ mempty { sinkConsume = (>> hFlush stdout) . putStr }++whileM :: Monad m => m Bool -> m () -> m ()+whileM cond iter = do+ resume <- cond+ when resume $ do+ iter+ whileM cond iter++-- | The Peakachu equivalent to 'interact'.+-- Prints all output lines from the program, and feeds+-- input lines from the user to the program.+interactB :: Backend String String+interactB =+ Backend f+ where+ f handler = do+ resumeVar <- newMVar True+ lineVar <- newMVar ""+ return Sink+ { sinkConsume = putStrLn+ , sinkMainLoop =+ mempty+ { mlQuit = writeMVar resumeVar False+ , mlRun =+ Just . ParIO . whileM (readMVar resumeVar) $ do+ isReady <- hReady stdin+ when isReady $ do+ c <- getChar+ prevLine <- takeMVar lineVar+ case c of+ '\n' -> do+ _ <- handler prevLine+ putMVar lineVar ""+ _ ->+ putMVar lineVar $ prevLine ++ [c]+ }+ }
src/FRP/Peakachu/Backend/Time.hs view
@@ -1,21 +1,22 @@ -- | A Peakachu backend to get the time module FRP.Peakachu.Backend.Time- ( getTimeB- ) where+ ( getTimeB+ ) where import Data.Monoid (Monoid(..))-import FRP.Peakachu.Backend (Backend(..), Sink(..))+import FRP.Peakachu.Backend (Backend(..))+import FRP.Peakachu.Backend.Internal (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)+ Backend f+ where+ f handler =+ return mempty { sinkConsume = consume }+ where+ consume tag = do+ now <- getCurrentTime+ handler (now, tag)
src/FRP/Peakachu/Program.hs view
@@ -1,183 +1,194 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} +-- | @Program a b@ is a pure representation of a computer program,+-- which accepts inputs of type @a@, and outputs values of type @b@.+-- It may also terminate. It can output zero or more @b@ values after each @a@ input.+--+-- * A simple stateless input-output-loop can be created from a function+-- with 'arrC'.+--+-- * A simple stateful input-output-loop can be created using 'scanlP'.+--+-- * Outputs can be filtered using 'filterC'.+--+-- Programs may also be composed together in several ways using common type-classes+--+-- * 'Category': @Program a b -> Program b c -> Program a c@. One program's outputs are fed+-- to another program as input.+--+-- * 'Monoid': @Program a b -> Program a b -> Program a b@. Both programs run in parallel processing the same input. Resulting Program outputs both's outputs.+--+-- * 'Applicative': @Program a (b -> c) -> Program a b -> Program a c@.+--+-- * Alternative `MonadPlus`: 'AppendProgram' is a newtype wrapper whose `Monoid` instance runs one program after the other finishes (like `ZipList` offers an alternative `Applicative` instance for lists). It's also a `Monad` ant its monadic bind allows us to invoke inner programs based on an outer program's outputs.+ module FRP.Peakachu.Program- ( Program(..), MergeProgram(..), AppendProgram(..)- , ProgCat(..)- , singleValueP, lstP, lstPs, delayP- ) where+ ( Program(..), AppendProgram(..)+ , scanlP, emptyP, takeWhileP, loopbackP, singleValueP, lstP, lstPs, delayP+ , withAppendProgram1, withAppendProgram2+ ) 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.DeriveTH (derive, makeFunctor) import Data.List (genericDrop, genericTake) import Data.Maybe (mapMaybe, catMaybes) import Data.Monoid (Monoid(..)) import Prelude hiding ((.), id) +-- | A computer program 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)+ { progVals :: [b]+ , progMore :: Maybe (a -> Program a b)+ }+$(derive makeFunctor ''Program) 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- }+ 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 FilterCategory Program where- flattenC =- f []- where- f = (`Program` Just f)- arrC = (<$> id)+ 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 =+-- | Create a stateful input-output-loop from a simple function+scanlP :: (b -> a -> b) -> b -> Program a b+scanlP step start = Program [start] $ Just (scanlP step . step start)++-- | A program that terminates immediately+emptyP :: Program a b+emptyP = Program [] Nothing++-- | Terminate when a predicate on input fails+takeWhileP :: (a -> Bool) -> Program a a+takeWhileP cond = Program [] (Just f) where- f x- | cond x = Program [x] (Just f)- | otherwise = Program [] Nothing- loopbackP program =+ f x+ | cond x = Program [x] (Just f)+ | otherwise = Program [] Nothing++-- | Feed some outputs of a 'Program' to itself+loopbackP :: Program a (Either a b) -> Program a b+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)+ stuff =+ scanl step program+ . mapMaybe gLeft . progVals $ program+ step prev val =+ maybe emptyP ($ val) (progMore prev) -$(mkWithNewtypeFuncs [2] ''MergeProgram)+-- | A program that outputs a value and immediately terminates+singleValueP :: Program a ()+singleValueP = scanlP const () . emptyP -biMergeProg :: Bijection (->) (Program a b) (MergeProgram a b)-biMergeProg = Bi MergeProg runMergeProg+-- | Delay the outputs of a 'Program'+delayP :: Integral i => i -> Program a a+delayP n =+ flattenC . arrC (genericDrop n) . scanlP step []+ where+ step xs = (: genericTake n xs) -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)- }+-- would be nice to derive this.+-- but "derive" currently can't: http://code.google.com/p/ndmitchell/issues/detail?id=270&q=proj:Derive+instance Monoid (Program a b) where+ mempty = Program mempty mempty+ mappend left right =+ Program+ { progVals = mappend (progVals left) (progVals right)+ , progMore = 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)- }+instance Applicative (Program a) where+ pure x =+ Program+ { progVals = pure x+ , progMore = (pure . pure) (pure x)+ }+ left <*> right =+ Program+ { progVals = progVals left <*> progVals right+ , progMore = (liftA2 . liftA2) (<*>) (progMore left) (progMore right)+ } +-- Combine programs to run in sequence newtype AppendProgram a b = AppendProg- { runAppendProg :: Program a b- } deriving (Category, FilterCategory, Functor, ProgCat)+ { runAppendProg :: Program a b+ } deriving (Category, FilterCategory, Functor) $(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- }+ mempty = AppendProg 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)- }+ 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+ mzero = mempty+ mplus = mappend instance Applicative (AppendProgram a) where- pure = return- (<*>) = ap+ pure = return+ (<*>) = ap -lstPs :: ProgCat prog => Maybe b -> (a -> Maybe b) -> prog a b+-- | Given a partial function @(a -> Maybe b)@ and a start value, output its most recent result on an input.+lstPs :: Maybe b -> (a -> Maybe b) -> Program a b lstPs start f =- genericFlattenC . scanlP (flip orElse) start . arrC f+ genericFlattenC . scanlP (flip mplus) start . arrC f -lstP :: ProgCat prog => (a -> Maybe b) -> prog a b+-- | Given a partial function @(a -> Maybe b)@, output its most recent result on an input.+lstP :: (a -> Maybe b) -> Program a b lstP = lstPs Nothing