{- |
Module : ./CMDL/Utils.hs
Description : utilitary functions used throughout the CMDL interface
Copyright : uni-bremen and DFKI
License : GPLv2 or higher, see LICENSE.txt
Maintainer : r.pascanu@jacobs-university.de
Stability : provisional
Portability : portable
CMDL.Utils contains different basic functions that are
used throughout the CMDL interface and could not be found in
Prelude
-}
module CMDL.Utils
( decomposeIntoGoals
, obtainNodeList
, createEdgeNames
, obtainEdgeList
, obtainGoalEdgeList
, finishedNames
, stripComments
, lastChar
, lastString
, safeTail
, fileFilter
, fileExtend
, prettyPrintErrList
, edgeContainsGoals
, isOpenConsEdge
, checkIntString
, delExtension
, arrowLink
) where
import Data.List
import Data.Maybe
import Data.Char (isDigit)
import Data.Graph.Inductive.Graph (LNode, LEdge)
import System.Directory
import System.FilePath
import Static.DevGraph
import Static.DgUtils
import Common.Utils
{- removes the extension of the file find in the
name of the prompter ( it delets everything
after the last . and assumes a prompter length of 2 ) -}
delExtension :: String -> String
delExtension str = let rstr = reverse str in
reverse $ safeTail $ case dropWhile (/= '.') rstr of
"" -> safeTail rstr
dstr -> dstr
-- | Checks if a string represents a int or not
checkIntString :: String -> Bool
checkIntString = not . any (not . isDigit)
localArr :: String
localArr = "..>"
globalArr :: String
globalArr = "->"
padBlanks :: String -> String
padBlanks s = ' ' : s ++ " "
-- | Generates a string representing the type of link
arrowLink :: DGLinkLab -> String
arrowLink edgLab = padBlanks $ if isLocalEdge $ dgl_type edgLab
then localArr
else globalArr
-- | Checks if the string starts with an arrow
checkArrowLink :: String -> Maybe (String, String)
checkArrowLink str = case find snd
$ map (\ s -> (s, isPrefixOf s str)) [localArr, globalArr] of
Nothing -> Nothing
Just (a, _) -> Just (padBlanks a, drop (length a) str)
{- | Given a string inserts spaces before and after an
arrow -}
spacesAroundArrows :: String -> String
spacesAroundArrows s = case s of
[] -> []
hd : tl -> case checkArrowLink $ trimLeft s of
Just (arr, rs) -> arr ++ spacesAroundArrows rs
Nothing -> hd : spacesAroundArrows tl
{- | Given a string the function decomposes it into 4 lists,
one for node goals, the other for edges, the third for
numbered edges and the last for names that could not be
processed due to errors -}
decomposeIntoGoals :: String -> ([String], [String], [String], [String])
decomposeIntoGoals input = let
{- the new input where words and arrows are separated
by exactly one space -}
nwInput = words $ spacesAroundArrows input
{- function to parse the input and decompose it into
the three goal list -}
parse info nbOfArrows word sw listNode listEdge listNbEdge listError =
case info of
[] -> case nbOfArrows :: Integer of
0 -> (word : listNode, listEdge, listNbEdge, listError)
1 -> (listNode, word : listEdge, listNbEdge, listError)
2 -> (listNode, listEdge, word : listNbEdge, listError)
_ -> (listNode, listEdge, listNbEdge, word : listError)
x : l -> case checkArrowLink x of
Just (arr, _) ->
case word of
[] -> (listNode, listEdge, listNbEdge, word : listError)
_ -> parse l (nbOfArrows + 1) (word ++ arr) True
listNode listEdge listNbEdge listError
Nothing ->
if sw
then parse l nbOfArrows (word ++ x) False
listNode listEdge listNbEdge listError
else
case nbOfArrows of
0 -> parse l 0 x False
(word : listNode) listEdge listNbEdge listError
1 -> parse l 0 x False
listNode (word : listEdge) listNbEdge listError
2 -> parse l 0 x False
listNode listEdge (word : listNbEdge) listError
_ -> parse l 0 x False
listNode listEdge listNbEdge (word : listError)
(ns, es, les, errs) = parse nwInput 0 [] True [] [] [] []
in (reverse ns, reverse es, reverse les, reverse errs)
{- | mapAndSplit maps a function to a list. If the function can not
be applied to an element it is stored in a different list for
producing error message later on -}
mapAndSplit :: (a -> Maybe b) -> [a] -> ([a], [b])
mapAndSplit fn ls =
let ps = zip ls $ map fn ls
(oks, errs) = partition (isJust . snd) ps
in (map fst errs, mapMaybe snd oks)
{- | concatMapAndSplit is similar to mapAndSplit, just that it behaves
in a similar manner to concatMap (i.e. sums up lists produced by
the function -}
concatMapAndSplit :: (a -> [b]) -> [a] -> ([a], [b])
concatMapAndSplit fn ls =
let ps = zip ls $ map fn ls
(errs, oks) = partition (null . snd) ps
in (map fst errs, concatMap snd oks)
{- | Given a list of node names and the list of all nodes
the function returns all the nodes that have their name
in the name list -}
obtainNodeList :: [String] -> [LNode DGNodeLab] -> ([String], [LNode DGNodeLab])
obtainNodeList lN allNodes = mapAndSplit
(\ x -> find (\ (_, label) -> getDGNodeName label == x) allNodes) lN
-- | Given an edge decides if it contains goals or not
edgeContainsGoals :: LEdge DGLinkLab -> Bool
edgeContainsGoals (_, _, l) = case thmLinkStatus $ dgl_type l of
Just LeftOpen -> True
_ -> False
-- | Given an edge: does it contain an open conservativity goal or not
isOpenConsEdge :: LEdge DGLinkLab -> Bool
isOpenConsEdge (_, _, l) = hasOpenConsStatus False $ getEdgeConsStatus l
{- | Given a list of edges and the complete list of all
edges computes not only the names of edges but also the
numbered name of edges -}
createEdgeNames :: [LNode DGNodeLab] -> [LEdge DGLinkLab]
-> [(String, LEdge DGLinkLab)]
createEdgeNames lsN lsE = let
-- function that returns the name of a node given its number
nameOf x ls = case lookup x ls of
Nothing -> "Unknown node"
Just nlab -> getDGNodeName nlab
ordFn (x1, x2, _) (y1, y2, _) = compare (x1, x2) (y1, y2)
-- sorted and grouped list of edges
edgs = groupBy ( \ x y -> ordFn x y == EQ) $ sortBy ordFn lsE
in concatMap (\ l -> case l of
[el@(x, y, edgLab)] -> [(nameOf x lsN ++
arrowLink edgLab ++
nameOf y lsN, el)]
_ -> map (\ el@(x, y, edgLab) ->
(nameOf x lsN ++
arrowLink edgLab ++
showEdgeId (dgl_id edgLab)
++ arrowLink edgLab
++ nameOf y lsN, el)) l) edgs
{- | Given a list of edge names and numbered edge names
and the list of all nodes and edges the function
identifies the edges that appear in the name lists -}
obtainEdgeList :: [String] -> [String] -> [LNode DGNodeLab]
-> [LEdge DGLinkLab] -> ([String], [LEdge DGLinkLab])
obtainEdgeList lsEdge lsNbEdge allNodes allEdges = let
{- function that searches through a list of nodes to
find the node number for a given name. -}
getNodeNb s ls =
case find ( \ (_, label) ->
getDGNodeName label == s) ls of
Nothing -> Nothing
Just (nb, _) -> Just nb
-- compute the list of all edges from source node to target
l1 = concatMapAndSplit
(\ nme -> case words nme of
[src, _, tar] -> let
node1 = getNodeNb src allNodes
node2 = getNodeNb tar allNodes
in case node1 of
Nothing -> []
Just x ->
case node2 of
Nothing -> []
Just y ->
filter (\ (x1, y1, _) -> x == x1 && y == y1) allEdges
_ -> error "CMDL.Utils.obtainEdgeList1"
) lsEdge
-- compute the list of all numbered edges
l2 = mapAndSplit
(\ nme -> case words nme of
[src, _, numb, _, tar] -> let
node1 = getNodeNb src allNodes
node2 = getNodeNb tar allNodes
mnb = readMaybe numb
in case node1 of
Nothing -> Nothing
Just x -> case node2 of
Nothing -> Nothing
Just y -> case mnb of
Nothing -> Nothing
Just nb -> let
ls = filter (\ (x1, y1, elab) -> x == x1 && y == y1 &&
dgl_id elab == EdgeId nb) allEdges
in case ls of
[] -> Nothing
els : _ -> Just els
_ -> error "CMDL.Utils.obtainEdgeList2") lsNbEdge
in (fst l1 ++ fst l2, snd l1 ++ snd l2)
{- | Giben a listof edgenamesand numbered edge names and
the list of all nodes and edges the function identifies
the edges that appearin the name list and are also goals -}
obtainGoalEdgeList :: [String] -> [String] -> [LNode DGNodeLab]
-> [LEdge DGLinkLab] -> ([String], [LEdge DGLinkLab])
obtainGoalEdgeList ls1 ls2 ls3 ls4 =
let (l1, l2) = obtainEdgeList ls1 ls2 ls3 ls4
in (l1, filter edgeContainsGoals l2)
{- | Function that given a string removes comments contained
in the string -}
stripComments :: String -> String
stripComments input =
let fn ls = case ls of
'#' : _ -> []
'%' : ll ->
case ll of
'%' : _ -> []
'{' : _ -> []
_ -> '%' : fn ll
[] -> []
l : ll -> l : fn ll
in trim $ fn input
-- | check if edges are to be completed in the presence of nodes
finishedNames :: [String] -> String -> ([String], String)
finishedNames ns i =
let e@(fs, r) = fNames ns i in
if not (null r) && any (isPrefixOf r) [localArr, globalArr] then
case reverse fs of
lt : ei : ar : sr : fr | elem ar [localArr, globalArr]
-> (reverse fr, unwords [sr, ar, ei, lt, r])
lt : fr -> (reverse fr, unwords [lt, r])
_ -> e
else e
fNames :: [String] -> String -> ([String], String)
fNames ns input = let i = trimLeft input in
case filter (isJust . snd) $ zip ns
$ map ((`stripPrefix` i) . (++ " ")) ns of
(n, Just r) : _ -> let (fs, s) = fNames ns r in (n : fs, s)
_ -> ([], i)
{- | Given a list of files and folders the function filters
only directory names and files ending in extenstion
.casl or .het -}
fileFilter :: String -> [String] -> [String] -> IO [String]
fileFilter lPath ls cons = case ls of
[] -> return cons
x : l -> do
-- check if current element is a directory
b <- doesDirectoryExist (lPath </> x)
fileFilter lPath l $ if b
-- if it is,then add "/" to indicate is a folder
then addTrailingPathSeparator x : cons
{- if it is not a folder then it must be a file
so check the extension -}
else if elem (takeExtensions x) [".casl", ".het" ]
then x : cons else cons
{- | Given a list of files and folders the function expands
the list adding the content of all folders in the list -}
fileExtend :: String -> [String] -> [String] -> IO [String]
fileExtend lPath ls cons = case ls of
[] -> return cons
x : l -> do
-- check if current element is a directory
let lPathx = lPath </> x
b <- doesDirectoryExist lPathx
if b then
-- if it is a folder add its content
do ll <- getDirectoryContents lPathx
nll <- fileFilter lPathx ll []
let nll' = map (x </>) nll
fileExtend lPath l (nll' ++ cons)
-- if it is not then leave the file alone
else fileExtend lPath l (x : cons)
{- | The function behaves exactly as tail just that
in the case of empty list returns an empty list
instead of an error -}
safeTail :: [a] -> [a]
safeTail = drop 1
safeLast :: a -> [a] -> a
safeLast d l = if null l then d else last l
{- | The function behaves exactly like last just that
in case of an empty list returns the space
character (it works only for lists of chars) -}
lastChar :: String -> Char
lastChar = safeLast ' '
{- | The function behaves exactly like last just that
in case of an empty list returns the empty string
(it is meant only for list of strings) -}
lastString :: [String] -> String
lastString = safeLast ""
-- | The function nicely outputs a list of errors
prettyPrintErrList :: [String] -> String
prettyPrintErrList = intercalate "\n"
. map (\ x -> "Input " ++ x ++ " could not be processed")