diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,16 @@ +2019-10-15 Ivan Perez + * Yampa.cabal: Version bump (0.13.1), introduce examples + as executables, depend on fail if needed. + * README.md: Add Peoplemon. + * examples/: Fix errors due to module reorg. + * extensions/: Chnage testing to use tasty. + * .travis.yml: Compile with GHC8.8. + * src/: Support MonadFail proposal and GHC 8.8. + * Thanks to @sigrlami, @RyanGlScott and @CraigTreptow. + 2018-11-02 Ivan Perez * Yampa.cabal: Version bump (0.13). - * README.md: Documents relatec projects. + * README.md: Documents related projects. * src/: Cleans API, removes deprecated constructs, moves vector and points into separate library, hides Core, eliminates Forceable and MergeableRecord, adds documentation. diff --git a/Yampa.cabal b/Yampa.cabal --- a/Yampa.cabal +++ b/Yampa.cabal @@ -1,5 +1,5 @@ name: Yampa -version: 0.13 +version: 0.13.1 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE @@ -62,6 +62,8 @@ hs-source-dirs: src ghc-options : -O3 -Wall -fno-warn-name-shadowing build-Depends: base < 6, random, deepseq, simple-affine-space + if !impl(ghc>=8.0) + build-Depends: fail == 4.9.* exposed-modules: -- Main FRP modules FRP.Yampa @@ -159,6 +161,28 @@ if flag(examples) buildable: True build-depends: base < 5, random, deepseq, SDL, hcwiid, Yampa + else + buildable: False + +executable yampa-examples-elevator + main-is: TestElevatorMain.hs + other-modules: Elevator + hs-source-dirs: examples/Elevator + ghc-options : -O3 -Wall -fno-warn-name-shadowing + if flag(examples) + buildable: True + build-depends: base < 5, Yampa + else + buildable: False + +executable yampa-examples-tailgatingdetector + main-is: TestTGMain.hs + other-modules: TailgatingDetector + hs-source-dirs: examples/TailgatingDetector + ghc-options : -O3 -Wall -fno-warn-name-shadowing + if flag(examples) + buildable: True + build-depends: base < 5, Yampa else buildable: False diff --git a/examples/Elevator/Elevator.hs b/examples/Elevator/Elevator.hs --- a/examples/Elevator/Elevator.hs +++ b/examples/Elevator/Elevator.hs @@ -18,7 +18,6 @@ module Elevator where import FRP.Yampa -import FRP.Yampa.Utilities -- ((^<<), dHold) ------------------------------------------------------------------------------ -- Auxiliary definitions @@ -56,22 +55,22 @@ goUp `tag` upRate `lMerge` goDown `tag` (-downRate) - - y <- (lower +) ^<< integral -< v - + + y <- (lower +) ^<< integral -< v + let atBottom = y <= lower atTop = y >= upper stopped = v == 0 -- Somewhat dubious ... - + waitingBottom = atBottom && stopped waitingTop = atTop && stopped - + arriveBottom <- edge -< atBottom arriveTop <- edge -< atTop - + let setUp = lbp `tag` True setDown = rbp `tag` True - + -- This does not work. The reset events would be generated as soon -- as the corresponding go event was generated, but the latter -- depend instantaneusly on the reset signals. @@ -92,10 +91,10 @@ -- But that does not seem to be the right solution to me. upPending <- hold False -< setUp `lMerge` resetUp downPending <- hold False -< setDown `lMerge` resetDown - + let pending = upPending || downPending eitherButton = lbp `lMerge` rbp - + goDown = arriveTop `gate` pending `lMerge` eitherButton `gate` waitingTop @@ -103,5 +102,5 @@ `lMerge` eitherButton `gate` waitingBottom stop = (arriveTop `lMerge` arriveBottom) `gate` not pending - + returnA -< y diff --git a/examples/Elevator/TestElevatorMain.hs b/examples/Elevator/TestElevatorMain.hs --- a/examples/Elevator/TestElevatorMain.hs +++ b/examples/Elevator/TestElevatorMain.hs @@ -17,8 +17,6 @@ import Data.Maybe (catMaybes) import FRP.Yampa -import FRP.Yampa.Utilities -import FRP.Yampa.Internals -- Just for testing purposes. import Elevator @@ -53,7 +51,7 @@ where feAux _ _ [] = [] feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') = - if not (null message) then + if not (null message) then (t, y, message) : feAux s y tios' else feAux s y tios' diff --git a/examples/TailgatingDetector/TailgatingDetector.hs b/examples/TailgatingDetector/TailgatingDetector.hs --- a/examples/TailgatingDetector/TailgatingDetector.hs +++ b/examples/TailgatingDetector/TailgatingDetector.hs @@ -45,7 +45,6 @@ import FRP.Yampa import FRP.Yampa.Conditional import FRP.Yampa.EventS -import FRP.Yampa.Utilities ------------------------------------------------------------------------------ @@ -304,7 +303,7 @@ sameOrder [] _ = False sameOrder _ [] = False sameOrder ((i,_):ics) ((i',_):ics') - | i == i' = sameOrder ics ics' + | i == i' = sameOrder ics ics' | otherwise = False updateTGDs is (MTGDCol iitgs) = MTGDCol $ diff --git a/examples/TailgatingDetector/TestTGMain.hs b/examples/TailgatingDetector/TestTGMain.hs --- a/examples/TailgatingDetector/TestTGMain.hs +++ b/examples/TailgatingDetector/TestTGMain.hs @@ -18,8 +18,6 @@ import Data.List (sortBy) import FRP.Yampa -import FRP.Yampa.Utilities -import FRP.Yampa.Internals -- Just for testing purposes. import TailgatingDetector @@ -40,7 +38,7 @@ /= (map fst (sortBy comparePos v)) then Just v else - Nothing + Nothing comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 @@ -76,7 +74,7 @@ /= (map fst (sortBy comparePos v)) then Just v else - Nothing + Nothing comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 @@ -91,7 +89,7 @@ &&& (proc _ -> do s <- uavStatus -< () h <- highway -< () (v, ect) <- mkVideoAndTrackers -< (h, s) - (ics, etgs) <- findTailgaters -< (v,s,ect) + (ics, etgs) <- findTailgaters -< (v,s,ect) etgs <- mtgd -< ics returnA -< (etgs, ics))) (deltaEncode smplPer (repeat ())) diff --git a/src/FRP/Yampa/Event.hs b/src/FRP/Yampa/Event.hs --- a/src/FRP/Yampa/Event.hs +++ b/src/FRP/Yampa/Event.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} ----------------------------------------------------------------------------------------- -- | @@ -90,6 +91,7 @@ import Control.Applicative import Control.DeepSeq (NFData(..)) +import qualified Control.Monad.Fail as Fail import FRP.Yampa.Diagnostics @@ -175,9 +177,15 @@ -- | See 'pure'. return = pure + +#if !(MIN_VERSION_base(4,13,0)) -- | Fail with 'NoEvent'. - fail _ = NoEvent + fail = Fail.fail +#endif +instance Fail.MonadFail Event where + -- | Fail with 'NoEvent'. + fail _ = NoEvent -- | Alternative instance instance Alternative Event where