From 7ddd8e4cb911e62f72c0505a0f21c0e13b2a2d35 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Tue, 5 Mar 2013 14:07:50 +0100
Subject: [PATCH] Expand Haddock to run over test files as well

This patch does multiple enhancements to the way we build the Haddock
docs, motivated by the fact that if we don't run Haddock over test
files as well, bad formatting can be submitted and will accumulate
over time (without any checks).

The patch does:

- replace manual built ALL_APIDOC_HS_DIRS with automatically built one
  (from HS_DIRS)
- change Haddock so that it runs from the top directory (instead of
  from src/)
- change HsColour target file to be built via bash parameter
  substitution, rather than sed (I don't know how to do it in one go,
  so I use 2 intermediate variables)
- change 'hs-apidoc' target so that it depends on the real target
  file; in case no source file has been modified, running 'make
  hs-apidoc' twice will not result in two runs
- run HsColour/Haddock under en_US.UTF-8 locale, otherwise they can't
  parse correctly the Unicode chars in the test files

Additionally, wrong formatting (oops) in a test file has been
corrected.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Michele Tartara <mtartara@google.com>
---
 Makefile.am                       | 45 ++++++++++++++------------
 test/hs/Test/Ganeti/BasicTypes.hs | 53 +++++++++++++++++++++++--------
 2 files changed, 63 insertions(+), 35 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 5831bb92d..9df18b4e8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -14,6 +14,9 @@ empty :=
 space := $(empty) $(empty)
 comma := ,
 
+# Helper function to strip src/ and test/hs/ from a list
+strip_hsroot = $(patsubst src/%,%,$(patsubst test/hs/%,%,$(1)))
+
 # Use bash in order to be able to use pipefail
 SHELL=/bin/bash
 
@@ -76,6 +79,9 @@ HS_DIRS = \
 	test/hs/Test/Ganeti/HTools/Backend \
 	test/hs/Test/Ganeti/Query
 
+# Haskell directories without the roots (src, test/hs)
+HS_DIRS_NOROOT = $(filter-out src,$(filter-out test/hs,$(HS_DIRS)))
+
 DIRS = \
 	$(HS_DIRS) \
 	autotools \
@@ -114,15 +120,7 @@ DIRS = \
 
 ALL_APIDOC_HS_DIRS = \
 	$(APIDOC_HS_DIR) \
-	$(APIDOC_HS_DIR)/Ganeti \
-	$(APIDOC_HS_DIR)/Ganeti/Block \
-	$(APIDOC_HS_DIR)/Ganeti/Block/Drbd \
-	$(APIDOC_HS_DIR)/Ganeti/Confd \
-	$(APIDOC_HS_DIR)/Ganeti/DataCollectors \
-	$(APIDOC_HS_DIR)/Ganeti/HTools \
-	$(APIDOC_HS_DIR)/Ganeti/HTools/Backend \
-	$(APIDOC_HS_DIR)/Ganeti/HTools/Program \
-	$(APIDOC_HS_DIR)/Ganeti/Query
+	$(patsubst %,$(APIDOC_HS_DIR)/%,$(call strip_hsroot,$(HS_DIRS_NOROOT)))
 
 BUILDTIME_DIR_AUTOCREATE = \
 	scripts \
@@ -590,6 +588,8 @@ HS_BUILT_SRCS = \
 	src/Ganeti/Version.hs
 HS_BUILT_SRCS_IN = $(patsubst %,%.in,$(HS_BUILT_SRCS))
 
+HS_LIBTESTBUILT_SRCS = $(HS_LIBTEST_SRCS) $(HS_BUILT_SRCS)
+
 $(RUN_IN_TEMPDIR): | stamp-directories
 
 doc/html/index.html: ENABLE_MANPAGES =
@@ -747,7 +747,7 @@ install-exec-hook:
 	done
 endif
 
-$(HS_ALL_PROGS): %: %.hs $(HS_LIBTEST_SRCS) $(HS_BUILT_SRCS) Makefile
+$(HS_ALL_PROGS): %: %.hs $(HS_LIBTESTBUILT_SRCS) Makefile
 	@if [ "$(notdir $@)" = "test" ] && [ "$(HS_NODEV)" ]; then \
 	  echo "Error: cannot run unittests without the development" \
 	       " libraries (see devnotes.rst)" 1>&2; \
