Skip to content

Commit

Permalink
[#500] Trails: Refactor tests to simplify expression.
Browse files Browse the repository at this point in the history
  • Loading branch information
@a-stacey
a-stacey committed Aug 19, 2019
1 parent 0c3a143 commit 59a253d
Showing 1 changed file with 61 additions and 27 deletions.
88 changes: 61 additions & 27 deletions projects/trails/test/Mirza/Trails/Tests/Client.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -83,51 +83,51 @@ clientSpec = do
let checkDistinctTrailsCommonEventIdWithContext = checkDistinctTrailsCommonEventId step http

-- Trail: *---*
let buildTwoEntryTrail = join $ addNextEntry <$> (fmap pure buildEntry)
let buildTwoEntryTrail = addNextEntryIO $ buildSingleEntryTrail
twoEntryTrail <- buildTwoEntryTrail
checkTrailWithContext "2 Entry Trail (1 Previous Entry)" twoEntryTrail

-- Trail: *---*---*
let buildThreeEntryTrail = join $ addNextEntry <$> buildTwoEntryTrail
let buildThreeEntryTrail = addNextEntryIO $ buildTwoEntryTrail
threeEntryTrail <- buildThreeEntryTrail
checkTrailWithContext "3 Entry Trail (1 Previous Entry, 1 Next Entry)" threeEntryTrail

-- Trail: *--\
-- *
-- *--/
let buildTwoPreviousEntryTrail = join $ addPreviousEntry <$> buildTwoEntryTrail
let buildTwoPreviousEntryTrail = addPreviousEntryIO $ buildTwoEntryTrail
twoPreviousEntryTrail <- buildTwoPreviousEntryTrail
checkTrailWithContext "2 Previous Entries Trail" twoPreviousEntryTrail

-- Trail: *--\
-- *---*
-- *--/
threePreviousEntryTrail <- join $ addPreviousEntry <$> buildTwoPreviousEntryTrail
threePreviousEntryTrail <- addPreviousEntryIO $ buildTwoPreviousEntryTrail
checkTrailWithContext "3 Previous Entries Trail" threePreviousEntryTrail

-- Trail: /--*
-- *
-- \--*
let buildTwoNextEntryTrail = join $ addNextEntry <$> (swap <$> buildTwoEntryTrail)
let buildTwoNextEntryTrail = addNextEntryIO $ swapIO $ buildTwoEntryTrail
twoNextEntryTrail <- buildTwoNextEntryTrail
checkTrailWithContext "2 Next Entries Trail" twoNextEntryTrail

-- Trail: /--*
-- *---*
-- \--*
threeNextEntryTrail <- join $ addNextEntry <$> (swap <$> buildTwoNextEntryTrail)
threeNextEntryTrail <- addNextEntryIO $ swapIO $ buildTwoNextEntryTrail
checkTrailWithContext "3 Next Entries Trail" threeNextEntryTrail

-- Trail: *--\ /--*
-- *
-- *--/ \--*
twoPreviousTwoNextEntryTrail <- join $ fmap addNextEntry $ fmap swap $ join $ addNextEntry <$> buildTwoPreviousEntryTrail
twoPreviousTwoNextEntryTrail <- addNextEntryIO $ swapIO $ addNextEntryIO $ buildTwoPreviousEntryTrail
checkTrailWithContext "2 Previous 2 Next Entries Trail" twoPreviousTwoNextEntryTrail

-- Trail: *--\ /--*
-- *---*
-- *--/ \--*
twoPreviousThenNextThenTwoNextEntryTrail <- join $ fmap addNextEntry $ fmap swap $ join $ fmap addNextEntry $ join $ addNextEntry <$> buildTwoPreviousEntryTrail
twoPreviousThenNextThenTwoNextEntryTrail <- addNextEntryIO $ swapIO $ addNextEntryIO $ addNextEntryIO $ buildTwoPreviousEntryTrail
checkTrailWithContext "1 Previous Entry, then 2 Previous Entries and 2 Next Entries Trail" twoPreviousThenNextThenTwoNextEntryTrail

-- Trail: *---*--\ /--*---*
Expand All @@ -136,10 +136,10 @@ clientSpec = do
let buildLongWing = do
topInput <- buildThreeEntryTrail
bottomInput <- buildTwoEntryTrail
let inputWing = joinEntries (trailEntrySignature $ head bottomInput) topInput <> bottomInput
let inputWing = joinEntries (firstSignature bottomInput) topInput <> bottomInput
inputArrow <- addNextEntry inputWing
inputAndTopOutput <- join $ fmap addNextEntry $ addNextEntry inputArrow
bottomOutput <- join $ fmap addNextEntry $ fmap (joinEntries (trailEntrySignature $ head inputArrow)) $ fmap pure $ buildEntry
inputAndTopOutput <- addNextEntryIO $ addNextEntry inputArrow
bottomOutput <- addNextEntryIO $ joinEntriesIO (firstSignature inputArrow) $ buildSingleEntryTrail
pure $ inputAndTopOutput <> bottomOutput
longWing <- buildLongWing
checkTrailWithContext "Long Wing Trail (see code comment diagram)" longWing
Expand Down Expand Up @@ -186,9 +186,9 @@ clientSpec = do
topInput <- buildTwoEntryTrail
bottomInput <- buildTwoEntryTrail
topOutputNode <- buildEntry
topOutput <- addNextEntry $ pure $ addPreviousEntrySignature topOutputNode (trailEntrySignature $ head topInput)
topOutput <- addNextEntry $ pure $ addPreviousEntrySignature topOutputNode (firstSignature topInput)
outputNode <- buildEntry
bottomOutput <- addNextEntry $ pure $ foldl addPreviousEntrySignature outputNode (trailEntrySignature <$> [head topInput, head bottomInput])
bottomOutput <- addNextEntry $ pure $ foldl addPreviousEntrySignature outputNode (firstSignature <$> [topInput, bottomInput])
pure $ topOutput <> bottomOutput <> topInput <> bottomInput
latticeTrail <- buildLattice
checkTrailWithContext "Lattice Trail (see code comment diagram)" latticeTrail
Expand All @@ -198,8 +198,8 @@ clientSpec = do
-- *---*---*
-- Note: ':' Denotes matching eventId (but otherwise distinct trails).
commonEventIdDistinctTrailsTopInput <- buildTwoEntryTrail
let commonEventIdDistinctTrailsMatchingTrailId = trailEntryEventID $ head commonEventIdDistinctTrailsTopInput
commonEventIdDistinctTrailsBottomTrail <- addNextEntryIO $ updateFirstEventId commonEventIdDistinctTrailsMatchingTrailId <$> buildTwoEntryTrail
let commonEventIdDistinctTrailsMatchingTrailId = firstEventId commonEventIdDistinctTrailsTopInput
commonEventIdDistinctTrailsBottomTrail <- addNextEntryIO $ updateFirstEventIdIO commonEventIdDistinctTrailsMatchingTrailId $ buildTwoEntryTrail
commonEventIdDistinctTrailsTopTrail <- addNextEntry $ commonEventIdDistinctTrailsTopInput
checkDistinctTrailsCommonEventIdWithContext "mid" commonEventIdDistinctTrailsTopTrail commonEventIdDistinctTrailsBottomTrail commonEventIdDistinctTrailsMatchingTrailId

Expand All @@ -208,8 +208,8 @@ clientSpec = do
-- *---*---*
-- Note: ':' Denotes matching eventId (but otherwise distinct trails).
commonEventIdStartDistinctTrailsTopInput <- buildSingleEntryTrail
let commonEventIdStartDistinctTrailsMatchingTrailId = trailEntryEventID $ head commonEventIdStartDistinctTrailsTopInput
commonEventIdStartDistinctTrailsBottomInput <- updateFirstEventId commonEventIdStartDistinctTrailsMatchingTrailId <$> buildSingleEntryTrail
let commonEventIdStartDistinctTrailsMatchingTrailId = firstEventId commonEventIdStartDistinctTrailsTopInput
commonEventIdStartDistinctTrailsBottomInput <- updateFirstEventIdIO commonEventIdStartDistinctTrailsMatchingTrailId $ buildSingleEntryTrail
commonEventIdStartDistinctTrailsTopTrail <- addNextEntryIO $ addNextEntry commonEventIdStartDistinctTrailsTopInput
commonEventIdStartDistinctTrailsBottomTrail <- addNextEntryIO $ addNextEntry commonEventIdStartDistinctTrailsBottomInput
-- traceM $ "Top Trail: " <> (prettyTrail commonEventIdStartDistinctTrailsTopTrail)
Expand All @@ -223,7 +223,7 @@ clientSpec = do
-- Note: ':' Denotes matching eventId (but otherwise distinct trails).
commonEventIdEndDistinctTrailsTopTrail <- buildThreeEntryTrail
commonEventIdEndDistinctTrailsBottomInput <- buildThreeEntryTrail
let commonEventIdEndDistinctTrailsMatchingTrailId = trailEntryEventID $ head commonEventIdEndDistinctTrailsTopTrail
let commonEventIdEndDistinctTrailsMatchingTrailId = firstEventId commonEventIdEndDistinctTrailsTopTrail
let commonEventIdEndDistinctTrailsBottomTrail = updateFirstEventId commonEventIdEndDistinctTrailsMatchingTrailId commonEventIdEndDistinctTrailsBottomInput
checkDistinctTrailsCommonEventIdWithContext "at the end of the" commonEventIdEndDistinctTrailsTopTrail commonEventIdEndDistinctTrailsBottomTrail commonEventIdEndDistinctTrailsMatchingTrailId

Expand All @@ -232,9 +232,9 @@ clientSpec = do
-- *---*---/
-- Note: ':' Denotes matching eventId (but otherwise distinct trail entries).
commonEventIdJoinedEndTopInput <- buildTwoEntryTrail
let commonEventIdJoinedEndMatchingTrailId = trailEntryEventID $ head commonEventIdJoinedEndTopInput
commonEventIdJoinedEndBottomTrail <- addNextEntryIO $ updateFirstEventId commonEventIdJoinedEndMatchingTrailId <$> buildTwoEntryTrail
let commonEventIdJoinedEndTopTrail = joinEntries (trailEntrySignature $ head commonEventIdJoinedEndBottomTrail) commonEventIdJoinedEndTopInput
let commonEventIdJoinedEndMatchingTrailId = firstEventId commonEventIdJoinedEndTopInput
commonEventIdJoinedEndBottomTrail <- addNextEntryIO $ updateFirstEventIdIO commonEventIdJoinedEndMatchingTrailId $ buildTwoEntryTrail
let commonEventIdJoinedEndTopTrail = joinEntries (firstSignature commonEventIdJoinedEndBottomTrail) commonEventIdJoinedEndTopInput
let completeCommentEventIdJoinedEndTrail = commonEventIdJoinedEndTopTrail <> commonEventIdJoinedEndBottomTrail
checkTrailWithContext "Common EventId Joined End Trail" completeCommentEventIdJoinedEndTrail

Expand All @@ -244,8 +244,8 @@ clientSpec = do
-- Note: ':' Denotes matching eventId (but otherwise distinct trail entries).
let buildCommonEventIdJoinedStart = do
root <- buildEntry
topNext <- joinEntries (trailEntrySignature root) <$> buildSingleEntryTrail
bottomNext <- updateFirstEventId (trailEntryEventID $ head topNext) <$> (joinEntries (trailEntrySignature root) <$> buildSingleEntryTrail)
topNext <- joinEntriesIO (trailEntrySignature root) $ buildSingleEntryTrail
bottomNext <- updateFirstEventIdIO (firstEventId topNext) $ (joinEntriesIO (trailEntrySignature root) $ buildSingleEntryTrail)
topBoth <- addNextEntry $ topNext
bottomBoth <- addNextEntry $ bottomNext
pure $ bottomBoth <> topBoth <> [root]
Expand All @@ -259,9 +259,9 @@ clientSpec = do
-- Note: ':' Denotes matching eventId (but otherwise distinct trail entries).
let buildCommonEventIdJoinedStartEnd = do
root <- buildEntry
topNext <- joinEntries (trailEntrySignature root) <$> buildSingleEntryTrail
bottomNext <- updateFirstEventId (trailEntryEventID $ head topNext) <$> (joinEntries (trailEntrySignature root) <$> buildSingleEntryTrail)
topEnd <- joinEntries (trailEntrySignature $ head bottomNext) <$> (addNextEntry $ topNext)
topNext <- joinEntriesIO (trailEntrySignature root) $ buildSingleEntryTrail
bottomNext <- updateFirstEventIdIO (firstEventId topNext) $ (joinEntriesIO (trailEntrySignature root) $ buildSingleEntryTrail)
topEnd <- joinEntriesIO (firstSignature bottomNext) $ (addNextEntry $ topNext)
pure $ topEnd <> bottomNext <> [root]
commonEventIdJoinedStartEnd <- buildCommonEventIdJoinedStartEnd
--traceM $ prettyTrail commonEventIdJoinedStartEnd
Expand Down Expand Up @@ -326,13 +326,20 @@ addPreviousEntry entries = do
newEntry <- buildEntry
pure $ swap $ newEntry : (joinEntries (trailEntrySignature newEntry) entries)

-- This function is just designed to simplify expression.
addPreviousEntryIO :: IO [TrailEntry] -> IO [TrailEntry]
addPreviousEntryIO trail = join $ addNextEntry <$> trail

-- This function is just designed to simplify expression.
joinEntriesIO :: SignaturePlaceholder -> IO [TrailEntry] -> IO [TrailEntry]
joinEntriesIO sig = fmap (joinEntries sig)

joinEntries :: SignaturePlaceholder -> [TrailEntry] -> [TrailEntry]
joinEntries sig (entry : entries) = (addPreviousEntrySignature entry sig) : entries
-- Could just define the following as buildEntry, but it seems that this is likely to be a logic error and so its probably better to just fail here.
joinEntries _ [] = error "Error: There is a logic error in the tests. Can't add a previous entry of a non existant entry."


-- This function is just designed to simplify expression.
addNextEntryIO :: IO [TrailEntry] -> IO [TrailEntry]
addNextEntryIO trail = join $ addNextEntry <$> trail

Expand All @@ -349,9 +356,15 @@ addNextEntry entries@(entry : _) = do
addNextEntry [] = error "Error: There is a logic error in the tests. Can't add the next entry of a non existant entry."


-- This function is just designed to simplify expression.
addPreviousEntrySignature :: TrailEntry -> SignaturePlaceholder -> TrailEntry
addPreviousEntrySignature entry sig = entry{trailEntryParentSignatures = sig : (trailEntryParentSignatures entry)}

-- This function is just designed to simplify expression.
updateFirstEventIdIO :: EventId -> IO [TrailEntry] -> IO [TrailEntry]
updateFirstEventIdIO eventId entries = updateFirstEventId eventId <$> entries

-- This function is just designed to simplify expression.
updateFirstEventId :: EventId -> [TrailEntry] -> [TrailEntry]
updateFirstEventId eventId (entry : entries) = (updateEventId eventId entry) : entries
-- Could just define the following as NOP, but it seems that this is likely to be a logic error and so its probably better to just fail here.
Expand Down Expand Up @@ -417,6 +430,27 @@ checkDistinctTrailsCommonEventId step http differentator topTrail bottomTrail co
checkPartialTrailWithContext ("Two distinct trails with a common EventId " <> differentator <> " trail (common EventId)") completeTrail completeTrail [] [commonEventId]




-- This function is just designed to simplify expression.
firstSignature :: [TrailEntry] -> SignaturePlaceholder
firstSignature = firstField trailEntrySignature

-- This function is just designed to simplify expression.
firstEventId :: [TrailEntry] -> EventId
firstEventId = firstField trailEntryEventID

-- This function is just designed to simplify expression.
firstField :: (TrailEntry -> a) -> [TrailEntry] -> a
firstField _ [] = error "Error: There is a logic error in the tests. Can't get the first field in an empty trail."
firstField fn entries = fn $ head entries



-- This function is just designed to simplify expression.
swapIO :: IO [TrailEntry] -> IO [TrailEntry]
swapIO = fmap swap

swap :: [TrailEntry] -> [TrailEntry]
swap [] = []
swap list@[_] = list
Expand Down

0 comments on commit 59a253d

Please sign in to comment.