{- |

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")