neil (empty) → 0.0
raw patch · 39 files changed
+2432/−0 lines, 39 filesdep +GoogleChartdep +basedep +cmdargssetup-changed
Dependencies added: GoogleChart, base, cmdargs, containers, directory, extra, filepath, json, old-time, process, time
Files
- CHANGES.txt +8/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- neil.cabal +80/−0
- src/Arguments.hs +49/−0
- src/Cabal.hs +192/−0
- src/Git.hs +69/−0
- src/Main.hs +34/−0
- src/Neil.hs +26/−0
- src/Paper/Ftp.hs +63/−0
- src/Paper/Graph.hs +91/−0
- src/Paper/Haskell.hs +45/−0
- src/Paper/Haskell/Check.hs +116/−0
- src/Paper/Haskell/Fragment.hs +19/−0
- src/Paper/Haskell/Haskell/Provides.hs +91/−0
- src/Paper/Haskell/Haskell/Tweak.hs +17/−0
- src/Paper/Haskell/Latex/Parser.hs +46/−0
- src/Paper/Haskell2/All.hs +24/−0
- src/Paper/Haskell2/Haskell.hs +109/−0
- src/Paper/Haskell2/Stage1.hs +119/−0
- src/Paper/Haskell2/Stage2.hs +42/−0
- src/Paper/Haskell2/Stage3.hs +86/−0
- src/Paper/Haskell2/Type.hs +66/−0
- src/Paper/LatexError.hs +89/−0
- src/Paper/Main.hs +159/−0
- src/Paper/Make.hs +96/−0
- src/Paper/Push.hs +33/−0
- src/Paper/Ref.hs +50/−0
- src/Paper/Sync.hs +35/−0
- src/Paper/Talk.hs +175/−0
- src/Paper/Todo.hs +31/−0
- src/Paper/Util/CmdNumber.hs +18/−0
- src/Paper/Util/Error.hs +20/−0
- src/Paper/Util/FileData.hs +83/−0
- src/Paper/Util/IO.hs +11/−0
- src/Paper/Util/String.hs +30/−0
- src/Paper/WordCount.hs +55/−0
- src/Travis.hs +89/−0
- src/Util.hs +34/−0
+ CHANGES.txt view
@@ -0,0 +1,8 @@+Changelog for Neil++2012.10.29+ Baby+2009.9.19+ Married+1981.12.7+ Born
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Neil Mitchell 2010-2014+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of its contributors may not be used to endorse or + promote products derived from this software without specific prior + written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ neil.cabal view
@@ -0,0 +1,80 @@+cabal-version: >= 1.6+build-type: Simple+name: neil+version: 0.0+license: BSD3+license-file: LICENSE+category: Development+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2010-2014+synopsis: General tools for Neil+description:+ General tools for Neil.+homepage: http://community.haskell.org/~ndm/+bug-reports: https://github.com/ndmitchell/neil/issues+tested-with: GHC==7.8.2, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2+extra-source-files:+ CHANGES.txt++source-repository head+ type: git+ location: https://github.com/ndmitchell/neil.git++library+ hs-source-dirs: src+ build-depends: base == 4.*, filepath, directory, time, process, extra++ exposed-modules:+ Neil+ other-modules:+ Util++flag small+ default: False+ description: Minimise dependencies++executable neil+ hs-source-dirs: src+ build-depends: containers, cmdargs+ if flag(small)+ cpp-options: -DSMALL+ else+ build-depends: json, GoogleChart, old-time++ main-is: Main.hs++ other-modules:+ Paper.LatexError+ Paper.Haskell.Latex.Parser+ Paper.Haskell.Haskell.Provides+ Paper.Haskell.Haskell.Tweak+ Paper.Haskell.Fragment+ Paper.Haskell.Check+ Paper.Util.String+ Paper.Util.CmdNumber+ Paper.Haskell2.Haskell+ Paper.Haskell2.Type+ Paper.Haskell2.Stage3+ Paper.Haskell2.Stage2+ Paper.Util.IO+ Paper.Util.Error+ Paper.Haskell2.Stage1+ Paper.Todo+ Paper.Ref+ Paper.Ftp+ Paper.Sync+ Paper.Push+ Paper.Haskell2.All+ Paper.WordCount+ Paper.Talk+ Paper.Make+ Paper.Graph+ Paper.Util.FileData+ Paper.Haskell+ Paper.Main+ Arguments+ Util+ Cabal+ Git+ Travis
+ src/Arguments.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Arguments where++import System.Console.CmdArgs++data Arguments+ -- darcs stuff+ = Whatsnew {repo :: FilePath, delete_locks :: Bool, local :: Bool, look_for_adds :: Bool, ssh :: Bool}+ | Pull {repo :: FilePath, delete_locks :: Bool}+ | Push {repo :: FilePath, ssh :: Bool}+ | Send {repo :: FilePath, patch :: FilePath}+ | Apply {patch :: FilePath}+ | Tag+ | Docs {username :: String}++ | Travis {wait :: Double}+ + -- cabal stuff+ | Sdist+ | Check+ | Test {install :: Bool}+ deriving (Data,Typeable,Show)++arguments = cmdArgsMode $ modes+ [Whatsnew {repo = "." &= typDir &= help "Repo to use"+ ,delete_locks = False &= help "Delete lock files"+ ,local = False &= help "Only check for local changes, no network required"+ ,look_for_adds = False &= name "l" &= help "Look for files to add"+ ,ssh = False &= help "SSH connections only, for if the http is down"}+ &= help "See what has changed (local and remote changes)"+ ,Pull {}+ &= help "Pull from the default locations"+ ,Push {}+ &= help "Push to the calculated SSH location"+ ,Send {patch="patches.tar" &= typFile &= help "Location for patches"}+ &= help "Send patches as a tarball"+ ,Apply {}+ &= help "Apply a patch tarball"+ ,Sdist {}+ &= help "Create a cabal sdist with extra checks"+ ,Tag {} &= help "Tag the repo, after a release"+ ,Check+ ,Docs {username = "NeilMitchell"}+ ,Travis {wait = 0 &= help "Time to wait after each wget request"}+ ,Test {install = False &= help "Install after building"}+ ]+ &= summary "Neil's utility tool"
+ src/Cabal.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE RecordWildCards, PatternGuards, ViewPatterns #-}++module Cabal(run, readCabal) where++import Control.Monad.Extra+import Data.Char+import Data.List.Extra+import Data.Maybe+import Data.Functor+import System.Directory.Extra+import System.IO.Extra+import System.FilePath+import Util+import Arguments++defAllow = ["7.0.4","7.2.2","7.4.2","7.6.3","7.8.2"]+++---------------------------------------------------------------------+-- COMMANDS+++-- | Check the .cabal file is well formed+cabalCheck :: IO ()+cabalCheck = do+ res <- cmdCode "cabal check"+ checkCabalFile+ checkReadme+ let require = ":set -fwarn-unused-binds -fwarn-unused-imports"+ src <- readFile' ".ghci"+ when (require `notElem` lines src) $+ error $ "The .ghci file does not contain " ++ require++-- | Run some commands in a temporary directory with the unpacked cabal+withSDist :: IO a -> IO a+withSDist run = withTempDir $ \tdir -> do+ cmd $ "cabal configure --builddir=" ++ tdir+ cmd $ "cabal sdist --builddir=" ++ tdir+ files <- getDirectoryContents tdir+ let tarball = head $ [x | x <- files, ".tar.gz" `isSuffixOf` x]+ withCurrentDirectory tdir $ cmd $ "tar -xf " ++ tarball+ lst <- getDirectoryContentsRecursive tdir+ let binary = [".png",".gz",".bat",".zip",".gif",""]+ bad <- flip filterM lst $ \file ->+ return (takeExtension file `notElem` binary) &&^+ fmap ('\r' `elem`) (readFileBinary' file)+ when (bad /= []) $ do+ error $ unlines $ "The following files have \\r characters in, Windows newlines?" : bad+ withCurrentDirectory (tdir </> dropExtension (dropExtension $ takeFileName tarball)) run+++run :: Arguments -> Maybe (IO ())+run Test{..} = Just $ do+ cabalCheck+ withSDist $ do+ cmd "cabal install --only-dependencies"+ cmd $ "cabal configure --enable-tests --disable-library-profiling " +++ "--ghc-option=-fwarn-unused-binds --ghc-option=-fwarn-unused-imports " +++ "--ghc-option=-Werror --ghc-option=-fno-warn-warnings-deprecations" -- CABAL BUG WORKAROUND :(+ cmd "cabal build"+ cmd "cabal test --show-details=always"+ when install $+ cmd "cabal install --force-reinstalls"++run Check = Just cabalCheck++run Sdist{..} = Just $ do+ cabalCheck+ tested <- testedWith+ withSDist $ do+ forM_ (sort tested) $ \x -> do -- deliberately start with the oldest first+ putStrLn $ "Building with " ++ x+ cmd "cabal clean"+ cmd $ "cabal install --only-dependencies " +++ "--with-compiler=c:\\ghc\\ghc-" ++ x ++ "\\bin\\ghc.exe --with-haddock=c:\\ghc\\ghc-" ++ x ++ "\\bin\\haddock.exe " +++ "--with-hc-pkg=c:\\ghc\\ghc-" ++ x ++ "\\bin\\ghc-pkg.exe " +++ "--flags=testprog"+ cmd $ "cabal configure --ghc-option=-fwarn-unused-imports --disable-library-profiling " +++ "--ghc-option=-Werror --ghc-option=-fno-warn-warnings-deprecations " ++ -- CABAL BUG WORKAROUND :(+ "--with-compiler=c:\\ghc\\ghc-" ++ x ++ "\\bin\\ghc.exe --with-haddock=c:\\ghc\\ghc-" ++ x ++ "\\bin\\haddock.exe " +++ "--with-hc-pkg=c:\\ghc\\ghc-" ++ x ++ "\\bin\\ghc-pkg.exe " +++ "--flags=testprog"+ cmd "cabal build"+ cmd "cabal haddock --executables"+ cmd "cabal sdist"+ putStrLn $ "Ready to release! (remember to neil tag after uploading)"++run Docs{..} = Just $ do+ src <- readCabal+ let [ver] = [strip $ drop 8 x | x <- lines src, "version:" `isPrefixOf` x]+ let [name] = [strip $ drop 5 x | x <- lines src, "name:" `isPrefixOf` x]+ cmd $ "cabal haddock --hoogle --hyperlink-source " +++ "--contents-location=/package/" ++ name+ withTempDir $ \dir -> do+ cmd $ "cp -R dist/doc/html/" ++ name ++ " \"" ++ dir ++ "/" ++ name ++ "-" ++ ver ++ "-docs"+ files <- getDirectoryContentsRecursive dir+ forM_ files $ \file -> when (takeExtension file == ".html") $ do+ src <- readFileBinary' $ dir </> file+ src <- return $ filter (/= '\r') src -- filter out \r, due to CPP bugs+ src <- return $ fixFileLinks $ fixHashT src+ writeFileBinary (dir </> file) src+ cmd $ "tar cvz -C " ++ dir ++ " --format=ustar -f " ++ dir ++ "/" ++ name ++ "-" ++ ver ++ "-docs.tar.gz " ++ name ++ "-" ++ ver ++ "-docs"+ cmd $ "curl -X PUT -H \"Content-Type: application/x-tar\" " +++ "-H \"Content-Encoding: gzip\" " +++ "-u " ++ username ++ " " +++ "--data-binary \"@" ++ dir ++ "/" ++ name ++ "-" ++ ver ++ "-docs.tar.gz\" " +++ "https://hackage.haskell.org/package/" ++ name ++ "-" ++ ver ++ "/docs"++run _ = Nothing+++fixHashT :: String -> String+fixHashT (stripPrefix ".html#t:" -> Just (x:xs)) | not $ isUpper x = ".html#v:" ++ fixHashT (x:xs)+fixHashT (x:xs) = x : fixHashT xs+fixHashT [] = []++fixFileLinks :: String -> String+fixFileLinks (stripPrefix "<a href=\"file://" -> Just xs)+ | (a,'\"':b) <- break (== '\"') xs+ , modu <- takeFileName a+ , (pkg,_) <- breakEnd (== '-') $ takeFileName $ takeDirectory a+ = "<a href=\"/package/" ++ pkg ++ "/docs/" ++ modu ++ "\"" ++ fixFileLinks b+fixFileLinks (x:xs) = x : fixFileLinks xs+fixFileLinks [] = []+++testedWith :: IO [String]+testedWith = do+ src <- readCabal+ return $ concat [ map f $ words $ map (\x -> if x == ',' then ' ' else x) $ drop 12 x+ | x <- lines src, "tested-with:" `isPrefixOf` x]+ where+ f x | Just rest <- stripPrefix "GHC==" x = rest+ | otherwise = error $ "Invalid tested-with, " ++ x+++checkReadme :: IO ()+checkReadme = do+ project <- takeBaseName . fromMaybe (error "Couldn't find cabal file") <$> findCabal+ let want =+ "[![Hackage version](https://img.shields.io/hackage/v/" ++ project ++ ".svg?style=flat)]" +++ "(http://hackage.haskell.org/package/" ++ project ++ ") " +++ "[![Build Status](http://img.shields.io/travis/ndmitchell/" ++ project ++ ".svg?style=flat)]" +++ "(https://travis-ci.org/ndmitchell/" ++ project ++ ")"+ src <- readFile "README.md"+ let line1 = head $ lines src ++ [""]+ when (not $ want `isSuffixOf` line1) $+ error $ "Expected first line of README.md to end with:\n" ++ want ++ "\nBut got:\n" ++ line1+++checkCabalFile :: IO ()+checkCabalFile = do+ project <- takeBaseName . fromMaybe (error "Couldn't find cabal file") <$> findCabal + src <- fmap lines readCabal+ test <- testedWith+ let grab tag = [stripStart $ drop (length tag + 1) x | x <- relines src, (tag ++ ":") `isPrefixOf` x]+ license <- readFile' $ concat $ grab "license-file"+ let bad =+ ["Incorrect declaration style: " ++ x+ | (x,':':_) <- map (break (== ':') . stripStart) src+ , not $ any isSpace $ strip x, not $ "http" `isSuffixOf` x || "https" `isSuffixOf` x+ , not $ all (\x -> isLower x || x == '-') x] +++ ["2014 is not in the copyright year" | not $ "2014" `isInfixOf` concat (grab "copyright")] +++ ["copyright string is not at the start of the license" | not $ concat (grab "copyright") `isInfixOf` concat (take 1 $ lines license)] +++ ["No correct source-repository link"+ | let want = "source-repository head type: git location: https://github.com/ndmitchell/" ++ project ++ ".git"+ , not $ want `isInfixOf` unwords (words $ unlines src)] +++ ["No bug-reports link" | grab "bug-reports" /= ["https://github.com/ndmitchell/" ++ project ++ "/issues"]] +++ ["Incorrect license " | grab "license" `notElem` [["BSD3"],["MIT"]]] +++ ["Invalid tested-with: " ++ show test | length test < 1 || not (null $ test \\ defAllow) || test /= reverse (sort test) || not (test `isPrefixOf` reverse defAllow)] +++ ["Bad stabilty, should be missing" | grab "stability" /= []] +++ ["Missing CHANGES.txt in extra-source-files" | "CHANGES.txt" `notElem` concatMap words (grab "extra-source-files")]+ unless (null bad) $ error $ unlines bad++relines :: [String] -> [String]+relines (x:xs) | ":" `isSuffixOf` x = unwords (x:a) : relines b+ where (a,b) = break (\x -> stripStart x == x) xs+relines (x:xs) = x : relines xs+relines [] = []++readCabal :: IO String+readCabal = do+ file <- findCabal+ case file of+ Nothing -> return []+ Just file -> readFile' file+++findCabal :: IO (Maybe FilePath)+findCabal = do+ x <- getDirectoryContents "."+ return $ listToMaybe $ filter ((==) ".cabal" . takeExtension) x
+ src/Git.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE RecordWildCards #-}++module Git(run) where++import Control.Monad+import Data.List.Extra+import System.Directory.Extra+import System.Exit+import System.FilePath+import Util+import Arguments+import Cabal(readCabal)+++---------------------------------------------------------------------+-- UTILITIES++-- Find all the repos. Look for .git (I am a repo) and */.git (I have child repos)+-- If you don't find any, look up.+findRepos :: IO [FilePath]+findRepos = do+ putStr "Looking for repos... "+ dirs <- getDirectoryContents "."+ res <- filterM (\x -> doesDirectoryExist $ x </> ".git") dirs+ putStrLn $ show (length res) ++ " found"+ return $ sort res+++-- Run over each repo+forEachRepo :: (String -> IO ()) -> IO ()+forEachRepo act = do+ res <- findRepos+ when (null res) $ do+ putStrLn $ "Error: No repos found relative to here"+ exitFailure+ forM_ res $ \x ->+ if x == "." then do+ cdir <- getCurrentDirectory+ act $ takeFileName cdir+ else+ withCurrentDirectory x $ act x+++---------------------------------------------------------------------+-- COMMANDS++run :: Arguments -> Maybe (IO ())++run Whatsnew{..} = Just $ forEachRepo $ \name -> do+ changes <- fmap (length . filter (not . null) . lines) $ cmdOut $ "git status --porcelain --untracked-files=no"+ adds <- if not look_for_adds then return 0 else fmap (subtract changes . length . filter (not . null) . lines) $ cmdOut "git status --porcelain"+ unless local $ cmd "git fetch --quiet"+ local <- fmap read $ cmdOut $ "git rev-list origin/master..master --count"+ remote <- fmap read $ cmdOut $ "git rev-list master..origin/master --count"+ let items = [changes,adds,local,remote]+ let names = [("local change","s"),("addable",""),("local patch","es"),("remote patch","es")]+ let res = [show n ++ " " ++ s ++ (if n == 1 then "" else ss) | (n,(s,ss)) <- zip items names, n /= 0]+ unless (null res) $ putStrLn $ name ++ ": " ++ intercalate ", " res++run Tag = Just $ do+ src <- readCabal+ let [ver] = [strip $ drop 8 x | x <- lines src, "version:" `isPrefixOf` x]+ putStrLn $ "Confirm to tag the release with version " ++ ver ++ "? Type 'yes':"+ "yes" <- getLine+ cmd "git push"+ cmd $ "git tag v" ++ ver+ cmd "git push --tags"++run _ = Nothing
+ src/Main.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}++module Main(main) where++import Control.Monad+import Data.Maybe+import System.Console.CmdArgs+import System.Environment+import System.IO++import Arguments+import Cabal+import Git+#ifndef SMALL+import Travis+#endif+import qualified Paper.Main as Paper+++main :: IO ()+main = do+ hSetBuffering stdout NoBuffering+ a <- getArgs+ case a of+ "paper":a -> withArgs a Paper.main+ _ -> do+ args <- cmdArgsRun arguments+ fromMaybe (error $ "Don't know how to deal with argument: " ++ show args) $ msum+ [Git.run args+ ,Cabal.run args+#ifndef SMALL+ ,Travis.run args+#endif+ ]
+ src/Neil.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Neil(+ neil,+ module Util,+ module Control.Monad,+ module Data.List,+ module Data.Maybe,+ module Extra+ ) where++import Util+import Control.Monad+import Data.List+import Data.Maybe+import Extra+import System.Environment+++neil :: IO () -> IO ()+neil act = do+ args <- getArgs+ if "--go" `elem` args then+ act+ else+ putStrLn "Script type checks successfully, pass --go to run it"
+ src/Paper/Ftp.hs view
@@ -0,0 +1,63 @@++module Paper.Ftp(ftp) where++import Control.Monad+import System.Cmd+import System.Directory+import System.FilePath+import System.IO+import Paper.Util.IO+++ftp :: FilePath -> IO ()+ftp darcs = do+ let name = takeFileName darcs+ out = darcs </> name <.> "patch"+ ftpfile = out <.> "ftp"++ b <- doesFileExist out+ when b $ removeFile out+ b <- doesFileExist (out <.> "send")+ when b $ removeFile (out <.> "send")++ system $ "darcs send" +++ " --repodir=\"" ++ darcs ++ "\"" +++ " --output=\"" ++ (out <.> "send") ++ "\""+ b <- doesFileExist (out <.> "send")+ when b $ do+ password <- getPassword+ writeFile ftpfile $ unlines+ ["ndm500"+ ,password+ ,"lcd " ++ darcs+ ,"cd web/patches"+ ,"binary"+ ,"put " ++ (name <.> "patch" <.> "send")+ ,"rename " ++ (name <.> "patch" <.> "send") ++ " " ++ (name <.> "patch")+ ,"get " ++ (name <.> "patch")+ ,"quit"]+ system $ "ftp -s:" ++ ftpfile ++ " ftp.york.ac.uk > nul"+ check out (out <.> "send")+ removeFile ftpfile+ removeFile out+ removeFile (out <.> "send")+ return ()+++getPassword = do+ hSetBuffering stdout NoBuffering+ hSetBuffering stdin NoBuffering+ hSetEcho stdout False+ hSetEcho stdin False+ putStr "Enter password: "+ s <- getLine+ putStrLn ""+ return s+++check x y = do+ x1 <- readFile' x+ y1 <- readFile' y+ if x1 == y1+ then putStrLn "Success"+ else putStrLn "ERROR: FTP was unsuccessful"
+ src/Paper/Graph.hs view
@@ -0,0 +1,91 @@++module Paper.Graph(graphLog, graphCreate) where++import Data.List+import qualified Data.Map as Map+import Data.Ord+import System.Cmd+import System.Time++import Graphics.Google.Chart+++graphLog :: FilePath -> [(String,Int)] -> IO ()+graphLog dest xs = do+ t <- getClockTime+ t <- toCalendarTime t+ appendFile dest $ unlines [show (t,a,b) | (a,b) <- xs]++++-- load the data+graphLoad :: FilePath -> [String] -> IO [(Date,String,Int)]+graphLoad src files = do+ src <- readFile src+ res <- return [(date a,b,c) | s <- lines src, not $ null s, let (a,b,c) = read s, b `elem` files]+ return $ sortBy (comparing fst3) res++fst3 (x,_,_) = x++-- year, month (1 based), day (1 based)+type Date = (Int,Int,Int)++date :: CalendarTime -> Date+date t = (ctYear t, fromEnum (ctMonth t) + 1, ctDay t)+++incDate :: Date -> Date+incDate (a,12,31) = (a+1,1,1)+incDate (a, b,31) = (a,b+1,1)+incDate (a, b, c) = (a,b,c+1)+++totalCounts :: [FilePath] -> [(Date,FilePath,Int)] -> [(Date,Int)]+totalCounts _ [] = [((2000,1,1),0)]+totalCounts files xs = f (Map.fromList (zip files $ repeat 0)) xs steps+ where+ steps = iterate incDate $ fst3 (head xs)++ f now xxs@((a,b,c):xs) (s:ss)+ | a > s = dump s now : f now xxs ss+ | otherwise = f (Map.insert b c now) xs (s:ss)+ f now [] (s:ss) = [dump s now]++ dump s mp = (s, sum $ Map.elems mp)+++graphCreate :: FilePath -> FilePath -> [String] -> IO ()+graphCreate src dest files = do+ xs <- graphLoad src files+ let url = graphUrl $ totalCounts files xs+ system $ "wget \"" ++ url ++ "\" -O \"" ++ dest ++ "\""+ return ()+++-- a list of date/count pairs+-- all the dates must be in order+graphUrl :: [(Date,Int)] -> String+graphUrl dat = chartURL $+ setSize 400 300 $+ setTitle "Word Count" $+ setAxisTypes [AxisBottom,AxisLeft] $+ setAxisLabels [xAxis, yAxis] $+ setData (encodeDataSimple [map scale allY]) $+ newLineChart+ where+ -- calculate the bounding box+ minX = let (a,b,_) = fst (head dat) in (a,b,1)+ maxX = let (a,b,_) = fst (last dat) in incDate (a,b,31)+ allY = if length dat == 1 then replicate 2 $ snd $ head dat else map snd dat+ minY = (minimum allY `div` 1000) * 1000+ maxY = (maximum allY `div` 1000) * 1000 + 1000++ -- calculate the axis+ yAxis = map show [minY, minY+1000 .. maxY]+ xAxis = map g $ takeWhile (<= maxX) $ iterate f minX+ where+ f (a,b,c) = incDate (a,b,31)+ g (a,b,c) = take 3 (show (toEnum (b-1) :: Month)) ++ " " ++ show (a `mod` 100)++ -- scaling (new range is 0 <= x <= 61)+ scale y = (61 * (y - minY)) `div` (maxY - minY)
+ src/Paper/Haskell.hs view
@@ -0,0 +1,45 @@++module Paper.Haskell where++import Data.Ix+import Data.Char+import Data.List+import System.Directory+import System.FilePath+import Paper.Util.FileData+import Paper.Haskell.Fragment+import Paper.Haskell.Check+++haskell obj files = do+ let incFile = directory files </> "Include.hs"+ b <- doesFileExist incFile+ pre <- if b then readFile incFile else return ""++ src <- readFile (directory files </> mainFile files)+ let (debug,ranges) = partition (== "d") $ flags files+ checkFragments (not $ null debug)+ (checkRange $ parseRanges ranges)+ pre (parseFragments src)+++-- ranges are one of:+-- -from..to+-- -from.. (where the .. is optional)++parseRanges :: [String] -> [(Int,Int)]+parseRanges [] = [(minBound,maxBound)]+parseRanges xs = map f xs+ where+ f x = (read a, if null c then maxBound else read c)+ where+ (a,b) = span isDigit x+ c = dropWhile (== '.') b++-- a list of ranges, union'ed together+checkRange :: [(Int,Int)] -> Int -> Bool+checkRange [] i = False+checkRange (x:xs) i = inRange x i || checkRange xs i+++rep from with = map (\x -> if x == from then with else x)
+ src/Paper/Haskell/Check.hs view
@@ -0,0 +1,116 @@++module Paper.Haskell.Check where++import Paper.Haskell.Fragment+import Paper.Haskell.Haskell.Provides+import System.Cmd+import System.Exit+import System.IO+import Data.List+import Data.Char+import Control.Monad+++data Result = Pass | Fail String | Missing String | Instances [String]+ deriving (Eq,Show)++builtin = ["where"] +++ ["Int","Bool","Float","Integer","String","Char"]+++checkFragments :: Bool -> (Int -> Bool) -> String -> [Frag] -> IO ()+checkFragments debug test prefix xs = mapM_ f xs+ where+ names = split [drop 5 x | x <- lines prefix, "-- # " `isPrefixOf` x]+ insts = split [drop 12 x | x <- lines prefix, "-- instance " `isPrefixOf` x]+ split = concatMap (map trim . lines . map (\x -> if x == ';' then '\n' else x))+ trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+ + f (Expr i s)+ | test i && s `elem` (names ++ builtin ++ concat [has | Stmt _ has _ <- xs])+ = putStrLn $ "Checking line " ++ show i ++ "... success"++ f (Expr i s) = f $ Stmt i [] ("tex2hs _ = (" ++ s ++ ")")+ f (Stmt i has s) | test i = do+ putStr $ "Checking line " ++ show i ++ "... "+ res <- check (prefix ++ "\n" ++ s)+ case res of+ Pass -> putStrLn "success"+ Fail msg -> do+ putStrLn "FAILURE"+ putStr $ unlines $ map (" "++) $ lines msg+ error "Fix your code, or we'll reject you!"++ f _ = return ()++ check s = do+ res <- checkCode debug s+ case res of+ Missing x -> g (Fail $ "Can't find: " ++ show x) s [t | Stmt _ has t <- xs, x `elem` has]+ Instances x ->+ let add = unlines ["instance " ++ z | i <- x, z <- filter (\j -> blur i == blur j) insts]+ blur = filter (isUpper . head) . lexemes+ in g (Fail $ "No instance: " ++ show x) s [add | not $ null add]+ _ -> return res+ + g err s [] = return err+ g err s (x:xs) = do+ r <- check (s ++ "\n" ++ x)+ if r == Pass then return Pass else g r s xs++checkCode :: Bool -> String -> IO Result+checkCode debug orig = do+ writeFile "temp.hs" orig+ res <- system "ffihugs -98 temp.hs 2> temp.txt"+ if res == ExitSuccess then return Pass else do+ x <- readFileStrict "temp.txt"+ let s = unlines $ filter (not . null) $ drop 1 $ lines x+ err = parseError s+ + when debug $ do+ putStrLn orig+ putStrLn s+ print err+ getChar+ return ()++ return err+++readFileStrict s = do+ h <- openFile s ReadMode+ s <- hGetContents h+ length s `seq` hClose h+ return s+++parseError s =+ if any ("- Undefined" `isPrefixOf`) (tails s) then+ Missing $ takeWhile (/= '\"') $ drop 1 $ dropWhile (/= '\"') $ dropWhile (/= '-') s+ else if any ("- Instance" `isPrefixOf`) (tails s) then+ Instances $ insts s+ else if any ("requires extra context" `isPrefixOf`) (tails s) then+ Instances $ nub $ insts2 s+ else+ Fail s++++insts = map (unwords . words) . lines . map rep . sel+ where+ rep x = if x == ',' then '\n'+ else if x `elem` "()" then ' '+ else x+ + sel (' ':'o':'f':' ':xs) = g xs+ sel (x:xs) = sel xs+ + g (' ':'r':xs) = []+ g (x:xs) = x : g xs+++insts2 = map (unwords . words) . lines . map rep . reverse . takeWhile (/= ':') . reverse+ where+ rep x = if x == ',' then '\n'+ else if x `elem` "()" then ' '+ else x
+ src/Paper/Haskell/Fragment.hs view
@@ -0,0 +1,19 @@++module Paper.Haskell.Fragment where++import Paper.Haskell.Haskell.Provides+import Paper.Haskell.Haskell.Tweak+import Paper.Haskell.Latex.Parser+++data Frag = Stmt Line [String] String+ | Expr Line String+ deriving Show+++parseFragments :: String -> [Frag]+parseFragments = map f . parseLatex+ where+ f (HsExpr line x) | isStmt x = f $ HsCode line x+ f (HsCode line x) = Stmt line (map fromProvides $ provides x) (tweak x)+ f (HsExpr line x) = Expr line x
+ src/Paper/Haskell/Haskell/Provides.hs view
@@ -0,0 +1,91 @@++module Paper.Haskell.Haskell.Provides(Provides(..), provides, fromProvides, isStmt, lexemes) where++import Data.List+import Data.Char+++data Provides = ProvidesBody String+ | ProvidesSig String+ | ProvidesName String+ deriving (Eq,Show)+++fromProvides (ProvidesBody x) = x+fromProvides (ProvidesSig x) = x+fromProvides (ProvidesName x) = x+++provides :: String -> [Provides]+provides x = nub $ concatMap (provider . lexemes) $ indents $ lines x+++indents (x:(y:ys):zs) | isSpace y = indents $ (x++" ; "++y:ys) : zs+indents (x:xs) = x : indents xs+indents [] = []+++isStmt x = "=" `elem` before "let" xs || "::" `elem` xs+ where xs = lexemes x++before x xs = if x `elem` xs then takeWhile (/= x) xs else xs+++split on xs = a : if null b then [] else split on (tail b)+ where (a,b) = break (== on) xs+++provider :: [String] -> [Provides]+provider xs = case xs of+ "type":xs -> [ProvidesName $ headNote 1 con]+ "data":xs -> ProvidesName (headNote 2 con) : providerCtors (map (rep "=" "|") (tail con))+ "class":xs -> ProvidesName (headNote 3 con) : map asClass (concatMap provider (tail $ split ";" con))+ _ | "::" `elem` (takeWhile (`notElem` ["where","="]) xs) -> providesSig xs+ _ -> providesBody xs+ where+ con = dropContext $ tail xs+ asClass = ProvidesName . fromProvides++ dropContext xs = if null b then a else tail b+ where (a,b) = break (== "=>") xs++++providerCtors = map f . tail . split "|"+ where+ f xs = ProvidesName $ headNote 4 $ y ++ xs+ where y = filter (\x -> ":" `isPrefixOf` x && x /= "::") xs+++providesSig = map ProvidesSig . filter (`notElem` [",","(",")"]) . takeWhile (/= "::") . takeWhile (/= "=")+++-- approximation:+-- (symbol)+-- (...) symbol+-- ... symbol+-- name+providesBody [] = []+providesBody xs = map ProvidesBody $ f xs+ where+ f (x:ys:xs) | isSymbol ys = [getSymbol (ys:xs)]+ f ("(":xs) = [a | _:a:_ <- [dropWhile (/= ")") xs]]+ f (x:xs) = [x]++ isSymbol (y:ys) = not (isAlpha y) && y `notElem` "([" && (y:ys) /= "="++ getSymbol ("`":x:xs) = x+ getSymbol (x:xs) = x+++lexemes :: String -> [String]+lexemes x = case lex x of+ [("",_)] -> []+ [(x,y)] -> x : lexemes y+ [] -> []++rep from to x = if x == from then to else x+++headNote i [] = error $ show i+headNote i (x:xs) = x
+ src/Paper/Haskell/Haskell/Tweak.hs view
@@ -0,0 +1,17 @@++module Paper.Haskell.Haskell.Tweak(tweak) where++import Paper.Haskell.Haskell.Provides+import Data.List+++tweak :: String -> String+tweak = dummy . unlines . filter (not . isModule) . lines+ where isModule x = "module " `isPrefixOf` x || "import " `isPrefixOf` x+++dummy x = unlines (x : map f undef)+ where+ p = provides x+ undef = [x | ProvidesSig x <- p] \\ [x | ProvidesBody x <- p]+ f x = "(" ++ x ++ ") = undefined"
+ src/Paper/Haskell/Latex/Parser.hs view
@@ -0,0 +1,46 @@++module Paper.Haskell.Latex.Parser(Line, HsCode(..), parseLatex) where++import Data.List++type Line = Int++data HsCode = HsCode Line String+ | HsExpr Line String+ deriving (Eq,Show)++++parseLatex :: String -> [HsCode]+parseLatex x = f $ zip [1..] (lines x)+ where+ f ((i,x):xs) | beginCode x = let (a,b) = break (endCode . snd) xs+ code = (unlines $ map snd a)+ in HsCode i code : f b+ | ignoreCode x = f $ drop 1 $ dropWhile (not . endCode . snd) xs+ | otherwise = concat (zipWith (g i) [1..] (parseLine x)) ++ f xs+ f [] = []++ g line col s = [HsExpr line s]+++ignoreCode = isPrefixOf "\\ignore\\begin{code}"+beginCode = isPrefixOf "\\begin{code}"+endCode = isPrefixOf "\\end{code}"+++parseLine :: String -> [String]+parseLine ('%':xs) = []+parseLine ('|':'|':xs) = parseLine xs+parseLine ('|':xs) = a : parseLine b+ where (a,b) = parseBar xs+parseLine xs | "\\ignore|" `isPrefixOf` xs = parseLine $ snd $ parseBar $ drop 8 xs+parseLine (x:xs) = parseLine xs+parseLine [] = []++parseBar ('|':'|':xs) = ('|':a,b)+ where (a,b) = parseBar xs+parseBar ('|':xs) = ("",xs)+parseBar (x:xs) = (x:a,b)+ where (a,b) = parseBar xs+parseBar [] = ("","")
+ src/Paper/Haskell2/All.hs view
@@ -0,0 +1,24 @@++module Paper.Haskell2.All(haskell2) where++import Control.Monad+import System.Cmd+import System.Exit+import System.FilePath++import Paper.Haskell2.Stage1+import Paper.Haskell2.Stage2+import Paper.Haskell2.Stage3+++haskell2 :: FilePath -> [FilePath] -> IO ()+haskell2 obj files = mapM_ f files+ where+ f file = do+ putStrLn $ "Checking " ++ takeBaseName file+ src <- readFile file+ let dest = obj </> takeFileName file+ res = stage3 dest $ stage2 $ stage1 file src+ mapM_ (uncurry writeFile) res+ res <- system $ "runghc -i" ++ obj ++ " " ++ fst (head res)+ when (res /= ExitSuccess) $ error "Failed to check"
+ src/Paper/Haskell2/Haskell.hs view
@@ -0,0 +1,109 @@++module Paper.Haskell2.Haskell(+ isHaskellSym, haskellKeywords, lexer,+ defines, rename, fakeImplement+ ) where++import Data.Char+import Data.List+import Data.Maybe+import Paper.Util.String+++haskellKeywords = ["class","instance","where","data","type","import","in","let","do","module","newtype"]+haskellKeySymbols = ["--","="]+++isHaskellSym xs = all (`elem` "|+-*<>.=?&") xs && xs `notElem` haskellKeySymbols+isHaskellVar xs = isAlpha (head xs) && xs `notElem` haskellKeywords+validName xs = isHaskellSym xs || isHaskellVar xs+++defines :: String -> [String]+defines = nub . filter validName . concatMap f . map lexer . classLeft . lines+ where+ f ("(":name:")":_) | isHaskellSym name = [name]+ f ("(":xs) | isHaskellSym name = [name]+ where name:_ = drop 1 $ dropWhile (/= ")") xs+ f (_:name:_) | isHaskellSym name = [name]+ f ("type":name:_) = [name]+ f (name:_) = [name]+ f _ = []+++flushLeft (x:xs) = not $ isSpace x+flushLeft [] = False+++classLeft (x:xs) | "class" `isPrefixOf` x = x : a ++ classLeft xs+ where (a,_) = span (\x -> null x || isSpace (head x)) xs+classLeft ((x:_):xs) | isSpace x = classLeft xs+classLeft (x:xs) = x : classLeft xs+classLeft [] = []+++rename :: [(String, String)] -> String -> String+rename [] = id+rename ren = concatMap f . lexerSpace+ where f x = fromMaybe x $ lookup x ren+++-- figure out which definitions have a type signature+-- but no associated body, and make one up+fakeImplement :: String -> String+fakeImplement xs = unlines $+ ["-- !typesigFunction " ++ show typ, "-- !implementsFunction " ++ show imp, xs] +++ [operator x ++ " = undefined -- stub" | x <- typ \\ imp]+ where (typ,imp) = (typesigFunction xs, implementsFunction xs)+++-- more a "this function is definately defined"+-- as conservative+typesigFunction :: String -> [String]+typesigFunction = nub . concatMap (typesigs . lexer) . filter flushLeft . lines+++typesigs :: [String] -> [String]+typesigs = f []+ where+ f seen ("(":x:")":xs) = f seen (x:xs)+ f seen (x:"::":xs) = x:seen+ f seen (x:",":xs) = f (x:seen) xs+ f _ _ = []+++-- more a "this function is possibly implemented"+-- as conservative+implementsFunction :: String -> [String]+implementsFunction = nub . concatMap (f . lexer) . lines+ where+ f xs | not $ null $ typesigs xs = []+ f (_:"`":x:"`":_) = [x]+ f (_:x:_) | isHaskellSym x = [x]+ f ("(":xs) | bs /= [] && isHaskellSym (head bs) = [head bs]+ where bs = drop 1 $ dropWhile (/= ")") xs+ f (x:xs) = [x]+ f [] = []+++operator (x:xs) | isAlpha x = x:xs+operator x = "(" ++ x ++ ")"+++-- concat . lexerSpace == id (nearly, just comments)+lexerSpace :: String -> [String]+lexerSpace [] = []+lexerSpace xs@(x:_) | isSpace x = a : lexerSpace b+ where (a,b) = span isSpace xs+lexerSpace ('{':'-':'\"':xs) = (" {-\"" ++ a ++ c) : lexerSpace d+ where (a,b) = breakStr "\"-}" xs+ (c,d) = splitAt 3 b+lexerSpace ('-':'-':x:xs) | isAlphaNum x || isSpace x = (" --" ++ a) : lexerSpace b+ where (a,b) = break (== '\n') (x:xs)+lexerSpace xs = case lex xs of+ [(a,'.':x:xs)] | isUpper x -> (a++'.':b) : c+ where b:c = lexerSpace (x:xs)+ [(a,b)] -> a : lexerSpace b+ other -> error $ "lexerSpace, unexpected: " ++ show (xs, other)++lexer = filter (not . isSpace . head) . lexerSpace
+ src/Paper/Haskell2/Stage1.hs view
@@ -0,0 +1,119 @@++module Paper.Haskell2.Stage1(stage1) where++import Data.Char+import Data.List+import Paper.Util.String+import Paper.Util.Error+import Paper.Haskell2.Type+import Paper.Haskell2.Haskell+++defs = [("\\hsdef{\\begin{comment}","\\end{comment}}")+ ,("\\begin{hsdef}","\\end{hsdef}")+ ,("\\hsdef\\begin{comment}","\\end{comment}")+ ,("\\hsdef{","}")+ ]++stage1 :: FilePath -> String -> [HsLow]+stage1 file = f 1 ""+ where+ pos = Pos file++ f i cmd xs | match /= [] = map (HsDef (pos i)) (lines a) ++ f (i + newlines a) "" b+ where+ match = filter ((`isPrefixOf` xs) . fst) defs+ (start,end):_ = match+ (a,b) = breakStr end $ drop (length start) xs++ f i cmd xs | "\\ignore" `isPrefixOf` xs = f i "ignore" $ drop 7 xs++ f i cmd xs | "\\h{" `isPrefixOf` xs = f (i + newlines a) a $ drop 1 b+ where (a,b) = break (== '}') $ drop 3 xs++ f i cmd ('|':'|':xs) = f i "" xs+ f i cmd ('|':xs) | '\n' `elem` a = errorDie file i "Failed to parse | lines" a+ | otherwise = hsCheck (pos i) Expr cmd a ++ f i "" b+ where (a,b) = spanExpr xs++ f i cmd xs | "\\begin{code}" `isPrefixOf` xs+ = hsCheck (pos i) Stmt cmd a ++ concatMap (f i "") (comments a) ++ f (i + newlines a) "" b+ where (a,b) = breakStr "\\end{code}" $ drop 12 xs++ f i cmd xs | "%if 0" `isPrefixOf` xs = f (i + newlines a) "" b+ where (a,b) = breakStr "%endif" xs++ f i cmd ('%':xs) = f i "" $ dropWhile (/= '\n') xs+ f i cmd (x:xs) | x == '\n' = f (i+1) cmd xs+ | isSpace x = f i cmd xs+ | otherwise = f i "" xs+ f i cmd [] = []+++comments :: String -> [String]+comments = concatMap f . lines+ where+ f xs = [drop 2 b | not $ null b]+ where (_,b) = breakStr "--" xs+++spanExpr :: String -> (String, String)+spanExpr ('|':'|':xs) = ('|':a, b)+ where (a,b) = spanExpr xs+spanExpr ('|':xs) = ("", xs)+spanExpr (x:xs) = (x:a,b)+ where (a,b) = spanExpr xs+spanExpr [] = ("","")+++newlines :: String -> Int+newlines = length . filter (== '\n')+++readCmd :: String -> ([String], String)+readCmd ('.':xs) = (a:c,d)+ where+ (a,b) = break (== ' ') xs+ (c,d) = readCmd $ drop 1 b+readCmd xs = ([], xs)+++hsCheck pos typ cmd x+ | b == "ignore" = []+ | b == "" = cont [(typ,x)]+ | otherwise = cont $ hsCustom b x+ where+ cont tx = [HsCheck pos t (parseWhere a) x | (t,x) <- tx]+ (a,b) = readCmd cmd+++-- @ foo = bar+-- @ = def+-- implicitly insert foo before each =+hsCustom "deflist" x = [(Stmt,unlines $ map f ls)]+ where+ ls = lines x+ prefix = takeWhile (/= '=') $ head $ dropWhile (all isSpace) ls+ f x | "=" `isPrefixOf` dropWhile isSpace x = prefix ++ x+ | otherwise = x++-- each line started at column 1 is a new expr+hsCustom "exprlist" x = map ((,) Expr) $ f $ lines x+ where+ f (x:(y:ys):z) | isSpace y = f ((x ++ '\n':y:ys) : z)+ f (x:xs) = x : f xs+ f [] = []++-- a piece of context+hsCustom "ctxt" x = [(Stmt,"context_expression :: " ++ x ++ " => " ++ free ++ "()\ncontext_expression = undefined")]+ where free = concat [x:xs ++ " -> " | x:xs <- lexer x, isLower x]++-- a type expression+hsCustom "type" x = [(Stmt,"type TypeType " ++ free ++ " = " ++ x)]+ where free = unwords [x | x <- lexer x, isLower $ head x]++hsCustom "do" x = [(Expr,unlines $ "do" : map (' ':) (lines x))]++hsCustom "stmt" x = [(Stmt,x)]+hsCustom "expr" x = [(Expr,unlines $ map (' ':) $ lines x)]+hsCustom name _ = error $ "Stage1 todo: " ++ show name
+ src/Paper/Haskell2/Stage2.hs view
@@ -0,0 +1,42 @@++module Paper.Haskell2.Stage2(stage2) where++import Data.Char+import Data.List+import qualified Data.Set as Set+import Paper.Util.String+import Paper.Haskell2.Type+import Paper.Haskell2.Haskell+++stage2 :: [HsLow] -> [HsItem]+stage2 xs = reverse stmts2 ++ exprs2+ where+ (defs,checks) = partition isHsDef $ nub xs+ defNames = nub $ concatMap parseDefs defs+ (stmts,exprs) = partition ((==) Stmt . lowType) checks+ (useNames,stmts2) = unzip $ map parseStmt stmts+ names = flip Set.member $ Set.fromList $ haskellKeywords ++ defNames ++ concat useNames+ exprs2 = concat $ zipWith (parseExpr defNames names) [1..] exprs++++parseDefs :: HsLow -> [String]+parseDefs (HsDef pos x) = map (dropWhile (== ',')) $ splitStr "," x+++parseStmt :: HsLow -> ([String],HsItem)+parseStmt (HsCheck pos Stmt whr x) = (lexer x, HsItem Stmt pos (fakeImplement x) whr)+++parseExpr :: [String] -> (String -> Bool) -> Int -> HsLow -> [HsItem]+parseExpr names seen n (HsCheck pos expr whr x) =+ case lexer x of+ [] -> []+ [y] | seen y -> []+ ["(",y,")"] | seen y -> []+ [y] | isHaskellSym y -> f [y] ("(" ++ y ++ ")")+ lexed -> f lexed x+ where+ f lexed x = [HsItem Stmt pos (unwords (("auto_" ++ show n) : free) ++ " = " ++ x ++ "\n") whr]+ where free = filter (not . isUpper . head) $ names `intersect` lexed
+ src/Paper/Haskell2/Stage3.hs view
@@ -0,0 +1,86 @@++module Paper.Haskell2.Stage3(stage3) where++import Data.Char+import Data.List+import System.FilePath+import Paper.Haskell2.Type+import Paper.Haskell2.Haskell+++exts = "NoMonomorphismRestriction, MultiParamTypeClasses, FlexibleContexts, " +++ "FlexibleInstances, UndecidableInstances, Rank2Types, EmptyDataDecls, " +++ "FunctionalDependencies, TypeSynonymInstances, IncoherentInstances, " +++ "ExtendedDefaultRules, ScopedTypeVariables, GADTs, ViewPatterns, " +++ "GeneralizedNewtypeDeriving, DeriveDataTypeable"++prefix = "{-# LANGUAGE " ++ exts ++ " #-}\n" +++ "{-# OPTIONS_GHC -w #-}\n"+++stage3 :: FilePath -> [HsItem] -> [(FilePath,String)]+stage3 file xs = (filename "", importer) : [(filename n, text n) | n <- need]+ where+ filename n = dropFileName file </> modname n <.> "hs"+ modname n = capital (takeBaseName file) ++ ['_'| n/=""] ++ n+ need = allWhere $ map itemWhere xs++ importer = unlines $ ("module Main where") :+ ["import " ++ modname n ++ "()" | n <- need] +++ ["main = putStrLn \"Successfully checked\""]++ text n = unlines $ prefix :+ ("module " ++ modname n ++ " where") :+ render items+ where items = filter (matchWhere n . itemWhere) xs+++render = collectImports . f [] . zip [0..]+ where+ f seen [] = []+ f seen ((n,HsItem Stmt pos x _) : xs) =+ linePragma pos : defNote : lines x2 ++ "" : f seen2 xs+ where+ def = defines x+ defNote = "-- !defines " ++ show def+ bad = def `intersect` seen+ x2 = rename (zip bad $ prime n bad) x+ seen2 = def `union` seen++ f seen (x:xs) = error $ "Stage 4, todo: " ++ show x+++collectImports xs = imports ++ map f xs+ where+ imports = filter (\x -> "import " `isPrefixOf` x && g x `notElem` modules) xs+ modules = map g (filter ("module " `isPrefixOf`) xs) \\ ["Prelude"]+ g = takeWhile (\x -> isAlphaNum x || x `elem` "._") . dropWhile isSpace . dropWhile (not . isSpace)+ + f x | any (`isPrefixOf` x) ["import ","module "] = "-- HIDE " ++ x+ | otherwise = x+++capital (x:xs) = toUpper x : xs+++prime :: Int -> [String] -> [String]+prime n xs | length pos == length (nub pos) = pos+ | otherwise = def+ where+ end = "''" ++ (uniqueStr !! n)+ sym = uniqueSym !! n+ (pos,def) = unzip $ map f xs++ f (x:xs) | isHaskellSym (x:xs) = (x:xs ++ "++" ++ sym, x:xs ++ "++" ++ sym)+ | otherwise = (x : (reverse $ drop (length end) $ reverse xs) ++ end, x:xs ++ end)++++uniqueStr = map (:[]) one ++ two ++ error "Stage3, uniqueStr exhausted"+ where+ one = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']+ two = [[a,b] | a <- one, b <- one]+++uniqueSym = [[a,b] | a <- syms, b <- syms] ++ error "Stage3, uniqueSym exhausted"+ where syms = "!+-<>=*&^%$"
+ src/Paper/Haskell2/Type.hs view
@@ -0,0 +1,66 @@++module Paper.Haskell2.Type where++import Data.List+++data Pos = Pos FilePath !Int+ deriving Show++linePragma :: Pos -> String+linePragma (Pos file line) = "{- # LINE " ++ show line ++ " " ++ show file ++ " # -}"+++data HsLow = HsDef {lowPos :: Pos, lowText :: String}+ | HsCheck {lowPos :: Pos, lowType :: HsType, lowWhere :: Where, lowText :: String}+ deriving Show+++instance Eq HsLow where+ (HsDef a1 b1) == (HsDef a2 b2) = b1 == b2+ (HsCheck a1 b1 c1 d1) == (HsCheck a2 b2 c2 d2) = b1 == b2 && c1 == c2 && d1 == d2+ _ == _ = False+++isHsDef (HsDef{}) = True; isHsDef _ = False++-- lowExpr: True is Expr, False is Stmt+-- lowCmd: any proceeding command, possibly none+-- \ignore, or \hs{command}+++data HsItem = HsItem {itemType :: HsType, itemPos :: Pos, itemText :: String, itemWhere :: Where}+ deriving Show++data HsType = Stmt+ | Expr+ | TExpr+ deriving (Eq,Show)+++data Where = Always+ | Only [String]+ | OnlyNot [String]+ deriving (Show,Eq)+++parseWhere :: [String] -> Where+parseWhere [] = Only ["default"]+parseWhere ["*"] = Always+parseWhere xs | null neg = Only xs+ | otherwise = OnlyNot $ map tail neg+ where neg = filter ("!" `isPrefixOf`) xs+++allWhere :: [Where] -> [String]+allWhere = nub . sort . concatMap f+ where+ f (Only x) = x+ f (OnlyNot x) = x+ f _ = []+++matchWhere :: String -> Where -> Bool+matchWhere x Always = True+matchWhere x (Only xs) = x `elem` xs+matchWhere x (OnlyNot xs) = x `notElem` xs
+ src/Paper/LatexError.hs view
@@ -0,0 +1,89 @@++module Paper.LatexError(latexError) where++import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import System.Directory+import System.FilePath+++-- given a list of all the files that went into the mix+-- and the log file+-- and the errors reported to the screen+-- attempt to diagnose something+latexError :: [FilePath] -> FilePath -> String -> IO ()+latexError texFiles logFile messages = do+ putStrLn "\nAnalysing Errors:\n"+ src <- readFile logFile+ let log = processLog src+ mapM_ (f log) $ nub $ map (\(a,b,_) -> (a,b)) $ mapMaybe splitErrLine $ lines messages+ mapM_ checkFile texFiles+ where+ f log (file,line) = do+ mapM_ putStr $ take 1 [c | (a,b,c) <- log, a == file2, b == line]+ showSection file line+ where file2 = takeBaseName file++splitErrLine s+ | null rest2 || null pos || not (all isDigit pos) = Nothing+ | otherwise = Just (s1++file, read pos :: Int, drop 1 rest2)+ where+ (s1,s2) = splitAt 3 s+ (file,rest1) = break (== ':') s2+ (pos,rest2) = break (== ':') $ drop 1 rest1+++-- show a section of a file, centered around a particular point+showSection :: FilePath -> Int -> IO ()+showSection file pos = do+ b <- doesFileExist file+ when b $ do+ src <- readFile file+ putStrLn $ unlines $ map f $ take 5 $ drop (pos - 3) $ zip [1..] $ lines src+ where f (p,s) = show p ++ (if p == pos then "> " else " ") ++ s++++processLog :: String -> [(FilePath,Int,String)]+processLog x = f (lines x)+ where+ f [] = []+ f (x:xs) = case splitErrLine x of+ Nothing -> f xs+ Just (a,b,c) -> (takeBaseName a,b,unlines (c:d)) : f e+ where (d,e) = break null xs+++---------------------------------------------------------------------+-- Check a file for obvious bracketing errors+checkFile :: FilePath -> IO ()+checkFile file = do+ src <- readFile file+ let errs = f [] (zip [0..] $ lines src)+ putStr $ unlines ["Error in " ++ takeBaseName file ++ ":" ++ show n ++ ", " ++ x | (n,x) <- errs]+ where+ (open,shut) = unzip brackets+ search x ys = listToMaybe [(i, drop (length y) x) | (i,y) <- zip [0..] ys, y `isPrefixOf` x]++ f seen [] = if null seen then [] else+ [(n, "Bracket openned but never shut " ++ show (open !! i)) | (n,i) <- seen]+ f seen ((n,[]):xs) = f seen xs+ f seen ((n,x):xs) =+ case (search x open, search x shut) of+ (Just (i,x),_) -> f ((n,i):seen) ((n,x):xs)+ (_,Just (i,x)) | null seen ->+ [(n,"Close bracket " ++ show (shut !! i) ++ ", but no open anywhere")]+ | otherwise ->+ let ((n2,i2):seen2) = seen+ in if i2 == i then f seen2 ((n,x):xs)+ else [(n,"Bracket mismatch, " ++ show (open !! i2) ++ " openned on " ++ show n2 +++ " but shut with " ++ show (shut !! i))]+ _ -> f seen ((n,tail x):xs)+++brackets :: [(String,String)]+brackets = let (*) = (,) in+ ["{" * "}"+ ]
+ src/Paper/Main.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP #-}+module Paper.Main(main) where++import System.Directory+import System.Environment+import System.FilePath++import Paper.Util.FileData+#ifndef SMALL+import Paper.Graph+#endif+import Paper.Make+import Paper.Talk+import Paper.WordCount+import Paper.Haskell+import Paper.Haskell2.All+import Paper.Push+import Paper.Sync+import Paper.Ftp+import Paper.Ref+import Paper.Todo+++{-+COMMANDS:+make -- compile the document+wc -- word count+wcmin -- minimal word count+graph -- make a graph+spell -- complete spell check+colin -- auto-colin grammar check+haskell -- auto-haskell checking++CONVENTIONS:+all object files go in obj/ directory+all stored files go in paper/ directory+ the output from chart+ word count logs (used for charting)+ grammar checking logs++all commands that take arguments take either:+ nothing - use the current directory+ a directory name - index.tex is the main file, all other *.tex files are extras+ a list of files - first is the main file, all others are extras (all must be the same directory)+-}++main :: IO ()+main = do+ args <- getArgs+ case args of+ (cmd:files) -> do+ files <- getFileData files+ process cmd files+ _ -> error "No arguments given"+++wc :: (FilePath -> IO Int) -> FileData -> IO ()+wc f files = do+ let shw = fixed ("total" : map dropExtension (allFiles files))+ res <- flip mapM (allFiles files) $ \file -> do+ putStr $ shw (dropExtension file) ++ " "+ count <- f (directory files </> file)+ putStrLn $ int count+ return (file,count)+ putStrLn $ shw "Total" ++ " " ++ int (sum $ map snd res)+#ifndef SMALL+ root <- settingsDir files+ graphLog (root </> "graph.txt") res+#endif++process :: String -> FileData -> IO ()+process "wc" files = wc wordCountNorm files+process "wcmin" files = wc wordCountMin files++#ifndef SMALL+process "graph" files = do+ root <- settingsDir files+ let res = root </> "graph.png"+ graphCreate (root </> "graph.txt") res (allFiles files)+ putStrLn $ "Written graph, " ++ res+#endif++process "make" files = do+ dat <- dataDir+ obj <- objDir "make" files+ make dat obj (directory files) (mainFile files) (allFiles files)++process "haskell" files = do+ obj <- objDir "haskell" files+ haskell obj files++process "haskell2" files = do+ obj <- objDir "haskell2" files+ haskell2 obj (argFiles files)++process "talk" files = do+ tlk <- objDir "talk" files+ talk tlk (argFiles files) (flags files)++process "push" files = push (darcs files)++process "sync" files = do+ dat <- dataDir+ sync (takeDirectory $ takeDirectory dat)++process "ref" files = ref (argFiles files)++process "todo" files = todo (argFiles files)++process "ftp" files = ftp (darcs files)++process "check" files = do+ mapM_ (`process` files) ["ref","todo"]+ putStrLn "All checks succeeded"++process x files = putStrLn $ "Error: Unknown action, " ++ show x+++----- utility stuff++-- the directory where data files (paper.bib/paper.fmt) live+dataDir :: IO FilePath+dataDir = do+ x <- findExecutable "paper"+ case x of+ Nothing -> error "Couldn't find the data directory"+ Just y -> return $ dropFileName y </> "data"++settingsDir :: FileData -> IO FilePath+settingsDir = ensureDir "paper"++objDir :: String -> FileData -> IO String+objDir cmd = ensureDir ("obj" </> cmd)+++ensureDir :: FilePath -> FileData -> IO FilePath+ensureDir name files = do+ let s = directory files </> name+ createDirectoryIfMissing True s+ return s+++----- mini formatting library++padR, padL :: Int -> String -> String+padL n s = replicate (n - length s) ' ' ++ s+padR n s = s ++ replicate (n - length s) ' '+++maxIntWidth = maximum $ map (length . show) [minBound::Int, maxBound]++int :: Int -> String+int = padL maxIntWidth . show+++fixed :: [String] -> String -> String+fixed ss = let n = maximum $ map length ss+ in \s -> padR n s+
+ src/Paper/Make.hs view
@@ -0,0 +1,96 @@++module Paper.Make(make) where++import Control.Exception+import Control.Monad+import System.Cmd+import System.Directory+import System.Exit+import System.FilePath++import Paper.LatexError+import Paper.Util.IO+++make :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> IO ()+make dataDir objDir srcDir mainFile allFiles = do+ let dataFile x = liftM ((dataDir </> x) :)+ sys = System (return ()) (const $ return ()) objDir++ eps1 <- files (srcDir </> "graphics") "eps"+ eps2 <- files srcDir "eps"+ fmt <- dataFile "paper.fmt" $ files srcDir "fmt"+ cls <- files srcDir "cls"+ bib <- dataFile "paper.bib" $ files srcDir "bib"+ tex <- dataFile "paper.tex" $ return allFiles++ for (eps2 ++ fmt ++ cls) $+ \e -> replaceDirectory e objDir <== [e] $ copyFile+ when (not $ null eps1) $ createDirectoryIfMissing True (objDir </> "graphics")+ for eps1 $+ \e -> replaceDirectory e (objDir </> "graphics") <== [e] $ copyFile+ for bib $+ \b -> replaceDirectory b objDir <== [b] $ \from to -> do+ copyFile from to+ system_ sys $ "bibtex -quiet " ++ takeBaseName b+ for tex $+ \t -> replaceDirectory t objDir <== (t:fmt) $ \from to -> do+ -- intermediate copy step because lhs2tex has bugs+ -- which means the input can't be an absolute path+ let temp = to <.> "lhs"+ copyFile from temp+ system_ sys{cleanup=removeFile to} $+ "lhs2tex " ++ takeFileName temp ++ " -o " ++ to+ fixLineEndings to++ let base = takeBaseName mainFile+ system_ sys{errorMsg=latexError (tex++fmt) (objDir </> base <.> "log")} $+ "texify --quiet " ++ (base <.> "tex")+ copyFile (objDir </> base <.> "dvi") (srcDir </> base <.> "dvi")+++fixLineEndings file = do+ src <- readFile' file+ writeFile file $ filter (/= '\r') src++for x = flip mapM x++files dir ext = do+ b <- doesDirectoryExist dir+ s <- if b then getDirectoryContents dir else return []+ s <- return $ filter ((==) ('.':ext) . takeExtension) s+ return $ map (dir </>) s++++data System = System+ {cleanup :: IO ()+ ,errorMsg :: String -> IO ()+ ,curDir :: FilePath}++system_ sys cmd = do+ orig <- getCurrentDirectory+ bracket_ (setCurrentDirectory (curDir sys)) (setCurrentDirectory orig) $ do+ putStrLn cmd+ res <- system $ cmd ++ " > stdout.txt 2> stderr.txt"+ out <- readFile "stdout.txt"+ err <- readFile "stderr.txt"+ putStr $ out ++ err+ when (res /= ExitSuccess) $ do+ cleanup sys+ errorMsg sys out+ putStrLn "System command failed! Press enter to continue"+ getChar+ exitWith (ExitFailure 1)+++(<==) :: FilePath -> [FilePath] -> (FilePath -> FilePath -> IO ()) -> IO ()+(<==) to froms@(from:_) action = do+ b <- doesFileExist to+ rebuild <- if not b then return True else do+ from2 <- liftM maximum $ mapM getModificationTime froms+ to2 <- getModificationTime to+ return $ to2 < from2+ when rebuild $ do+ putStrLn $ "Building: " ++ to+ action from to
+ src/Paper/Push.hs view
@@ -0,0 +1,33 @@++module Paper.Push(push) where++import Control.Monad+import Data.List+import Data.Maybe+import System.Cmd+import System.FilePath+++push :: FilePath -> IO ()+push darcs = do+ src <- readFile $ darcs </> "_darcs" </> "prefs" </> "repos"+ () <- length src `seq` return ()+ let r = pick $ lines src+ when (isNothing r) $ error "No non-http repos in the prefs/repos file"++ putStrLn $ "Pushing to " ++ show (fromJust r) ++ "..."+ system $ "darcs push --no-set-default \"" ++ fromJust r ++ "\""+ return ()+++-- pick the ssh address+pick :: [String] -> Maybe String+pick xs = listToMaybe $ ssh ++ [b ++ drop (length a) h | h <- http, (a,b) <- mapping, a `isPrefixOf` h]+ where (http,ssh) = partition ("http://" `isPrefixOf`) xs+++mapping = [("http://www.cs.york.ac.uk/fp/darcs/","ndm@community.haskell.org:/home/ndm/darcs/")+ ,("http://community.haskell.org/~ndm/darcs/","ndm@community.haskell.org:/home/ndm/darcs/")+ ,("http://code.haskell.org/","ndm@code.haskell.org:/srv/code/")+ ]+
+ src/Paper/Ref.hs view
@@ -0,0 +1,50 @@++module Paper.Ref(ref) where++import Control.Monad+import Data.Char+import Data.List+import qualified Data.Map as Map+import Paper.Util.Error++data Ref = Ref FilePath Int Bool -- True = ref, False = label+type Refs = Map.Map String [Ref]++addRef m (s,ref) = Map.insertWith (++) s [ref] m+++ref :: [FilePath] -> IO ()+ref files = do+ r <- mapM readRefs files+ let errs = checkRefs $ foldl addRef Map.empty $ concat r+ sequence errs+ when (not $ null errs) $+ error $ "Error: " ++ show (length errs) ++ " references failed"+ putStrLn "All references are correct"+++readRefs :: FilePath -> IO [(String,Ref)]+readRefs file = liftM (f 1) $ readFile file+ where+ f n ('\n':xs) = f (n+1) xs+ f n ('\\':'r':'e':'f':xs) = g n True xs+ f n ('\\':'l':'a':'b':'e':'l':xs) = g n False xs+ f n (x:xs) = f n xs+ f n [] = []++ g n b ('{':xs) | "}" `isPrefixOf` post = (pre, Ref file n b) : f n (tail post) + where (pre,post) = span (`notElem` "\n}") xs+ g n b (x:xs) | isSpace x || x == '{' =+ error $ file ++ "(" ++ show n ++ ") Unrecognised label: " ++ take 25 xs+ g n b xs = f n xs+++checkRefs :: Refs -> [IO ()]+checkRefs = concatMap f . Map.toList+ where+ f (s,xs) | null b = err (head a) "Reference used but not defined"+ | length b > 1 = err (head b) "Reference defined multiple times"+ | otherwise = []+ where+ (a,b) = partition (\(Ref a b c) -> c) xs+ err (Ref file line _) msg = [errorMsg file line msg ("{" ++ s ++ "}")]
+ src/Paper/Sync.hs view
@@ -0,0 +1,35 @@++module Paper.Sync(sync) where++import Control.Monad+import Data.List+import System.Cmd+import System.Directory+import System.FilePath+import Paper.Util.IO+++sync :: FilePath -> IO ()+sync dir = do+ b <- doesDirectoryExist $ dir </> "_darcs"+ if b then check dir else do+ xs <- getDirectoryContents dir+ xs <- return [dir </> x | x <- xs, not $ all (== '.') x]+ flip mapM_ xs $ \x -> do+ b <- doesDirectoryExist x+ when b $ sync x+++check :: FilePath -> IO ()+check dir = do+ b1 <- run "darcs whatsnew --summary" "No changes!"+ b2 <- run "darcs send --dry-run --all" "No recorded local changes to send!"+ let msg = ["changes"|b1] ++ ["patches"|b2]+ when (msg /= []) $+ putStrLn $ unwords $ [takeFileName dir,"has"] ++ intersperse "and" msg+ where+ run cmd want = do+ let out = dir </> "paper_sync.tmp"+ system $ cmd ++ " --repodir=\"" ++ dir ++ "\" > \"" ++ out ++ "\""+ src <- readFile' out+ return $ want `notElem` lines src
+ src/Paper/Talk.hs view
@@ -0,0 +1,175 @@++module Paper.Talk(talk) where++import Control.Monad+import Data.List+import Data.Char+import Data.Maybe+import Paper.Util.CmdNumber+import Paper.Util.String+import System.FilePath+import System.Cmd+import System.Directory+++talk :: FilePath -> [FilePath] -> [String] -> IO ()+talk objDir files args = do+ rPtts <- findExecutable "ptts"+ when (isNothing rPtts) $+ error $ "Can't find ptts executable, please install"++ rLame <- findExecutable "lame"+ when (isNothing rLame) $+ putStrLn "Warning: lame not found, .wav files will be generated"++ mapM_ (f (isJust rLame)) files+ where+ permit = cmdNumber args++ f lame file = do+ src <- readFileSpeach file+ mapM_ (g lame file) $ zip [0..] src++ g lame file (n,s) | not $ permit n = return ()+ | otherwise = do+ let name ext = objDir </> (takeBaseName file ++ "_" ++ show n) <.> ext+ writeFile (name "txt") s+ putStrLn $ "Writing " ++ name "wav"+ system $ "ptts -voice \"Microsoft Mary\" -w \"" ++ name "wav" ++ "\" < \"" ++ name "txt" ++ "\""+ putStrLn $ "Writing " ++ name "mp3"+ system $ "lame -b 64 --quiet \"" ++ name "wav" ++ "\" \"" ++ name "mp3" ++ "\""+ removeFile (name "wav")+++---------------------------------------------------------------------+-- TEXT PROCESSING BIT+++-- read a file and split it into text chunks+readFileSpeach :: FilePath -> IO [String]+readFileSpeach file = do+ src <- readFile file+ return $ map (flatten . text) $ divide src+++-- compress \n\n\n -> \n+-- " " -> " "+-- " \n" -> "\n"+flatten = f . g+ where+ g (' ':'\n':xs) = g ('\n':xs)+ g ('\n':' ':xs) = g ('\n':xs)+ g (' ':' ':xs) = g (' ':xs)+ g (x:xs) = x : g xs+ g [] = []++ f ('\n':'\n':'\n':xs) = f ('\n':'\n':xs)+ f (x:xs) = x : f xs+ f [] = []+++divide = splitStr "\\section"+++text :: String -> String++text ('%':xs) = text $ dropWhile (/= '\n') xs+text ('\\':'%':xs) = '%' : text xs++text xs | "|(:)|" `isPrefixOf` xs = "cons" ++ text (drop 5 xs)+text xs | "|[]|" `isPrefixOf` xs = "nil" ++ text (drop 4 xs)+text (x:xs) | x `elem` "|$" = case lex xs of+ [(s,y:xs)] | x == y -> s ++ text xs+ _ -> "expression" ++ text (drop 1 $ dropWhile (/= x) xs)+text ('\\':'$':xs) = '$' : text xs++text ('`':'`':xs) = '\"' : text xs+text ('\'':'\'':xs) = '\"' : text xs+text ('`':xs) = '\'' : text xs++-- change some constructs to insert pauses+text (' ':'-':'-':xs) = " ; " ++ text (dropWhile (== '-') xs)+text ('(':xs) = " ; " ++ text xs+text (')':xs) = " ; " ++ text xs++-- Given an environment there are several behaviours:+-- replace the entire environment with some alternative text (figure, code)+-- drop the begin/end bits+text ('\\':xs) | "begin" `isPrefixOf` xs =+ case lookup a rep of+ Nothing -> text b+ Just y -> y ++ "\n\n" ++ text (skipTilEnd a b)+ where+ (a,b) = spanCurly $ drop 5 xs+ rep = [("figure",""),("table",""),("comment","")+ ,("tabular","Table."),("verbatim","Code."),("code","Code.")]++text ('\\':xs) + -- lists+ | a == "item" && "[" `isPrefixOf` b =+ let (c,d) = break (== ']') (tail b) in+ "\n" ++ text c ++ [':' | not $ ":" `isSuffixOf` c] ++ text (dropWhile (== ']') d)+ | a == "item" = "\nBullet: " ++ text b++ -- accents+ | a == "o" = 'o' : text b+ | null a && "\"" `isPrefixOf` b = text (tail b)++ -- special+ | a == "ref" = "1" ++ text (skipCurly b)+ | null a && "[" `isPrefixOf` b = "Code." ++ text (dropUntilStr "\\]" b)+ | a == "url" = "url" ++ text (skipCurly b)+ | a == "citet" = "paper" ++ text (skipCurly b)+ | a == "S" = "section " ++ text b++ | otherwise = text $ skippy (fromMaybe "" $ lookup a skip) b+ where+ (a,b2) = span isAlpha xs+ b = if "*" `isPrefixOf` b2 then tail b2 else b2++text (x:xs) | x `elem` "{}" = text xs+text (x:xs) = x : text xs+text [] = []++++skip = let (*) = (,) in+ map (* "[{")+ ["end","label","cite","vspace","hspace","footnote","documentclass"+ ,"include","title","author","institute","caption","usepackage"+ ,"copyrightyear","copyrightdata","titlebanner","title","subtitle"+ ,"bibliographystyle","citep"]+ ++ ["newenvironment" * "{{{", "newcommand" * "{[{", "conferenceinfo" * "{{"+ ,"authorinfo" * "{{{","category" * "{{{", "terms" * "\n\n", "keywords" * "\n\n"+ ,"setcounter" * "{{"]+++skippy ('{':xs) t = skippy xs $ skipCurly t+skippy ('[':xs) t = skippy xs $ skipSquare t+skippy ('\n':xs) t = skippy xs $ drop 1 $ dropWhile (/= '\n') t+skippy [] t = t++++-- "{foo}test" = ("foo","test")+-- "test = ("","test")+spanCurly = spanPair '{' '}'+skipCurly = snd . spanCurly++skipSquare = snd . spanPair '[' ']'+++spanPair start stop xs | [start] `isPrefixOf` rest = f 1 $ drop 1 rest+ where+ rest = dropWhile isSpace xs+ f 1 (x:xs) | x == stop = ([],xs)+ f n (x:xs) | x == stop = g (n-1)+ | x == start = g (n+1)+ | otherwise = g n+ where g n = let (a,b) = f n xs in (x:a,b)+ f n [] = ([],[])+spanPair start stop xs = ([],xs)++++skipTilEnd s = dropUntilStr ("\\end{" ++ s ++ "}")
+ src/Paper/Todo.hs view
@@ -0,0 +1,31 @@++module Paper.Todo(todo) where++import Control.Monad+import Data.Char+import Paper.Util.Error+++todo :: [FilePath] -> IO ()+todo files = do+ errs <- liftM concat $ mapM readTodos files+ sequence errs+ when (not $ null errs) $+ error $ "Error: " ++ show (length errs) ++ " todo commands found"+ putStrLn "No todo commands found"+++readTodos :: FilePath -> IO [IO ()]+readTodos file = liftM (f 1) $ readFile file+ where+ f n ('\n':xs) = f (n+1) xs+ f n ('\\':t:'o':'d':'o':x:xs)+ | toLower t == 't' && not (isAlpha x) && x /= '}'+ = errorMsg file n "\\todo" msg : f n xs+ where msg = g $ dropWhile isSpace (x:xs)+ f n (x:xs) = f n xs+ f n [] = []++ g ('{':xs) = "{" ++ takeWhile (`notElem` "\n}") xs ++ "}"+ g _ = ""+
+ src/Paper/Util/CmdNumber.hs view
@@ -0,0 +1,18 @@++module Paper.Util.CmdNumber(cmdNumber) where++import Data.Char+import Data.Ix+import Paper.Util.String+++cmdNumber :: [String] -> Int -> Bool+cmdNumber args | null nums = \n -> True+ | otherwise = \n -> any (`inRange` n) nums+ where+ nums :: [(Int,Int)]+ nums = map f $ filter (isDigit . head) args++ f x = (read a+ ,case b of {[] -> read a; ".." -> maxBound; _ -> read $ drop 2 b})+ where (a,b) = breakStr ".." x
+ src/Paper/Util/Error.hs view
@@ -0,0 +1,20 @@++module Paper.Util.Error(errorMsg, errorDie) where++import System.FilePath+++errorMsg :: FilePath -> Int -> String -> String -> IO ()+errorMsg = errorWith putStrLn+++errorDie :: FilePath -> Int -> String -> String -> a+errorDie = errorWith error+++errorWith :: (String -> a) -> FilePath -> Int -> String -> String -> a+errorWith action file line short long = action $+ takeFileName file +++ (if line == 0 then "" else "(" ++ show line ++ ")") +++ " " ++ short +++ (if null long then "" else ": " ++ take 25 long)
+ src/Paper/Util/FileData.hs view
@@ -0,0 +1,83 @@++module Paper.Util.FileData(+ FileData(..), getFileData+ ) where++import Control.Monad+import Data.List+import System.Directory+import System.FilePath+++data FileData = FileData+ {directory :: FilePath -- ^ All files must reside in one directory+ ,mainFile :: FilePath -- ^ The main file+ ,argFiles :: [FilePath] -- ^ Files given on the command line+ ,allFiles :: [FilePath] -- ^ All files in the directory+ ,flags :: [String] -- ^ Any flags given+ ,darcs :: FilePath -- ^ The location of the _darcs directory+ }+ deriving Show++++getFileData :: [String] -> IO FileData+getFileData args = do+ let (opt,files) = partition ("-" `isPrefixOf`) args+ files <- if null files then liftM (:[]) getCurrentDirectory else return files+ (dirs,explicit,implicit) <- liftM unzip3 $ mapM f files+ (explicit,implicit) <- return (concat explicit, concat implicit)++ when (length (nub dirs) > 1) $+ error "All files must be from the same directory"++ let snub = nub . sort+ nullErr x | null explicit = error $ "Error: No Latex files found in " ++ show (head dirs)+ | otherwise = x++ let dir = head dirs+ darcs <- getDarcs dir+ + return $ FileData+ dir+ (nullErr $ head $ explicit)+ (nullErr $ snub $ explicit)+ (nullErr $ snub $ explicit ++ implicit)+ (map tail opt)+ darcs+ where+ -- return (directory, explicit, implicit)+ f file = do+ file <- canonicalizePath file+ bDir <- doesDirectoryExist file+ bFile <- doesFileExist file+ if bDir then getDir file+ else if bFile then getFile file+ else error $ "Error: Could not find file " ++ show file++++getDir dir = do+ files <- getDirectoryContents dir+ files <- return $ filter ((==) ".tex" . takeExtension) files++ -- now pick the main file+ let mainFile = snd $ maximum [(rank x, x) | x <- files]+ dirs = reverse $ splitDirectories dir+ rank x = liftM negate $ findIndex (== dropExtension x) dirs+ return (dir, [mainFile | not $ null files] ++ files, [])+++getFile file = do+ (a,b,[]) <- getDir $ takeDirectory file+ return (a, [file], b)+++getDarcs = f . reverse . map joinPath . tail . inits . splitDirectories+ where+ f [] = return $ error "Darcs repo not found"+ f (x:xs) = do+ b <- doesDirectoryExist (x </> "_darcs")+ if b then return $ dropTrailingPathSeparator x else f xs++
+ src/Paper/Util/IO.hs view
@@ -0,0 +1,11 @@++module Paper.Util.IO where++import System.IO++readFile' x = do+ h <- openFile x ReadMode+ s <- hGetContents h+ seq (length s) $ do+ hClose h+ return s
+ src/Paper/Util/String.hs view
@@ -0,0 +1,30 @@++module Paper.Util.String where++import Data.Char+import Data.List+++dropUntilStr s xs | s `isPrefixOf` xs = drop (length s) xs+dropUntilStr s (x:xs) = dropUntilStr s xs+dropUntilStr s [] = []++++breakStr :: String -> String -> (String,String)+breakStr s xs | s `isPrefixOf` xs = ("",xs)+breakStr s (x:xs) = (x:a,b)+ where (a,b) = breakStr s xs+breakStr s [] = ([],[])++++splitStr s [] = []+splitStr s xs = a : case splitStr s (drop (length s) b) of+ [] -> []+ x:xs -> (s++x):xs+ where (a,b) = breakStr s xs++++trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+ src/Paper/WordCount.hs view
@@ -0,0 +1,55 @@++module Paper.WordCount(wordCountNorm, wordCountMin) where++import Data.Char+import Data.List+++-- Do not follow \include{} links+wordCount :: ([String] -> Int) -> FilePath -> IO Int+wordCount f file = return . f . dropComments . lines =<< readFile file+++dropComments :: [String] -> [String]+dropComments (x:xs) | isBeginComment x = drop 1 $ dropWhile (not . isEndComment) xs+dropComments (x:xs) = f x : dropComments xs+ where+ f ('\\':'%':xs) = '\\':'%':f xs+ f ('%':xs) = []+ f (x:xs) = x : f xs+ f [] = []+dropComments [] = []++isBeginComment = isPrefixOf "\\begin{comment}"+isEndComment = isPrefixOf "\\end{comment}"+++wordCountNorm = wordCount wordsBlock+ ++wordsBlock :: [String] -> Int+wordsBlock = sum . map f+ where+ f ('\\':xs) = f (dropWhile isAlpha xs)+ f (x:xs) | isAlpha x = 1 + f (dropWhile (not . isSpace) xs)+ f (x:xs) = f xs+ f [] = 0+++wordCountMin = wordCount (wordsBlock . map dropDollar . dropEqn)++dropDollar ('\\':'$':xs) = '\\':'$':dropDollar xs+dropDollar ('$':xs) = dropDollar $ drop 1 $ dropWhile (/= '$') xs+dropDollar (x:xs) = x : dropDollar xs+dropDollar [] = []++dropEqn (x:xs) | "\\beqa" `isPrefixOf` x = dropEqn $ f (x:xs)+ where+ f (x:xs) | "\\eeqa" `isPrefixOf` x = drop 5 x : xs+ f ((x:xs):ys) = f (xs:ys)+ f ([]:ys) = f ys+ f [] = []+dropEqn ((x:xs):ys) = (x:a):b+ where (a:b) = dropEqn (xs:ys)+dropEqn ([]:ys) = [] : dropEqn ys+dropEqn [] = []
+ src/Travis.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}++module Travis(run) where++import Control.Monad+import Data.Char+import Data.List.Extra hiding (list)+import System.Directory+import System.IO.Extra+import System.FilePath+import System.Time.Extra+import Text.JSON+import Arguments+import Util+++run :: Arguments -> Maybe (IO ())+run Travis{..} = Just $ do+ dir <- getCurrentDirectory+ let name = takeFileName dir+ createDirectoryIfMissing True "dist"+ appendFile "dist/travis" ""+ rel <- findRelevant+ found <- findEntries++ let more [] = more . list =<< wgetJSON wait ("https://api.travis-ci.org/repos/ndmitchell/" ++ name ++ "/builds")+ more xs = let i = read (last xs ! "number") in if i == 1 then return xs else do+ new <- wgetJSON wait $ "https://api.travis-ci.org/repos/ndmitchell/" ++ name ++ "/builds?after_number=" ++ show i+ more $ xs ++ list new+ builds <- more []+ + forM_ (reverse builds) $ \x -> do+ let num = x ! "number"+ let id = show (x ! "id" :: Int)+ let time = x ! "started_at"+ when (num `notElem` found && x ! "result" /= JSNull) $ do+ build <- wgetJSON wait $ "https://api.travis-ci.org/builds/" ++ id+ sleep 2++ let jobs = map (\x -> show (x ! "id" :: Int)) $ build ! "matrix"+ forM_ jobs $ \i -> do+ putChar '.'+ src <- wget wait $ "https://s3.amazonaws.com/archive.travis-ci.org/jobs/" ++ i ++ "/log.txt"+ let want = [x | x <- lines $ reps '\r' '\n' src, any (`isPrefixOf` x) rel]+ addEntry num time want+ when (null jobs) $ addEntry num time []+ putStrLn "\nDone!"+run _ = Nothing+++findRelevant :: IO [String]+findRelevant = do+ src <- fmap lines $ readFile ".travis.yml"+ src <- return $ takeWhile (isPrefixOf " ") $ drop 1 $ dropWhile (not . isPrefixOf "relevant") src+ when (null src) $ error "No relevant lines in the travis file"+ return $ map (dropWhile isSpace) src+++findEntries :: IO [String]+findEntries = do+ x <- readFile "dist/travis"+ return [takeWhile isDigit x | x <- lines x, Just x <- ["BUILD " `stripPrefix` x]]+++addEntry :: String -> String -> [String] -> IO ()+addEntry num time xs = appendFile "dist/travis" $ unlines $ ("BUILD " ++ num ++ " " ++ time) : xs+++wget :: Double -> String -> IO String+wget wait x = withTempFile $ \t -> do+ putStr $ "wget " ++ x ++ " ... "+ cmd $ "wget " ++ x ++ " -O" ++ t ++ " --no-check-certificate --quiet"+ res <- readFile' t+ putStrLn "done"+ sleep wait+ return res+++wgetJSON :: Double -> String -> IO JSValue+wgetJSON wait x = fmap (ok . decode) $ wget wait x++ok (Ok x) = x+ok (Error x) = error x++(!) :: JSON a => JSValue -> String -> a+(!) (JSObject mp) k = ok $ valFromObj k mp++list :: JSValue -> [JSValue]+list (JSArray x) = x
+ src/Util.hs view
@@ -0,0 +1,34 @@++module Util(cmd, cmdCode, cmdOut, cmdCodeOutErr) where++import Control.Monad+import System.Exit+import System.IO.Extra+import System.Cmd+++cmdCodeOutErr :: String -> IO (ExitCode, String, String)+cmdCodeOutErr x = withTempFile $ \stderr -> withTempFile $ \stdout -> do+ res <- system $ x ++ " > " ++ stdout ++ " 2> " ++ stderr+ err <- readFile' stderr+ out <- readFile' stdout+ return (res,out,err)++cmdOut :: String -> IO String+cmdOut x = withTempFile $ \stdout -> do+ res <- system $ x ++ " > " ++ stdout+ out <- readFile' stdout+ when (res /= ExitSuccess) $+ error $ "Failed in system command: " ++ x+ return out+++cmdCode :: String -> IO ExitCode+cmdCode = system+++cmd :: String -> IO ()+cmd x = do+ res <- system x+ when (res /= ExitSuccess) $+ error $ "Failed in system command: " ++ x