module Development.Flo
(
Node (..),
Type (..),
Edge (..),
Decl (..),
Name,
digraph,
nodesToDot,
declsToNodes,
parseFile)
where
import Control.Applicative
import Control.Monad.Except ()
import Control.Monad.State hiding (void)
import Control.Monad.Writer hiding (void)
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