Merge pull request #66 from quchen/haddock/crc32-haddockrender

Make haddockRender report file size and CRC32 (instead of filename)

Author: quchen

package.yaml

@@ -18,6 +18,7 @@ dependencies:
     - base >= 4.7 && < 5
 
     - alfred-margaret
+    - bytestring
     - cairo
     - colour
     - containers

src/Data/Crc32.hs

@@ -0,0 +1,61 @@
+module Data.Crc32 (
+      crc32
+    , Crc32(..)
+) where
+
+
+
+import           Data.Bits
+import           Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as BSL
+import           Data.Vector          (Vector, (!))
+import qualified Data.Vector          as V
+import           Data.Word
+import           Text.Printf
+
+
+
+table :: Vector Word32
+table = createCrc32Table 0xedb88320
+
+createCrc32Table :: Word32 -> Vector Word32
+createCrc32Table poly = V.generate 256 $ \n -> V.foldl'
+    (\acc _ -> if odd acc
+        then poly `xor` shiftR acc 1
+        else shiftR acc 1
+        )
+    (fromIntegral n)
+    (V.enumFromN 0 8)
+
+-- fn crc32_compute_table() -> [u32; 256] {
+--     let mut crc32_table = [0; 256];
+--
+--     for n in 0..256 {
+--         crc32_table[n as usize] = (0..8).fold(n as u32, |acc, _| {
+--             match acc & 1 {
+--                 1 => 0xedb88320 ^ (acc >> 1),
+--                 _ => acc >> 1,
+--             }
+--         });
+--     }
+--
+--     crc32_table
+-- }
+
+newtype Crc32 = Crc32 Word32
+    deriving (Eq, Ord)
+
+instance Show Crc32 where show (Crc32 crc) = printf "%#08x" crc
+
+-- | CRC32 checksum.
+--
+-- >>> import Data.ByteString.Lazy.Char8
+-- >>> crc32 (pack "The quick brown fox jumps over the lazy dog")
+-- 0x414fa339
+--
+-- >>> crc32 (pack "123456789")
+-- 0xcbf43926
+crc32 :: ByteString -> Crc32
+crc32 bs =
+    let Crc32 crcResult = BSL.foldl' (\(Crc32 crc) byte -> Crc32 (xor (crc `shiftR` 8) (table ! fromIntegral (fromIntegral (crc .&. 0xff) `xor` byte)))) (Crc32 0xffffffff) bs
+    in Crc32 (complement crcResult)

src/Draw.hs

@@ -60,15 +60,19 @@ module Draw (
 
 
 
-import Control.Monad
-import Data.Default.Class
-import Data.Foldable
-import Data.List
-import Graphics.Rendering.Cairo        as C hiding (x, y)
-import Graphics.Rendering.Cairo.Matrix (Matrix (..))
-import System.Directory
-import System.FilePath
-
+import           Control.Monad
+import qualified Data.ByteString.Lazy            as BSL
+import           Data.Default.Class
+import           Data.Foldable
+import           Data.Int
+import           Data.List
+import           Graphics.Rendering.Cairo        as C hiding (x, y)
+import           Graphics.Rendering.Cairo.Matrix (Matrix (..))
+import           System.Directory
+import           System.FilePath
+import           Text.Printf
+
+import Data.Crc32
 import Draw.Color
 import Draw.Color.Schemes.Continuous
 import Draw.Color.Schemes.Discrete
@@ -142,7 +146,7 @@ data CoordinateSystem
         --                       def {_arrowDrawBody=False})
         --         stroke
         -- :}
-        -- docs/haddock/Draw/coordinate_system_cairo_standard.svg
+        -- Generated file: size 2KB, crc32: 0x22a87e3e
 
     | MathStandard_ZeroBottomLeft_XRight_YUp Double
         -- ^ __Right-handed coordinate system.__ Standard math coordinates, with
@@ -168,7 +172,7 @@ data CoordinateSystem
         --                       def {_arrowDrawBody=False})
         --         stroke
         -- :}
-        -- docs/haddock/Draw/coordinate_system_math_standard.svg
+        -- Generated file: size 3KB, crc32: 0xd33a20ee
 
     | MathStandard_ZeroCenter_XRight_YUp Double Double
         -- ^ __Right-handed coordinate system.__ Standard math coordinates, with
@@ -194,7 +198,7 @@ data CoordinateSystem
         --                       def {_arrowDrawBody=False})
         --         stroke
         -- :}
