-- Shake Generator for wiki pages
{-# LANGUAGE CPP #-}
module Main where
import Prelude hiding ((*>))
import Control.Concurrent
import Data.Char
import Data.List
import qualified Development.Shake as Shake
import Development.Shake hiding (doesFileExist)
import Development.Shake.FilePath
import System.Directory
import System.Environment
import System.IO
import System.Process
-- TO test: ghci wiki-suite/Draw_Canvas.hs -idist/build/autogen/:.:wiki-suite
import qualified Arc
import qualified Bezier_Curve
import qualified Bounce
import qualified Circle
import qualified Clipping_Region
import qualified Color_Fill
import qualified Color_Square
import qualified Custom_Shape
import qualified Draw_Canvas
import qualified Draw_Device
import qualified Draw_Image
import qualified Favicon
import qualified Font_Size_and_Style
import qualified Get_Image_Data_URL
import qualified Global_Alpha
import qualified Global_Composite_Operations
import qualified Grayscale
import qualified Image_Crop
import qualified Image_Loader
import qualified Image_Size
import qualified Is_Point_In_Path
import qualified Key_Read
import qualified Line
import qualified Line_Cap
import qualified Line_Color
import qualified Line_Join
import qualified Line_Width
import qualified Linear_Gradient
import qualified Load_Image_Data_URL
import qualified Load_Image_Data_URL_2
import qualified Miter_Limit
import qualified Path
import qualified Pattern
import qualified Quadratic_Curve
import qualified Radial_Gradient
import qualified Rectangle
import qualified Red_Line
import qualified Rotating_Square
import qualified Rounded_Corners
import qualified Semicircle
import qualified Shadow
import qualified Square
import qualified Text_Align
import qualified Text_Baseline
import qualified Text_Color
import qualified Text_Metrics
import qualified Text_Stroke
import qualified Text_Wrap
import qualified Tic_Tac_Toe
import qualified Translate_Transform
import qualified Scale_Transform
import qualified Rotate_Transform
import qualified Custom_Transform
import System.Environment
main :: IO ()
main = do
args <- getArgs
main2 args
main2 :: [String] -> IO ()
main2 ["Arc"] = Arc.main
main2 ["Bezier_Curve"] = Bezier_Curve.main
main2 ["Bounce"] = Bounce.main
main2 ["Circle"] = Circle.main
main2 ["Clipping_Region"] = Clipping_Region.main
main2 ["Color_Fill"] = Color_Fill.main
main2 ["Color_Square"] = Color_Square.main
main2 ["Custom_Shape"] = Custom_Shape.main
main2 ["Draw_Canvas"] = Draw_Canvas.main
main2 ["Draw_Device"] = Draw_Device.main
main2 ["Draw_Image"] = Draw_Image.main
main2 ["Favicon"] = Favicon.main
main2 ["Font_Size_and_Style"] = Font_Size_and_Style.main
main2 ["Get_Image_Data_URL"] = Get_Image_Data_URL.main
main2 ["Global_Alpha"] = Global_Alpha.main
main2 ["Global_Composite_Operations"] = Global_Composite_Operations.main
main2 ["Grayscale"] = Grayscale.main
main2 ["Image_Crop"] = Image_Crop.main
main2 ["Image_Loader"] = Image_Loader.main
main2 ["Miter_Limit"] = Miter_Limit.main
main2 ["Image_Size"] = Image_Size.main
main2 ["Is_Point_In_Path"] = Is_Point_In_Path.main
main2 ["Key_Read"] = Key_Read.main
main2 ["Line"] = Line.main
main2 ["Line_Cap"] = Line_Cap.main
main2 ["Line_Color"] = Line_Color.main
main2 ["Line_Join"] = Line_Join.main
main2 ["Line_Width"] = Line_Width.main
main2 ["Linear_Gradient"] = Linear_Gradient.main
main2 ["Load_Image_Data_URL"] = Load_Image_Data_URL.main
main2 ["Load_Image_Data_URL_2"] = Load_Image_Data_URL_2.main
main2 ["Path"] = Path.main
main2 ["Pattern"] = Pattern.main
main2 ["Quadratic_Curve"] = Quadratic_Curve.main
main2 ["Radial_Gradient"] = Radial_Gradient.main
main2 ["Rectangle"] = Rectangle.main
main2 ["Red_Line"] = Red_Line.main
main2 ["Rotating_Square"] = Rotating_Square.main
main2 ["Rounded_Corners"] = Rounded_Corners.main
main2 ["Semicircle"] = Semicircle.main
main2 ["Shadow"] = Shadow.main
main2 ["Square"] = Square.main
main2 ["Text_Align"] = Text_Align.main
main2 ["Text_Baseline"] = Text_Baseline.main
main2 ["Text_Color"] = Text_Color.main
main2 ["Text_Metrics"] = Text_Metrics.main
main2 ["Text_Stroke"] = Text_Stroke.main
main2 ["Text_Wrap"] = Text_Wrap.main
main2 ["Tic_Tac_Toe"] = Tic_Tac_Toe.main
main2 ["Translate_Transform"] = Translate_Transform.main
main2 ["Scale_Transform"] = Scale_Transform.main
main2 ["Rotate_Transform"] = Rotate_Transform.main
main2 ["Custom_Transform"] = Custom_Transform.main
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
want ["blank-canvas.wiki/images/" ++ nm ++ ".gif" | nm <- movies ]
want ["blank-canvas.wiki/images/" ++ nm ++ ".png" | nm <- examples ++ tutorial]
want ["blank-canvas.wiki/examples/" ++ nm ++ ".hs" | nm <- movies ++ examples ++ tutorial]
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
let nm = takeBaseName out
liftIO $ print (out,nm)
let tmp = "tmp"
liftIO $ createDirectoryIfMissing False tmp
liftIO $ removeFiles tmp [nm ++ "*.png"]
liftIO $ createDirectoryIfMissing False tmp
need [ "blank-canvas.wiki/" ++ toMinus nm ++ ".md" ]
let haskell_file = nm ++ ".hs"
need [ "wiki-suite/" ++ haskell_file, "blank-canvas.wiki/examples/" ++ haskell_file ]
liftIO $ print nm
txt <- readFile' $ "wiki-suite/" ++ haskell_file
let (w,h) = head $
[ case words ln of
[_,_,_,n] -> read n
_ -> (512,384)
| ln <- lines txt
, "import" `isPrefixOf` ln && "Wiki" `isInfixOf` ln
] ++ [(512,384) :: (Int, Int)]
sequence_ [
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"
["-a"
,"/Applications/Google Chrome.app"
,"http://localhost:3000/?height=" ++ show (h) ++ "&width=" ++ show (w) ++ hd]
#else
-- TODO: Figure out what Windows/MinTTY uses
command_ [] "/usr/bin/xdg-open" ["http://localhost:3000/?height=" ++ show (h) ++ "&width=" ++ show (w) ++ hd]
#endif
-- wait for haskell program to stop
liftIO $ waitForProcess ghc | hd <- [("")] ++ if nm == "Text_Wrap" then [("&hd")] else [] ]
return ()
"blank-canvas.wiki/examples/*.hs" %> \ out -> do
liftIO $ print out
let haskell_file = takeFileName out
txt <- readFile' $ "./wiki-suite/" ++ haskell_file
let new = reverse
$ dropWhile (all isSpace)
$ reverse
[ 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
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
hClose h
return txts
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"
liftIO $ print haskell_file
txt <- readFile' $ "blank-canvas.wiki/examples/" ++ haskell_file
let new = unlines $
[ t | t <- textToKeep
] ++
[code_header] ++
lines txt ++
[code_footer]
-- liftIO $ putStrLn new
writeFileChanged out new
-- to clean: rm images/*png images/*gif examples/*hs
-- */
movies :: [String]
movies = ["Rotating_Square","Tic_Tac_Toe","Bounce","Key_Read","Square"]
examples :: [String]
examples = ["Red_Line","Favicon"]
++ ["Color_Square"]
tutorial :: [String]
tutorial = ["Line", "Line_Width", "Line_Color", "Line_Cap","Miter_Limit"]
++ ["Arc","Quadratic_Curve","Bezier_Curve"]
++ ["Path","Line_Join","Rounded_Corners","Is_Point_In_Path"]
++ ["Custom_Shape","Rectangle","Circle","Semicircle"]
++ ["Color_Fill","Linear_Gradient","Radial_Gradient","Pattern"]
++ ["Draw_Image","Image_Size","Image_Crop","Image_Loader", "Draw_Canvas", "Draw_Device"]
++ ["Font_Size_and_Style","Text_Color","Text_Stroke","Text_Align","Text_Baseline","Text_Metrics","Text_Wrap"]
++ ["Translate_Transform","Scale_Transform","Rotate_Transform","Custom_Transform"]
++ ["Shadow","Global_Alpha","Clipping_Region","Global_Composite_Operations"]
++ ["Grayscale","Get_Image_Data_URL","Load_Image_Data_URL"]
++ ["Load_Image_Data_URL_2"]
wiki_dir :: String
wiki_dir = "."
toMinus :: String -> String
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
code_header :: String
code_header = "````Haskell"
code_footer :: String
code_footer = "````"