@@ -1810,7 +1810,9 @@ py-apidoc: epydoc.conf $(RUN_IN_TEMPDIR) $(GENERATED_FILES)
 	  --output $(CURDIR)/$(APIDOC_PY_DIR)
 
 .PHONY: hs-apidoc
-hs-apidoc: $(HS_BUILT_SRCS)
+hs-apidoc: $(APIDOC_HS_DIR)/index.html
+
+$(APIDOC_HS_DIR)/index.html: $(HS_LIBTESTBUILT_SRCS) Makefile
 	@test -n "$(HSCOLOUR)" || \
 	    { echo 'HsColour' not found during configure; exit 1; }
 	@test -n "$(HADDOCK)" || \
@@ -1823,10 +1825,10 @@ hs-apidoc: $(HS_BUILT_SRCS)
 	$(LN_S) ../hscolour.css $(APIDOC_HS_DIR)/Ganeti/HTools/hscolour.css
 	$(LN_S) ../hscolour.css $(APIDOC_HS_DIR)/Ganeti/Confd/hscolour.css
 	set -e ; \
-	cd src; \
+	export LC_ALL=en_US.UTF-8; \
+	OPTGHC="--optghc=-isrc --optghc=-itest/hs"; \
 	if [ "$(HS_NOCURL)" ]; \
-	then OPTGHC="--optghc=$(HS_NOCURL)"; \
-	else OPTGHC=""; \
+	then OPTGHC="$$OPTGHC --optghc=$(HS_NOCURL)"; \
 	fi; \
 	if [ "$(HS_PARALLEL3)" ]; \
 	then OPTGHC="$$OPTGHC --optghc=$(HS_PARALLEL3)"; \
@@ -1834,17 +1836,18 @@ hs-apidoc: $(HS_BUILT_SRCS)
 	if [ "$(HS_REGEX_PCRE)" ]; \
 	then OPTGHC="$$OPTGHC --optghc=$(HS_REGEX_PCRE)"; \
 	fi; \
-	RELSRCS="$(HS_LIB_SRCS:src/%=%) $(patsubst src/%,%,$(filter src/%,$(HS_BUILT_SRCS)))"; \
-	for file in $$RELSRCS; do \
-	  hfile=`echo $$file|sed 's/\\.hs$$//'`.html; \
-	  $(HSCOLOUR) -css -anchor $$file > ../$(APIDOC_HS_DIR)/$$hfile ; \
+	for file in $(HS_LIBTESTBUILT_SRCS); do \
+	  f_nosrc=$${file##src/}; \
+	  f_notst=$${f_nosrc##test/hs/}; \
+	  f_html=$${f_notst%%.hs}.html; \
+	  $(HSCOLOUR) -css -anchor $$file > $(APIDOC_HS_DIR)/$$f_html ; \
 	done ; \
-	$(HADDOCK) --odir ../$(APIDOC_HS_DIR) --html --ignore-all-exports -w \
-	  -t ganeti -p haddock-prologue \
+	$(HADDOCK) --odir $(APIDOC_HS_DIR) --html --ignore-all-exports -w \
+	  -t ganeti -p src/haddock-prologue \
 	  --source-module="%{MODULE/.//}.html" \
 	  --source-entity="%{MODULE/.//}.html#%{NAME}" \
 	  $$OPTGHC \
-	  $(filter-out Ganeti/HTools/ExtLoader.hs,$(HS_LIB_SRCS:src/%=%))
+	  $(HS_LIBTESTBUILT_SRCS)
 
 .PHONY: TAGS
 TAGS: $(GENERATED_FILES)
diff --git a/test/hs/Test/Ganeti/BasicTypes.hs b/test/hs/Test/Ganeti/BasicTypes.hs
index a74bc299c..d365ab077 100644
--- a/test/hs/Test/Ganeti/BasicTypes.hs
+++ b/test/hs/Test/Ganeti/BasicTypes.hs
@@ -7,7 +7,7 @@
 
 {-
 
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -56,24 +56,31 @@ instance (Arbitrary a) => Arbitrary (Result a) where
 
 -- * Test cases
 
--- | Tests the functor identity law (fmap id == id).
+-- | Tests the functor identity law:
+--
+-- > fmap id == id
 prop_functor_id :: Result Int -> Property
 prop_functor_id ri =
   fmap id ri ==? ri
 
--- | Tests the functor composition law (fmap (f . g)  ==  fmap f . fmap g).
+-- | Tests the functor composition law:
+--
+-- > fmap (f . g)  ==  fmap f . fmap g
 prop_functor_composition :: Result Int
                          -> Fun Int Int -> Fun Int Int -> Property
 prop_functor_composition ri (Fun _ f) (Fun _ g) =
   fmap (f . g) ri ==? (fmap f . fmap g) ri
 
--- | Tests the applicative identity law (pure id <*> v = v).
+-- | Tests the applicative identity law:
+--
+-- > pure id <*> v = v
 prop_applicative_identity :: Result Int -> Property
 prop_applicative_identity v =
   pure id <*> v ==? v
 
--- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w
--- = u <*> (v <*> w)).
+-- | Tests the applicative composition law:
+--
+-- > pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
 prop_applicative_composition :: Result (Fun Int Int)
                              -> Result (Fun Int Int)
                              -> Result Int
@@ -83,33 +90,47 @@ prop_applicative_composition u v w =
       v' = fmap apply v
   in pure (.) <*> u' <*> v' <*> w ==? u' <*> (v' <*> w)
 
--- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)).
+-- | Tests the applicative homomorphism law:
+--
+-- > pure f <*> pure x = pure (f x)
 prop_applicative_homomorphism :: Fun Int Int -> Int -> Property
 prop_applicative_homomorphism (Fun _ f) x =
   ((pure f <*> pure x)::Result Int) ==? pure (f x)
 
