diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,12 @@ +2015-11-14 Ivan Perez + * tests/: Include haddock. Regression tests now exit with proper exit + code. + * src/: Includes more documentation. + * Yampa.cabal: Include haddock and regression test suites. + Version bump (0.10.4). + 2015-10-02 Ivan Perez - * src:/ Event instances of Applicative and Alternative. + * src/: Event instances of Applicative and Alternative. * Yampa.cabal: Version bump (0.10.3). 2015-06-19 Ivan Perez diff --git a/Yampa.cabal b/Yampa.cabal --- a/Yampa.cabal +++ b/Yampa.cabal @@ -1,5 +1,5 @@ name: Yampa -version: 0.10.3 +version: 0.10.4 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE @@ -34,12 +34,21 @@ CHANGELOG - -- You can disable the hlint test suite with -f-test-hlint flag test-hlint default: False manual: True +-- You can disable the haddock coverage test suite with -f-test-doc-coverage +flag test-doc-coverage + default: False + manual: True + +-- You can disable the regression test suite with -f-test-regression +flag test-regression + default: True + manual: True + library hs-source-dirs: src ghc-options : -O3 -Wall -fno-warn-name-shadowing @@ -95,6 +104,34 @@ build-depends: base, hlint >= 1.7 + +-- Verify that the code is thoroughly documented +test-suite haddock-coverage + type: exitcode-stdio-1.0 + main-is: HaddockCoverage.hs + ghc-options: -Wall + hs-source-dirs: tests + + if !flag(test-doc-coverage) + buildable: False + else + build-depends: + base >= 4 && < 5, + directory, + filepath, + process, + regex-posix + +test-suite regression + type: exitcode-stdio-1.0 + main-is: testAFRPMain.hs + hs-source-dirs: tests + if !flag(test-regression) + buildable: False + else + build-depends: + base, + Yampa source-repository head type: git diff --git a/src/FRP/Yampa.hs b/src/FRP/Yampa.hs --- a/src/FRP/Yampa.hs +++ b/src/FRP/Yampa.hs @@ -383,9 +383,11 @@ -- ** Integration and differentiation integral, -- :: VectorSpace a s => SF a a - - derivative, -- :: VectorSpace a s => SF a a -- Crude! imIntegral, -- :: VectorSpace a s => a -> SF a a + impulseIntegral, -- :: VectorSpace a k => SF (a, Event a) a + count, -- :: Integral b => SF (Event a) (Event b) + derivative, -- :: VectorSpace a s => SF a a -- Crude! + -- Temporarily hidden, but will eventually be made public. -- iterFrom, -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b diff --git a/src/FRP/Yampa/Basic.hs b/src/FRP/Yampa/Basic.hs --- a/src/FRP/Yampa/Basic.hs +++ b/src/FRP/Yampa/Basic.hs @@ -8,6 +8,14 @@ -- Stability : provisional -- Portability : non-portable (GHC extensions) +-- | Defines basic signal functions, and elementary ways of altering them. +-- +-- This module defines very basic ways of creating and modifying signal +-- functions. In particular, it defines ways of creating constant output +-- producing SFs, and SFs that just pass the signal through unmodified. +-- +-- It also defines ways of altering the input and the output signal only +-- by inserting one value in the signal, or by transforming it. module FRP.Yampa.Basic ( -- * Basic signal functions 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 @@ -125,70 +125,71 @@ noEventSnd (a, _) = (a, NoEvent) ------------------------------------------------------------------------------- --- Eq instance ------------------------------------------------------------------------------- - --- Right now, we could derive this instance. But that could possibly change. - +-- | Eq instance (equivalent to derived instance) instance Eq a => Eq (Event a) where + -- | Equal if both NoEvent or both Event carrying equal values. NoEvent == NoEvent = True (Event x) == (Event y) = x == y _ == _ = False ------------------------------------------------------------------------------- --- Ord instance ------------------------------------------------------------------------------- - +-- | Ord instance (equivalent to derived instance) instance Ord a => Ord (Event a) where + -- | NoEvent is smaller than Event, Event x < Event y if x < y compare NoEvent NoEvent = EQ compare NoEvent (Event _) = LT compare (Event _) NoEvent = GT compare (Event x) (Event y) = compare x y - ------------------------------------------------------------------------------- --- Functor instance ------------------------------------------------------------------------------- - +-- | Functor instance (could be derived). instance Functor Event where + -- | Apply function to value carried by 'Event', if any. fmap _ NoEvent = NoEvent fmap f (Event a) = Event (f a) ------------------------------------------------------------------------------- --- Applicative instance ------------------------------------------------------------------------------- - +-- | Applicative instance (similar to 'Maybe'). instance Applicative Event where + -- | Wrap a pure value in an 'Event'. pure = Event + -- | If any value (function or arg) is 'NoEvent', everything is. NoEvent <*> _ = NoEvent Event f <*> x = f <$> x +-- | Monad instance +instance Monad Event where + -- | Combine events, return 'NoEvent' if any value in the + -- sequence is 'NoEvent'. + (Event x) >>= k = k x + NoEvent >>= _ = NoEvent ------------------------------------------------------------------------------- --- Alternative instance ------------------------------------------------------------------------------- + (>>) = (*>) + -- | See 'pure'. + return = pure + -- | Fail with 'NoEvent'. + fail _ = NoEvent + + +-- | Alternative instance instance Alternative Event where + -- | An empty alternative carries no event, so it is ignored. empty = NoEvent + -- | Merge favouring the left event ('NoEvent' only if both are + -- 'NoEvent'). NoEvent <|> r = r l <|> _ = l ------------------------------------------------------------------------------- --- Forceable instance ------------------------------------------------------------------------------- - +-- | Forceable instance instance Forceable a => Forceable (Event a) where + -- | Force an event by evaluating its argument. force ea@NoEvent = ea force ea@(Event a) = force a `seq` ea ------------------------------------------------------------------------------- --- NFData instance ------------------------------------------------------------------------------- +-- | NFData instance instance NFData a => NFData (Event a) where + -- | Evaluate value carried by event. rnf NoEvent = () rnf (Event a) = rnf a `seq` () @@ -199,6 +200,7 @@ -- These utilities are to be considered strictly internal to AFRP for the -- time being. +-- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe'). maybeToEvent :: Maybe a -> Event a maybeToEvent Nothing = NoEvent maybeToEvent (Just a) = Event a diff --git a/src/FRP/Yampa/Integration.hs b/src/FRP/Yampa/Integration.hs --- a/src/FRP/Yampa/Integration.hs +++ b/src/FRP/Yampa/Integration.hs @@ -16,14 +16,15 @@ -- * Integration integral, -- :: VectorSpace a s => SF a a imIntegral, -- :: VectorSpace a s => a -> SF a a + impulseIntegral, -- :: VectorSpace a k => SF (a, Event a) a + count, -- :: Integral b => SF (Event a) (Event b) -- * Differentiation - derivative, -- :: VectorSpace a s => SF a a -- Crude! + derivative -- :: VectorSpace a s => SF a a -- Crude! + -- Temporarily hidden, but will eventually be made public. -- iterFrom, -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b - impulseIntegral, - count ) where diff --git a/tests/AFRPTests.hs b/tests/AFRPTests.hs --- a/tests/AFRPTests.hs +++ b/tests/AFRPTests.hs @@ -40,7 +40,6 @@ module AFRPTests where import FRP.Yampa -import FRP.Yampa.Task (forAll) import AFRPTestsCommon import AFRPTestsArr @@ -141,15 +140,14 @@ format n i = "Test " ++ n ++ "_t" ++ show i ++ " failed." -runRegTests :: IO () +runRegTests :: IO Bool runRegTests = do putStrLn "" putStrLn "Running the AFRP regression tests ..." - if allGood then - putStrLn "All tests succeeded!" - else - forAll failedTests putStrLn - + if allGood + then putStrLn "All tests succeeded!" + else mapM_ putStrLn failedTests + return allGood runSpaceTests :: IO () runSpaceTests = do diff --git a/tests/HaddockCoverage.hs b/tests/HaddockCoverage.hs new file mode 100644 --- /dev/null +++ b/tests/HaddockCoverage.hs @@ -0,0 +1,94 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (HaddockCoverage) +-- Copyright : (C) 2015 Ivan Perez +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Ivan Perez +-- Stability : provisional +-- Portability : portable +-- +-- Copyright notice: This file borrows code +-- https://hackage.haskell.org/package/lens-4.7/src/tests/doctests.hsc +-- which is itself licensed BSD-style as well. +-- +-- Run haddock on a source tree and report if anything in any +-- module is not documented. +----------------------------------------------------------------------------- +module Main where + +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process +import Text.Regex.Posix + +main :: IO () +main = do + -- Find haskell modules + -- TODO: Ideally cabal should do this (provide us with the + -- list of modules). An alternative would be to use cabal haddock + -- but that would need a --no-html argument or something like that. + -- Alternatively, we could use cabal haddock with additional arguments. + -- + -- See: + -- https://github.com/keera-studios/haddock/commit/d5d752943c4e5c6c9ffcdde4dc136fcee967c495 + -- https://github.com/haskell/haddock/issues/309#issuecomment-150811929 + files <- getSources + + let haddockArgs = [ "--no-warnings" ] ++ files + let cabalArgs = [ "exec", "--", "haddock" ] ++ haddockArgs + print cabalArgs + (code, out, _err) <- readProcessWithExitCode "cabal" cabalArgs "" + + -- Filter out coverage lines, and find those that denote undocumented + -- modules. + -- + -- TODO: is there a way to annotate a function as self-documenting, + -- in the same way we do with ANN for hlint? + let isIncompleteModule :: String -> Bool + isIncompleteModule line = isCoverageLine line && not (line =~ "^ *100%") + where isCoverageLine :: String -> Bool + isCoverageLine line = line =~ "^ *[0-9]+%" + + let incompleteModules :: [String] + incompleteModules = filter isIncompleteModule $ lines out + + -- Based on the result of haddock, report errors and exit. + -- Note that, unline haddock, this script does not + -- output anything to stdout. It uses stderr instead + -- (as it should). + case (code, incompleteModules) of + (ExitSuccess , []) -> return () + (ExitFailure _, _) -> exitFailure + (_ , _) -> do + hPutStrLn stderr "The following modules are not fully documented:" + mapM_ (hPutStrLn stderr) incompleteModules + exitFailure + +getSources :: IO [FilePath] +getSources = filter isHaskellFile <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + + isHaskellFile fp = (isSuffixOf ".hs" fp || isSuffixOf ".lhs" fp) + && not (any (`isSuffixOf` fp) excludedFiles) + + excludedFiles = [ "Vector2.hs", "Vector3.hs" + , "Point2.hs", "Point3.hs" + , "MergeableRecord.hs" ] + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c + +-- find-based implementation (not portable) +-- +-- getSources :: IO [FilePath] +-- getSources = fmap lines $ readProcess "find" ["src/", "-iname", "*hs"] "" diff --git a/tests/testAFRPMain.hs b/tests/testAFRPMain.hs --- a/tests/testAFRPMain.hs +++ b/tests/testAFRPMain.hs @@ -14,8 +14,10 @@ import AFRPTests -import System.IO +import Control.Monad (when) import System.Environment (getArgs, getProgName) +import System.Exit (exitWith, ExitCode(..)) +import System.IO -- main = runTests -- main = runSpaceTests @@ -52,20 +54,24 @@ main = do pname <- getProgName args <- getArgs - let eFlags = if (length args) < 1 - then (Left allFlags) + let eFlags = if (length args) < 1 + then Left allFlags else parseArgs defFlags args case eFlags of - (Left tFlags) -> - if (tHelp tFlags) + Right emsg -> usage pname (Just emsg) + Left tFlags -> + if tHelp tFlags then usage pname Nothing else do - if (tReg tFlags) - then runRegTests - else return () - if (tSpace tFlags) - then runSpaceTests - else return () - (Right emsg) -> usage pname (Just emsg) + -- Run regresion tests, check if passed + t <- if tReg tFlags + then runRegTests + else return True + -- Run space tests + when (tSpace tFlags) + runSpaceTests + -- Communicate if all tests have passed + let exitCode = if t then ExitSuccess else (ExitFailure 1) + exitWith exitCode