Revision 7ddd8e4c

b/Makefile.am
14 14
space := $(empty) $(empty)
15 15
comma := ,
16 16

  
17
# Helper function to strip src/ and test/hs/ from a list
18
strip_hsroot = $(patsubst src/%,%,$(patsubst test/hs/%,%,$(1)))
19

  
17 20
# Use bash in order to be able to use pipefail
18 21
SHELL=/bin/bash
19 22

  
......
76 79
	test/hs/Test/Ganeti/HTools/Backend \
77 80
	test/hs/Test/Ganeti/Query
78 81

  
82
# Haskell directories without the roots (src, test/hs)
83
HS_DIRS_NOROOT = $(filter-out src,$(filter-out test/hs,$(HS_DIRS)))
84

  
79 85
DIRS = \
80 86
	$(HS_DIRS) \
81 87
	autotools \
......
114 120

  
115 121
ALL_APIDOC_HS_DIRS = \
116 122
	$(APIDOC_HS_DIR) \
117
	$(APIDOC_HS_DIR)/Ganeti \
118
	$(APIDOC_HS_DIR)/Ganeti/Block \
119
	$(APIDOC_HS_DIR)/Ganeti/Block/Drbd \
120
	$(APIDOC_HS_DIR)/Ganeti/Confd \
121
	$(APIDOC_HS_DIR)/Ganeti/DataCollectors \
122
	$(APIDOC_HS_DIR)/Ganeti/HTools \
123
	$(APIDOC_HS_DIR)/Ganeti/HTools/Backend \
124
	$(APIDOC_HS_DIR)/Ganeti/HTools/Program \
125
	$(APIDOC_HS_DIR)/Ganeti/Query
123
	$(patsubst %,$(APIDOC_HS_DIR)/%,$(call strip_hsroot,$(HS_DIRS_NOROOT)))
126 124

  
127 125
BUILDTIME_DIR_AUTOCREATE = \
128 126
	scripts \
......
590 588
	src/Ganeti/Version.hs
591 589
HS_BUILT_SRCS_IN = $(patsubst %,%.in,$(HS_BUILT_SRCS))
592 590

  
591
HS_LIBTESTBUILT_SRCS = $(HS_LIBTEST_SRCS) $(HS_BUILT_SRCS)
592

  
593 593
$(RUN_IN_TEMPDIR): | stamp-directories
594 594

  
595 595
doc/html/index.html: ENABLE_MANPAGES =
......
747 747
	done
748 748
endif
749 749

  
750
$(HS_ALL_PROGS): %: %.hs $(HS_LIBTEST_SRCS) $(HS_BUILT_SRCS) Makefile
750
$(HS_ALL_PROGS): %: %.hs $(HS_LIBTESTBUILT_SRCS) Makefile
751 751
	@if [ "$(notdir $@)" = "test" ] && [ "$(HS_NODEV)" ]; then \
752 752
	  echo "Error: cannot run unittests without the development" \
753 753
	       " libraries (see devnotes.rst)" 1>&2; \
......
1810 1810
	  --output $(CURDIR)/$(APIDOC_PY_DIR)
1811 1811

  
1812 1812
.PHONY: hs-apidoc
1813
hs-apidoc: $(HS_BUILT_SRCS)
1813
hs-apidoc: $(APIDOC_HS_DIR)/index.html
1814

  
1815
$(APIDOC_HS_DIR)/index.html: $(HS_LIBTESTBUILT_SRCS) Makefile
1814 1816
	@test -n "$(HSCOLOUR)" || \
1815 1817
	    { echo 'HsColour' not found during configure; exit 1; }
1816 1818
	@test -n "$(HADDOCK)" || \
......
1823 1825
	$(LN_S) ../hscolour.css $(APIDOC_HS_DIR)/Ganeti/HTools/hscolour.css
1824 1826
	$(LN_S) ../hscolour.css $(APIDOC_HS_DIR)/Ganeti/Confd/hscolour.css
1825 1827
	set -e ; \
1826
	cd src; \
1828
	export LC_ALL=en_US.UTF-8; \
1829
	OPTGHC="--optghc=-isrc --optghc=-itest/hs"; \
1827 1830
	if [ "$(HS_NOCURL)" ]; \
1828
	then OPTGHC="--optghc=$(HS_NOCURL)"; \
1829
	else OPTGHC=""; \
1831
	then OPTGHC="$$OPTGHC --optghc=$(HS_NOCURL)"; \
1830 1832
	fi; \
1831 1833
	if [ "$(HS_PARALLEL3)" ]; \
1832 1834
	then OPTGHC="$$OPTGHC --optghc=$(HS_PARALLEL3)"; \
......
1834 1836
	if [ "$(HS_REGEX_PCRE)" ]; \
1835 1837
	then OPTGHC="$$OPTGHC --optghc=$(HS_REGEX_PCRE)"; \
1836 1838
	fi; \
1837
	RELSRCS="$(HS_LIB_SRCS:src/%=%) $(patsubst src/%,%,$(filter src/%,$(HS_BUILT_SRCS)))"; \
1838
	for file in $$RELSRCS; do \
1839
	  hfile=`echo $$file|sed 's/\\.hs$$//'`.html; \
1840
	  $(HSCOLOUR) -css -anchor $$file > ../$(APIDOC_HS_DIR)/$$hfile ; \
1839
	for file in $(HS_LIBTESTBUILT_SRCS); do \