--- | Tests the applicative interchange law (u <*> pure y = pure ($ y) <*> u).
+-- | Tests the applicative interchange law:
+--
+-- > u <*> pure y = pure ($ y) <*> u
 prop_applicative_interchange :: Result (Fun Int Int)
                              -> Int -> Property
 prop_applicative_interchange f y =
   let u = fmap apply f -- need to extract the actual function from Fun
   in u <*> pure y ==? pure ($ y) <*> u
 
--- | Tests the applicative\/functor correspondence (fmap f x = pure f <*> x).
+-- | Tests the applicative\/functor correspondence:
+--
+-- > fmap f x = pure f <*> x
 prop_applicative_functor :: Fun Int Int -> Result Int -> Property
 prop_applicative_functor (Fun _ f) x =
   fmap f x ==? pure f <*> x
 
--- | Tests the applicative\/monad correspondence (pure = return and
--- (<*>) = ap).
+-- | Tests the applicative\/monad correspondence:
+--
+-- > pure = return
+--
+-- > (<*>) = ap
 prop_applicative_monad :: Int -> Result (Fun Int Int) -> Property
 prop_applicative_monad v f =
   let v' = pure v :: Result Int
       f' = fmap apply f -- need to extract the actual function from Fun
   in v' ==? return v .&&. (f' <*> v') ==? f' `ap` v'
 
--- | Tests the monad laws (return a >>= k == k a, m >>= return == m, m
--- >>= (\x -> k x >>= h) == (m >>= k) >>= h).
+-- | Tests the monad laws:
+--
+-- > return a >>= k == k a
+--
+-- > m >>= return == m
+--
+-- > m >>= (\x -> k x >>= h) == (m >>= k) >>= h
 prop_monad_laws :: Int -> Result Int
                 -> Fun Int (Result Int)
                 -> Fun Int (Result Int)
@@ -122,7 +143,11 @@ prop_monad_laws a m (Fun _ k) (Fun _ h) =
     ((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))
   ]
 
--- | Tests the monad plus laws ( mzero >>= f = mzero, v >> mzero = mzero).
+-- | Tests the monad plus laws:
+--
+-- > mzero >>= f = mzero
+--
+-- > v >> mzero = mzero
 prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property
 prop_monadplus_mzero v (Fun _ f) =
   printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.
-- 
GitLab