diff --git a/src/Modelling/StateDiagram/Generate.hs b/src/Modelling/StateDiagram/Generate.hs index 2412799f..0ed3b435 100644 --- a/src/Modelling/StateDiagram/Generate.hs +++ b/src/Modelling/StateDiagram/Generate.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-error=x-partial -Wno-error=deprecations #-} +{-# OPTIONS_GHC -Wno-error=deprecations #-} {-# LANGUAGE LambdaCase, RecordWildCards #-} module Modelling.StateDiagram.Generate (randomSD) where @@ -70,10 +70,10 @@ checkParallelRegion [_] _ _ = True checkParallelRegion _ [_] _ = True checkParallelRegion [_,_] _ _ = True checkParallelRegion _ [_,_] _ = True -checkParallelRegion (x:xs) (y:ys) subs - = case (x == y, all (isNotCD x) subs) of - (True, True) -> checkParallelRegion xs ys (getSubstates x subs) - (True, False) -> head xs == head ys && checkParallelRegion xs ys (getSubstates x subs) +checkParallelRegion (x1:x2:xs) (y1:y2:ys) subs + = case (x1 == y1, all (isNotCD x1) subs) of + (True, True) -> checkParallelRegion (x2:xs) (y2:ys) (getSubstates x1 subs) + (True, False) -> x2 == y2 && checkParallelRegion (x2:xs) (y2:ys) (getSubstates x1 subs) (False, _) -> True --haveForkOrJoin:: StateDiagram n Int [Connection Int] -> Bool @@ -239,8 +239,8 @@ randomSD' outermost c cdMaxNum leastTwoLevels ns alphabet (l,nm,mustCD) exclude start randomInnerSD :: Int -> Int -> [Int] -> [String] -> (Int,NodeType,[String],Bool) -> [String]-> Gen (StateDiagram String Int [Connection Int]) -randomInnerSD counter cdMaxNum ns alphabet (l,t,s,mustCD) exclude = do - let nm = head s +randomInnerSD _ _ _ _ (_,_,[],_) _ = error "randomInnerSD: empty name list" +randomInnerSD counter cdMaxNum ns alphabet (l,t,s@(nm:_),mustCD) exclude = do case t of Hist -> frequency [(1,return (History l Shallow)),(1,return (History l Deep))] End -> return (EndState l) diff --git a/src/Modelling/StateDiagram/Instance.hs b/src/Modelling/StateDiagram/Instance.hs index c293c843..8d4abfb4 100644 --- a/src/Modelling/StateDiagram/Instance.hs +++ b/src/Modelling/StateDiagram/Instance.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-error=x-partial -Wwarn=incomplete-patterns #-} +{-# OPTIONS_GHC -Wwarn=incomplete-patterns #-} module Modelling.StateDiagram.Instance ( parseInstance, failWith @@ -158,7 +158,10 @@ Get path to element in the forest. Assumes there is just one such element. Fails if the element does not exist within the forest. -} getPathTo :: Eq a => Forest (a, b) -> a -> b -getPathTo x = head . catMaybes . getPathsTo x +getPathTo x y = + case catMaybes (getPathsTo x y) of + (p:_) -> p + [] -> error "getPathTo: element not found in forest" getPathsTo :: Eq a => Forest (a, b) -> a -> [Maybe b] getPathsTo [] _ = [] @@ -197,19 +200,12 @@ forestToStateDiagram -> StateDiagram String Int () forestToStateDiagram getName getStart ts = StateDiagram { label = 1, - substates = treeToStateDiagram getName (stail . getStart) <$> ts, + substates = treeToStateDiagram getName (drop 1 . getStart) <$> ts, name = "", connections = (), -- TODO startState = getStart Nothing } -{-| -Like 'tail', but never trying to shorten the empty list. --} -stail :: [a] -> [a] -stail [] = [] -stail xs = tail xs - treeToStateDiagram :: (Node -> String) -> (Maybe Node -> [Int]) @@ -243,7 +239,7 @@ treeToStateDiagram getName getStart n = case node of l = last $ snd root root = rootLabel n node = fst root - fromTree = treeToStateDiagram getName (stail . getStart) + fromTree = treeToStateDiagram getName (drop 1 . getStart) {-| Transforms a mapping of containments into a tree structure. diff --git a/src/Modelling/StateDiagram/Layout.hs b/src/Modelling/StateDiagram/Layout.hs index b3dec8a4..d20a7c6d 100644 --- a/src/Modelling/StateDiagram/Layout.hs +++ b/src/Modelling/StateDiagram/Layout.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-error=x-partial #-} {-# LANGUAGE RecordWildCards #-} module Modelling.StateDiagram.Layout @@ -12,7 +11,9 @@ import Diagrams.Backend.SVG.CmdLine import qualified Data.Map as Map import Data.Graph import Data.Tree +import Data.List (find) import Data.List.Index +import Data.Maybe (fromMaybe) import Modelling.StateDiagram.Arrows import Modelling.StateDiagram.Support import Modelling.StateDiagram.Style (Styling(..)) @@ -122,12 +123,19 @@ drawWrapper _ a (Transition b c l rightType layouts) = appendEdges layouts # named (a ++ [b]) where x = drawText c black -drawWrapper style a s@AndDecomposition {} = appendEdges (roundedRect (width f) (height f) 0.1 # lc (hashToColour style (head (dropWhile null (map strings (component s)) ++ [""]))) - <> f) (lengthXY s) (rightC s) (outerLayout s) # named (a ++ - [key s]) +drawWrapper style a s@AndDecomposition {} = + appendEdges + (roundedRect (width f) (height f) 0.1 + # lc (hashToColour style (fromMaybe "" (find (not . null) (map strings (component s))))) + <> f) + (lengthXY s) (rightC s) (outerLayout s) # named (a ++ [key s]) where - w = maximum (fmap (width . drawWrapper style (a ++ [key s])) (component s)) - h = maximum (fmap (height . drawWrapper style (a ++ [key s])) (component s)) + w = case fmap (width . drawWrapper style (a ++ [key s])) (component s) of + [] -> error "drawWrapper AndDecomposition: empty component" + xs -> maximum xs + h = case fmap (height . drawWrapper style (a ++ [key s])) (component s) of + [] -> error "drawWrapper AndDecomposition: empty component" + xs -> maximum xs d = (vcat . fmap alignL) (drawSwimlane False (fmap (drawWrapper' style (a ++ [key s])) (component s)) w) # centerXY e = (hcat . fmap alignT) (drawSwimlane True (fmap (drawWrapper' style (a ++ [key @@ -230,7 +238,9 @@ toWrapper s@StateDiagram {} = OrDecomposition toWrapper' (label s) (name s) newConnection = if null (startState s) then connections s else Connection [-1] (startState s) "" : connections s convertedConnection = changeConnectionType newConnection toWrapper' [] - maxKey = maximum (Map.keys $ mapWithLabel $ substates s) + maxKey = case Map.keys (mapWithLabel $ substates s) of + [] -> error "toWrapper: empty substates" + ks -> maximum ks createGraph :: Map.Map Int [Int] -> [StateDiagram String Int [Connection Int]] -> [(StateDiagram String Int [Connection Int], Int, [Int])] -> (Graph, Vertex -> (StateDiagram String Int [Connection Int], Int, [Int]), Int -> Maybe @@ -265,7 +275,9 @@ placeStartState [[a]] _ = [StartS (-1) 0 NoConnection Unspecified] : [[a]] placeStartState originalW ss = modifyAt layerToInsert (++ [StartS (-1) 0 NoConnection Unspecified]) originalW where - ssLayer = findLayer (head ss) originalW 0 + ssLayer = case ss of + h:_ -> findLayer h originalW 0 + [] -> error "placeStartState: empty startState list" layerToInsert = if ssLayer == (length originalW -1) then ssLayer - 1 else ssLayer + 1 @@ -302,12 +314,13 @@ addD :: ConnectionType -> Int -> [Int] -> [[Wrapper]] -> ConnectWithType -> addD a maxKey [_, _] withDummy c@ConnectWithType {} withConnect = (withDummy, maxKey, withConnect ++ [ConnectWithType (Connection [maxKey] (pointTo $ connecting c) (transition $ connecting c)) a]) -addD a maxKey (_:xs) withDummy c@ConnectWithType {} [] = - addD a (maxKey + 1) xs (modifyAt (head xs) (\ x -> x ++ [Dummy (maxKey + 1) +addD a maxKey (_:x1:xs) withDummy c@ConnectWithType {} [] = + addD a (maxKey + 1) (x1:xs) (modifyAt x1 (\ x -> x ++ [Dummy (maxKey + 1) Unspecified 0.1]) withDummy) c [ConnectWithType (Connection (pointFrom $ connecting c) [maxKey + 1] "") (betweenConnection a)] -addD a maxKey (_:xs) withDummy c@ConnectWithType {} withConnect = - addD a (maxKey + 1) xs (modifyAt (head xs) (\ x -> x ++ [Dummy (maxKey + 1) +addD _ _ [_] _ _ _ = error "addD: single element list - insufficient layers" +addD a maxKey (_:x1:xs) withDummy c@ConnectWithType {} withConnect = + addD a (maxKey + 1) (x1:xs) (modifyAt x1 (\ x -> x ++ [Dummy (maxKey + 1) Unspecified 0.1]) withDummy) c (withConnect ++ [ConnectWithType ( Connection [maxKey] [maxKey + 1] "") (betweenConnection a)]) addD _ _ _ _ _ _ = ([], 0, []) @@ -380,8 +393,12 @@ addTransitionStates maxKey transitionLayer originalLayer (x:xs) newConnection = addTransitionStates k (modifyAt endLayer addState transitionLayer) originalLayer xs (newConnection ++ type2) where - startLayer = findLayer (head $ pointFrom $ connecting x) originalLayer 0 - endLayer = findLayer (head $ pointTo $ connecting x) originalLayer 0 + startLayer = case pointFrom (connecting x) of + h:_ -> findLayer h originalLayer 0 + [] -> error "addTransitionStates: empty pointFrom" + endLayer = case pointTo (connecting x) of + h:_ -> findLayer h originalLayer 0 + [] -> error "addTransitionStates: empty pointTo" startLabel = pointFrom $ connecting x endLabel = pointTo $ connecting x connectName = transition (connecting x) @@ -417,16 +434,18 @@ connectionsByLayers (x:xs) layers connectionLayers = startStateFirst :: StateDiagram String Int [Connection Int] -> [Int] -> StateDiagram String Int [Connection Int] startStateFirst a [] = a startStateFirst a@StateDiagram {} (x:xs) = - StateDiagram (loopOrder : tail newOrder) (label a) (name a) (connections a) - (startState a) - where - newOrder = moveToFirst (substates a) x [] - loopOrder = startStateFirst (head newOrder) xs + case moveToFirst (substates a) x [] of + h:ts -> + let loopOrder = startStateFirst h xs + in StateDiagram (loopOrder : ts) (label a) (name a) (connections a) + (startState a) + [] -> error "startStateFirst: target startState not found" startStateFirst a@CombineDiagram {} (x:xs) = - CombineDiagram (loopOrder : tail newOrder) (label a) - where - newOrder = moveToFirst (substates a) x [] - loopOrder = startStateFirst (head newOrder) xs + case moveToFirst (substates a) x [] of + h:ts -> + let loopOrder = startStateFirst h xs + in CombineDiagram (loopOrder : ts) (label a) + [] -> error "startStateFirst: target startState not found" startStateFirst a _ = a rearrangeSubstates :: StateDiagram String Int [Connection Int] -> StateDiagram String Int [Connection Int] @@ -581,8 +600,12 @@ addCrossSuperStateDummy a b = case (pointFrom $ connecting b, pointTo $ ForwardWH startPoint [ConnectWithType (Connection pointFromLabel pointToLabel connectionName) SelfCL] a) where - startLayer = findLayer (head $ pointFrom $ connecting b) (layered a) 0 - endLayer = findLayer (head $ pointTo $ connecting b) (layered a) 0 + startLayer = case pointFrom (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "addCrossSuperStateDummy: empty pointFrom" + endLayer = case pointTo (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "addCrossSuperStateDummy: empty pointTo" startPoint = pointFrom $ connecting b endPoint = pointTo $ connecting b connectionName = transition $ connecting b @@ -678,14 +701,22 @@ csdWidth :: Double csdWidth = 0.05 insertDummyLeft :: Wrapper -> [[Wrapper]] -insertDummyLeft a = if all checkWrapperLayer (head $ layered a) then - (CrossStateDummy (maxLabel a + 1) csdWidth : head (layered a)) : tail (layered a) - else [CrossStateDummy (maxLabel a + 1) csdWidth] : layered a +insertDummyLeft a = case layered a of + first:rest -> + if all checkWrapperLayer first + then (CrossStateDummy (maxLabel a + 1) csdWidth : first) : rest + else [CrossStateDummy (maxLabel a + 1) csdWidth] : layered a + [] -> error "insertDummyLeft: layered is empty" insertDummyRight :: Wrapper -> [[Wrapper]] -insertDummyRight a = if all checkWrapperLayer (last $ layered a) then init ( - layered a) ++ [last (layered a) ++ [CrossStateDummy (maxLabel a + 1) csdWidth]] else - layered a ++ [[CrossStateDummy (maxLabel a + 1) csdWidth]] +insertDummyRight a = case reverse (layered a) of + lastPart:restRev -> + let initPart = reverse restRev + dummy = CrossStateDummy (maxLabel a + 1) csdWidth + in if all checkWrapperLayer lastPart + then initPart ++ [lastPart ++ [dummy]] + else reverse (lastPart:restRev) ++ [[dummy]] + [] -> error "insertDummyRight: layered is empty" changeConnectionType :: [Connection Int] -> [[Wrapper]] -> [ConnectWithType] -> [ConnectWithType] @@ -693,8 +724,12 @@ changeConnectionType [] _ withType = withType changeConnectionType (x:xs) layers withType = changeConnectionType xs layers (withType ++ [ConnectWithType x decideType]) where - startLayer = findLayer (head $ pointFrom x) layers 0 - endLayer = findLayer (head $ pointTo x) layers 0 + startLayer = case pointFrom x of + h:_ -> findLayer h layers 0 + [] -> error "changeConnectionType: empty pointFrom" + endLayer = case pointTo x of + h:_ -> findLayer h layers 0 + [] -> error "changeConnectionType: empty pointTo" decideType = decideConnectionType startLayer endLayer changeRightConnection :: Wrapper -> RightConnect -> Wrapper @@ -744,8 +779,12 @@ markRightConnection a b = OrDecomposition (layered afterChange) (key a) (strings (typedConnections a ++ [ConnectWithType (connecting b) decideConnectType]) (layout a) (maxLabel a) (lengthXY a) (rightC a) (outerLayout a) where - startLayer = findLayer (head (pointFrom $ connecting b)) (layered a) 0 - endLayer = findLayer (head (pointTo $ connecting b)) (layered a) 0 + startLayer = case pointFrom (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "markRightConnection: empty pointFrom" + endLayer = case pointTo (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "markRightConnection: empty pointTo" stateToModify = if startLayer < endLayer then pointFrom $ connecting b else pointTo $ connecting b afterChange = changeRightConnections stateToModify (key a) (if connectType diff --git a/src/Modelling/StateDiagram/Support.hs b/src/Modelling/StateDiagram/Support.hs index e1171751..80145083 100644 --- a/src/Modelling/StateDiagram/Support.hs +++ b/src/Modelling/StateDiagram/Support.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-error=x-partial #-} - module Modelling.StateDiagram.Support where import Modelling.StateDiagram.Datatype import Data.Graph @@ -16,14 +14,14 @@ betweenConnection _ = ForwardH buildEmptyWrapperByLayer :: [[Wrapper]] -> [[Wrapper]] -> [[Wrapper]] buildEmptyWrapperByLayer [_, _] list = list ++ [[]] -buildEmptyWrapperByLayer xs list = buildEmptyWrapperByLayer (tail xs) - (list ++ [[]]) +buildEmptyWrapperByLayer (_:xs) list = buildEmptyWrapperByLayer xs (list ++ [[]]) +buildEmptyWrapperByLayer [] _ = error "buildEmptyWrapperByLayer: insufficient layers" buildEmptyConnectionByLayer :: [[Wrapper]] -> [[ConnectWithType]] -> [[ConnectWithType]] buildEmptyConnectionByLayer [_, _] list = list ++ [[]] -buildEmptyConnectionByLayer xs list = buildEmptyConnectionByLayer (tail xs) - (list ++ [[]]) +buildEmptyConnectionByLayer (_:xs) list = buildEmptyConnectionByLayer xs (list ++ [[]]) +buildEmptyConnectionByLayer [] _ = error "buildEmptyConnectionByLayer: insufficient layers" checkWrapperLayer :: Wrapper -> Bool checkWrapperLayer StartS {} = True @@ -88,9 +86,11 @@ findLayer num (x:xs) layer getCompareList :: Bool -> Wrapper -> [[Int]] getCompareList checkType wrapper = case wrapper of - OrDecomposition {} -> if checkType then fmap ((\ a -> key wrapper : [a]) . key) - (head $ layered wrapper) else fmap ((\ a -> key wrapper : [a]) . key) - (last $ layered wrapper) + OrDecomposition {} -> case layered wrapper of + [] -> error "getCompareList: empty layered" + layers@(l:_) -> + let pick = if checkType then l else last layers + in fmap ((\ a -> key wrapper : [a]) . key) pick AndDecomposition {} -> fmap (key wrapper :) (concatMap (getCompareList checkType) (component wrapper)) _ -> [] @@ -103,13 +103,16 @@ getConnection a = fmap (\ (ConnectWithType x y) -> ((a ++ pointFrom x, a ++ getConnectionWithLayerBefore2 :: Wrapper -> [ConnectWithType] -> [[Int]] -> [[Int]] getConnectionWithLayerBefore2 _ [] connected = connected getConnectionWithLayerBefore2 wrapper (x:xs) connected - | head (pointFrom y) == key wrapper = getConnectionWithLayerBefore2 wrapper xs + | startsWithWrapper (pointFrom y) = getConnectionWithLayerBefore2 wrapper xs (connected ++ [pointTo y]) - | head (pointTo y) == key wrapper = getConnectionWithLayerBefore2 wrapper xs + | startsWithWrapper (pointTo y) = getConnectionWithLayerBefore2 wrapper xs (connected ++ [pointFrom y]) | otherwise = getConnectionWithLayerBefore2 wrapper xs connected where y = connecting x + startsWithWrapper z = case z of + h:_ -> h == key wrapper + [] -> error "getConnectionWithLayerBefore2: empty point list" getConnectionWithLayerBefore3 :: [Int] -> [ConnectWithType] -> [[Int]] -> [[Int]] getConnectionWithLayerBefore3 _ [] connected = connected @@ -143,14 +146,18 @@ getDeeperLevelL ([a], [b]) commonValue layersBef = higherIndex (a, b) (fmap key newLayerBef) where newState = returnState layersBef commonValue - newLayerBef = last $ layered newState + newLayerBef = case layered newState of + [] -> error "getDeeperLevelL: empty layered" + xs -> last xs getDeeperLevelL ([a, as], [b, bs]) commonValue layersBef = if a /= b then higherIndex (a, b) (fmap key (component newState)) else higherIndex (as, bs) newAndLayerBef where newState = returnState layersBef commonValue newState' = returnState (component newState) a - newAndLayerBef = fmap key (last (layered newState')) + newAndLayerBef = case layered newState' of + [] -> error "getDeeperLevelL: empty layered (nested)" + xs -> fmap key (last xs) getDeeperLevelL _ _ _ = 0 -- jscpd:ignore-end @@ -159,14 +166,18 @@ getDeeperLevelR ([a], [b]) commonValue layersBef = higherIndex (a, b) (fmap key newLayerBef) where newState = returnState layersBef commonValue - newLayerBef = head $ layered newState + newLayerBef = case layered newState of + [] -> error "getDeeperLevelR: empty layered" + (x:_) -> x getDeeperLevelR ([a, as], [b, bs]) commonValue layersBef = if a /= b then higherIndex (a, b) (fmap key (component newState)) else higherIndex (as, bs) newAndLayerBef where newState = returnState layersBef commonValue newState' = returnState (component newState) a - newAndLayerBef = fmap key (head (layered newState')) + newAndLayerBef = case layered newState' of + [] -> error "getDeeperLevelR: empty layered (nested)" + (x:_) -> fmap key x getDeeperLevelR _ _ _ = 0 getFirstFromTuple3 :: (a, b, c) -> a @@ -213,8 +224,9 @@ mapWithLabel a = Map.fromList (fmap (\ x -> (label x, x)) a) mapWithConnection :: Ord a => [Connection a] -> Map.Map a [a] mapWithConnection - = foldl (\ a x -> Map.insertWith (++) (head (pointFrom x)) (pointTo x) a) - Map.empty + = foldl (\ a x -> case pointFrom x of + h:_ -> Map.insertWith (++) h (pointTo x) a + [] -> error "mapWithConnection: empty pointFrom") Map.empty mapWithConnection' :: [StateDiagram n Int [Connection Int]] -> Map.Map Int [Int] -> Map.Map Int [Int] diff --git a/test/Modelling/StateDiagram/EnumArrowsSpec.hs b/test/Modelling/StateDiagram/EnumArrowsSpec.hs index 0e8cd750..9805e3e1 100644 --- a/test/Modelling/StateDiagram/EnumArrowsSpec.hs +++ b/test/Modelling/StateDiagram/EnumArrowsSpec.hs @@ -115,8 +115,11 @@ spec let task = defaultEnumArrowsInstance answer = concatMap (uncurry zip) $ taskSolution task + answerTail = case answer of + [] -> [] + (_:xs) -> xs in - rate (taskSolution task) (tail answer) + rate (taskSolution task) answerTail `shouldBe` toRational (length answer - 1) / toRational (length answer) it "ambiguous placeholder test variant 1" $ do