regex-examples-1.0.2.0: examples/re-top.lhs
top: Calculating league table variations for the Premier League
===============================================================
This program calculates top-n league tables for the Premier League based
on this [openfootball
data](https://github.com/cdornan/eng-england/tree/corrections).
The program has enough data to self-test but to generate any useful data
you will need to clone [this
repo](git@github.com:cdornan/eng-england.git) into the parent directory
and checkout the 'corrections' branch.
\begin{code}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Main(main) where
import qualified Control.Monad as M
import Data.Functor.Identity
import qualified Data.HashMap.Lazy as HML
import qualified Data.List as L
import Data.Maybe
import qualified Data.Monoid as M
import Data.Ord
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time
import Prelude.Compat
import qualified Shelly as SH
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import TestKit
import Text.RE.Summa
import qualified Text.RE.TDFA as TDFA
import Text.RE.TDFA.Text
import Text.Read
\end{code}
The CLI parser yields a list of jobs to generate or check various
league tables.
\begin{code}
main :: IO ()
main = parseCLI >>= mapM_ job
\end{code}
Data Types
----------
A Job contains everything we need to generate a league table, and what
to do with it.
\begin{code}
data Job =
Job
{ jobTitle :: T.Text -- ^ title for the table
, jobSize :: Maybe Int -- ^ a full table or a top-n table
, jobInputs :: [FilePath] -- ^ the files containing the game data
, jobIsTest :: Bool -- ^ are we testing o/p or writing it
, jobIsHtml :: Bool -- ^ are we generating HTML from markdown
, jobOutput :: FilePath -- ^ where is the output
}
deriving (Show)
\end{code}
A match result lists the data in the usual order:
<home-team> <home-score> <away-score> <away-team>
\begin{code}
data Game = Game Team Int Int Team
deriving (Eq,Ord,Read,Show)
\end{code}
A league table is a list of teams and their results with the ordering
on everything is arranged so that the list can be sorted with the
default `Ord` ordering to arrange the table according to PL conventions.
\begin{code}
newtype Table = Table { getTable :: [(Results,Team)] }
deriving (Show)
\end{code}
Teams are just Text containing the names used by the openfootball data.
\begin{code}
type Team = T.Text
\end{code}
Results contain everything we need to generate a league table.
\begin{code}
data Results =
Results
{ resultsGamesPlayed :: Int
, resultsGamesWon :: Int
, resultsGoalsFor :: Int
, resultsGoalsAgainst :: Int
, resultsPointsScored :: Int
}
deriving (Show)
\end{code}
These vectors have expected zeros and sums.
\begin{code}
#if __GLASGOW_HASKELL__ >= 804
instance Semigroup Results where
(<>) = mappend_r
#endif
instance Monoid Results where
mempty = mempty_r
mappend = mappend_r
\end{code}
\begin{code}
mappend_r :: Results -> Results -> Results
mappend_r (Results gp1 gw1 gf1 ga1 ps1)
(Results gp2 gw2 gf2 ga2 ps2) =
Results (gp1+gp2)
(gw1+gw2)
(gf1+gf2)
(ga1+ga2)
(ps1+ps2)
mempty_r :: Results
mempty_r = Results 0 0 0 0 0
\end{code}
PL results are ordered by (points,goal-difference,goals-scored).
\begin{code}
instance Ord Results where
compare = comparing $ \Results{..} ->
( resultsPointsScored
, resultsGoalsFor - resultsGoalsAgainst
, resultsGoalsFor
)
instance Eq Results where
(==) x y = compare x y == EQ
\end{code}
Executing Jobs
--------------
\begin{code}
job :: Job -> IO ()
job jb = top jb <$> input jb >>= output jb
\end{code}
Compute a Table from Game data according to the jobSize parameter.
\begin{code}
top :: Job -> [Game] -> Table
top Job{..} mtchs = case jobSize of
Nothing -> full_tbl
Just n -> aggregate $
filterGames (topTeams n full_tbl) mtchs
where
full_tbl = aggregate mtchs
\end{code}
Calculate the top n teams in a table.
\begin{code}
topTeams :: Int -> Table -> [Team]
topTeams n = map snd . take n . getTable
\end{code}
Filter game data to only include games between the listed teams.
\begin{code}
filterGames :: [Team] -> [Game] -> [Game]
filterGames tms = filter $ \(Game h _ _ a) ->
h `elem` tms && a `elem` tms
\end{code}
Aggregate game data into a table.
\begin{code}
aggregate :: [Game] -> Table
aggregate mtchs = sortResults $
map homeResults mtchs ++ map awayResults mtchs
\end{code}
Generate the results for the home team from a Game result.
\begin{code}
homeResults :: Game -> (Results,Team)
homeResults (Game h hs as _) = flip (,) h
Results
{ resultsGamesPlayed = 1
, resultsGamesWon = wins $ hs - as
, resultsGoalsFor = hs
, resultsGoalsAgainst = as
, resultsPointsScored = points $ hs - as
}
\end{code}
Generate the results for the away team from a Game result.
\begin{code}
awayResults :: Game -> (Results,Team)
awayResults (Game _ hs as a) = flip (,) a
Results
{ resultsGamesPlayed = 1
, resultsGamesWon = wins $ as - hs
, resultsGoalsFor = as
, resultsGoalsAgainst = hs
, resultsPointsScored = points $ as - hs
}
\end{code}
Calculate the points accruing to a team from their goal difference
for a game.
\begin{code}
points :: Int -> Int
points gd = case compare gd 0 of
LT -> 0
EQ -> 1
GT -> 3
\end{code}
Calculate the number of wins accruing to a team (0 or 1) from their goal
for a game.
\begin{code}
wins :: Int -> Int
wins gd = case gd>0 of
True -> 1
False -> 0
\end{code}
Collate a list of results into a table.
\begin{code}
sortResults :: [(Results,Team)] -> Table
sortResults =
Table
. L.sortBy (flip $ comparing fst)
. groupSortBy (comparing snd) grp
where
grp (r,t) ps = (r',t)
where
r' = mconcat $ r : map fst ps
\end{code}
input
-----
Parse openfootball data into Game data, eliminating duplicate results.
(For `g1` and `g2` to be recognised as a duplicate, it must be true that
`g1==g2`.)
\begin{code}
input :: Job -> IO [Game]
input Job{..} =
groupSort const . parseGames . T.concat <$> mapM T.readFile jobInputs
\end{code}
parseGames
----------
The Game parser has three variants that should all be equivalent.
\begin{code}
parseGames :: T.Text -> [Game]
parseGames = case PrimParseGames of
SimpleParseGames -> simpleParseGames
FunParseGames -> funParseGames
PrimParseGames -> primParseGames
data ParseGames = SimpleParseGames | FunParseGames | PrimParseGames
\end{code}
<h3>simpleParseGames</h3>
Here we apply the `gameEdit` `SearchReplace` editor to:
1. recognise the lines that contain the match results data and
2. transform the lines into Haskell `Game` format which can be
parsed by `readText`.
The `edit` function is a simple specialisation of the `regex` `sed'`
function (defined below) that deletes every line in the file that edits
every line in the file according to the given `SearchReplace`, deleting
all other lies.
\begin{code}
simpleParseGames :: T.Text -> [Game]
simpleParseGames = map readText . T.lines . edit gameEdit
\end{code}
The `[ed|` ... `///` ... `|]` `SearchReplace` editors for recognizing
line containing matchresults and converting them to Haskell-format
`Game` data come in two variants that should be equivalent.
\begin{code}
gameEdit :: SearchReplace RE T.Text
gameEdit = case MacrosGameEdit of
SimpleGameEdit -> simpleGameEdit
MacrosGameEdit -> macrosGameEdit
data GameEdit = SimpleGameEdit | MacrosGameEdit
\end{code}
<h4>simpleGameEdit</h4>
\begin{code}
simpleGameEdit :: SearchReplace RE T.Text
simpleGameEdit =
[ed|^ *${ht}([A-Za-z][a-zA-Z ]*[A-Za-z]) +${hs}([0-9]+)-${as}([0-9]+) +(\([^)]+\) *)?${at}([A-Za-z][a-zA-Z ]*[A-Za-z]) *(@.*)?$///Game "${ht}" ${hs} ${as} "${at}"|]
\end{code}
<h4>simpleGameEdit</h4>
\begin{code}
macrosGameEdit :: SearchReplace RE T.Text
macrosGameEdit =
[ed_|^ *${ht}(@{team}) +${hs}([0-9]+)-${as}([0-9]+) +(\([0-9]+-[0-9]+\) *)?${at}(@{team}) *(@.*)?$///Game "${ht}" ${hs} ${as} "${at}"|] macs
\end{code}
\begin{code}
macs :: Macros RE
macs = makeMacros env
env :: MacroEnv
env = makeEnv [(,) "team" teamMacro] TDFA.preludeEnv
\end{code}
\begin{code}
teamMacro :: MacroEnv -> MacroID -> MacroDescriptor
teamMacro ev mid =
runTests TDFA.regexType Just (map dup samples) ev mid
MacroDescriptor
{ macroSource = RegexSource "([a-zA-Z]+ ?)*[A-Za-z]" -- the RE to be substituted for the macro
, macroSamples = samples -- list of strings that should match the above macro RE
, macroCounterSamples = counter_samples -- list of strings that should **not** match the above macro RE
, macroTestResults = [] -- for bookkeeping
, macroParser = Nothing -- no parser needed for this one!
, macroDescription = "team names: alphabetic characters interspersed with spaces"
}
where
samples =
[ "Chelsea FC"
, "West Bromwich Albion"
, "AFC Bournemouth"
, "F"
, "AB"
, "A B"
, "AA B"
]
counter_samples =
[ "Arsenal FC "
, " Liverpool FC"
, "West Bromwich Albion"
, "F2"
, ""
]
dup x = (x,x)
\end{code}
\begin{code}
listMacros :: IO ()
listMacros = do
hPutStr stderr $ formatMacroTable TDFA.regexType env
ok <- testMacroEnv "macros" TDFA.regexType env
M.when (not ok) $ exitWith $ ExitFailure 1
\end{code}
<h3>funParseGames</h3>
Here we use the `regex` `grepFilter` to extract all of the lines that
match our `rex` RE for detecting match-result data and assemble the
`Game` data directly by extracting the `ht`, `hs`, `as` and `at`
fields from the matched result.
\begin{code}
funParseGames :: T.Text -> [Game]
funParseGames txt =
[ Game ( mtch !$$ [cp|ht|])
(readText $ mtch !$$ [cp|hs|])
(readText $ mtch !$$ [cp|as|])
( mtch !$$ [cp|at|])
| Line{..} <- grepFilter rex txt
, [mtch] <- [allMatches getLineMatches]
]
\end{code}
The RE for merely recognising lines that contain match results in the
input data come in two variants. We either extract the RE from the above
`SearchReplace` template or rebuild the `[re|` ... `]`. (They should of
course be equivalent.)
\begin{code}
rex :: RE
rex = case Direct of
Direct ->
[re_|^ *${ht}(@{team}) +${hs}([0-9]+)-${as}([0-9]+) +(\([0-9]+-[0-9]+\) *)?${at}(@{team}) *(@.*)?$|] macs
Recycle ->
getSearch gameEdit
data REX = Direct | Recycle
\end{code}
<h3>primParseGames</h3>
This variant of `funParseGames` uses `T.lines` and `?=~` instead of
`grepFilter`.
\begin{code}
primParseGames :: T.Text -> [Game]
primParseGames txt =
[ Game ( mtch !$$ [cp|ht|])
(readText $ mtch !$$ [cp|hs|])
(readText $ mtch !$$ [cp|as|])
( mtch !$$ [cp|at|])
| mtch <- map (?=~ rex) $ T.lines txt
, matched mtch
]
\end{code}
output
------
Write out/test the Table according to the Job output parameters.
\begin{code}
output :: Job -> Table -> IO ()
output jb@Job{..} tbl = case jobIsTest of
True -> test_it =<< formatTable jb tbl
False -> case jobOutput of
"-" -> T.putStr =<< formatTable jb tbl
fp -> T.writeFile fp =<< formatTable jb tbl
where
test_it txt = do
txt' <- T.readFile jobOutput
case txt == txt' of
True -> putStrLn "OK"
False -> do
putStrLn "Test Failed"
exitWith $ ExitFailure 1
\end{code}
Generate the markdown for a table and optionally use Pandoc to generate
the Html.
\begin{code}
formatTable :: Job -> Table -> IO T.Text
formatTable Job{..} (Table ps) = to_html $ T.unlines $
[ "# " M.<> jobTitle
, ""
, mk_row header_row
, mk_row divider_row
] ++ map mk_row (zipWith gen_row [1..] ps)
where
divider_row = map (T.map (const '-')) header_row
header_row = map column_header [minBound..maxBound]
mk_row :: [T.Text] -> T.Text
mk_row = T.intercalate "|"
gen_row :: Int -> (Results,Team) -> [T.Text]
gen_row i (r,t) = map (gen_field i t r) [minBound..maxBound]
gen_field :: Int -> Team -> Results -> Col -> T.Text
gen_field i tm Results{..} col = lj $ case col of
Position -> showText i
Club -> tm
Played -> showText resultsGamesPlayed
Won -> showText resultsGamesWon
Drawn -> showText games_drawn
Lost -> showText $ resultsGamesPlayed -
(resultsGamesWon + games_drawn)
GF -> showText resultsGoalsFor
GA -> showText resultsGoalsAgainst
GD -> showText $ resultsGoalsFor -
resultsGoalsAgainst
Points -> showText resultsPointsScored
where
lj = T.justifyLeft wd ' '
wd = T.length $ column_header col
games_drawn = resultsPointsScored - win_points
win_points = resultsGamesWon * 3
to_html = case jobIsHtml of
True -> pandoc jobTitle
False -> return
data Col
= Position
| Club
| Played
| Won
| Drawn
| Lost
| GF
| GA
| GD
| Points
deriving (Bounded,Enum,Show)
column_header :: Col -> T.Text
column_header col = case col of
Position -> "Pos"
Club -> "Club "
_ -> T.justifyLeft 7 ' ' $ showText col
\end{code}
parseCLI
--------
The command line parser generates a list of league-table
generating/testing jobs for execution by the above `job`
action. Non-league-table-generating CLI commands like
`macros` for listing our RE table macros just do their
thing and return an empty list of jobs.
\begin{code}
parseCLI :: IO [Job]
parseCLI = do
args <- getArgs
case args of
[] -> listMacros >> testJob -- test with canned vectors
["test"] -> listMacros >> testJob -- "
["setup-test"] -> setupTestJob -- setup the test data, generating the golden data
["update"] -> updateIndex >> updateJobs -- update the website with latest data
["table",pth] -> discover pth Nothing -- write out a full league table
["table",pth,sz_s]
| Just sz <- readMaybe sz_s
-> discover pth $ Just sz -- write out a bounded league table
["macros"] -> listMacros >> return [] -- list the RE macros we are using to parse the data
_ -> do -- generate the usage message and fail
pn <- getProgName
hPutStr stderr $ prog pn
[ "[test]"
, "setup-test"
, "update"
, "table <path> [<size>]"
]
exitWith $ ExitFailure 1
where
prog pn as = unlines $ zipWith prog_ (pn : repeat pn') as
where
pn' = map (const ' ') pn
prog_ p a = unwords [p,a]
testJob, setupTestJob :: IO [Job]
testJob = testJob_ True
setupTestJob = testJob_ False
testJob_ :: Bool -> IO [Job]
testJob_ is_t = do
createDirectoryIfMissing True "data"
return
[ Job
{ jobTitle = "Premier League 2015-16: Top 7"
, jobSize = Just 7
, jobInputs =
[ "data/2015-16-premierleague.txt"
]
, jobIsTest = is_t
, jobIsHtml = False
, jobOutput = "data/league-table.md"
}
]
updateJobs :: IO [Job]
updateJobs = do
dy <- utctDay <$> getCurrentTime
return $ concat $ map (mk dy) updateJobSpecs
where
mk dy js@JobSpec{..} =
[ Job
{ jobTitle = T.unwords $
[ "Premier League " M.<> T.pack jsSeason
, maybe "" (\n->"Top " M.<> showText n M.<> " ") jsSize
, "[" M.<> showText dy M.<> "]"
]
, jobSize = jsSize
, jobInputs =
[ mkPath jsSeason "1-premierleague-i.txt"
, mkPath jsSeason "1-premierleague-ii.txt"
]
, jobIsTest = False
, jobIsHtml = is_html
, jobOutput = leagueTablesDir </> tableFile js is_html
}
| is_html <- [True,False]
]
updateIndex :: IO ()
updateIndex = pandoc title toc >>= T.writeFile index_file
where
toc = T.unlines $
[ "# " M.<> title
, ""
, mk_row ["Season", "Top-N", "Html", "Text"]
, mk_row ["------", "-----", "----", "----"]
] ++
[ mk_row
[ T.pack jsSeason
, maybe "all" showText jsSize
, lk "HTML" $ T.pack $ tableFile js True
, lk "Text" $ T.pack $ tableFile js False
]
| js@JobSpec{..} <- updateJobSpecs
]
title = "The League Tables"
index_file = leagueTablesDir </> "index.html"
mk_row = T.intercalate "|"
lk lab url = "[" M.<> lab M.<> "](" M.<> url M.<> ")"
tableFile :: JobSpec -> Bool -> FilePath
tableFile JobSpec{..} is_html = jsSeason ++ "-" ++ sze <.> ext
where
sze = maybe "all" (("top-"++).show) jsSize
ext = if is_html then "html" else "txt"
leagueTablesDir :: FilePath
leagueTablesDir = "docs/league-tables"
updateJobSpecs :: [JobSpec]
updateJobSpecs =
[ JobSpec sn mb
| sn <- ["2016-17","2015-16"]
, mb <- Nothing : map Just [6..10]
]
data JobSpec =
JobSpec
{ jsSeason :: String
, jsSize :: Maybe Int
}
deriving (Show)
discover :: FilePath -> Maybe Int -> IO [Job]
discover fp mb = do
inps <- dscvr candidates
return
[ Job
{ jobTitle = maybe fp_t mk_ttl $
matchedText $ fp_t ?=~ [re|[0-9]{4}-[0-9]{2}|]
, jobSize = mb
, jobInputs = inps
, jobIsTest = False
, jobIsHtml = False
, jobOutput = "-"
}
]
where
fp_t = T.pack fp
mk_ttl ssn = "Premier League " M.<> ssn
dscvr [] = error $ fp ++ ": no data found"
dscvr (fps:cds) = do
ok <- and <$> mapM doesFileExist fps
case ok of
True -> return fps
False -> dscvr cds
candidates =
[ [ fp
]
, [ data_dir </> fp </> "1-premierleague.txt"
]
, [ data_dir </> fp </> "1-premierleague-i.txt"
, data_dir </> fp </> "1-premierleague-ii.txt"
]
]
mkPath :: String -> String -> FilePath
mkPath ssn hlf = data_dir </> ssn </> hlf
data_dir :: FilePath
data_dir = "../eng-england"
\end{code}
Pandoc
------
Use Pandoc to generate a an Html file from a title and markdown text.
\begin{code}
pandoc :: T.Text -> T.Text -> IO T.Text
pandoc title txt = do
T.writeFile inp_file txt
T.writeFile mda_file $ T.unlines
[ "---"
, "title: " M.<> title
, "---"
]
fmap (const ()) $
SH.shelly $ SH.verbosely $
SH.run "pandoc"
[ "-f", "markdown+grid_tables"
, "-t", "html5"
, "-T", "regex"
, "-s"
, "-c", "bs.css"
, "-c", "styles.css"
, "-c", "tabular.css"
, "-o", T.pack out_file
, T.pack mda_file
, T.pack inp_file
]
T.readFile out_file
where
mda_file = "tmp/metadata.markdown"
inp_file = "tmp/pandoc-inp.md"
out_file = "tmp/pandoc-out.html"
\end{code}
Helpers
-------
The general helpers.
<h3>edit</h3>
The `edit` function is a simple specialisation of the `regex`
`sed'` function (defined below) that deletes every line in the file
that edits every line in the file according to the given `SearchReplace`
template, deleting all other lines. (It should probably be added to
regex.)
\begin{code}
edit :: SearchReplace RE T.Text -> T.Text -> T.Text
edit sr txt = runIdentity $ flip sed' txt $
Select
[ Template sr
, LineEdit [re|.*|] $ \_ _ -> return Delete
]
\end{code}
<h3>makeMacros and makeEnv</h3>
Construct a Macros table for compiling REs from a MacroEnv. (Something
similar should probably be added to regex.)
\begin{code}
makeMacros :: MacroEnv -> Macros RE
makeMacros ev = runIdentity $
mkMacros mk TDFA.regexType ExclCaptures ev
where
mk = maybe oops Identity .
TDFA.compileRegexWithOptions TDFA.noPreludeREOptions
oops = error "makeMacros: unexpected RE compilation error"
\end{code}
Construct a a `MacroEnv` from an association list of `MacroId` and
`MacroDescriptior` constructor functions and the base `MacroEnv`
(the macros that can be used inside the macros). (Something
similar should probably be added to regex.)
\begin{code}
makeEnv :: [(MacroID,MacroEnv -> MacroID -> MacroDescriptor)]
-> MacroEnv
-> MacroEnv
makeEnv al ev0 = ev
where
ev = ev0 `HML.union` HML.fromList
[ (mid, mk ev mid) | (mid,mk) <- al ]
\end{code}
<h3>showText and readText</h3>
Variants of the standard functions that operate over `Text`.
\begin{code}
showText :: Show a => a -> T.Text
showText = T.pack . show
readText :: Read a => T.Text -> a
readText = fromMaybe (error "readText") . readMaybe . T.unpack
\end{code}