typed-fsm 0.1.0.0 → 0.1.0.1
raw patch · 12 files changed
+1/−1042 lines, 12 filesdep −containersdep −lineardep −microlensdep ~basedep ~dependent-mapdep ~dependent-sumPVP ok
version bump matches the API change (PVP)
Dependencies removed: containers, linear, microlens, microlens-mtl, microlens-th, sdl2, sdl2-ttf, stm, typed-fsm, unordered-containers
Dependency ranges changed: base, dependent-map, dependent-sum, mtl, singletons-base
API changes (from Hackage documentation)
Files
- examples/ATM/EventToMsg.hs +0/−57
- examples/ATM/Handler.hs +0/−92
- examples/ATM/Main.hs +0/−79
- examples/ATM/Type.hs +0/−144
- examples/ATM/Utils.hs +0/−91
- examples/motion/EventToMsg.hs +0/−48
- examples/motion/Handler.hs +0/−82
- examples/motion/Main.hs +0/−85
- examples/motion/Type.hs +0/−94
- examples/motion/Utils.hs +0/−91
- examples/turnstile/Main.hs +0/−104
- typed-fsm.cabal +1/−75
− examples/ATM/EventToMsg.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE ViewPatterns #-}--module EventToMsg where--import Data.Data (Proxy (..))-import qualified Data.Dependent.Map as D-import Data.Dependent.Sum-import Data.Singletons (SingI)-import Lens.Micro-import Type-import TypedFsm.Driver-import Utils--scEventHandler- :: (SingI n, Less3 n)- => Proxy n- -> GenMsg ATMSt InternalState MyEvent (CardInserted n)-scEventHandler _ =- GenMsg- ( \ist event -> case event of- MyMouseLeftButtonClick (fmap fromIntegral -> p) ->- if- | (ist ^. ejectLabel . rect) `contains` p -> Just (SomeMsg CIEject)- | (ist ^. checkPinLabel . rect) `contains` p -> Just (SomeMsg (CheckPIN 1234))- | (ist ^. checkPinErrorLabel . rect) `contains` p -> Just (SomeMsg (CheckPIN 1))- | otherwise -> Nothing- )--atmDepMap :: State2GenMsg ATMSt InternalState MyEvent-atmDepMap =- D.fromList- [ SReady- :=> GenMsg- ( \ist event -> case event of- MyMouseLeftButtonClick (fmap fromIntegral -> p) ->- ( if- | (ist ^. insCardLabel . rect) `contains` p -> Just (SomeMsg InsertCard)- | (ist ^. exitLabel . rect) `contains` p -> Just (SomeMsg ExitATM)- | otherwise -> Nothing- )- )- , SCardInserted SZ :=> scEventHandler Proxy- , SCardInserted (SS SZ) :=> scEventHandler Proxy- , SCardInserted (SS (SS SZ)) :=> scEventHandler Proxy- , SSession- :=> GenMsg- ( \ist event -> case event of- MyMouseLeftButtonClick (fmap fromIntegral -> p) ->- if- | (ist ^. ejectLabel . rect) `contains` p -> Just (SomeMsg SEject)- | (ist ^. getAmountLabel . rect) `contains` p -> Just (SomeMsg GetAmount)- | (ist ^. dispenseLabel . rect) `contains` p -> Just (SomeMsg (Dispense 100))- | otherwise -> Nothing- )- ]
− examples/ATM/Handler.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Handler where--import Control.Monad.State-import Data.IFunctor (At (..), IMonad (..), returnAt)-import qualified Data.IFunctor as I-import Data.Singletons (SingI (sing))-import Lens.Micro.Mtl (use, (-=), (.=))-import Type-import TypedFsm.Core-import TypedFsm.Driver--checkResult- :: forall n- . (SingI n, Less3 n)- => Int- -> Operate (StateT InternalState IO) CheckPINResult (CheckPin n)-checkResult i = I.do- At userPin <- liftm $ use pin- if i == userPin- then LiftM $ pure (ireturn Correct)- else LiftM $ pure (ireturn (Incorrect @n))--checkPinFun- :: forall (n :: N)- . (SingI n)- => Int- -> Operate (StateT InternalState IO) CheckPINResult (CheckPin (n :: N))-checkPinFun i = I.do- case sing @n of- SS SZ -> checkResult i- SS (SS SZ) -> checkResult i- sn@(SS (SS (SS SZ))) -> I.do- At userPin <- liftm $ use pin- if i == userPin- then LiftM $ pure (ireturn Correct)- else LiftM $ do- liftIO $ putStrLn "-> test 3 times, eject card!"- pure (ireturn (EjectCard sn))- _ -> error "np"--readyHandler :: Op ATMSt InternalState IO () Exit Ready-readyHandler = I.do- msg <- getInput- case msg of- InsertCard -> cardInsertedHandler- ExitATM -> returnAt ()--cardInsertedHandler- :: (SingI n)- => Op ATMSt InternalState IO () Exit (CardInserted n)-cardInsertedHandler = I.do- msg <- getInput- case msg of- CIEject -> I.do- readyHandler- CheckPIN i -> I.do- res <- checkPinFun i- case res of- EjectCard _ -> readyHandler- Incorrect -> cardInsertedHandler- Correct -> I.do- liftm $ amountLabel . label .= ("Amount: -- ")- sessionHandler--sessionHandler :: Op ATMSt InternalState IO () Exit Session-sessionHandler = I.do- msg <- getInput- case msg of- GetAmount -> I.do- liftm $ do- am <- use amount- amountLabel . label .= ("Amount: " <> show am)- liftIO $ putStrLn ("-> User Amount: " <> show am)- sessionHandler- Dispense i -> I.do- liftm $ do- amount -= i -- need to check amount is enough?- liftIO $ putStrLn ("-> Use dispense " ++ show i)- am <- use amount- amountLabel . label .= ("Now Amount: " <> show am)- liftIO $ putStrLn ("-> Now User Amount: " <> show am)- sessionHandler- SEject -> readyHandler
− examples/ATM/Main.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# OPTIONS_GHC -Wno-unused-do-bind #-}--module Main where--import Control.Concurrent (threadDelay)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State (StateT (runStateT))-import qualified Control.Monad.State as M-import EventToMsg-import Handler-import Lens.Micro ((^.))-import SDL-import qualified SDL.Font as Font-import Type-import TypedFsm.Driver-import Utils--main :: IO ()-main = do- initialize [InitVideo]- Font.initialize- font <- Font.load "data/fonts/SourceCodePro-Regular.otf" 20- window <- createWindow "test" defaultWindow- renderer <- createRenderer window (-1) defaultRenderer- ccref <- initCharCache-- runStateT- (appLoop (DrawEnv renderer font ccref) (SomeOperate readyHandler))- initInternState- destroyWindow window--appLoop :: DrawEnv -> SomeOp ATMSt InternalState IO () -> StateT InternalState IO ()-appLoop de@(DrawEnv renderer _font _ccref) (SomeOperate fun) = do- events <- pollEvents- -- liftIO $ print events- v <- runOp atmDepMap (makeMyEvent events) fun- case v of- Finish _ -> pure ()- NotMatchGenMsg si -> liftIO $ putStrLn $ "error: not match GenMsg " ++ show si- Cont fun1 -> do- let atmSt = getSomeOperateSt fun1- rendererDrawColor renderer $= V4 0 0 0 255- clear renderer-- rendererDrawColor renderer $= V4 255 0 155 255- liftIO $ drawStrings de [show atmSt] (10, 30)-- ist <- M.get- case atmSt of- Ready -> do- liftIO $ drawLabel de (ist ^. insCardLabel)- liftIO $ drawLabel de (ist ^. exitLabel)- CardInserted _n -> do- liftIO $ drawLabel de (ist ^. checkPinLabel)- liftIO $ drawLabel de (ist ^. checkPinErrorLabel)- liftIO $ drawLabel de (ist ^. ejectLabel)- Session -> do- liftIO $ drawLabel de (ist ^. amountLabel)- liftIO $ drawLabel de (ist ^. getAmountLabel)- liftIO $ drawLabel de (ist ^. dispenseLabel)- liftIO $ drawLabel de (ist ^. ejectLabel)- CheckPin _n -> pure ()- Exit -> pure ()-- present renderer- liftIO $ threadDelay (1000000 `div` 30)- appLoop de fun1
− examples/ATM/Type.hs
@@ -1,144 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}--module Type where--import Data.GADT.Compare (GCompare (..), GEq (..))-import Data.Int (Int32)-import Data.Kind (Constraint, Type)-import Data.Singletons.Base.TH-import Data.Type.Equality (TestEquality (testEquality))-import GHC.TypeError (TypeError)-import GHC.TypeLits (ErrorMessage (..))-import Lens.Micro.TH (makeLenses)-import SDL-import TypedFsm.Core (StateTransMsg (..))-import TypedFsm.Driver (sOrdToGCompare)--$( singletons- [d|- data N = Z | S N- deriving (Show, Eq, Ord)-- data ATMSt- = Ready- | CardInserted N- | CheckPin N- | Session- | Exit- deriving (Show, Eq, Ord)- |]- )--satmToatm :: SATMSt s -> ATMSt-satmToatm = fromSing--instance GEq SN where- geq = testEquality--instance GEq SATMSt where- geq = testEquality--instance GCompare SN where- gcompare = sOrdToGCompare--instance GCompare SATMSt where- gcompare = sOrdToGCompare--type family Less3 (n :: N) :: Constraint where- Less3 Z = ()- Less3 (S Z) = ()- Less3 (S (S Z)) = ()- Less3 _ = TypeError (Text "test must less 3")--data CheckPINResult :: ATMSt -> Type where- EjectCard :: (n ~ S (S (S Z))) => SN n -> CheckPINResult Ready- Incorrect :: (SingI n, Less3 n) => CheckPINResult (CardInserted n)- Correct :: CheckPINResult Session--instance StateTransMsg ATMSt where- data Msg ATMSt from to where- ExitATM :: Msg ATMSt Ready Exit- InsertCard :: Msg ATMSt Ready (CardInserted Z)- CIEject :: Msg ATMSt (CardInserted n) Ready- ---------------- CheckPIN :: Int -> Msg ATMSt (CardInserted n) (CheckPin (S n))- ---------------- GetAmount :: Msg ATMSt Session Session- Dispense :: Int -> Msg ATMSt Session Session- SEject :: Msg ATMSt Session Ready-------------------------------------type Point' = Point V2 Int--pattern Point :: a -> a -> Point V2 a-pattern Point x y = P (V2 x y)-{-# COMPLETE Point #-}--newtype MyEvent = MyMouseLeftButtonClick (Point V2 Int32)- deriving (Show, Eq, Ord)--data Rect = Rect- { _rx :: Int- , _ry :: Int- , _width :: Int- , _height :: Int- }- deriving (Show)--data Label = Label- { _rect :: Rect- , _label :: String- }- deriving (Show)--------------------------------------data InternalState = InternalState- { _pin :: Int- , _amount :: Int- , _amountLabel :: Label- , _insCardLabel :: Label- , _exitLabel :: Label- , _checkPinLabel :: Label- , _checkPinErrorLabel :: Label- , _getAmountLabel :: Label- , _dispenseLabel :: Label- , _ejectLabel :: Label- }- deriving (Show)--initInternState :: InternalState-initInternState =- InternalState- { _pin = 1234- , _amount = 1000- , _amountLabel = Label (Rect 10 130 100 30) "null"- , _insCardLabel = (Label (Rect 10 230 100 30) "Insert Card")- , _exitLabel = (Label (Rect 10 270 100 30) "EXIT")- , _checkPinLabel = (Label (Rect 10 230 100 30) "checkPin 1234")- , _checkPinErrorLabel = (Label (Rect 10 274 100 30) "checkPin 1 error")- , _getAmountLabel = (Label (Rect 10 230 100 30) "GetAmount")- , _dispenseLabel = (Label (Rect 130 230 100 30) "Dispense 100")- , _ejectLabel = (Label (Rect 10 330 100 30) "Eject")- }--Lens.Micro.TH.makeLenses ''Rect-Lens.Micro.TH.makeLenses ''Label-Lens.Micro.TH.makeLenses ''InternalState
− examples/ATM/Utils.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QualifiedDo #-}--module Utils where--import Control.Monad-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as H-import Data.IORef-import Linear-import SDL-import SDL.Font (Font)-import qualified SDL.Font as Font-import Type--type CharCache = HashMap Char Texture-type CharCacheRef = IORef CharCache--data DrawEnv = DrawEnv- { _renderer :: Renderer- , _font :: Font- , _charCacheRef :: CharCacheRef- }--eventToKP :: Event -> Maybe MyEvent-eventToKP e = case eventPayload e of- MouseButtonEvent (MouseButtonEventData _ Pressed _ _ _ pos) ->- Just $ MyMouseLeftButtonClick pos- _ -> Nothing--makeMyEvent :: [Event] -> [MyEvent]-makeMyEvent events =- let fun b a =- case eventToKP a of- Nothing -> b- Just a' -> a' : b- in reverse (foldl' fun [] events)--pattern KBE- :: InputMotion- -> Keycode- -> Bool- -> Maybe Window- -> Scancode- -> KeyModifier- -> EventPayload-pattern KBE press keycode repeat a d f =- KeyboardEvent- (KeyboardEventData a press repeat (Keysym d keycode f))--initCharCache :: IO CharCacheRef-initCharCache = newIORef H.empty--getCharTexure :: Renderer -> Font -> CharCacheRef -> Char -> IO Texture-getCharTexure r font cref c = do- cc <- readIORef cref- case H.lookup c cc of- Nothing -> do- surf <- Font.blendedGlyph font (V4 0 255 0 255) c- text <- createTextureFromSurface r surf- freeSurface surf- modifyIORef' cref (H.insert c text)- pure text- Just t -> pure t--drawString :: DrawEnv -> String -> (Int, Int) -> IO ()-drawString (DrawEnv r font cref) st (x', y') = do- let go _ _ [] = pure ()- go x y (t : ts) = do- TextureInfo _ _ w h <- queryTexture t- copy r t Nothing (Just (Rectangle (P (V2 x y)) (V2 w h)))- go (x + w) y ts- txts <- mapM (getCharTexure r font cref) st- go (fromIntegral x') (fromIntegral y') txts--drawStrings :: DrawEnv -> [String] -> (Int, Int) -> IO ()-drawStrings de sts (x, y) = do- forM_ (zip [0 ..] sts) $ \(i, st) -> do- drawString de st (x, y + i * 20)--drawLabel :: DrawEnv -> Label -> IO ()-drawLabel de@(DrawEnv{_renderer}) (Label (Rect x y w h) st) = do- drawRect _renderer (Just (Rectangle (P (V2 (fromIntegral x) (fromIntegral y))) (V2 (fromIntegral w) (fromIntegral h))))- drawString de st (x, y)--contains :: Rect -> Point' -> Bool-contains (Rect rx1 ry1 w h) (Point x y) =- (rx1 <= x && x <= rx1 + w) && (ry1 <= y && y <= ry1 + h)
− examples/motion/EventToMsg.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--module EventToMsg where--import qualified Data.Dependent.Map as D-import Data.Dependent.Sum-import Type-import TypedFsm.Driver-import Utils--mouseDepMap :: State2GenMsg Motion MotionState MyEvent-mouseDepMap =- D.fromList- [ SIdle- :=> GenMsg- ( \(MotionState rect' _ _ _) event -> case event of- MyQuit -> Just (SomeMsg ExitMotion)- MyMouseMotion (fmap fromIntegral -> p) tms ->- if rect' `contains` p- then Just $ SomeMsg (MoveIn p tms)- else Nothing- _ -> Nothing- )- , SOver- :=> GenMsg- ( \(MotionState rect' _ _ _) event -> case event of- MyQuit -> Just (SomeMsg ExitMotion)- MyMouseMotion (fmap fromIntegral -> p) tms ->- if rect' `contains` p- then Just $ SomeMsg (InMove p tms)- else Just $ SomeMsg MoveOut- MyTimeout -> Just $ SomeMsg TimeoutH- )- , SHover- :=> GenMsg- ( \(MotionState rect' _ (Point mx my) _) event -> case event of- MyQuit -> Just (SomeMsg ExitMotion)- MyMouseMotion (fmap fromIntegral -> p@(Point x y)) tms ->- if rect' `contains` p- then- if abs (mx - x) < 30 && abs (my - y) < 30- then Nothing- else- Just $ SomeMsg (HInMove p tms)- else Just $ SomeMsg HMoveOut- _ -> Nothing- )- ]
− examples/motion/Handler.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wall #-}--module Handler where--import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TChan-import Control.Monad.State-import Data.IFunctor (At (..), returnAt)-import qualified Data.IFunctor as I-import GHC.Event-import Lens.Micro.Mtl-import SDL-import Type-import TypedFsm.Core-import TypedFsm.Driver--timeoutSize :: Int-timeoutSize = 400_000--myRegisterTimeout :: StateT MotionState IO (TimerManager, TimeoutKey)-myRegisterTimeout = do- chan <- use channel- liftIO $ do- tm <- getSystemTimerManager- tk <- registerTimeout tm timeoutSize (atomically $ writeTChan chan ())- pure (tm, tk)--idelHandler :: Op Motion MotionState IO () Exit Idle-idelHandler = I.do- msg <- getInput- case msg of- ExitMotion -> returnAt ()- MoveIn pos tms -> I.do- At tp <- liftm $ do- mousePos .= pos- (tm, tk) <- myRegisterTimeout- pure (tm, tk, tms)- overHandler tp--overHandler :: (TimerManager, TimeoutKey, Timestamp) -> Op Motion MotionState IO () Exit Over-overHandler (tm, tk, oldtms) = I.do- msg <- getInput- case msg of- ExitMotion -> returnAt ()- MoveOut -> I.do- liftm $ liftIO $ unregisterTimeout tm tk- idelHandler- InMove pos tms -> I.do- liftm $ do- mousePos .= pos- if tms - oldtms > 40- then I.do- liftm $ liftIO $ updateTimeout tm tk timeoutSize- overHandler (tm, tk, tms)- else overHandler (tm, tk, oldtms)- TimeoutH -> I.do- liftm $ do- liftIO $ unregisterTimeout tm tk- pos <- use mousePos- onHover .= Just (pos, [show oldtms, show pos])- hoverHandler--hoverHandler :: Op Motion MotionState IO () Exit Hover-hoverHandler = I.do- msg <- getInput- case msg of- ExitMotion -> returnAt ()- HInMove pos tms -> I.do- At tp <- liftm $ do- mousePos .= pos- onHover .= Nothing- (tm, tk) <- myRegisterTimeout- pure (tm, tk, tms)- overHandler tp- HMoveOut -> I.do- liftm $ onHover .= Nothing- idelHandler
− examples/motion/Main.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-unused-do-bind #-}--module Main where--import Control.Concurrent (threadDelay)-import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TChan-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State (StateT (runStateT))-import qualified Control.Monad.State as M-import EventToMsg-import Handler-import SDL-import qualified SDL.Font as Font-import Type-import TypedFsm.Driver-import Utils--main :: IO ()-main = do- initialize [InitVideo]- Font.initialize- font <- Font.load "data/fonts/SourceCodePro-Regular.otf" 20- window <- createWindow "test" defaultWindow- renderer <- createRenderer window (-1) defaultRenderer- ccref <- initCharCache- chan <- newTChanIO @()-- runStateT- (appLoop (DrawEnv renderer font ccref) chan mouseDepMap (SomeOperate idelHandler))- (MotionState (Rect 100 100 400 400) chan (Point 0 0) Nothing)-- destroyWindow window--creatRect :: (Integral p1, Integral p2, Integral p3, Integral p4, Num a) => p1 -> p2 -> p3 -> p4 -> Rectangle a-creatRect x y w h =- Rectangle- (P (V2 (fromIntegral x) (fromIntegral y)))- (V2 (fromIntegral w) (fromIntegral h))--appLoop- :: DrawEnv- -> TChan ()- -> State2GenMsg Motion MotionState MyEvent- -> SomeOp Motion MotionState IO ()- -> StateT MotionState IO ()-appLoop de@(DrawEnv renderer _font _ccref) chan depMap (SomeOperate fun) = do- events <- pollEvents- ma <- liftIO (atomically $ tryReadTChan chan)- v <- runOp depMap (makeMyEvent ma events) fun- case v of- Finish _ -> pure ()- NotMatchGenMsg si -> liftIO $ putStrLn $ "error: not match GenMsg " ++ show si- Cont fun1 -> do- rendererDrawColor renderer $= V4 0 0 0 255- clear renderer-- let motionState = getSomeOperateSt fun1- liftIO $ drawStrings de [show motionState] (10, 30)-- MotionState (Rect x y w h) _ _ mOnhove <- M.get- rendererDrawColor renderer $= V4 255 0 155 255- drawRect renderer $ Just (creatRect x y w h)-- liftIO $- case mOnhove of- Nothing -> pure ()- Just (Point x' y', st) -> do- rendererDrawColor renderer $= V4 100 155 144 255- fillRect renderer $ Just (creatRect x' y' (300 :: Int) (-100 :: Int))- drawStrings de st (fromIntegral x', fromIntegral y' - 60)-- present renderer- liftIO $ threadDelay (1000000 `div` 30)-- appLoop de chan depMap fun1
− examples/motion/Type.hs
@@ -1,94 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--module Type where--import Control.Concurrent.STM.TChan-import Data.GADT.Compare (GCompare (..), GEq (..))-import Data.Int (Int32)-import Data.Singletons.Base.TH-import Data.Type.Equality (TestEquality (testEquality))-import Lens.Micro.TH-import SDL-import TypedFsm.Core-import TypedFsm.Driver--$( singletons- [d|- data Motion- = Idle- | Over- | Hover- | Exit- deriving (Show, Eq, Ord)- |]- )--instance GEq SMotion where- geq = testEquality--instance GCompare SMotion where- gcompare = sOrdToGCompare--smTom :: SMotion m -> Motion-smTom = fromSing-------------------------------------type Point' = Point V2 Int--pattern Point :: a -> a -> Point V2 a-pattern Point x y = P (V2 x y)-{-# COMPLETE Point #-}--instance StateTransMsg Motion where- data Msg Motion from to where- ExitMotion :: Msg Motion s Exit- ------------------ MoveIn :: Point' -> Timestamp -> Msg Motion Idle Over- ------------------ MoveOut :: Msg Motion Over Idle- InMove :: Point' -> Timestamp -> Msg Motion Over Over- TimeoutH :: Msg Motion Over Hover- ------------------ HInMove :: Point' -> Timestamp -> Msg Motion Hover Over- HMoveOut :: Msg Motion Hover Idle--data Rect = Rect- { _rx :: Int- , _ry :: Int- , _width :: Int- , _height :: Int- }- deriving (Show)--data MotionState = MotionState- { _rect :: Rect- , _channel :: TChan ()- , _mousePos :: Point'- , _onHover :: Maybe (Point', [String])- }--data MyEvent- = MyMouseMotion (Point V2 Int32) Timestamp- | MyTimeout- | MyQuit- deriving (Show, Eq, Ord)--------------------------------------makeLenses ''MotionState
− examples/motion/Utils.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QualifiedDo #-}--module Utils where--import Control.Monad-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as H-import Data.IORef-import Linear-import SDL-import SDL.Font (Font)-import qualified SDL.Font as Font-import Type--type CharCache = HashMap Char Texture-type CharCacheRef = IORef CharCache--data DrawEnv = DrawEnv- { _renderer :: Renderer- , _font :: Font- , _charCacheRef :: CharCacheRef- }--eventToKP :: Event -> Maybe MyEvent-eventToKP e = case eventPayload e of- QuitEvent -> Just MyQuit- KBE Pressed KeycodeQ _ _ _ _ -> Just MyQuit- KBE Pressed KeycodeEscape _ _ _ _ -> Just MyQuit- MouseMotionEvent (MouseMotionEventData _ _ _ pos _) ->- Just $ MyMouseMotion pos (eventTimestamp e)- _ -> Nothing--makeMyEvent :: Maybe () -> [Event] -> [MyEvent]-makeMyEvent ma events =- let fun b a =- case eventToKP a of- Nothing -> b- Just a' -> a' : b- res = reverse (foldl' fun [] events)- in case ma of- Nothing -> res- Just _ -> MyTimeout : res--pattern KBE- :: InputMotion- -> Keycode- -> Bool- -> Maybe Window- -> Scancode- -> KeyModifier- -> EventPayload-pattern KBE press keycode repeat a d f =- KeyboardEvent- (KeyboardEventData a press repeat (Keysym d keycode f))--initCharCache :: IO CharCacheRef-initCharCache = newIORef H.empty--getCharTexure :: Renderer -> Font -> CharCacheRef -> Char -> IO Texture-getCharTexure r font cref c = do- cc <- readIORef cref- case H.lookup c cc of- Nothing -> do- surf <- Font.blendedGlyph font (V4 0 255 0 255) c- text <- createTextureFromSurface r surf- freeSurface surf- modifyIORef' cref (H.insert c text)- pure text- Just t -> pure t--drawString :: DrawEnv -> String -> (Int, Int) -> IO ()-drawString (DrawEnv r font cref) st (x', y') = do- let go _ _ [] = pure ()- go x y (t : ts) = do- TextureInfo _ _ w h <- queryTexture t- copy r t Nothing (Just (Rectangle (P (V2 x y)) (V2 w h)))- go (x + w) y ts- txts <- mapM (getCharTexure r font cref) st- go (fromIntegral x') (fromIntegral y') txts--drawStrings :: DrawEnv -> [String] -> (Int, Int) -> IO ()-drawStrings de sts (x, y) = do- forM_ (zip [0 ..] sts) $ \(i, st) -> do- drawString de st (x, y + i * 20)--contains :: Rect -> Point' -> Bool-contains (Rect rx ry w h) (Point x y) =- (rx <= x && x <= rx + w) && (ry <= y && y <= ry + h)
− examples/turnstile/Main.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wno-unused-do-bind #-}--module Main where--import Control.Monad (void)-import Control.Monad.State-import qualified Data.Dependent.Map as D-import Data.Dependent.Sum-import Data.GADT.Compare (GCompare (..), GEq (..))-import Data.IFunctor as I-import Data.Singletons.Base.TH-import Data.Type.Equality (TestEquality (testEquality))-import TypedFsm--$(singletons [d|data TurnSt = Locked | Unlocked | Exit deriving (Show, Eq, Ord)|])--instance StateTransMsg TurnSt where- data Msg TurnSt from to where- Coin :: Msg TurnSt Locked Unlocked- Push :: Msg TurnSt Unlocked Locked- ExitTurnSt :: Msg TurnSt Locked Exit--instance GEq STurnSt where- geq = testEquality--instance GCompare STurnSt where- gcompare = sOrdToGCompare--lockedHandler :: Op TurnSt Int IO () Exit Locked-lockedHandler = I.do- msg <- getInput- case msg of- Coin -> I.do- liftm $ do- liftIO $ putStrLn "Coin, internal int add one"- modify' (+ 1)- v <- get- liftIO $ putStrLn $ "Now coin: " ++ show v- unlockedHandler- ExitTurnSt -> I.do- liftm $ liftIO $ putStrLn "Exit turnSt"--unlockedHandler :: Op TurnSt Int IO () Exit Unlocked-unlockedHandler = I.do- msg <- getInput- case msg of- Push -> I.do- liftm $ do- liftIO $ putStrLn "Push"- lockedHandler--eventDepMap :: State2GenMsg TurnSt Int String-eventDepMap =- D.fromList- [ SLocked- :=> GenMsg- ( \_ ev -> case ev of- "coin" -> Just $ SomeMsg Coin- "exit" -> Just $ SomeMsg ExitTurnSt- _ -> Nothing- )- , SUnlocked- :=> GenMsg- ( \_ ev -> case ev of- "push" -> Just $ SomeMsg Push- _ -> Nothing- )- ]--loop- :: Result TurnSt (StateT Int IO) ()- -> StateT Int IO ()-loop res = do- case res of- Finish _ -> liftIO $ putStrLn "Finish"- NotMatchGenMsg singst -> liftIO $ putStrLn $ "NotMatch GenMSg: " ++ show singst- Cont sop@(SomeOperate op) -> do- st <- liftIO $ do- putStrLn $ "current state: " ++ show (getSomeOperateSt sop)- putStrLn "input command:"- getLine- nres <- runOp eventDepMap [st] op- loop nres--main :: IO ()-main = do- putStrLn "start loop"- void $ runStateT (loop (Cont $ SomeOperate lockedHandler)) 0
typed-fsm.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.0+version: 0.1.0.1 -- A short (one-line) description of the package. synopsis: A framework for strongly typed FSM@@ -60,10 +60,6 @@ -- Extra source files to be distributed with the package, such as examples, or a tutorial module. -- extra-source-files: -flag BuildExample- description: Build examples- default: False- common warnings ghc-options: -Wall @@ -95,76 +91,6 @@ -- Base language which the package is written in. default-language: GHC2021--executable motion- if !flag(BuildExample)- buildable: False- build-depends: base >=4.20.0.0- , typed-fsm- , sdl2 ^>= 2.5.5.0- , sdl2-ttf ^>= 2.1.3- , mtl >= 2.3.1- , stm ^>= 2.5.3.1- , linear ^>= 1.22- , unordered-containers ^>= 0.2.20- , dependent-map >= 0.4.0.0- , dependent-sum >= 0.7.2.0- , containers ^>= 0.7 - , microlens ^>= 0.4.0.0- , microlens-mtl ^>= 0.2.0.3- , microlens-th ^>= 0.4.3.15- , singletons-base >= 3.4- main-is: Main.hs- default-language: Haskell2010- hs-source-dirs: examples/motion- other-modules: Utils- , Handler- , Type- , EventToMsg- ghc-options: -threaded -Wall--executable atm- if !flag(BuildExample)- buildable: False- build-depends: base >=4.20.0.0- , typed-fsm- , unordered-containers ^>= 0.2.20- , dependent-map >= 0.4.0.0- , dependent-sum >= 0.7.2.0- , containers ^>= 0.7- , microlens ^>= 0.4.0.0- , microlens-mtl ^>= 0.2.0.3- , microlens-th ^>= 0.4.3.15- , mtl >= 2.3.1- , sdl2 ^>= 2.5.5.0- , sdl2-ttf ^>= 2.1.3- , mtl >= 2.3.1- , stm ^>= 2.5.3.1- , linear ^>= 1.22- , unordered-containers- , singletons-base >= 3.4- main-is: Main.hs- default-language: Haskell2010- hs-source-dirs: examples/ATM- other-modules: Type- , Handler- , EventToMsg- , Utils- ghc-options: -Wall--executable turnstile- if !flag(BuildExample)- buildable: False- build-depends: base >=4.20.0.0- , typed-fsm- , dependent-map >= 0.4.0.0- , dependent-sum >= 0.7.2.0- , mtl >= 2.3.1- , singletons-base >= 3.4- main-is: Main.hs- default-language: Haskell2010- hs-source-dirs: examples/turnstile- ghc-options: -Wall source-repository head type: git