-        -- docs/haddock/Draw/coordinate_system_math_standard_centered.svg
+        -- Generated file: size 3KB, crc32: 0xe6e10f11
 
     deriving (Eq, Ord, Show)
 
@@ -217,6 +221,10 @@ coordinateSystem cosy = do
 
 -- | Render pictures for Haddock with doctests. Nomenclature: the 'FilePath' for
 -- /Foo.Bar.Baz/ is /Foo\/Bar\/Baz\/pic_name.svg/.
+--
+-- Prints status information about the generated file so that doctests fail when
+-- the file contents change. Inspect the new output and update the output if the
+-- result is OK.
 haddockRender :: FilePath -> Int -> Int -> Render () -> IO ()
 haddockRender filename w h actions = do
     let filepath = "docs/haddock/" ++ filename
@@ -244,7 +252,7 @@ haddockRender filename w h actions = do
             haddockAxes (Vec2 5 5) 15
 
     normalizeSvgFile filepath
-    putStrLn filepath
+    haddockPrintInfo filepath
 
 haddockGrid :: Int -> Int -> Render ()
 haddockGrid w h = grouped (paintWithAlpha 0.1) $ do
@@ -296,6 +304,20 @@ haddockAxes start len = grouped (paintWithAlpha 0.5) $ do
                           | otherwise      = mirrorYCoords
         in G.transform (G.translate (start +. Vec2 0 (len+5)) <> G.scale 2 <> directionFlip) y'
 
+haddockPrintInfo :: FilePath -> IO ()
+haddockPrintInfo filepath = do
+    contents <- BSL.readFile filepath
+    printf "Generated file: size %s, crc32: %s" (humanFilesize (BSL.length contents)) (show (crc32 contents))
+
+humanFilesize :: Int64 -> String
+humanFilesize = go suffixes
+  where
+    go [] size = printf "Oh wow this file is %d byte large I ran out of suffixes" size
+    go (suffix:rest) size
+        | size < 1000 = show size ++ suffix
+        | otherwise = go rest (size `div` 1000)
+    suffixes = ["B", "KB", "MB", "GB", "TB", "PB"] -- That should suffice.
+
 -- | 'Vec2'-friendly version of Cairo’s 'moveTo'.
 moveToVec :: Vec2 -> Render ()
 moveToVec (Vec2 x y) = moveTo x y
@@ -314,7 +336,7 @@ lineToVec (Vec2 x y) = lineTo x y
 --     sketch (Bezier (Vec2 10 10) (Vec2 50 200) (Vec2 100 (-50)) (Vec2 140 90))
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Bezier.svg
+-- Generated file: size 2KB, crc32: 0xe17dab02
 instance Sketch Bezier where
     sketch (Bezier start (Vec2 x1 y1) (Vec2 x2 y2) (Vec2 x3 y3)) = do
         moveToVec start
@@ -365,7 +387,7 @@ data Arrow = Arrow !Line !ArrowSpec
 --     sketch (Arrow (Line (Vec2 10 10) (Vec2 140 90)) def)
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Arrow.svg
+-- Generated file: size 2KB, crc32: 0x2c724862
 instance Sketch Arrow where
     sketch (Arrow line ArrowSpec{..}) = do
         when _arrowDrawBody (sketch line)
@@ -426,7 +448,7 @@ instance Sketch a => Sketch (Maybe a) where
 --     sketch (Line (Vec2 10 10) (Vec2 140 90))
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Line.svg
+-- Generated file: size 2KB, crc32: 0x9287e4a8
 instance Sketch Line where
     sketch (Line start end) = do
         moveToVec start
@@ -443,7 +465,7 @@ instance Sketch Line where
 --     sketch (Polyline [Vec2 10 10, Vec2 90 90, Vec2 120 10, Vec2 140 50])
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Sequential_Vec2.svg
+-- Generated file: size 2KB, crc32: 0x5d5a0158
 instance Sketch Polyline where
     sketch (Polyline xs) = go xs
       where
@@ -462,7 +484,7 @@ instance Sketch Polyline where
 --     sketch (Polygon [Vec2 20 10, Vec2 10 80, Vec2 45 45, Vec2 60 90, Vec2 90 30])
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Polygon.svg
+-- Generated file: size 2KB, crc32: 0x7f620554
 instance Sketch Polygon where
     sketch (Polygon []) = pure ()
     sketch (Polygon xs) = sketch (Polyline xs) >> closePath
