Wrote a quick viewing tool to display profiling cost centres

.gitignore

@@ -0,0 +1,24 @@
+# ---> Haskell
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
+

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for lemur
+
+## 0.1.0.0 -- 2020-02-12
+
+* Wrote a quick viewing tool to display profiling cost centres

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2020, Tissevert
+
+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.
+
+    * Neither the name of Tissevert nor the names of other
+      contributors may 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

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

lemur.cabal

@@ -0,0 +1,28 @@
+cabal-version:       >=1.10
+-- Initial package description 'lemur.cabal' generated by 'cabal init'.
+-- For further documentation, see http://haskell.org/cabal/users-guide/
+
+name:                lemur
+version:             0.1.0.0
+synopsis:            A tool to browse profiling cost centre trees more easily
+-- description:
+homepage:            https://git.marvid.fr/Tissevert/lemur
+-- bug-reports:
+license:             BSD3
+license-file:        LICENSE
+author:              Tissevert
+maintainer:          tissevert+devel@marvid.fr
+-- copyright:
+category:            Development
+build-type:          Simple
+extra-source-files:  CHANGELOG.md
+
+executable lemur
+  main-is:             Main.hs
+  other-modules:       Zipper
+  -- other-extensions:
+  build-depends:       base >=4.11 && <4.12
+                     , mtl
+  ghc-options:         -Wall
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Main.hs

@@ -0,0 +1,49 @@
+module Main where
+
+import Control.Monad.State (MonadState(..), StateT(..), evalStateT, lift, modify)
+import Data.List (isPrefixOf, findIndex)
+import System.Environment (getArgs)
+import System.Exit (die)
+import System.IO (BufferMode(..), hSetBuffering, stdin)
+import Zipper (Tree(..), Zipper(..), at, parse, up)
+
+data Command = Quit | Up | Open Int
+type Zipping = StateT Zipper IO
+
+getLines :: Zipping [String]
+getLines = fmap fst . children . focus <$> get
+
+browse :: Zipper -> IO ()
+browse zipper = do
+  hSetBuffering stdin NoBuffering
+  evalStateT browseMain zipper
+
+prompt :: Zipping Command
+prompt = do
+  input <- lift $ getLine
+  case input of
+    "q" -> return Quit
+    "quit" -> return Quit
+    "\DEL" -> return Up
+    "up" -> return Up
+    s -> maybe (retry s) (return . Open) =<< firstMatch s
+  where
+    retry s = lift (putStrLn ("Command '" ++ s ++ "' not understood")) >> prompt
+    firstMatch s = findIndex (s `isPrefixOf`) <$> getLines
+
+browseMain :: Zipping ()
+browseMain = do
+  lift $ putStrLn "---------------------------------"
+  lift . mapM_ putStrLn =<< getLines
+  command <- prompt
+  case command of
+    Quit -> return ()
+    Up -> modify up >> browseMain
+    Open n -> modify (at n) >> browseMain
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    [filePath] -> readFile filePath >>= browse . parse
+    _ -> die "Syntax: lemur FILE_PATH"

src/Zipper.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Zipper (
+      Tree(..)
+    , Zipper(..)
+    , at
+    , parse
+    , up
+  ) where
+
+newtype Tree = Tree {
+    children :: [(String, Tree)]
+  }
+
+data Context = Top | Context {
+      before :: Tree
+    , after :: Tree
+    , line :: String
+    , above :: Context
+  }
+
+data Zipper = Zipper {
+      context :: Context
+    , focus :: Tree
+  }
+
+at :: Int -> Zipper -> Zipper
+at k (Zipper {context, focus}) =
+  let (beforeSubTrees, (line, newFocus), afterSubTrees) = openLines k ([], subTrees) in
+  Zipper {
+        context = Context {
+              before = Tree beforeSubTrees
+            , after = Tree afterSubTrees
+            , line
+            , above = context
+          }
+      , focus = newFocus
+    }
+  where
+    subTrees = children focus
+    openLines 0 (left, []) = (drop 1 left, head left, [])
+    openLines 0 (left, (center:right)) = (left, center, right)
+    openLines _ (left, []) = openLines 0 (left, [])
+    openLines n (left, (center:right)) = openLines (n-1) (center:left, right)
+
+insert :: String -> Zipper -> Zipper
+insert newLine z@(Zipper {context = Top}) = plug newLine z
+insert newLine (Zipper {context, focus}) = Zipper {
+      context = Context {
+            before = Tree ((line context, focus):(children $ before context))
+          , after = after context
+          , line = newLine
+          , above = above context
+        }
+    , focus = Tree []
+  }
+
+parse :: String -> Zipper
+parse = zipUp . fst . foldl getStructure (Zipper Top $ Tree [], 0) . lines
+  where
+    getStructure (zipper, depth) line =
+      let (indent, content) = span (== ' ') line in
+      let n = depth - length indent in
+      if n < 0
+      then (plug content zipper, length indent)
+      else (insert content (funPower n up zipper), length indent)
+    funPower 0 _ x = x
+    funPower n f x = funPower (n-1) f $ f x
+
+plug :: String -> Zipper -> Zipper
+plug line (Zipper {context}) = Zipper {
+      context = Context {
+            before = Tree []
+          , after = Tree []
+          , line
+          , above = context
+        }
+    , focus = Tree []
+  }
+
+up :: Zipper -> Zipper
+up z@(Zipper {context = Top}) = z
+up (Zipper {context = Context {before, after, line, above}, focus}) = Zipper {
+      context = above
+    , focus = Tree (reverse (children before) ++ ((line, focus) : children after))
+  }
+
+zipUp :: Zipper -> Zipper
+zipUp z@(Zipper {context = Top}) = z
+zipUp z = zipUp (up z)