Flowchart generation proposal.

flowchart.hs

-- | Generate a flow chart by scanning for annotations from a code base.

module Main where

import Development.Flo
import System.Environment

-- | Main entry point.
main :: IO ()
main = getArgs >>= mapM scanAndPrint >>= putStrLn.digraph.concat where
  scanAndPrint file = do
    result <- parseFile file
    either (error.show) (return.nodesToDot.declsToNodes) result

{-# OPTIONS -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Generate a flow chart by from annotations from a code base.
--
-- The syntax is as follows:
--
--    expr  <- label / next / do / if
--    label <- "label" name
--    next  <- "next" 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 -> IO (Either ParseError [Decl])
parseFile path = do
  contents <- B.readFile path
  return $ parse parseDeclsInSource path (contents `mappend` "\n")

-- | Parse all line-separated prefixed declarations in a source file.
parseDeclsInSource :: P [Decl]
parseDeclsInSource = do
  ls <- many1 (floComment <|> normalSource) <* eof
  return $ catMaybes ls
  
  where floComment = try (Just <$> (parsePrefix *> parseDecl))
        normalSource = const Nothing <$> manyTill anyChar newline

parsePrefix :: P String
parsePrefix = spaces *> string "/// "

-- | Parse a declaration (spanning many lines in some cases e.g. "if").
parseDecl :: P Decl
parseDecl = do
  keyword <- choice $ map (try.string) ["label","next","do","if","trigger","task"]
  space; spaces
  value <- manyTill anyChar (try newline)
  case keyword of
    "if"      -> parseIfClauses value
    "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 Decl
parseIfClauses cond = do
  parsePrefix
  string "then"
  space; spaces
  value <- manyTill anyChar (try newline)
  elseClause <- Just <$> parseElseClause <|> return Nothing
  return $ If cond (Name value) elseClause

-- | Parse the else clause for an `if' expression.
parseElseClause :: P Name
parseElseClause = do
  parsePrefix
  string "else"
  space; spaces
  value <- manyTill anyChar (try newline)
  return $ Name value