Skip to content

Commit

Permalink
Allow building with base-4.19.* (GHC 9.8), fix -Wx-partial warnings
Browse files Browse the repository at this point in the history 
GHC 9.8 adds `-Wx-partial` to `-Wall`, which triggers upon any use of the
`head` or `tail` function. This refactors the code slightly to avoid these
warnings.
  • Loading branch information
@RyanGlScott
RyanGlScott committed Aug 26, 2023
1 parent 182ac06 commit bc4d29b
Show file tree
Hide file tree
Showing 7 changed files with 48 additions and 34 deletions.
2 changes: 1 addition & 1 deletion blank-canvas.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -79,7 +79,7 @@ Library
default-language: Haskell2010
build-depends: aeson >= 1.4.4 && < 2.3,
base64-bytestring >= 1.0 && < 1.3,
base >= 4.9 && < 4.19,
base >= 4.9 && < 4.20,
base-compat-batteries >= 0.10 && < 0.14,
bytestring >= 0.10 && < 0.13,
colour >= 2.2 && < 2.4,
Expand Down
23 changes: 12 additions & 11 deletions examples/blank-canvas-examples.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,7 @@ executable blank-canvas-example-trivial
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
blank-canvas
hs-source-dirs: trivial
default-language: Haskell2010
Expand All @@ -58,7 +58,7 @@ executable blank-canvas-example-html5canvastutorial
buildable: False
main-is: Main.hs
other-modules: Paths_blank_canvas_examples
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
base-compat-batteries >= 0.10 && < 0.14,
blank-canvas,
text >= 1.1 && < 2.1
Expand All @@ -72,7 +72,7 @@ executable blank-canvas-example-keyread
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
base-compat-batteries >= 0.10 && < 0.14,
blank-canvas,
text >= 1.1 && < 2.1
Expand All @@ -86,7 +86,7 @@ executable blank-canvas-example-rotate-square
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
blank-canvas
hs-source-dirs: rotate-square
default-language: Haskell2010
Expand All @@ -98,7 +98,7 @@ executable blank-canvas-example-splat
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
blank-canvas
hs-source-dirs: splat
default-language: Haskell2010
Expand All @@ -110,7 +110,7 @@ executable blank-canvas-example-square
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
blank-canvas
hs-source-dirs: square
default-language: Haskell2010
Expand All @@ -122,7 +122,7 @@ executable blank-canvas-example-text
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
base-compat-batteries >= 0.10 && < 0.14,
blank-canvas,
text >= 1.1 && < 2.1
Expand All @@ -136,7 +136,7 @@ executable blank-canvas-example-tictactoe
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
blank-canvas,
containers >= 0.5 && < 0.7,
text >= 1.1 && < 2.1
Expand All @@ -151,8 +151,9 @@ executable blank-canvas-example-bounce
else
buildable: False
main-is: Main.hs
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
blank-canvas,
streams >= 0.1,
text >= 1.1 && < 2.1
hs-source-dirs: bounce
default-language: Haskell2010
Expand All @@ -165,7 +166,7 @@ executable blank-canvas-example-audio
buildable: False
main-is: Main.hs
other-modules: Paths_blank_canvas_examples
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
blank-canvas
hs-source-dirs: audio
default-language: Haskell2010
Expand All @@ -178,7 +179,7 @@ executable blank-canvas-example-cursor
buildable: False
main-is: Main.hs
other-modules: Paths_blank_canvas_examples
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
base-compat-batteries >= 0.10 && < 0.14,
blank-canvas,
keys >= 3.10,
Expand Down
16 changes: 10 additions & 6 deletions examples/bounce/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,9 @@
module Main where

import Control.Concurrent
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Stream.Infinite as Stream
import Data.Stream.Infinite (Stream)
import Data.Text (Text)
import Graphics.Blank

Expand Down Expand Up @@ -40,23 +43,24 @@ go context = do
| y + 25 >= h && d > 0 = ((x,y),-(d-0.5)*0.97,a)
| otherwise = ((x,y),d,a)

let loop (balls,cols) = do
let loop :: ([Ball Text], Stream Text) -> IO ()
loop (balls,cols) = do

send context $ do
clearCanvas
sequence_
[ showBall xy col
| (xy,_,col) <- balls
]
threadDelay (20 * 1000)
threadDelay (20 * 1000)

es <- flush context

