Browse files

First commit.

  • Loading branch information...
0 parents commit b53e0b0e0829f6c9a8c4e37557a8fd1d0812b221 @chrisdone committed Aug 7, 2011
Showing with 336 additions and 0 deletions.
  1. +6 −0 .gitignore
  2. +30 −0 LICENSE
  3. +2 −0 Setup.hs
  4. +21 −0 flo.cabal
  5. +238 −0 src/Development/Flo.hs
  6. +39 −0 src/Main.hs
6 .gitignore
@@ -0,0 +1,6 @@
+*.o
+*.hi
+dist/
+cabal-dev/
+src/TAGS
+
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2011, Chris Done
+
+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 Chris Done 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.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
21 flo.cabal
@@ -0,0 +1,21 @@
+Name: flo
+Version: 0.1
+Synopsis: Generate flow charts from your code base.
+License: BSD3
+License-file: LICENSE
+Author: Chris Done
+Maintainer: chrisdone@gmail.com
+Category: Development
+Build-type: Simple
+Cabal-version: >=1.2
+
+Executable flo
+ Hs-source-dirs: src
+ Ghc-options: -O2 -Wall
+ Main-is: Main.hs
+ Build-depends: base > 4 && <5,
+ text >= 0.11,
+ mtl >= 1.1,
+ parsec >= 3.0,
+ bytestring >= 0.9,
+ regex-compat >= 0.92
238 src/Development/Flo.hs
@@ -0,0 +1,238 @@
+{-# OPTIONS -Wall -fno-warn-unused-do-bind #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | Generate a flow chart by from annotations from a code base.
+--
+-- The syntax is as follows:
+--
+-- expr <- label / next / do / if / task
+-- label <- "label" name
+-- task <- "task" text
+-- next <- "next" name / "trigger" name
+-- do <- "do" text
+-- if <- "if" name "\n" "then" name ("\n" "else" name)?
+--
+-- where `name' and `text' are both arbitrary text.
+--
+-- A `label' is used to label a node in the graph. `next' is used to
+-- link the current node to another node by its label. The text for a
+-- node is written by `do', which explains what this node does, or by
+-- using `if' which makes this node a conditional which goes to one of
+-- two possible nodes.
+--
+-- Example (assuming '///' to be the declaration prefix):
+--
+-- /// label main
+-- /// if Logged in?
+-- /// then display_overview
+-- /// else display_login
+
+-- /// label display_overview
+-- /// do Display overview.
+-- /// next display_event
+-- /// next display_paper
+-- // Event list code here.
+-- event_list();
+
+-- /// label display_login
+-- /// do Display login.
+-- /// next try_login
+-- // Login display code here.
+-- display_login();
+
+-- /// label try_login
+-- /// do Check login.
+-- /// next main
+-- /// trigger log_access_time
+-- // Login attempt code here.
+-- if(check_login()) log_attempt_success();
+
+-- /// label display_event
+-- /// do Display a single event.
+-- /// next display_paper
+-- // Event list code here.
+-- display_event();
+
+-- /// label display_paper
+-- /// do Display a single paper.
+-- // Paper display code here.
+-- display_paper();
+
+-- /// label log_access_time
+-- /// task Log login accesses.
+-- log_login();
+--
+-- In other words: You have a main page which either displays a login
+-- screen or lists the user's events if logged in. From the events
+-- page you can get to the event page.
+
+module Development.Flo where
+
+import Control.Applicative
+import Control.Monad.Error ()
+import Control.Monad.State
+import Control.Monad.Writer
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.Char
+import Data.Maybe
+import Data.List
+import Text.Parsec hiding ((<|>))
+
+-- | A workflow node.
+data Node =
+ Node { nodeName :: Name
+ , nodeEdges :: [Edge]
+ , nodeDesc :: String
+ , nodeType :: Type
+ } deriving Show
+
+-- | Type of the node.
+data Type = Action | Condition | Background
+ deriving (Eq,Enum,Show)
+
+-- | A workflow connection.
+data Edge =
+ Edge { edgeLabel :: String
+ , edgeTo :: Name
+ } deriving Show
+
+-- | A workflow declaration.
+data Decl
+ = Label Name -- ^ Sets the current node.
+ | Next Name -- ^ Links to a next node (an edge).
+ | Do String -- ^ Describes this node.
+ | Task String -- ^ Run some task (create db entry,
+ -- delete file, send email etc.).
+ | If String Name (Maybe Name) -- ^ Makes this node a conditional.
+ deriving Show
+
+-- | A node name.
+newtype Name = Name String
+ deriving (Eq,Show)
+
+-- | Simple alias for the parser type.
+type P = Parsec ByteString ()
+
+-- | Wrap a string up in a digraph.
+digraph :: String -> String
+digraph x = "digraph G {\n" ++ x ++ "\n}"
+
+-- | Convert a list of nodes to a Graphviz dot document.
+nodesToDot :: [Node] -> String
+nodesToDot nodes = concat . map nodeToDot $ nodes where
+ nodeToDot Node{..} =
+ normalizeName nodeName ++ " [" ++ props ++ "]\n" ++
+ concat (map (edgeToDot nodeName) nodeEdges)
+ where props = intercalate ","
+ ["label=" ++ show nodeDesc
+ ,"shape=" ++ case nodeType of
+ Condition -> "house"
+ Action -> "box"
+ Background -> "oval"
+ ]
+ edgeToDot from Edge{..} = normalizeName from ++ " -> " ++ normalizeName edgeTo ++
+ " [label=" ++ show edgeLabel ++
+ ",style=" ++ (if trig then "dotted" else "solid") ++
+ "]\n"
+ where trig = maybe False ((==Background).nodeType) $
+ find ((==edgeTo).nodeName) nodes
+
+-- | Normalize a node name to fit Dot syntax.
+normalizeName :: Name -> String
+normalizeName (Name name) = replace name where
+ replace [] = []
+ replace (x:xs) | isDigit x || isLetter x || x== '_' = x : replace xs
+ | otherwise = "_" ++ show (fromEnum x) ++ replace xs
+
+-- | Converts a list of declarations to a list of nodes.
+declsToNodes :: [Decl] -> [Node]
+declsToNodes ds = snd $ runWriter (runStateT (go ds) Nothing) where
+ go (Label name@(Name desc):xs) = do
+ let setNew = put (Just $ Node name [] desc Action)
+ get >>= maybe setNew (\x -> do tell [x]; setNew)
+ go xs
+ go (Next edge:xs) = do
+ modify $ fmap $ \node ->
+ if nodeType node /= Condition
+ then node { nodeEdges = Edge "" edge : nodeEdges node }
+ else node
+ go xs
+ go (Do desc:xs) = do
+ modify $ fmap $ \node -> node { nodeDesc = desc }
+ go xs
+ go (Task desc:xs) = do
+ modify $ fmap $ \node -> node { nodeDesc = desc, nodeType = Background }
+ go xs
+ go (If cond xthen xelse:xs) = do
+ modify $ fmap $ \node ->
+ node { nodeType = Condition
+ , nodeDesc = cond
+ , nodeEdges = [Edge "Yes" xthen] ++
+ maybe [] (return . Edge "No") xelse
+ }
+ go xs
+ go [] = get >>= maybe (return ()) (tell . return)
+
+-- | Parse a source file containing commented declarations.
+parseFile :: FilePath -> String -> Maybe String -> IO (Either ParseError [Decl])
+parseFile path start end = do
+ contents <- B.readFile path
+ return $ parse (parseDeclsInSource startP endP)
+ path
+ (contents `mappend` "\n")
+
+ where startP = spaces *> string start *> pure ()
+ endP = maybe (void $ lookAhead newline)
+ (void.string)
+ end
+ void p = p *> pure ()
+
+-- | Parse all line-separated prefixed declarations in a source file.
+parseDeclsInSource :: P () -> P () -> P [Decl]
+parseDeclsInSource start end = do
+ ls <- many1 (floComment <|> normalSource) <* eof
+ return $ catMaybes ls
+
+ where floComment = try (Just <$> parseDecl start end)
+ normalSource = const Nothing <$> manyTill anyChar newline
+
+-- | Parse a declaration (spanning many lines in some cases e.g. "if").
+parseDecl :: P () -> P () -> P Decl
+parseDecl start end = do
+ start
+ keyword <- choice $ map (try.string) ["label","next","do","if","trigger","task"]
+ space; spaces
+ value <- manyTill anyChar (try $ lookAhead end)
+ end
+ case keyword of
+ "if" -> parseIfClauses value start end
+ "next" -> return $ Next $ Name value
+ "trigger" -> return $ Next $ Name value
+ "do" -> return $ Do value
+ "task" -> return $ Task value
+ _ -> return $ Label $ Name value
+
+-- | Parse the then/else clauses of the if with the given condition.
+parseIfClauses :: String -> P () -> P () -> P Decl
+parseIfClauses cond start end = do
+ start
+ string "then"
+ space; spaces
+ value <- manyTill anyChar (try $ lookAhead end)
+ end
+ elseClause <- Just <$> (parseElseClause start end) <|> return Nothing
+ return $ If cond (Name value) elseClause
+
+-- | Parse the else clause for an `if' expression.
+parseElseClause :: P () -> P () -> P Name
+parseElseClause start end = do
+ start
+ string "else"
+ space; spaces
+ value <- manyTill anyChar (try $ lookAhead newline)
+ end
+ return $ Name value
39 src/Main.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Generate a flow chart by scanning for annotations from a code base.
+
+module Main where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Development.Flo
+import System.Environment
+import System.IO
+import Text.Regex
+
+-- | Main entry point.
+main :: IO ()
+main = do
+ args <- getArgs
+ let files = filter (not.opt) args
+ optish = filter opt args
+ opts = catMaybes (map parseOpt optish)
+ opt = isPrefixOf "-"
+ when (any (=="-v") optish) (hPrint stderr opts)
+ mapM (scanAndPrint opts) files >>= putStrLn.digraph.join.join
+
+ where scanAndPrint opts file =
+ fmap (either (error.show) (return.nodesToDot.declsToNodes))
+ (parseFile file start end)
+
+ where start = fromMaybe (error $ "No pattern specified for " ++ ext)
+ (lookup ext opts)
+ end = lookup (ext++"-end") opts
+ ext = reverse.takeWhile (/='.').reverse $ file
+
+-- | Parse an -x=y option.
+parseOpt :: String -> Maybe (String,String)
+parseOpt (matchRegex (mkRegex "^-([a-zA-Z-]+)=(.+)$") -> Just [lang,start])
+ | all (not.null) [lang,start] = Just (lang,start)
+parseOpt _ = Nothing

0 comments on commit b53e0b0

Please sign in to comment.