module Development.Flo
(
Node (..),
Type (..),
Edge (..),
Decl (..),
Name,
digraph,
nodesToDot,
declsToNodes,
parseFile)
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 ((<|>))
data Node =
Node { nodeName :: Name
, nodeEdges :: [Edge]
, nodeDesc :: String
, nodeType :: Type
} deriving Show
data Type = Action | Condition | Background
deriving (Eq,Enum,Show)
data Edge =
Edge { edgeLabel :: String
, edgeTo :: Name
} deriving Show
data Decl
= Label Name
| Next Name
| Do String
| Task String
| If String Name (Maybe Name)
deriving Show
newtype Name = Name String
deriving (Eq,Show)
type P = Parsec ByteString ()
digraph :: String -> String
digraph x = "digraph G {\n" ++ x ++ "\n}"
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
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
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)
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 ()
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
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
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
parseElseClause :: P () -> P () -> P Name
parseElseClause start end = do
start
string "else"
space; spaces
value <- manyTill anyChar (try $ lookAhead newline)
end
return $ Name value