avers 0.0.7 → 0.0.8

raw patch · 3 files changed

+119/−2 lines, 3 filesdep ~template-haskell

Dependency ranges changed: template-haskell

Files

• avers.cabal +7/−2
• src/Avers/Metrics/Measurements.txt +28/−0
• src/Avers/Metrics/TH.hs +84/−0

@@ -1,5 +1,5 @@ name:                avers-version:             0.0.7+version:             0.0.8 license:             GPL-3 license-file:        LICENSE author:              Tomas Carnecky@@ -12,6 +12,10 @@ description:         empty  +extra-source-files:+    src/Avers/Metrics/Measurements.txt++ source-repository head     type:     git     location: git://github.com/wereHamster/avers-haskell.git@@ -29,6 +33,7 @@     exposed-modules:         Avers       , Avers.Metrics+      , Avers.Metrics.TH       , Avers.Metrics.Measurements       , Avers.Patching       , Avers.Storage@@ -52,7 +57,7 @@       , mtl       , network       , stm-      , template-haskell         >= 2.10+      , template-haskell       , text       , time       , unordered-containers

@@ -0,0 +1,28 @@+avers+    storage++        lookupObject+            duration++        lookupSnapshot+            duration++        lookupLatestSnapshot+            duration++        newestSnapshot+            duration++        patchesAfterRevision+            duration++        lookupPatch+            duration++        applyObjectUpdates+            duration+            numOperations+            numPreviousPatches++        exists+            duration

@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Avers.Metrics.TH where+++import           Control.Applicative++import           Data.Char+import           Data.List++import           Language.Haskell.TH+import qualified Language.Haskell.TH.Syntax as TH++import           System.FilePath            ((</>), dropFileName)++import           Prelude+++toLabels :: [String] -> [[String]]+toLabels = go [] []+  where+    go :: [(Int, String)] -> [[String]] -> [String] -> [[String]]+    go _ res [] = res+    go ctx res (x:xs) = case compare prefixLength indent of+        EQ -> if null ctx+            then go [(0, label)] (res ++ [[label]]) xs+            else go ctx (res ++ [init (map snd ctx) ++ [label]]) xs+        GT -> go (ctx ++ [(prefixLength - indent, label)]) (res ++ [(map snd ctx) ++ [label]]) xs+        LT -> go (newCtx ++ [(prefixLength - newCtxIndent, label)]) (res ++ [map snd newCtx ++ [label]] ) xs++      where+        indent = sum $ map fst ctx+        prefixLength = length $ takeWhile (==' ') x+        label = dropWhile (==' ') x++        newCtx = init (pop (indent - prefixLength) ctx)+        newCtxIndent = sum $ map fst newCtx++        pop n cx+            | n <= 0 = cx+            | otherwise = case reverse cx of+                [] -> error "pop empty list"+                (cn, _):rest -> pop (n - cn) (reverse rest)+++toMetrics :: [[String]] -> [[String]]+toMetrics [] = []+toMetrics (x:[]) = [x]+toMetrics (x : (y : rest)) = case compare (length y) (length x) of+    EQ -> [x] ++ toMetrics (y:rest)+    GT -> toMetrics (y:rest)+    LT -> [x] ++ toMetrics (y:rest)+++mkMeasurements :: Q [Dec]+mkMeasurements = do+    filePath <- dropFileName . TH.loc_filename <$> TH.qLocation+    src <- runIO $ do+        body <- readFile (filePath </> "Measurements.txt")+        return $ filter (not . null) $ lines body++    let labels = toLabels src+    let metrics = toMetrics labels++    return+        [ DataD [] (mkName "Measurement") [] (map genCon metrics) []++        , SigD (mkName "measurementLabels") (AppT (AppT ArrowT (ConT (mkName "Measurement"))) (AppT ListT $ AppT ListT (ConT ''Char)))+        , FunD (mkName "measurementLabels")+            (map toClause metrics)+        ]++  where+    toName :: [String] -> Name+    toName labels = (mkName $ "M_" ++ (intercalate "_" labels))++    genCon :: [String] -> Con+    genCon labels =+        NormalC (toName labels) []++    toClause :: [String] -> Clause+    toClause labels =+        Clause [(ConP (toName labels) [])] (NormalB $ ListE $ map (LitE . StringL) labels) []