keera-hails-mvc-model-lightmodel 0.0.3.4 → 0.6.0
raw patch · 13 files changed
+310/−123 lines, 13 filesdep +directorydep +filepathdep +hlintdep ~basenew-uploader
Dependencies added: directory, filepath, hlint, process, regex-posix
Dependency ranges changed: base
Files
- LICENSE +5/−4
- keera-hails-mvc-model-lightmodel.cabal +101/−60
- src/Hails/MVC/Model/ProtectedModel.hs +17/−13
- src/Hails/MVC/Model/ProtectedModel/Initialisation.hs +3/−0
- src/Hails/MVC/Model/ProtectedModel/Reactive.hs +7/−4
- src/Hails/MVC/Model/ReactiveFields.hs +7/−2
- src/Hails/MVC/Model/ReactiveModel.hs +8/−4
- src/Hails/MVC/Model/ReactiveModel/Events.hs +5/−2
- src/Hails/MVC/Model/ReactiveModel/Initialisation.hs +3/−0
- src/Hails/MVC/Model/THAccessors.hs +20/−17
- src/Hails/MVC/Model/THFields.hs +20/−17
- tests/HLintMain.hs +23/−0
- tests/HaddockCoverage.hs +91/−0
LICENSE view
@@ -1,4 +1,5 @@-Copyright (c)2012, Ivan Perez+Copyright (c) 2013-2020, Keera Studios Ltd+Copyright (c) 2010-2012, Ivan Perez All rights reserved. @@ -13,9 +14,9 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Ivan Perez nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+ * Neither the name of Ivan Perez, nor the name of Keera Studios, nor the+ names of other contributors may be used to endorse or promote products+ derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
keera-hails-mvc-model-lightmodel.cabal view
@@ -1,75 +1,116 @@--- hails.cabal auto-generated by cabal init. For additional options,--- see--- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.--- The name of the package.-Name: keera-hails-mvc-model-lightmodel+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : All Rights Reserved+-- Maintainer : support@keera.co.uk+--+cabal-version: >= 1.10+build-type: Simple --- The package version. See the Haskell package versioning policy--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for--- standards guiding when and how versions should be incremented.-Version: 0.0.3.4+name: keera-hails-mvc-model-lightmodel+version: 0.6.0+author: Ivan Perez+maintainer: support@keera.co.uk+homepage: http://www.keera.co.uk/blog/community/+license: BSD3+license-file: LICENSE+category: Development+synopsis: Rapid Gtk Application Development - Reactive Protected Light Models+description:+ Light Protected Models are Thread-safe (STM) Reactive Models with change+ propagation and notification. They are meant to enclose a whole (MVC)+ application's model, using field accessors to access every part of a Protected+ Model as a Reactive Value. Unline full Protected Models, Light models do not+ have an undo/redo queue. --- A short (one-line) description of the package.-Synopsis: Rapid Gtk Application Development - Reactive Protected Light Models+source-repository head+ type: git+ location: git://github.com/keera-studios/keera-hails+ subdir: keera-hails-mvc-model-lightmodel --- A longer description of the package.-Description: Light Protected Models are Thread-safe (STM) Reactive Models- with change propagation and notification. They are meant- to enclose a whole (MVC) application's model, using field- accessors to access every part of a Protected Model as a- Reactive Value. Unline full Protected Models, Light models- do not have an undo/redo queue.+-- You can disable the hlint test suite with -f-test-hlint+flag test-hlint+ default: False+ manual: True --- URL for the project homepage or repository.-Homepage: http://www.keera.es/blog/community/+-- You can disable the haddock coverage test suite with -f-test-doc-coverage+flag test-doc-coverage+ default: False+ manual: True --- The license under which the package is released.-License: BSD3+library --- The file containing the license text.-License-file: LICENSE+ exposed-modules:+ Hails.MVC.Model.ProtectedModel+ Hails.MVC.Model.ProtectedModel.Reactive+ Hails.MVC.Model.ProtectedModel.Initialisation+ Hails.MVC.Model.THAccessors+ Hails.MVC.Model.THFields+ Hails.MVC.Model.ReactiveFields+ Hails.MVC.Model.ReactiveModel.Initialisation+ Hails.MVC.Model.ReactiveModel+ Hails.MVC.Model.ReactiveModel.Events --- The package author(s).-Author: Ivan Perez+ build-depends:+ base >= 4 && < 5+ , template-haskell+ , containers+ , stm+ , MissingK --- An email address to which users can send suggestions, bug reports,--- and patches.-Maintainer: ivan.perez@keera.es+ , keera-hails-reactivevalues --- A copyright notice.--- Copyright: + default-language: Haskell2010 -Category: Development+ hs-source-dirs: src/ -Build-type: Simple+ ghc-options: -Wall -fno-warn-unused-do-bind -O2 --- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files: --- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.2+test-suite hlint -Library- hs-source-dirs: src/- - ghc-options: -Wall -fno-warn-unused-do-bind -O2+ type:+ exitcode-stdio-1.0 - -- Modules exported by the library.- Exposed-modules: Hails.MVC.Model.ProtectedModel- , Hails.MVC.Model.ProtectedModel.Reactive- , Hails.MVC.Model.ProtectedModel.Initialisation- , Hails.MVC.Model.THAccessors- , Hails.MVC.Model.THFields- , Hails.MVC.Model.ReactiveFields- , Hails.MVC.Model.ReactiveModel.Initialisation- , Hails.MVC.Model.ReactiveModel- , Hails.MVC.Model.ReactiveModel.Events- - -- Packages needed in order to build this package.- Build-depends: base >= 4 && < 5- , template-haskell- , containers- , stm- , keera-hails-reactivevalues- , MissingK+ main-is:+ HLintMain.hs++ hs-source-dirs:+ tests++ if !flag(test-hlint)+ buildable: False+ else+ build-depends:+ base+ , hlint >= 1.7++ default-language:+ Haskell2010+++-- 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++ default-language:+ Haskell2010
src/Hails/MVC/Model/ProtectedModel.hs view
@@ -4,12 +4,16 @@ -- see it. I'd like to make this code as generic and useful as -- possible. ----- | This module holds the protected reactive program model. It holds+-- This module holds the protected reactive program model. It holds -- a reactive model, but includes an interface that is thread safe -- (can be called concurrently). This makes it easier for different -- threads to modify the model without having to worry about -- concurrency. Note that using this interface can lead to deadlocks -- in the program.+--+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.ProtectedModel ( ProtectedModel (reactiveModel) -- * Construction@@ -70,7 +74,7 @@ -- | Lock the calling thread until the reactive model fulfills a -- condition.-waitFor :: Event b => +waitFor :: Event b => ProtectedModel a b -> (ReactiveModelIO a b -> Bool) -> IO () waitFor p c = atomically $ void $ do rm <- readTVar $ reactiveModel p@@ -86,20 +90,20 @@ pa <- atomically $ do rm <- readTVar rmvar -- Check that there's something pending- check (not (Seq.null (pendingEvents rm)) + check (not (Seq.null (pendingEvents rm)) || not (Seq.null (pendingHandlers rm))) -- Get the next handler let (rm', op) = getPendingHandler rm- + -- Update the ReactiveModel writeTVar rmvar rm'- + -- Return the next handler to execute return op -- Execute the handler- when (isJust pa) $ fromJust pa - + when (isJust pa) $ fromJust pa+ -- Let other threads run yield @@ -112,17 +116,17 @@ onEvents pm evs f = applyToReactiveModel pm (\rm -> RM.onEvents rm evs f) -- | Perform a modification to the underlying reactive model.-applyToReactiveModel :: Event b - => ProtectedModel a b - -> (ReactiveModelIO a b -> ReactiveModelIO a b) +applyToReactiveModel :: Event b+ => ProtectedModel a b+ -> (ReactiveModelIO a b -> ReactiveModelIO a b) -> IO () applyToReactiveModel p f = atomically $ onTVar (reactiveModel p) f where onTVar v g = readTVar v >>= (writeTVar v . g) -- | Calculate a value from the reactive model.-onReactiveModel :: Event b - => ProtectedModel a b - -> (ReactiveModelIO a b -> c) +onReactiveModel :: Event b+ => ProtectedModel a b+ -> (ReactiveModelIO a b -> c) -> IO c onReactiveModel p f = fmap f $ atomically $ readTVar $ reactiveModel p
src/Hails/MVC/Model/ProtectedModel/Initialisation.hs view
@@ -1,6 +1,9 @@ -- | Contains only one operation to notify that the system's been -- initialised. --+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.ProtectedModel.Initialisation where import qualified Hails.MVC.Model.ReactiveModel.Initialisation as RM
src/Hails/MVC/Model/ProtectedModel/Reactive.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -- | Protected Reactive Fields--- +-- -- This module defines several classes and operations that are used to -- create reactive fields and to bind reactive fields in the view to -- reactive fields in the model. -- -- FIXME: Due to the restrictions in the type classes, the current -- version uses Model.ProtectedModel.ProtectedModelInternals.ProtectedModel.-+--+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.ProtectedModel.Reactive where import Data.ReactiveValue@@ -63,9 +66,9 @@ instance Event c => ReactiveReadWriteField (ReactiveElement a b c) a b c where -type FieldAccessor a b c = ProtectedModel b c -> ReactiveFieldReadWrite a+type FieldAccessor a b c = ProtectedModel b c -> ReactiveFieldReadWrite IO a -mkFieldAccessor :: (InitialisedEvent c, Event c) => ReactiveElement a b c -> ProtectedModel b c -> ReactiveFieldReadWrite a+mkFieldAccessor :: (InitialisedEvent c, Event c) => ReactiveElement a b c -> ProtectedModel b c -> ReactiveFieldReadWrite IO a mkFieldAccessor (ReactiveElement evs setter' getter') pm = ReactiveFieldReadWrite set get notify where set = setter' pm get = getter' pm
src/Hails/MVC/Model/ReactiveFields.hs view
@@ -1,3 +1,8 @@+-- |+--+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.ReactiveFields where import Hails.MVC.Model.ReactiveModel@@ -5,7 +10,7 @@ -- TODO: With the new reactive lenses interface, -- this should uses lenses instead. A 'Field' is -- just a lens, augmented with an event and a--- precondition checker. +-- precondition checker. -- The following code presents a possibly simpler way of creating reactive -- fields in a reactive model.@@ -14,7 +19,7 @@ preTrue :: a -> b -> Bool preTrue _ _ = True -fieldSetter :: (Eq a, Event c) => +fieldSetter :: (Eq a, Event c) => Field a b c -> ReactiveModel b c d -> a -> ReactiveModel b c d fieldSetter f@(_, pre, rSet, ev) rm newVal | fieldGetter f rm == newVal = rm
src/Hails/MVC/Model/ReactiveModel.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification #-} -- | This module holds a reactive program model. It holds a program model, but -- includes events that other threads can listen to, so that a change in a part -- of the model is notified to another part of the program. The reactive model@@ -9,6 +9,10 @@ -- This type includes operations to handle undoing-redoing and -- tracking which notifications must be triggered in each -- undo-redo step.+--+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.ReactiveModel ( ReactiveModel (basicModel) -- * Construction@@ -53,7 +57,7 @@ -- instance Eq FullEvent where -- (FullEvent a) == (FullEvent b) = typeOf a == typeOf b -- && cast a == Just b--- instance Ord FullEvent where +-- instance Ord FullEvent where -- (FullEvent a) < (FullEvent b) = (typeOf a == typeOf b -- && fromJust (cast a) < b) -- || (show (typeOf a) < show (typeOf b))@@ -62,7 +66,7 @@ -- show (FullEvent x) = show x -- | A model of kind a with a stack of events of kind b-data Event b => ReactiveModel a b c = ReactiveModel +data Event b => ReactiveModel a b c = ReactiveModel { basicModel :: a , eventHandlers :: M.Map b (Seq c) , pendingEvents :: Seq b@@ -124,5 +128,5 @@ where evs = pendingEvents rm m = eventHandlers rm hs1 = pendingHandlers rm- hs2 = F.foldl (><) Seq.empty $ + hs2 = F.foldl (><) Seq.empty $ fmap (\e -> M.findWithDefault Seq.empty e m) evs
src/Hails/MVC/Model/ReactiveModel/Events.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE DeriveDataTypeable #-}--- | This module contains all the events in our program. +-- | This module contains all the events in our program. -- -- FIXME: Because we want events to be comparable, we need to use the -- same datatype. It remains to be checked whether using an instance -- of Typeable and an existential type will be enough to have a good -- instance of Eq and therefore a heterogeneous model (wrt. events).--- +--+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.ReactiveModel.Events where
src/Hails/MVC/Model/ReactiveModel/Initialisation.hs view
@@ -1,6 +1,9 @@ -- | Contains only one operation to notify that the system's been -- initialised. --+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.ReactiveModel.Initialisation where import Hails.MVC.Model.ReactiveModel
src/Hails/MVC/Model/THAccessors.hs view
@@ -1,7 +1,10 @@ -- | This module uses Template Haskell to declare getters and setters -- for a given field and type that access the ProtectedModel in the -- IO Monad and the reactive model.-+--+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.THAccessors where -- External imports@@ -14,11 +17,11 @@ protectedModelAccessors fname ftype = sequenceQ -- Declare plain setter [ sigD setterName setterType- , funD setterName [clause [varP (mkName "pm"), varP (mkName "n")] + , funD setterName [clause [varP (mkName "pm"), varP (mkName "n")] (normalB (appE (appE (varE (mkName "applyToReactiveModel")) (varE (mkName "pm")) )- (infixE Nothing + (infixE Nothing (varE (mkName ("RM.set" ++ fname))) (Just (varE (mkName "n"))) )@@ -29,8 +32,8 @@ -- Declare plain getter , sigD getterName getterType , funD getterName [clause []- (normalB (infixE Nothing - (varE (mkName "onReactiveModel")) + (normalB (infixE Nothing+ (varE (mkName "onReactiveModel")) (Just (varE (mkName ("RM.get" ++ fname)))) ) )@@ -51,8 +54,8 @@ reactiveModelAccessors fname ftype = sequenceQ -- Declare plain setter [ sigD setterName setterType- , funD setterName - [clause + , funD setterName+ [clause -- Setter args: rm (reactive model), n (value) [varP (mkName "rm"), varP (mkName "n")] -- Main result: triggerEvent rm' ev@@ -68,7 +71,7 @@ (varE (mkName "onBasicModel")) (Just (lamE [varP (mkName "b")] (recUpdE (varE (mkName "b"))- [fieldExp + [fieldExp (mkName fnamelc) (varE (mkName "n")) ]@@ -83,13 +86,13 @@ (normalB (conE (mkName (fname ++ "Changed")))) [] ]- ] + ] -- Declare plain getter , sigD getterName getterType , funD getterName [clause [] -- recordField . basicModel (normalB (infixE (Just (varE (mkName fnamelc)))- (varE (mkName ".")) + (varE (mkName ".")) (Just (varE (mkName "basicModel"))) ) )@@ -103,14 +106,14 @@ rmTo = appT arrowT (conT (mkName "ReactiveModel")) typeToRM = appT (appT arrowT (conT (mkName ftype))) (conT (mkName "ReactiveModel")) fnamelc = lcFst fname- + -- | Creates a setter and a getter that works at ReactiveModel level. nonReactiveModelAccessors :: String -> Q Type -> Q [Dec] nonReactiveModelAccessors fname ftype = sequenceQ -- Declare plain setter [ sigD setterName setterType- , funD setterName - [clause + , funD setterName+ [clause -- Setter args: rm (reactive model), n (value) [varP (mkName "rm"), varP (mkName "n")] -- Main result: triggerEvent rm' ev@@ -121,7 +124,7 @@ (varE (mkName "onBasicModel")) (Just (lamE [varP (mkName "b")] (recUpdE (varE (mkName "b"))- [fieldExp + [fieldExp (mkName fnamelc) (varE (mkName "n")) ]@@ -132,13 +135,13 @@ ) [] ]- ] + ] -- Declare plain getter , sigD getterName getterType , funD getterName [clause [] -- recordField . basicModel (normalB (infixE (Just (varE (mkName fnamelc)))- (varE (mkName ".")) + (varE (mkName ".")) (Just (varE (mkName "basicModel"))) ) )@@ -153,6 +156,6 @@ typeToRM = appT (appT arrowT ftype) (conT (mkName "ReactiveModel")) fnamelc = lcFst fname -lcFst :: String -> String +lcFst :: String -> String lcFst [] = [] lcFst (x:xs) = (toLower x) : xs
src/Hails/MVC/Model/THFields.hs view
@@ -1,7 +1,10 @@ -- | This module uses Template Haskell to declare reactive fields for -- a given model field and type that access the ProtectedModel in -- the IO Monad and the reactive model.-+--+-- Copyright : (C) Keera Studios Ltd, 2013+-- License : BSD3+-- Maintainer : support@keera.co.uk module Hails.MVC.Model.THFields where -- External imports@@ -23,7 +26,7 @@ ) -- where []- ] + ] -- Declare plain getter , sigD getterName getterType , funD getterName [clause []@@ -37,11 +40,11 @@ -- Declare protected field , sigD fieldName fieldType , funD fieldName [clause []- (normalB + (normalB (recConE (mkName "ReactiveElement") [fieldExp (mkName "reEvents")- (listE [conE (mkName + (listE [conE (mkName ("RM." ++ fname ++ "Changed")) ] )@@ -49,12 +52,12 @@ (mkName "reSetter") (lamE [varP (mkName "pm") , varP (mkName "c")- ] - (infixE + ]+ (infixE (Just (varE (mkName "pm"))) (varE (mkName "applyToReactiveModel")) (Just (infixE Nothing- (varE (mkName + (varE (mkName ("RM." ++ "set" ++ fname) ) )@@ -64,7 +67,7 @@ ) ) , fieldExp (mkName "reGetter")- (infixE + (infixE Nothing (varE (mkName "onReactiveModel")) (Just (varE (mkName@@ -84,7 +87,7 @@ getterType = appT pmTo ioType fieldType = appT (appT- (appT (conT (mkName "ReactiveElement")) + (appT (conT (mkName "ReactiveElement")) ftype ) (conT (mkName pmodel))@@ -94,7 +97,7 @@ typeToIO = appT (appT arrowT ftype) ioNil ioNil = appT (conT (mkName "IO")) (conT (mkName "()")) ioType = appT (conT (mkName "IO")) ftype- + fnamelc = lcFst fname -- | Creates a setter and a getter that works at ReactiveModel level.@@ -110,7 +113,7 @@ ) -- where []- ] + ] -- Declare plain getter , sigD getterName getterType , funD getterName [clause []@@ -121,21 +124,21 @@ ) [] ]- -- Declare field with 4 elements + -- Declare field with 4 elements , sigD fieldName fieldType , funD fieldName [clause []- (normalB + (normalB (tupE [ varE (mkName fnamelc) -- function to read from model , varE (mkName "preTrue") -- precondition to update model , lamE [varP (mkName "v"), varP (mkName "b")] -- function to update model (recUpdE (varE (mkName "b"))- [fieldExp + [fieldExp (mkName fnamelc) (varE (mkName "v")) ] )- , (conE (mkName (fname ++ "Changed"))) -- Event to trigger when changed+ , conE (mkName (fname ++ "Changed")) -- Event to trigger when changed ] ) )@@ -149,10 +152,10 @@ getterType = appT rmTo ftype fieldType = appT (conT (mkName "Field")) ftype rmTo = appT arrowT (conT (mkName "ReactiveModel"))- typeToRM = appT (appT arrowT ftype) + typeToRM = appT (appT arrowT ftype) (conT (mkName "ReactiveModel")) fnamelc = lcFst fname -lcFst :: String -> String +lcFst :: String -> String lcFst [] = [] lcFst (x:xs) = (toLower x) : xs
+ tests/HLintMain.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main (hlint)+-- Copyright : (C) 2013 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+ args <- getArgs+ hints <- hlint $ ["src", "--cross", "--hint=tests/HLint.hs" ] ++ args+ unless (null hints) exitFailure
+ tests/HaddockCoverage.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main (HaddockCoverage)+-- Copyright : (C) 2015 Ivan Perez+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+-- 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", "--ignore-all-exports" ] ++ files+ let cabalArgs = [ "exec", "--", "haddock" ] ++ haddockArgs+ (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 = [ ]++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"] ""