@@ -476,7 +498,7 @@ instance Sketch Polygon where
 --     sketch (Circle (Vec2 50 50) 45)
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Circle.svg
+-- Generated file: size 2KB, crc32: 0xebd35c6d
 instance Sketch Circle where
     sketch (Circle (Vec2 x y) r) = arc x y r 0 (2*pi)
 
@@ -491,7 +513,7 @@ instance Sketch Circle where
 --                         (toEllipse (Circle zero 45)))
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Ellipse.svg
+-- Generated file: size 2KB, crc32: 0x25bae2ef
 --
 instance Sketch Ellipse where
     sketch (Ellipse t) = cairoScope $ do
@@ -518,7 +540,7 @@ data Cross = Cross
 --     sketch (Cross  (Vec2 60 20) 15) >> stroke
 --     sketch (Circle (Vec2 60 20) 15) >> stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Cross.svg
+-- Generated file: size 2KB, crc32: 0xe2cb8567
 instance Sketch Cross where
     sketch (Cross center r) = do
         let lowerRight = G.transform (rotateAround center (deg 45)) (center +. Vec2 r 0)
@@ -540,7 +562,7 @@ instance Sketch Cross where
 --     setColor (mathematica97 1) >> sketch (G.translate (Vec2 110 50) <> G.rotate (deg 30)) >> stroke
 --     setColor (mathematica97 2) >> sketch (G.shear 0.5 0.2 <> G.translate (Vec2 140 0)) >> stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_Transformation.svg
+-- Generated file: size 4KB, crc32: 0x1f4ae5da
 instance Sketch Transformation where
     sketch t = do
         let grid = [Line (Vec2 0 y) (Vec2 100 y) | y <- map fromIntegral [0,20..100]]
@@ -579,7 +601,7 @@ arcSketchNegative (Vec2 x y) r angleStart angleEnd
 --     sketch (boundingBox geometry)
 --     stroke
 -- :}
--- docs/haddock/Draw/instance_Sketch_BoundingBox.svg
+-- Generated file: size 3KB, crc32: 0xfed2c044
 instance Sketch BoundingBox where
     sketch (BoundingBox (Vec2 xlo ylo) (Vec2 xhi yhi)) = do
         let w = xhi - xlo
@@ -622,7 +644,7 @@ instance Default CartesianParams where
 -- >>> :{
 -- haddockRender "Draw/cartesianCoordinateSystem.svg" 320 220 (cartesianCoordinateSystem def)
 -- :}
--- docs/haddock/Draw/cartesianCoordinateSystem.svg
+-- Generated file: size 21KB, crc32: 0xf43aac0c
 cartesianCoordinateSystem :: CartesianParams -> Render ()
 cartesianCoordinateSystem params@CartesianParams{..}  = grouped (paintWithAlpha _cartesianAlpha) $ do
     let vec2 x y = Vec2 (fromIntegral x) (fromIntegral y)
@@ -684,7 +706,7 @@ instance Default PolarParams where
 --     C.translate 50 50
 --     radialCoordinateSystem def
 -- :}
--- docs/haddock/Draw/radialCoordinateSystem.svg
+-- Generated file: size 26KB, crc32: 0x9b68b36
 radialCoordinateSystem :: PolarParams -> Render ()
 radialCoordinateSystem PolarParams{_polarCenter=center, _polarMaxRadius=maxR} = cairoScope $ do
     setLineWidth 1
@@ -749,7 +771,7 @@ withOperator op actions = do
 --     sketch line
 --     stroke
 -- :}
--- docs/haddock/Draw/cairoScope.svg
+-- Generated file: size 2KB, crc32: 0x2d7bee90
 --
 -- <<docs/haddock/Draw/cairoScope.svg>>
 cairoScope :: Render a -> Render a

src/Draw/Color.hs

@@ -50,7 +50,7 @@ class CairoColor color where
     --         sketch (Circle (Vec2 x 20) 10)
     --         C.fill
     -- :}
-    -- docs/haddock/Draw/Color/set_color.svg
+    -- Generated file: size 4KB, crc32: 0xe0e16234
     --
     -- <<docs/haddock/Draw/Color/set_color.svg>>
     setColor :: color -> C.Render ()

src/Draw/Plotting.hs

@@ -16,7 +16,7 @@
 --             for_ geometry $ \logoPart -> plot logoPart
 --     _plotPreview plotResult
 -- :}
