-- | This module can take a parsed query, -- convert it into something it can use and -- execute it; resulting in a StatsTree, which -- can be printed by one of the Printers. -- module Query ( -- * Commands Commands, Queries, Query, SubQuery, View, Constraint, Group, Env, -- * Execute Queries interactiveQueries, commandsFromFile, commandsFromFiles, makeTree, QueryAST.E(..), emptyEnv, execute, execute' , module Printers ) where import Stats import Printers import QueryParser import QueryAST import Char import Data.List import Data.Function import qualified Data.Map as D import Maybe import Control.Applicative import System.Console.Editline.Readline import System.IO import System.Directory import System.FilePath import Text.Printf import Control.Monad type Commands = (Queries, Env) type ExecResult = ([StatsTree], Env) type Queries = [Query] type Env = D.Map String Query -- | Each query is represented by sub queries, -- each of which adds a new level to the tree. -- type Query = [SubQuery] type SubQuery = (Header, View, Constraint, Group) type Constraint = Stats -> (Stats, Stats) type View = EditStats -> String type Group = Stats -> [Stats] -- | Read commands from files in a given environment. -- commandsFromFiles :: Env -> [FilePath] -> IO (E Commands) commandsFromFiles env [] = return $ Ok ([], env) commandsFromFiles env (f:fp) = do o <- commandsFromFile env f case o of Ok (q,e) -> do o2 <- commandsFromFiles e fp case o2 of Ok (q2,e) -> return (Ok (q ++ q2, e)) Failed s -> return (Failed s) Failed s -> return (Failed s) -- | Read commands from a file in a given environment. -- commandsFromFile :: Env -> FilePath -> IO (E Commands) commandsFromFile env = fmap (>>= fromQCommands env) . parseFile -- | This function executes Commands in a given environment -- and then uses the Printers defined in the PrintOptions -- to return a String representation of the StatsTree. -- execute :: Env -> PrintOptions -> E Commands -> Stats -> String execute env po q st = case tr of Ok c -> printTree po c Failed f -> error f where tr = fst . executeCommands st <$> q execute' env po q st = execute env po (mapM parseCommands q >>= fromQCommands env . concat) st emptyEnv :: Env emptyEnv = D.fromList [] -- A Constraint separates Stats matching -- a predicate from the ones that don't -- (P(s), ¬P(s)) -- makeConstraint :: Pred EditStats -> Constraint makeConstraint p = con ([], []) where con (yes, no) [] = (yes, no) con (yes, no) (s:st) = con n st where n = if p s then (s : yes, no) else (yes, s:no) executeCommands :: Stats -> Commands -> ExecResult makeTree' :: Stats -> Query -> Time -> [StatsTree] makeNode :: String -> Stats -> Query -> StatsTree treeFromQuery :: String -> Env -> Stats -> E ExecResult executeCommands st (q, env) = (map (flip makeTree st) q, env) -- | Executing a Query: -- A Query works on Stats, which is a flat list of EditStats. -- For our results to be meaningful we need to -- create a StatsTree, where each level represents another -- subquery. Executing a query can thus be seen -- as building a tree from a list. -- makeTree :: Query -> Stats -> StatsTree makeTree [] s = Root [] [] "" (0,0,0) makeTree q s = Root nodes headers title time where nodes = makeTree' s q (0,0,0) headers = map (\(h,_,_,_) -> h) q ++ ["Edit Time"] title = concat . intersperse " / " $ reverse headers time = sumTime' (map f nodes) f (Node _ t _ _) = t f _ = (0,0,0) makeTree' s [] t = [Leaf t] makeTree' s ((_,v,c, g):cs) t = pruneNodeTrees nodes where (yes, no) = c s nodes = map (\gr -> makeNode (v . head $ gr) gr cs) (g yes) -- Pruning is pretty easy because we need to remove -- the trees that don't have any leafs in them, -- and we already keep that information in the Nodes. -- pruneNodeTrees :: [StatsTree] -> [StatsTree] pruneNodeTrees = filter ((/=0) . f) where f (Node i _ _ _) = i f _ = 1 -- A Node is made of an Int describing the number of leafs, -- a string that is used for printing, and of course its children. -- makeNode s yes cs = Node (n tr) time s tr where tr = makeTree' yes cs time time = sumTime yes n [] = 0 -- Count children n ((Node i _ _ _):cs) = i + n cs n ((Leaf _):cs) = 1 + n cs -- A helper function that builds a StatsTree out -- of a String in the Query language. -- treeFromQuery s env st = executeCommands st <$> (parseCommands s >>= fromQCommands env) -- | Interactive Query prompt using editline -- interactiveQueries :: PrintOptions -> Stats -> Env -> IO() promptStart :: IO Bool type Action = Stats -> Env -> PrintOptions -> IO() printerDict = [("csv", Csv), ("html", Html), ("text", Text), ("xhtml", XHtml)] makePrintAction (s, pr) = [('-' : s, (m un , "Disable " ++ s ++ " printer")) , ('+' : s, (m se , "Enable " ++ s ++ " printer"))] where un = unSet (PrinterF pr) se = set (PrinterF pr) m f stats env = repl stats env . f replCommands = concatMap makePrintAction printerDict ++ [("exit", (\_ _ _ -> onExit, "Exit Program")) , ("help", (\s e p -> printHelp >> repl s e p, "Output help"))] printHelp = putStrLn $ '\n' : unlines (sort (map h replCommands)) where h (c, (_, d)) = printf " %-8s %s" c d interactiveQueries po stats env = promptStart >> repl stats env po repl stats env po = do setCompletionEntryFunction (Just $ qCompleter env) maybeLine <- readline "> " case maybeLine of Nothing -> onExit Just "" -> repl stats env po Just s -> case lookup s replCommands of Just (c, _) -> c stats env po Nothing -> eval stats env po s eval stats env po s = do addHistory s case treeFromQuery s env stats of Ok (st, e) -> (putStrLn $ printTree po st) >> repl stats e po Failed e -> putStrLn e >> repl stats env po promptStart = do putStrLn (unlines ["Time Report 1.0a, interactive session" , "Copyright 2009-2010, Bart Spaans" , "Type \"help\" for more information"]) hSetBuffering stdout NoBuffering -- remove LineBuffering from stdout historyLocation >>= readHistory onExit = putStr "\n" >> historyLocation >>= writeHistory >> return () historyLocation :: IO FilePath historyLocation = ( ".report_history") <$> getUserDocumentsDirectory qCompleter :: Env -> String -> IO [String] qCompleter env s = return (filter (startsWith s) known) where known = ["extension", "language", "project", "filename" , "year", "month", "day", "dow", "doy", "limit" , "asc", "desc"] ++ D.keys env ++ map fst replCommands -- Convert AST to Query -- We have to transform the parsing result (QCommands) into -- SubQueries (ie. a view function, a constraint and a -- group function) and an Environment. -- fromQCommands :: Env -> QCommands -> E Commands fromQCommand :: Env -> QCommand -> E (Either Query Env) fromQQuery :: Env -> QQuery -> E Query fromQSubQuery :: Env -> QSubQuery -> E Query fromQIndex :: QIndex -> (EditStats -> String) addGrouping :: Ord a => Bool -> (EditStats -> a) -> Group fromQCommands env qs = fromQCommands' env [] qs where fromQCommands' env res [] = Ok (res, env) fromQCommands' env res (q:qs) = fromQCommand env q >>= f where f (Left qr) = fromQCommands' env (qr : res) qs f (Right e) = fromQCommands' newEnv res qs where newEnv = D.union e env fromQCommand env (Left q) = Left <$> fromQQuery env q fromQCommand env (Right a) = Right <$> i a where i (QAssign s q) = flip (D.insert s) env <$> fromQQuery env q -- First convert all the subqueries, then apply -- ordering and limiting to the last grouping function -- fromQQuery env [] = Ok [] fromQQuery env (c:cs) = fromQSubQuery env c >>= (\a -> (a++) <$> fromQQuery env cs) -- Sub queries -- fromQSubQuery _ q@(QSubQuery _ Ext _ _ _ _) = makeQuery q (takeExtension . fileName) fromQSubQuery _ q@(QSubQuery _ Lang _ _ _ _) = makeQuery q language fromQSubQuery _ q@(QSubQuery _ Proj _ _ _ _) = makeQuery q project fromQSubQuery _ q@(QSubQuery _ File _ _ _ _) = makeQuery q fileName fromQSubQuery _ q@(QSubQuery _ Year _ _ _ _) = makeQuery q (year . edit) fromQSubQuery _ q@(QSubQuery _ Month _ _ _ _) = makeQuery q (month . edit) fromQSubQuery _ q@(QSubQuery _ Day _ _ _ _) = makeQuery q (day . edit) fromQSubQuery _ q@(QSubQuery _ Dow _ _ _ _) = makeQuery q (dow . edit) fromQSubQuery _ q@(QSubQuery _ Doy _ _ _ _) = makeQuery q (doy . edit) fromQSubQuery env (QCall s) = case D.lookup s env of Just q -> Ok q Nothing -> Failed $ "Unknown definition `" ++ s ++ "'" makeQuery (QSubQuery gr t c h o l) f = Ok [(fromQAs h t, view, constraints, grouping)] where view = fromQIndex t constraints = fromQConstraints t c grouping = fromQLimit l . fromQOrder o . addGrouping gr f fromQAs (As s) _ = s fromQAs _ Ext = "Extension" fromQAs _ Lang = "Language" fromQAs _ Proj = "Project" fromQAs _ File = "File Name" fromQAs _ Year = "Year" fromQAs _ Month = "Month" fromQAs _ Day = "Day" fromQAs _ Dow = "Day of the Week" fromQAs _ Doy = "Day of the Year" -- Limiting and ordering is done before passing -- the grouped Stats on to the constraint function -- fromQOrder :: QOrder -> [Stats] -> [Stats] fromQOrder NoOrder = id fromQOrder Asc = sortBy (compare `on` sumTime) fromQOrder Desc = sortBy (flip compare `on` sumTime) fromQLimit :: QLimit -> [Stats] -> [Stats] fromQLimit NoLimit = id fromQLimit (Limit i) = take i -- The view function -- fromQIndex Ext = takeExtension . fileName fromQIndex Lang = maybe "Unknown language" snd . language fromQIndex Proj = maybe "Unknown project" snd . project fromQIndex File = fileName fromQIndex Year = show . year . edit fromQIndex Month = getMonth . month . edit fromQIndex Day = show . day . edit fromQIndex Dow = getDow . dow . edit fromQIndex Doy = show . doy . edit -- The grouping function -- addGrouping False _ = map (:[]) -- dontGroup addGrouping True f = groupWith f . sortBy (compare `on` f) addToGrouping [] _ = error "Empty query, can't add to grouping" addToGrouping cs f = init cs ++ [add (last cs)] where add (v, cs, gr) = (v, cs, f . gr) -- QConstraints to Constraints -- Individual QConstraints are first converted to predicates -- and get turned into one Constraint using makeConstraint. -- fromQConstraints :: QIndex -> [QConstraint] -> Constraint makePred :: QIndex -> QConstraint -> Pred EditStats fromQConstraints i qc = makeConstraint $ foldr f (const True) preds where f a b p = a p && b p preds = map (makePred i) qc makePred i (QC File op e) = fromQOper op (fromQExpr e) . fileName makePred i (QC Month op e) = numStringC op e month getMonth makePred i (QC Dow op e) = numStringC op e dow getDow makePred i (QC Year op e) = numericalC op year e makePred i (QC Day op e) = numericalC op day e makePred i (QC Doy op e) = numericalC op doy e makePred i (QC ind op e) = fromQOper op (fromQExpr e) . fromQIndex ind makePred i (QCOE op e) = makePred i (QC i op e) makePred i (QCE e) = makePred i (QC i QE e) -- helper functions; to do the conversion stringC op s f = fromQOper op (map toUpper s) . map toUpper . f . edit numericalC op g e = fromQOper op (read (fromQExpr e)) . g . edit maybeC op g h e = maybe False (fromQOper op (fromQExpr e) . h) . g numStringC op (QInt i) num _ = fromQOper op i . num . edit numStringC op (QString s) num str = stringC op s (str . num) -- Expressions -- fromQExpr :: QExpr -> String fromQExpr (QInt i) = show i fromQExpr (QString s) = s -- Operators are written flipped around to make it easier -- to write in a point-free style (see above) -- fromQOper :: Ord a => QOper -> (a -> a -> Bool) fromQOper QL = (>) fromQOper QG = (<) fromQOper QLE = (>=) fromQOper QGE = (<=) fromQOper QE = (==) fromQOper QNE = (/=)