lint: Add check for circular graph

1 files changed, 39 insertions, 3 deletions

diff --git a/src/lib/Codec/Pesto/Lint.lhs b/src/lib/Codec/Pesto/Lint.lhs
index affea98..45e3ef6 100644
--- a/src/lib/Codec/Pesto/Lint.lhs
+++ b/src/lib/Codec/Pesto/Lint.lhs
@@ -12,7 +12,7 @@ Linting
 > 	, Metadata(..)
 > 	, LintResult(..)) where
 > import Test.HUnit hiding (test, Node)
-> import Data.List (sort, isPrefixOf, insert)
+> import Data.List (sort, isPrefixOf, insert, intersect)
 > import Text.Parsec hiding (parse)
 > import Data.Char (isSpace, toLower)
 > import Data.Ratio ((%))
@@ -54,7 +54,7 @@ Empty recipes or circular references have no root node:
 > testConnectivity = [
 > 	  cmpLint "" [LintResult NoRootNode [], LintResult NoMetadata []]
 > 	, cmpLint "*foobar >foobar"
->		[LintResult NoRootNode [], LintResult NoMetadata []]
+>		[LintResult NoRootNode [], LintResult CircularLoop [0, 1], LintResult NoMetadata []]
 > 	, cmpLint "+foobar"
 >		[LintResult NonResultRootNode [0], LintResult NoMetadata []]
 
@@ -278,7 +278,7 @@ all results and alternatives are referenced at some point.
 >		f xs _ = xs
 
 > testLintRefs = [
-> 	  cmpLint "*foobar >foobar >barbaz" []
+> 	  cmpLint "*foobar >foobar >barbaz" [LintResult CircularLoop [0, 1]]
 > 	, cmpLint "*foobar >foo" [LintResult UndefinedReference [0]]
 > 	]
 
@@ -336,6 +336,39 @@ make the alternative pointless.
 > 	, cmpLint "+A &B |foo *foo >bar" []
 > 	]
 
+References cannot loop, because, well, you cannot cook something and
+use an ingredient you have not made yet. It is possible to branch out
+and merge again though if an ingredient is split into multiple parts
+and added to different outputs.
+
+> circularLoops nodes edges = map (LintResult CircularLoop) circles
+> 	where
+> 		allReferences = foldl referenceNodes [] nodes
+> 		referenceNodes xs (nodeid, Reference _) = nodeid:xs
+> 		referenceNodes xs _ = xs
+> 		circles = filter (not . null) $ map (visitIncoming [] . singleton) allReferences
+> 		singleton x = [x]
+> 		visitIncoming _ [] = []
+> 		visitIncoming visited next = case length (intersect visited nextNext) of
+> 			0 -> visitIncoming nextVisited nextNext
+> 			_ -> nextVisited
+> 			where
+> 				nextVisited = visited ++ next
+> 				nextNext = map fst $ concat $ map (incomingNodes nodes edges) next
+
+> testLintCircularLoops = [
+> 	  cmpLint "*y >x *x >y >foobar"
+> 		[LintResult CircularLoop [0, 3, 2, 1] , LintResult CircularLoop [2, 1, 0, 3]]
+> 	, cmpLint "*z >x *x >y *y >z *z >foobar" [
+> 		  LintResult CircularLoop [0, 5, 4, 3, 2, 1]
+> 		, LintResult CircularLoop [2, 1, 0, 5, 4, 3]
+> 		, LintResult CircularLoop [4, 3, 2, 1, 0, 5]
+> 		, LintResult CircularLoop [6, 5, 4, 3, 2, 1, 0]
+> 		]
+> 	, cmpLint "+a >foobar *1/2 _ foobar >x *1/2 _ foobar >y *x *y >final" []
+> 	, cmpLint "+a >foobar *1/2 _ foobar >x *x *1/2 _ foobar >final" []
+> 	]
+
 Ranges
 ++++++
 
@@ -370,6 +403,7 @@ Appendix
 > 	| MoreThanOneRootNode
 > 	| UndefinedReference
 > 	| DuplicateReferenceName
+> 	| CircularLoop
 > 	| TooFewChildren
 >	| TimeIsATool
 > 	| TimeAnnotatesAction
@@ -388,6 +422,7 @@ Every lint test checks a single aspect of the graph.
 > 	  rootIsResult
 >	, referencesResolved
 > 	, uniqueNames
+> 	, circularLoops
 >	, resultNonempty
 >	, twoAlternatives
 > 	, timeIsATool
@@ -419,6 +454,7 @@ Every lint test checks a single aspect of the graph.
 > 	, testMetadata
 > 	, testLintRefs
 > 	, testUniqueNames
+> 	, testLintCircularLoops
 > 	, testLintQuantity
 > 	, testLintWellKnownUnit
 > 	, testTimeAnnotatesAction