--- docs/haddock/Draw/Plotting/example.svg
+-- Generated file: size 10KB, crc32: 0x1e175925
 module Draw.Plotting (
     -- * 'Plot' type
       Plot()

src/Draw/Text.hs

@@ -45,7 +45,7 @@ data HAlign = HLeft | HCenter | HRight deriving (Eq, Ord, Show)
 --     C.scale 3 3
 --     showTextAligned HCenter VCenter "Hello world!"
 -- :}
--- docs/haddock/Draw/Text/show_text_aligned.svg
+-- Generated file: size 8KB, crc32: 0xefcaecf4
 showTextAligned
     :: C.CairoString string
     => HAlign -- ^ Horizontal alignment
@@ -103,7 +103,7 @@ instance Default PlotTextOptions where
 --         glyphs = plotText opts "Hello world!"
 --     for_ glyphs $ \glyph -> sketch glyph >> stroke
 -- :}
--- docs/haddock/Draw/Text/plot_text.svg
+-- Generated file: size 7KB, crc32: 0xd253d9dd
 plotText :: PlotTextOptions -> String -> [Polyline]
 plotText options text = transform (translate (_textStartingPoint options) <> scaleToHeight <> halign <> valign) glyphs
   where

src/Geometry/Algorithms/Clipping.hs

@@ -35,7 +35,7 @@
 --         setColor (mathematica97 i)
 --         stroke
 -- :}
--- docs/haddock/Geometry/Algorithms/Clipping/complicated_intersection.svg
+-- Generated file: size 5KB, crc32: 0xd81cbd60
 module Geometry.Algorithms.Clipping (
       cutLineWithLine
     , CutLine(..)
@@ -85,7 +85,7 @@ import Geometry.Core
 --     sketch polygon
 --     stroke
 -- :}
--- docs/haddock/Geometry/Algorithms/Clipping/hatched_polygon.svg
+-- Generated file: size 2KB, crc32: 0x81dce6d7
 hatch
     :: Polygon
     -> Angle -- ^ Direction in which the lines will point. @'deg' 0@ is parallel to the x axis.

src/Geometry/Algorithms/Clipping/CohenSutherland.hs

@@ -46,7 +46,7 @@ import Util
 --         sketch (boundingBoxPolygon mask)
 --         C.stroke
 -- :}
--- docs/haddock/Geometry/Algorithms/Clipping/CohenSutherland/cohenSutherland.svg
+-- Generated file: size 22KB, crc32: 0xa5dc883f
 cohenSutherland :: BoundingBox -> Line -> Maybe Line
 cohenSutherland bb = \line -> let Line start end = line in loop line (outCode start) (outCode end)
   where

src/Geometry/Algorithms/Clipping/MargalitKnott.hs

@@ -320,7 +320,7 @@ margalitKnott op Regular (polygonA, polygonA_Type) (polygonB', polygonB_Type) =
 --         fill
 --     sketch (p1, p2) >> stroke
 -- :}
--- docs/haddock/Geometry/Algorithms/Clipping/MargalitKnott/union.svg
+-- Generated file: size 2KB, crc32: 0xcc4c9f5e
 unionPP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
 unionPP = ppBinop Union
 
@@ -342,7 +342,7 @@ unionPP = ppBinop Union
 --         fill
 --     sketch (p1, p2) >> stroke
 -- :}
--- docs/haddock/Geometry/Algorithms/Clipping/MargalitKnott/intersection.svg
+-- Generated file: size 2KB, crc32: 0xdaf13db5
 intersectionPP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
 intersectionPP = ppBinop Intersection
 
@@ -361,7 +361,7 @@ intersectionPP = ppBinop Intersection
 --         fill
 --     sketch (p1, p2) >> stroke
 -- :}
--- docs/haddock/Geometry/Algorithms/Clipping/MargalitKnott/difference.svg
+-- Generated file: size 2KB, crc32: 0x9388b325
 differencePP
     :: Polygon -- ^ A
     -> Polygon -- ^ B

src/Geometry/Algorithms/Clipping/SutherlandHodgman.hs

@@ -28,7 +28,7 @@ import Geometry.Core
 --     sketch subject >> setColor (mathematica97 1) >> stroke
 --     sketch scissors >> setColor (mathematica97 3) >> setDash [3,3] 0 >> stroke
 -- :}
--- docs/haddock/Geometry/Algorithms/Clipping/SutherlandHodgman/sutherland_hodgman.svg
+-- Generated file: size 2KB, crc32: 0x722cb97a
 sutherlandHodgman
     :: Polygon -- ^ Subject
     -> Polygon -- ^ __Convex__ scissors