let newBalls = [ ((x,y),0,head cols)
let newBalls = [ ((x,y),0,Stream.head cols)
| Just (x,y) <- map ePageXY es
]

loop (map bounce $ map moveBall $ balls ++ newBalls, tail cols)

loop (map bounce $ map moveBall $ balls ++ newBalls, Stream.tail cols)

loop ([((100,100),0,"blue")],cycle ["red","blue","green","orange","cyan"])

loop ([((100,100),0,"blue")],Stream.cycle ("red" :| ["blue","green","orange","cyan"]))
14 changes: 9 additions & 5 deletions wiki-suite/Bounce.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,9 @@ module Bounce where

import Control.Concurrent
import Control.Monad -- wiki $
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Stream.Infinite as Stream
import Data.Stream.Infinite (Stream)
import Data.Text (Text)
import Graphics.Blank
import Wiki -- (512,384)
Expand Down Expand Up @@ -38,15 +41,16 @@ go context = do
| y + 25 >= height context && d > 0 = ((x,y),-(d-0.5)*0.97,a)
| otherwise = ((x,y),d,a)

let loop (balls,cols) = do
let loop :: ([Ball Text], Stream Text) -> IO ()
loop (balls,cols) = do

send context $ do
clearCanvas
sequence_
[ showBall xy col
| (xy,_,col) <- balls
]
threadDelay (20 * 1000)
threadDelay (20 * 1000)

wiki $ counter (\ _ -> True) $ \ n -> do
file <- wiki $ anim_png "Bounce"
Expand All @@ -57,11 +61,11 @@ go context = do
es <- flush context
if (null es) then return () else print es

let newBalls = [ ((x,y),0,head cols)
let newBalls = [ ((x,y),0,Stream.head cols)
| Just (x,y) <- map ePageXY es
]

loop (map bounce $ map moveBall $ balls ++ newBalls, tail cols)
loop (map bounce $ map moveBall $ balls ++ newBalls, Stream.tail cols)


loop ([((100,100),0,"blue")],cycle ["red","blue","green","orange","cyan"])
loop ([((100,100),0,"blue")],Stream.cycle ("red" :| ["blue","green","orange","cyan"]))
9 changes: 5 additions & 4 deletions wiki-suite/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -73,8 +73,6 @@ import qualified Scale_Transform
import qualified Rotate_Transform
import qualified Custom_Transform

import System.Environment

main :: IO ()
main = do
args <- getArgs
Expand Down Expand Up @@ -166,14 +164,17 @@ main2 args = shakeArgs shakeOptions $ do

txt <- Shake.readFile' $ "wiki-suite/" ++ haskell_file

let (w,h) = head $
let whLines =
[ case words ln of
[_,_,_,n] -> read n
_ -> (512,384)
| ln <- lines txt
, "import" `L.isPrefixOf` ln && "Wiki" `L.isInfixOf` ln
] ++ [(512,384) :: (Int, Int)]

let (w,h) =
case whLines of
whLine:_ -> whLine
[] -> error $ "No width/height found in " ++ haskell_file

sequence_ [
do (_,_,_,ghc) <- liftIO $
Expand Down
15 changes: 9 additions & 6 deletions wiki-suite/Tic_Tac_Toe.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -56,17 +56,20 @@ loop context board turn = do
y' <- fd ((y - height context / 2) / sz)
return (x',y')

fd x =
fd x =
-- trace (show ("fx",x,r)) $
if r `elem` [-1..1] then Just (signum r) else Nothing
where r = round (x * 3.3333)

let press = (width context / 2 + fromIntegral x * (sz / 4),height context / 2 + fromIntegral y * (sz / 4)) -- wiki $
where (x,y) = head [ ix | (ix,Nothing) -- wiki $
<- [ ((x',y'),Map.lookup (x',y') board) -- wiki $
| y' <- [-1,0,1] -- wiki $
, x' <- [-1,0,1] -- wiki $
]] -- wiki $
where xys = [ ix | (ix,Nothing) -- wiki $
<- [ ((x',y'),Map.lookup (x',y') board) -- wiki $
| y' <- [-1,0,1] -- wiki $
, x' <- [-1,0,1] -- wiki $
]] -- wiki $
(x,y) = case xys of -- wiki $
xy:_ -> xy -- wiki $
[] -> error "Impossible: Already cleared board" -- wiki $

_ <- wiki $ forkIO $ send context $ trigger $ Event {
eMetaKey = False
Expand Down
3 changes: 2 additions & 1 deletion wiki-suite/wiki-suite.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,14 +22,15 @@ data-files: images/Haskell.jpg
images/House.jpg

executable wiki-suite
build-depends: base >= 4.9 && < 4.19,
build-depends: base >= 4.9 && < 4.20,
base-compat-batteries >= 0.10 && < 0.14,
blank-canvas,
containers >= 0.5 && < 0.7,
process >= 1.2 && < 1.7,
directory >= 1.2,
shake >= 0.14,
stm >= 2.2 && < 2.6,
streams >= 0.1,
text >= 1.1 && < 2.1,
time >= 1.4 && < 1.13,
unix >= 2.7 && < 2.9,
Expand Down

0 comments on commit bc4d29b

Please sign in to comment.