1840
	  f_nosrc=$${file##src/}; \
1841
	  f_notst=$${f_nosrc##test/hs/}; \
1842
	  f_html=$${f_notst%%.hs}.html; \
1843
	  $(HSCOLOUR) -css -anchor $$file > $(APIDOC_HS_DIR)/$$f_html ; \
1841 1844
	done ; \
1842
	$(HADDOCK) --odir ../$(APIDOC_HS_DIR) --html --ignore-all-exports -w \
1843
	  -t ganeti -p haddock-prologue \
1845
	$(HADDOCK) --odir $(APIDOC_HS_DIR) --html --ignore-all-exports -w \
1846
	  -t ganeti -p src/haddock-prologue \
1844 1847
	  --source-module="%{MODULE/.//}.html" \
1845 1848
	  --source-entity="%{MODULE/.//}.html#%{NAME}" \
1846 1849
	  $$OPTGHC \
1847
	  $(filter-out Ganeti/HTools/ExtLoader.hs,$(HS_LIB_SRCS:src/%=%))
1850
	  $(HS_LIBTESTBUILT_SRCS)
1848 1851

  
1849 1852
.PHONY: TAGS
1850 1853
TAGS: $(GENERATED_FILES)
b/test/hs/Test/Ganeti/BasicTypes.hs
7 7

  
8 8
{-
9 9

  
10
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
10
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
11 11

  
12 12
This program is free software; you can redistribute it and/or modify
13 13
it under the terms of the GNU General Public License as published by
......
56 56

  
57 57
-- * Test cases
58 58

  
59
-- | Tests the functor identity law (fmap id == id).
59
-- | Tests the functor identity law:
60
--
61
-- > fmap id == id
60 62
prop_functor_id :: Result Int -> Property
61 63
prop_functor_id ri =
62 64
  fmap id ri ==? ri
63 65

  
64
-- | Tests the functor composition law (fmap (f . g)  ==  fmap f . fmap g).
66
-- | Tests the functor composition law:
67
--
68
-- > fmap (f . g)  ==  fmap f . fmap g
65 69
prop_functor_composition :: Result Int
66 70
                         -> Fun Int Int -> Fun Int Int -> Property
67 71
prop_functor_composition ri (Fun _ f) (Fun _ g) =
68 72
  fmap (f . g) ri ==? (fmap f . fmap g) ri
69 73

  
70
-- | Tests the applicative identity law (pure id <*> v = v).
74
-- | Tests the applicative identity law:
75
--
76
-- > pure id <*> v = v
71 77
prop_applicative_identity :: Result Int -> Property
72 78
prop_applicative_identity v =
73 79
  pure id <*> v ==? v
74 80

  
75
-- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w
76
-- = u <*> (v <*> w)).
81
-- | Tests the applicative composition law:
82
--
83
-- > pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
77 84
prop_applicative_composition :: Result (Fun Int Int)
78 85
                             -> Result (Fun Int Int)
79 86
                             -> Result Int
......
83 90
      v' = fmap apply v
84 91
  in pure (.) <*> u' <*> v' <*> w ==? u' <*> (v' <*> w)
85 92

  
86
-- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)).
93
-- | Tests the applicative homomorphism law:
94
--
95
-- > pure f <*> pure x = pure (f x)
87 96
prop_applicative_homomorphism :: Fun Int Int -> Int -> Property
88 97
prop_applicative_homomorphism (Fun _ f) x =
89 98
  ((pure f <*> pure x)::Result Int) ==? pure (f x)
90 99

  
91
-- | Tests the applicative interchange law (u <*> pure y = pure ($ y) <*> u).
100
-- | Tests the applicative interchange law:
101
--
102
-- > u <*> pure y = pure ($ y) <*> u
92 103
prop_applicative_interchange :: Result (Fun Int Int)
93 104
                             -> Int -> Property
94 105
prop_applicative_interchange f y =
95 106
  let u = fmap apply f -- need to extract the actual function from Fun
96 107
  in u <*> pure y ==? pure ($ y) <*> u
97 108

  
98
-- | Tests the applicative\/functor correspondence (fmap f x = pure f <*> x).
109
-- | Tests the applicative\/functor correspondence:
110
--
111
-- > fmap f x = pure f <*> x
99 112
prop_applicative_functor :: Fun Int Int -> Result Int -> Property
100 113
prop_applicative_functor (Fun _ f) x =
101 114
  fmap f x ==? pure f <*> x
102 115

  
103
-- | Tests the applicative\/monad correspondence (pure = return and
104
-- (<*>) = ap).
116
-- | Tests the applicative\/monad correspondence:
117
--
118
-- > pure = return
119
--
120
-- > (<*>) = ap
105 121
prop_applicative_monad :: Int -> Result (Fun Int Int) -> Property
106 122
prop_applicative_monad v f =
107 123
  let v' = pure v :: Result Int
108 124
      f' = fmap apply f -- need to extract the actual function from Fun
109 125
  in v' ==? return v .&&. (f' <*> v') ==? f' `ap` v'
110 126

  
111
-- | Tests the monad laws (return a >>= k == k a, m >>= return == m, m
112
-- >>= (\x -> k x >>= h) == (m >>= k) >>= h).
127
-- | Tests the monad laws:
128
--
129
-- > return a >>= k == k a
130
--
131
-- > m >>= return == m
132
--
133
-- > m >>= (\x -> k x >>= h) == (m >>= k) >>= h
113 134
prop_monad_laws :: Int -> Result Int
114 135
                -> Fun Int (Result Int)
115 136
                -> Fun Int (Result Int)
......
122 143
    ((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))
123 144
  ]
124 145

  
125
-- | Tests the monad plus laws ( mzero >>= f = mzero, v >> mzero = mzero).
146
-- | Tests the monad plus laws:
147
--
148
-- > mzero >>= f = mzero
149
--
150
-- > v >> mzero = mzero
126 151
prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property
127 152
prop_monadplus_mzero v (Fun _ f) =
128 153
  printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.

Also available in: Unified diff