diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,6 @@ +## 0.7 +* Strengthen the `Monad` constraint on `readColourName` to `MonadFail`. + #### 0.6.3 * Use `base-compat-batteries`. diff --git a/Graphics/Blank/Canvas.hs b/Graphics/Blank/Canvas.hs --- a/Graphics/Blank/Canvas.hs +++ b/Graphics/Blank/Canvas.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -61,7 +62,9 @@ (<>) = liftM2 (<>) instance Monoid a => Monoid (Canvas a) where +#if !(MIN_VERSION_base(4,11,0)) mappend = liftM2 mappend +#endif mempty = return mempty -- HTML5 Canvas assignments: FillStyle, Font, GlobalAlpha, GlobalCompositeOperation, LineCap, LineJoin, LineWidth, MiterLimit, ShadowBlur, ShadowColor, ShadowOffsetX, ShadowOffsetY, StrokeStyle, TextAlign, TextBaseline diff --git a/Graphics/Blank/Style.hs b/Graphics/Blank/Style.hs --- a/Graphics/Blank/Style.hs +++ b/Graphics/Blank/Style.hs @@ -189,6 +189,8 @@ , rebeccapurple ) where +import qualified Control.Monad.Fail as Fail + import qualified Data.Colour as Colour import Data.Colour hiding (black, transparent) import qualified Data.Colour.Names as Names @@ -248,7 +250,7 @@ -- | -- Takes a string naming a 'Colour' (must be all lowercase) and returns it. Fails if -- the name is not recognized. -readColourName :: Monad m => String -> m (Colour Double) +readColourName :: Fail.MonadFail m => String -> m (Colour Double) readColourName "rebeccapurple" = return rebeccapurple readColourName name = Names.readColourName name diff --git a/blank-canvas.cabal b/blank-canvas.cabal --- a/blank-canvas.cabal +++ b/blank-canvas.cabal @@ -1,5 +1,5 @@ Name: blank-canvas -Version: 0.6.3 +Version: 0.7 Synopsis: HTML5 Canvas Graphics Library Description: @blank-canvas@ is a Haskell binding to the complete @@ -41,7 +41,13 @@ Extra-source-files: README.md Changelog.md Cabal-version: >= 1.10 -tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 +tested-with: GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.1 data-files: static/index.html static/jquery.js @@ -68,20 +74,21 @@ Paths_blank_canvas default-language: Haskell2010 - build-depends: aeson >= 0.7 && < 1.4, + build-depends: aeson >= 0.7 && < 1.5, base64-bytestring == 1.0.*, - base >= 4.7 && < 4.12, + base >= 4.7 && < 4.14, base-compat-batteries >= 0.10 && < 0.11, bytestring == 0.10.*, - colour >= 2.2 && < 3.0, - containers == 0.5.*, + colour >= 2.2 && < 2.4, + containers >= 0.5 && < 0.7, data-default-class >= 0.0.1 && < 0.2, + fail == 4.9.*, http-types >= 0.8 && < 0.13, mime-types >= 0.1.0.3 && < 0.2, kansas-comet >= 0.4 && < 0.5, scotty >= 0.10 && < 0.12, semigroups >= 0.18 && < 1, - stm >= 2.2 && < 2.5, + stm >= 2.2 && < 2.6, text >= 1.1 && < 1.3, text-show >= 2 && < 4, transformers >= 0.3 && < 0.6, @@ -95,17 +102,17 @@ test-suite wiki-suite - build-depends: base >= 4.7 && < 4.12, + build-depends: base >= 4.7 && < 4.14, base-compat-batteries >= 0.10 && < 0.11, blank-canvas, - containers == 0.5.*, + containers >= 0.5 && < 0.7, process >= 1.2 && < 1.7, directory >= 1.2, - shake >= 0.13, - stm >= 2.2 && < 2.5, + shake >= 0.14, + stm >= 2.2 && < 2.6, text >= 1.1 && < 1.3, - time >= 1.4 && < 1.9, - unix == 2.7.*, + time >= 1.4 && < 1.10, + unix >= 2.7 && < 2.8, vector >= 0.10 && < 0.13 default-language: Haskell2010 diff --git a/wiki-suite/Main.hs b/wiki-suite/Main.hs --- a/wiki-suite/Main.hs +++ b/wiki-suite/Main.hs @@ -76,8 +76,8 @@ import System.Environment main :: IO () -main = do - args <- getArgs +main = do + args <- getArgs main2 args main2 :: [String] -> IO () @@ -135,10 +135,10 @@ main2 ["Rotate_Transform"] = Rotate_Transform.main main2 ["Custom_Transform"] = Custom_Transform.main -main2 ["clean"] = do +main2 ["clean"] = do _ <- createProcess $ shell "rm blank-canvas.wiki/images/*.png blank-canvas.wiki/images/*.gif blank-canvas.wiki/examples/*.hs" return () - + main2 args = shakeArgs shakeOptions $ do if null args then do @@ -148,12 +148,12 @@ want ["blank-canvas.wiki/" ++ toMinus nm ++ ".md" | nm <- movies ++ examples ++ tutorial] else return () - ["blank-canvas.wiki/images/*.png", "blank-canvas.wiki/images/*.gif"] |*> \out -> do + ["blank-canvas.wiki/images/*.png", "blank-canvas.wiki/images/*.gif"] |%> \out -> do let nm = takeBaseName out - liftIO $ print (out,nm) + liftIO $ print (out,nm) - let tmp = "tmp" + let tmp = "tmp" liftIO $ createDirectoryIfMissing False tmp liftIO $ removeFiles tmp [nm ++ "*.png"] @@ -161,7 +161,7 @@ need [ "blank-canvas.wiki/" ++ toMinus nm ++ ".md" ] let haskell_file = nm ++ ".hs" - need [ "wiki-suite/" ++ haskell_file, "blank-canvas.wiki/examples/" ++ haskell_file ] + need [ "wiki-suite/" ++ haskell_file, "blank-canvas.wiki/examples/" ++ haskell_file ] liftIO $ print nm txt <- readFile' $ "wiki-suite/" ++ haskell_file @@ -170,20 +170,20 @@ [ case words ln of [_,_,_,n] -> read n _ -> (512,384) - | ln <- lines txt + | ln <- lines txt , "import" `isPrefixOf` ln && "Wiki" `isInfixOf` ln ] ++ [(512,384) :: (Int, Int)] sequence_ [ - do (_,_,_,ghc) <- liftIO $ + do (_,_,_,ghc) <- liftIO $ createProcess (proc "./dist/build/wiki-suite/wiki-suite" [nm]) -- wait a second, for things to start liftIO $ threadDelay (1 * 1000 * 1000) - + #if defined(darwin_HOST_OS) - command_ [] "/usr/bin/open" + command_ [] "/usr/bin/open" ["-a" ,"/Applications/Google Chrome.app" ,"http://localhost:3000/?height=" ++ show (h) ++ "&width=" ++ show (w) ++ hd] @@ -196,7 +196,7 @@ return () - "blank-canvas.wiki/examples/*.hs" *> \ out -> do + "blank-canvas.wiki/examples/*.hs" %> \ out -> do liftIO $ print out let haskell_file = takeFileName out @@ -205,47 +205,47 @@ let new = reverse $ dropWhile (all isSpace) $ reverse - [ if "module" `isPrefixOf` ln - then "module Main where" - else ln - | ln <- lines txt + [ if "module" `isPrefixOf` ln + then "module Main where" + else ln + | ln <- lines txt , not ("wiki $" `isInfixOf` ln) -- remove the wiki stuff , not ("import" `isPrefixOf` ln && "Wiki" `isInfixOf` ln) ] writeFileChanged out (unlines $ map (untabify 0) new) - "blank-canvas.wiki/*.md" *> \ out -> do + "blank-canvas.wiki/*.md" %> \ out -> do b <- Shake.doesFileExist out -- liftIO $ print b txts <- liftIO $ if b then do h <- openFile out ReadMode let loop = do - b' <- hIsEOF h - if b' - then return [] - else do - ln <- hGetLine h - lns <- loop - return (ln : lns) - txts <- loop + b' <- hIsEOF h + if b' + then return [] + else do + ln <- hGetLine h + lns <- loop + return (ln : lns) + txts <- loop hClose h return txts - else return [] + else return [] -- liftIO $ print txts let p = not . (code_header `isPrefixOf`) let textToKeep = takeWhile p txts - let haskell_file = map (\ c -> if c == '-' then '_' else c) - $ replaceExtension (takeFileName out) ".hs" + let haskell_file = map (\ c -> if c == '-' then '_' else c) + $ replaceExtension (takeFileName out) ".hs" liftIO $ print haskell_file - txt <- readFile' $ "blank-canvas.wiki/examples/" ++ haskell_file + txt <- readFile' $ "blank-canvas.wiki/examples/" ++ haskell_file let new = unlines $ - [ t | t <- textToKeep + [ t | t <- textToKeep ] ++ [code_header] ++ lines txt ++ @@ -264,7 +264,7 @@ examples :: [String] examples = ["Red_Line","Favicon"] - ++ ["Color_Square"] + ++ ["Color_Square"] tutorial :: [String] tutorial = ["Line", "Line_Width", "Line_Color", "Line_Cap","Miter_Limit"] @@ -283,13 +283,13 @@ wiki_dir = "." toMinus :: String -> String -toMinus = map (\ c -> if c == '_' then '-' else c) +toMinus = map (\ c -> if c == '_' then '-' else c) untabify :: Int -> String -> String untabify _ [] = [] untabify n (c:cs) | c == '\t' = let t = 8 - n `mod` 8 in take t (cycle " ") ++ untabify (n + t) cs - | otherwise = c : untabify (n + 1) cs + | otherwise = c : untabify (n + 1) cs code_header :: String code_header = "````Haskell"