5c00948b-e964-4355-a92e-635ceece6223

Committed 18 Jul 2026 02:16AM UTC coverage: 58.657% (-0.6%) from 59.228%

Build # 5c00948b-e964-4355-a92e-635ceece6223

Build Type

push

circleci

Committed by

web-flow

Commit Message

Switched Haskell formatter to fourmolu and ran on all files (#1763)

Coverage Stats

517 of 966 branches covered (53.52%)

Branch coverage included in aggregate %.

851 of 1590 new or added lines in 34 files covered. (53.52%)

84 existing lines in 13 files now uncovered.

2522 of 4215 relevant lines covered (59.83%)

154.42 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

52.03

/app/DynamicGraphs/GraphGenerator.hs

{-# LANGUAGE OverloadedStrings #-}

module DynamicGraphs.GraphGenerator (
    sampleGraph,
    coursesToPrereqGraph,
    coursesToPrereqGraphExcluding,
    graphProfileHash,
    filterReq,
)
where

import Control.Monad.State (State)
import qualified Control.Monad.State as State
import Css.Constants (nodeFontSize)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.Graph (Tree (Node))
import Data.GraphViz.Attributes as A
import Data.GraphViz.Attributes.Complete as AC
import Data.GraphViz.Types.Generalised (
    DotEdge (..),
    DotGraph (..),
    DotNode (..),
    DotStatement (..),
    GlobalAttributes (..),
 )
import Data.Hash.MD5 (Str (Str), md5s)
import Data.List (elemIndex)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Sequence as Seq
import Data.Text.Lazy (Text, concat, isInfixOf, isPrefixOf, last, pack, take, unpack)
import Database.Requirement (Modifier (..), Req (..))
import DynamicGraphs.CourseFinder (lookupCourses)
import DynamicGraphs.GraphNodeUtils (formatModOr, maybeHead, paddingSpaces, stringifyModAnd)
import DynamicGraphs.GraphOptions (GraphOptions (..), defaultGraphOptions)
import Prelude hiding (last)

-- | Generates a DotGraph dependency graph including all the given courses and their recursive dependecies
coursesToPrereqGraph ::
    -- | courses to generate
    [String] ->
    IO (DotGraph Text)
coursesToPrereqGraph rootCourses = coursesToPrereqGraphExcluding (map pack rootCourses) defaultGraphOptions

-- | Takes a list of courses we wish to generate a dependency graph for, along with graph options
-- for the courses we want to include. The generated graph will not contain the dependencies of the courses
-- from excluded departments. In addition, it will neither include any of the taken courses,
-- nor the dependencies of taken courses (unless they are depended on by other courses)
coursesToPrereqGraphExcluding :: [Text] -> GraphOptions -> IO (DotGraph Text)
coursesToPrereqGraphExcluding rootCourses options = do
    reqs <- lookupCourses options rootCourses
    let reqs' = Map.toList reqs
    return $ fst $ State.runState (reqsToGraph options reqs') initialState
  where
    initialState = GeneratorState 0 Map.empty

sampleGraph :: DotGraph Text
sampleGraph =
    fst $
        State.runState
            ( reqsToGraph
                defaultGraphOptions
                [ ("MAT237H1", J "MAT137H1" "")
                , ("MAT133H1", None)
                , ("CSC148H1", ReqAnd [J "CSC108H1" "", J "CSC104H1" ""])
                , ("CSC265H1", ReqAnd [J "CSC148H1" "", J "CSC236H1" ""])
                ]
            )
            (GeneratorState 0 Map.empty)

-- ** Main algorithm for converting requirements into a DotGraph

-- | Convert a list of coursenames and requirements to a DotGraph object for
-- drawing using Dot. Also prunes any repeated edges that arise from
-- multiple Reqs using the same Grade requirement
reqsToGraph :: GraphOptions -> [(Text, Req)] -> State GeneratorState (DotGraph Text)
reqsToGraph options reqs = do
    allStmts <- concatUnique <$> mapM (reqToStmts options) reqs'
    return $ buildGraph allStmts
  where
    concatUnique = nubOrd . Prelude.concat
    filteredReqs = [(n, filterReq options req) | (n, req) <- reqs]
    reqs' = Prelude.filter includeName filteredReqs

    includeName (n, _) =
        pickCourse options n
            && n `notElem` taken options

-- | Recurse through the Req Tree to remove any nodes specified in GraphOptions
filterReq :: GraphOptions -> Req -> Req
filterReq _ None = None
filterReq options (J course info)
    | not (pickCourse options (pack course)) = None
    | pack course `elem` taken options = None
    | otherwise = J course info
filterReq options (ReqAnd reqs) =
    case Prelude.filter (/= None) (map (filterReq options) reqs) of
        [] -> None
        [r] -> r
        reqs' -> ReqAnd reqs'
filterReq options (ReqOr reqs) =
    case Prelude.filter (/= None) (map (filterReq options) reqs) of
        [] -> None
        [r] -> r
        reqs' -> ReqOr reqs'
filterReq _ (Fces fl modifier) = Fces fl modifier
filterReq options (Grade str req) = Grade str (filterReq options req)
filterReq _ (Gpa fl str) = Gpa fl str
filterReq _ (Program pro) = Program pro
filterReq _ (Raw s) = Raw s

data GeneratorState = GeneratorState Integer (Map.Map Text (DotNode Text))

pickCourse :: GraphOptions -> Text -> Bool
pickCourse options name =
    pickCourseByDepartment options name
        && pickCourseByLocation options name

pickCourseByDepartment :: GraphOptions -> Text -> Bool
pickCourseByDepartment options name =
    Prelude.null (departments options)
        || prefixedByOneOf name (departments options)

pickCourseByLocation :: GraphOptions -> Text -> Bool
pickCourseByLocation options name =
    Prelude.null (location options)
        || courseLocation `elem` mapMaybe locationNum (location options)
  where
    courseLocation = last name
    locationNum l = case l of
        "utsg" -> Just '1'
        "utsc" -> Just '3'
        "utm" -> Just '5'
        _ -> Nothing

nodeColor :: GraphOptions -> Text -> Color
nodeColor options name = colors !! depIndex
  where
    colors :: [Color]
    colors =
        cycle $
            map
                toColor
                [Orchid, Orange, CornFlowerBlue, Salmon, Aquamarine, Yellow, OliveDrab]
    depIndex :: Int
    depIndex = fromMaybe 0 (elemIndex courseDep (departments options))
    courseDep :: Text
    courseDep = Data.Text.Lazy.take 3 name

-- | Convert the original requirement data into dot statements that can be used by buildGraph to create the
-- corresponding DotGraph objects.
reqToStmts :: GraphOptions -> (Text, Req) -> State GeneratorState [DotStatement Text]
reqToStmts options (name, req) = do
    node <- makeNode name $ Just (nodeColor options name)
    stmts <- reqToStmtsTree options (nodeID node) req
    return $ DN node : Prelude.concat (toList stmts)

reqToStmtsTree ::
    -- | Options to toggle dynamic graph
    GraphOptions ->
    -- | Name of parent course
    Text ->
    -- | Requirement to generate dep tree for
    Req ->
    State GeneratorState (Tree [DotStatement Text])
reqToStmtsTree _ _ None = return (Node [] [])
reqToStmtsTree options parentID (J name2 _) = do
    let name = pack name2
    prereq <- makeNode name $ Just (nodeColor options name)
    edge <- makeEdge (nodeID prereq) parentID Nothing
    return (Node [DN prereq, DE edge] [])
-- Two or more required prerequisites.
reqToStmtsTree options parentID (ReqAnd reqs) = do
    (andNode, _) <- makeBool "and" reqs
    edge <- makeEdge (nodeID andNode) parentID Nothing
    prereqStmts <- mapM (reqToStmtsTree options (nodeID andNode)) reqs
    let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts
    case filteredStmts of
        [] -> return $ Node [] []
        [Node (DN node : _) xs] -> do
            -- make new edge with parent id and single child id
            newEdge <- makeEdge (nodeID node) parentID Nothing
            return $ Node [DN node, DE newEdge] xs
        _ -> return $ Node [DN andNode, DE edge] filteredStmts
-- A choice from two or more prerequisites.
reqToStmtsTree options parentID (ReqOr reqs) = do
    (orNode, _) <- makeBool "or" reqs
    edge <- makeEdge (nodeID orNode) parentID Nothing
    prereqStmts <- mapM (reqToStmtsTree options (nodeID orNode)) reqs
    let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts
    case filteredStmts of
        [] -> return $ Node [] []
        [Node (DN node : _) xs] -> do
            -- make new edge with parent id and single child id
            newEdge <- makeEdge (nodeID node) parentID Nothing
            return $ Node [DN node, DE newEdge] xs
        _ -> return $ Node [DN orNode, DE edge] filteredStmts

-- A prerequisite with a grade requirement.
reqToStmtsTree options parentID (Grade description req) = do
    if includeGrades options
        then do
            Node root rest <- reqToStmtsTree options parentID req
            case root of
                DN gradeNode : _ -> do
                    -- make an annotated edge
                    gradeEdge <-
                        makeEdge
                            (nodeID gradeNode)
                            parentID
                            (Just $ pack $ description ++ "%")
                    -- swap out top edge of prereqStmt tree with annotated edge
                    return $ Node [DN gradeNode, DE gradeEdge] rest
                _ -> return $ Node [] [] -- ERROR
        else reqToStmtsTree options parentID req

-- A raw string description of a prerequisite.
reqToStmtsTree options parentID (Raw rawText) =
    if not (includeRaws options) || "High school" `isInfixOf` pack rawText || rawText == ""
        then return $ Node [] []
        else do
            prereq <- makeNode (pack rawText) Nothing
            edge <- makeEdge (nodeID prereq) parentID Nothing
            return $ Node [DN prereq, DE edge] []

-- A prerequisite concerning a given number of earned credits
reqToStmtsTree _ parentID (Fces creds (Requirement (Raw ""))) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

-- A prerequisite concerning a given number of earned credits in some raw string
reqToStmtsTree _ parentID (Fces creds (Requirement (Raw text))) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs from " ++ text ++ paddingSpaces 18) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

-- A prerequisite concerning a given number of earned credits in some course(s)
reqToStmtsTree options parentID (Fces creds (Requirement req)) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    prereqStmts <- reqToStmtsTree options (nodeID fceNode) req
    return $ Node [DN fceNode, DE edge] [prereqStmts]

-- A prerequisite concerning a given number of earned credits in a department
reqToStmtsTree _ parentID (Fces creds (Department dept)) = do
    fceNode <- makeNode (pack $ show creds ++ " " ++ dept ++ " FCEs") Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

-- A prerequisite concerning a given number of earned credits at a given level
reqToStmtsTree _ parentID (Fces creds (Level level)) = do
    fceNode <- makeNode (pack $ show creds ++ " FCEs at the " ++ level ++ " level" ++ paddingSpaces 18) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing
    return $ Node [DN fceNode, DE edge] []

-- A prerequisite concerning a given number of earned credits with a combination
-- of some modifiers related through ModAnds
-- Assumes each modifier constructor appears in modifiers at most once
-- The ModOr constructor may appear more than once, but each occurrence
-- of ModOr contains exactly one constructor for all its elements
-- and such constructor does not appear anywhere else in ModAnd
reqToStmtsTree options parentID (Fces creds (ModAnd modifiers)) = do
    fceNode <- makeNode (pack $ stringifyModAnd creds modifiers ++ paddingSpaces 10) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing

    case maybeHead [req | Requirement req <- modifiers] of
        Nothing -> return $ Node [DN fceNode, DE edge] []
        Just req -> do
            prereqStmts <- reqToStmtsTree options (nodeID fceNode) req
            return $ Node [DN fceNode, DE edge] [prereqStmts]

-- A prerequisite concerning a given number of earned credits with a combination
-- of some modifiers related through a ModOr
-- Assumes all modifiers in the list have the same constructor
reqToStmtsTree options parentID (Fces creds (ModOr modifiers)) = do
    fceNode <- makeNode (pack $ formatModOr creds modifiers) Nothing
    edge <- makeEdge (nodeID fceNode) parentID Nothing

    case maybeHead [req | Requirement req <- modifiers] of
        Nothing -> return $ Node [DN fceNode, DE edge] []
        Just req -> do
            prereqStmts <- reqToStmtsTree options (nodeID fceNode) req
            return $ Node [DN fceNode, DE edge] [prereqStmts]

-- A program requirement
reqToStmtsTree _ parentID (Program prog) = do
    -- FIXME: weird width calculation from the library with the prog
    -- so we padded the string with prog again to work around it
    progNode <- makeNode (pack $ "Enrolled in " ++ prog ++ Prelude.replicate (Prelude.length prog) ' ') Nothing
    edge <- makeEdge (nodeID progNode) parentID Nothing
    return $ Node [DN progNode, DE edge] []

-- a cGPA requirement
reqToStmtsTree _ parentID (Gpa float string) = do
    gpaNode <- makeNode (pack $ "Minimum cGPA of " ++ show float ++ string) Nothing
    edge <- makeEdge (nodeID gpaNode) parentID Nothing
    return $ Node [DN gpaNode, DE edge] []

prefixedByOneOf :: Text -> [Text] -> Bool
prefixedByOneOf name = any (`isPrefixOf` name)

makeNode :: Text -> Maybe Color -> State GeneratorState (DotNode Text)
makeNode name nodeCol = do
    GeneratorState i nodesMap <- State.get
    case Map.lookup name nodesMap of
        Nothing -> do
            let nodeId = mappendTextWithCounter name i
                actualColor = case nodeCol of
                    Nothing -> toColor Gray
                    Just c -> c
                node =
                    DotNode
                        nodeId
                        [ AC.Label $ toLabelValue name
                        , ID nodeId
                        , AC.FixedSize AC.GrowAsNeeded
                        , AC.FontSize nodeFontSize
                        , FillColor $ toColorList [actualColor]
                        ]
                nodesMap' = Map.insert name node nodesMap
            State.put (GeneratorState (i + 1) nodesMap')
            return node
        Just node -> return node

makeBool :: Text -> [Req] -> State GeneratorState (DotNode Text, Text)
makeBool text1 reqs = do
    GeneratorState i boolsMap <- State.get
    reqsList <- mapM generateBoolKey reqs
    let sortedList = toList (sort $ fromList reqsList)
    let boolKey = Data.Text.Lazy.concat $ text1 : sortedList
    case Map.lookup boolKey boolsMap of
        Nothing -> do
            let nodeId = mappendTextWithCounter text1 i
            let boolNode =
                    DotNode
                        nodeId
                        ([AC.Label (toLabelValue text1), ID nodeId] ++ ellipseAttrs)
                boolsMap' = Map.insert boolKey boolNode boolsMap
            State.put (GeneratorState (i + 1) boolsMap')

            return (boolNode, boolKey)
        Just node -> do
            return (node, boolKey)

-- | Create edge from two node ids. Also allow for potential edge label
makeEdge :: Text -> Text -> Maybe Text -> State GeneratorState (DotEdge Text)
makeEdge id1 id2 description =
    return $
        DotEdge
            id1
            id2
            (ID (id1 `mappend` "|" `mappend` id2) : textLabelList)
  where
    textLabelList = case description of
        Nothing -> []
        Just a -> [textLabel a]

mappendTextWithCounter :: Text -> Integer -> Text
mappendTextWithCounter text1 counter = text1 `mappend` "_counter_" `mappend` pack (show counter)

-- | Generates a unique key for each boolean node
-- May generate lower level nodes that make up the boolean node
generateBoolKey :: Req -> State GeneratorState Text
generateBoolKey (J s1 _) = return $ pack ("_" ++ s1)
generateBoolKey (Grade _ req) = do
    generateBoolKey req
generateBoolKey (ReqAnd reqs) = do
    (_, boolKey) <- makeBool "and" reqs
    return $ pack ("_[" ++ unpack boolKey ++ "]")
generateBoolKey (ReqOr reqs) = do
    (_, boolKey) <- makeBool "or" reqs
    return $ pack ("_[" ++ unpack boolKey ++ "]")
generateBoolKey _ = return ""

-- ** Graphviz configuration

-- | With the dot statements converted from original requirement data as input, create the corresponding DotGraph
-- object with predefined hyperparameters (here, the hyperparameters defines that 1.graph can have multi-edges
-- 2.graph edges have directions 3.graphID not defined(not so clear) 4.the graph layout, node shape, edge shape
-- are defined by the attributes as below)
buildGraph :: [DotStatement Text] -> DotGraph Text
buildGraph statements =
    DotGraph
        { strictGraph = False
        , directedGraph = True
        , graphID = Nothing
        , graphStatements =
            Seq.fromList $
                [ GA graphAttrs
                , GA nodeAttrs
                , GA edgeAttrs
                ]
                    ++ statements
        }

graphProfileHash :: String
graphProfileHash = md5s . Str . show $ (buildGraph [], ellipseAttrs)

-- | Means the layout of the full graph is from left to right.
graphAttrs :: GlobalAttributes
graphAttrs =
    GraphAttrs
        [ AC.RankDir AC.FromTop
        , AC.Splines AC.Ortho
        , AC.Concentrate False
        ]

nodeAttrs :: GlobalAttributes
nodeAttrs =
    NodeAttrs
        [ A.shape A.BoxShape
        , AC.FixedSize GrowAsNeeded
        , A.style A.filled
        ]

ellipseAttrs :: A.Attributes
ellipseAttrs =
    [ A.shape A.Ellipse
    , AC.Width 0.20 -- min 0.01
    , AC.Height 0.15 -- min 0.01
    , AC.FixedSize SetNodeSize
    , A.fillColor White
    , AC.FontSize 6.0 -- min 1.0
    ]

edgeAttrs :: GlobalAttributes
edgeAttrs =
    EdgeAttrs
        [ ArrowHead (AType [(ArrMod FilledArrow BothSides, Normal)])
        ]

1	{-# LANGUAGE OverloadedStrings #-}
2
3	module DynamicGraphs.GraphGenerator (
4	sampleGraph,
5	coursesToPrereqGraph,
6	coursesToPrereqGraphExcluding,
7	graphProfileHash,
8	filterReq,
9	)
10	where
11
12	import Control.Monad.State (State)
13	import qualified Control.Monad.State as State
14	import Css.Constants (nodeFontSize)
15	import Data.Containers.ListUtils (nubOrd)
16	import Data.Foldable (toList)
17	import Data.Graph (Tree (Node))
18	import Data.GraphViz.Attributes as A
19	import Data.GraphViz.Attributes.Complete as AC
20	import Data.GraphViz.Types.Generalised (
21	DotEdge (..),
22	DotGraph (..),
23	DotNode (..),
24	DotStatement (..),
25	GlobalAttributes (..),
26	)
27	import Data.Hash.MD5 (Str (Str), md5s)
28	import Data.List (elemIndex)
29	import qualified Data.Map.Strict as Map
30	import Data.Maybe (fromMaybe, mapMaybe)
31	import Data.Sequence as Seq
32	import Data.Text.Lazy (Text, concat, isInfixOf, isPrefixOf, last, pack, take, unpack)
33	import Database.Requirement (Modifier (..), Req (..))
34	import DynamicGraphs.CourseFinder (lookupCourses)
35	import DynamicGraphs.GraphNodeUtils (formatModOr, maybeHead, paddingSpaces, stringifyModAnd)
36	import DynamicGraphs.GraphOptions (GraphOptions (..), defaultGraphOptions)
37	import Prelude hiding (last)
38
39	-- \| Generates a DotGraph dependency graph including all the given courses and their recursive dependecies
40	coursesToPrereqGraph ::
41	-- \| courses to generate
42	[String] ->
43	IO (DotGraph Text)
UNCOV 44	coursesToPrereqGraph rootCourses = coursesToPrereqGraphExcluding (map pack rootCourses) defaultGraphOptions	×
45
46	-- \| Takes a list of courses we wish to generate a dependency graph for, along with graph options
47	-- for the courses we want to include. The generated graph will not contain the dependencies of the courses
48	-- from excluded departments. In addition, it will neither include any of the taken courses,
49	-- nor the dependencies of taken courses (unless they are depended on by other courses)
50	coursesToPrereqGraphExcluding :: [Text] -> GraphOptions -> IO (DotGraph Text)
51	coursesToPrereqGraphExcluding rootCourses options = do	7✔
52	reqs <- lookupCourses options rootCourses	7✔
53	let reqs' = Map.toList reqs	7✔
54	return $ fst $ State.runState (reqsToGraph options reqs') initialState	7✔
55	where
56	initialState = GeneratorState 0 Map.empty	7✔
57
58	sampleGraph :: DotGraph Text
59	sampleGraph =
NEW 60	fst $	×
NEW 61	State.runState	×
NEW 62	( reqsToGraph	×
NEW 63	defaultGraphOptions	×
NEW 64	[ ("MAT237H1", J "MAT137H1" "")	×
NEW 65	, ("MAT133H1", None)	×
NEW 66	, ("CSC148H1", ReqAnd [J "CSC108H1" "", J "CSC104H1" ""])	×
NEW 67	, ("CSC265H1", ReqAnd [J "CSC148H1" "", J "CSC236H1" ""])	×
68	]
69	)
NEW 70	(GeneratorState 0 Map.empty)	×
71
72	-- ** Main algorithm for converting requirements into a DotGraph
73
74	-- \| Convert a list of coursenames and requirements to a DotGraph object for
75	-- drawing using Dot. Also prunes any repeated edges that arise from
76	-- multiple Reqs using the same Grade requirement
77	reqsToGraph :: GraphOptions -> [(Text, Req)] -> State GeneratorState (DotGraph Text)
78	reqsToGraph options reqs = do	7✔
79	allStmts <- concatUnique <$> mapM (reqToStmts options) reqs'	7✔
80	return $ buildGraph allStmts	7✔
81	where
82	concatUnique = nubOrd . Prelude.concat	1✔
83	filteredReqs = [(n, filterReq options req) \| (n, req) <- reqs]	23✔
84	reqs' = Prelude.filter includeName filteredReqs	7✔
85
86	includeName (n, _) =
87	pickCourse options n	23✔
88	&& n `notElem` taken options	22✔
89
90	-- \| Recurse through the Req Tree to remove any nodes specified in GraphOptions
91	filterReq :: GraphOptions -> Req -> Req
92	filterReq _ None = None	11✔
93	filterReq options (J course info)
94	\| not (pickCourse options (pack course)) = None	47✔
95	\| pack course `elem` taken options = None	42✔
96	\| otherwise = J course info	36!
97	filterReq options (ReqAnd reqs) =
98	case Prelude.filter (/= None) (map (filterReq options) reqs) of	17✔
99	[] -> None	×
100	[r] -> r	2✔
101	reqs' -> ReqAnd reqs'	15✔
102	filterReq options (ReqOr reqs) =
103	case Prelude.filter (/= None) (map (filterReq options) reqs) of	3✔
104	[] -> None	1✔
105	[r] -> r	1✔
106	reqs' -> ReqOr reqs'	1✔
107	filterReq _ (Fces fl modifier) = Fces fl modifier	×
NEW 108	filterReq options (Grade str req) = Grade str (filterReq options req)	×
109	filterReq _ (Gpa fl str) = Gpa fl str	×
110	filterReq _ (Program pro) = Program pro	×
111	filterReq _ (Raw s) = Raw s	×
112
113	data GeneratorState = GeneratorState Integer (Map.Map Text (DotNode Text))
114
115	pickCourse :: GraphOptions -> Text -> Bool
116	pickCourse options name =
117	pickCourseByDepartment options name	70✔
118	&& pickCourseByLocation options name	64✔
119
120	pickCourseByDepartment :: GraphOptions -> Text -> Bool
121	pickCourseByDepartment options name =
122	Prelude.null (departments options)	70✔
123	\|\| prefixedByOneOf name (departments options)	48✔
124
125	pickCourseByLocation :: GraphOptions -> Text -> Bool
126	pickCourseByLocation options name =
127	Prelude.null (location options)	64✔
NEW 128	\|\| courseLocation `elem` mapMaybe locationNum (location options)	×
129	where
NEW 130	courseLocation = last name	×
NEW 131	locationNum l = case l of	×
NEW 132	"utsg" -> Just '1'	×
NEW 133	"utsc" -> Just '3'	×
NEW 134	"utm" -> Just '5'	×
NEW 135	_ -> Nothing	×
136
137	nodeColor :: GraphOptions -> Text -> Color
138	nodeColor options name = colors !! depIndex	20✔
139	where
140	colors :: [Color]
141	colors =
142	cycle $	20✔
143	map	20✔
144	toColor	1✔
145	[Orchid, Orange, CornFlowerBlue, Salmon, Aquamarine, Yellow, OliveDrab]	1✔
146	depIndex :: Int
147	depIndex = fromMaybe 0 (elemIndex courseDep (departments options))	20✔
148	courseDep :: Text
149	courseDep = Data.Text.Lazy.take 3 name	16✔
150
151	-- \| Convert the original requirement data into dot statements that can be used by buildGraph to create the
152	-- corresponding DotGraph objects.
153	reqToStmts :: GraphOptions -> (Text, Req) -> State GeneratorState [DotStatement Text]
154	reqToStmts options (name, req) = do	20✔
155	node <- makeNode name $ Just (nodeColor options name)	20✔
156	stmts <- reqToStmtsTree options (nodeID node) req	20✔
157	return $ DN node : Prelude.concat (toList stmts)	20✔
158
159	reqToStmtsTree ::
160	-- \| Options to toggle dynamic graph
161	GraphOptions ->
162	-- \| Name of parent course
163	Text ->
164	-- \| Requirement to generate dep tree for
165	Req ->
166	State GeneratorState (Tree [DotStatement Text])
167	reqToStmtsTree _ _ None = return (Node [] [])	1✔
168	reqToStmtsTree options parentID (J name2 _) = do	14✔
169	let name = pack name2	14✔
170	prereq <- makeNode name $ Just (nodeColor options name)	14✔
171	edge <- makeEdge (nodeID prereq) parentID Nothing	14✔
172	return (Node [DN prereq, DE edge] [])	14✔
173	-- Two or more required prerequisites.
174	reqToStmtsTree options parentID (ReqAnd reqs) = do	5✔
175	(andNode, _) <- makeBool "and" reqs	5✔
176	edge <- makeEdge (nodeID andNode) parentID Nothing	5✔
177	prereqStmts <- mapM (reqToStmtsTree options (nodeID andNode)) reqs	5✔
178	let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts	5✔
179	case filteredStmts of	5✔
180	[] -> return $ Node [] []	×
NEW 181	[Node (DN node : _) xs] -> do	×
182	-- make new edge with parent id and single child id
183	newEdge <- makeEdge (nodeID node) parentID Nothing	×
184	return $ Node [DN node, DE newEdge] xs	×
185	_ -> return $ Node [DN andNode, DE edge] filteredStmts	5✔
186	-- A choice from two or more prerequisites.
187	reqToStmtsTree options parentID (ReqOr reqs) = do	×
188	(orNode, _) <- makeBool "or" reqs	×
189	edge <- makeEdge (nodeID orNode) parentID Nothing	×
190	prereqStmts <- mapM (reqToStmtsTree options (nodeID orNode)) reqs	×
191	let filteredStmts = Prelude.filter (Node [] [] /=) prereqStmts	×
192	case filteredStmts of	×
193	[] -> return $ Node [] []	×
NEW 194	[Node (DN node : _) xs] -> do	×
195	-- make new edge with parent id and single child id
196	newEdge <- makeEdge (nodeID node) parentID Nothing	×
197	return $ Node [DN node, DE newEdge] xs	×
NEW 198	_ -> return $ Node [DN orNode, DE edge] filteredStmts	×
199
200	-- A prerequisite with a grade requirement.
201	reqToStmtsTree options parentID (Grade description req) = do	×
NEW 202	if includeGrades options	×
NEW 203	then do	×
NEW 204	Node root rest <- reqToStmtsTree options parentID req	×
NEW 205	case root of	×
NEW 206	DN gradeNode : _ -> do	×
207	-- make an annotated edge
208	gradeEdge <-
NEW 209	makeEdge	×
NEW 210	(nodeID gradeNode)	×
NEW 211	parentID	×
NEW 212	(Just $ pack $ description ++ "%")	×
213	-- swap out top edge of prereqStmt tree with annotated edge
NEW 214	return $ Node [DN gradeNode, DE gradeEdge] rest	×
NEW 215	_ -> return $ Node [] [] -- ERROR	×
NEW 216	else reqToStmtsTree options parentID req	×
217
218	-- A raw string description of a prerequisite.
219	reqToStmtsTree options parentID (Raw rawText) =
220	if not (includeRaws options) \|\| "High school" `isInfixOf` pack rawText \|\| rawText == ""	×
221	then return $ Node [] []	×
222	else do	×
223	prereq <- makeNode (pack rawText) Nothing	×
224	edge <- makeEdge (nodeID prereq) parentID Nothing	×
225	return $ Node [DN prereq, DE edge] []	×
226
227	-- A prerequisite concerning a given number of earned credits
228	reqToStmtsTree _ parentID (Fces creds (Requirement (Raw ""))) = do	×
229	fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing	×
230	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
231	return $ Node [DN fceNode, DE edge] []	×
232
233	-- A prerequisite concerning a given number of earned credits in some raw string
UNCOV 234	reqToStmtsTree _ parentID (Fces creds (Requirement (Raw text))) = do	×
UNCOV 235	fceNode <- makeNode (pack $ show creds ++ " FCEs from " ++ text ++ paddingSpaces 18) Nothing	×
236	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
237	return $ Node [DN fceNode, DE edge] []	×
238
239	-- A prerequisite concerning a given number of earned credits in some course(s)
UNCOV 240	reqToStmtsTree options parentID (Fces creds (Requirement req)) = do	×
UNCOV 241	fceNode <- makeNode (pack $ show creds ++ " FCEs") Nothing	×
UNCOV 242	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
243	prereqStmts <- reqToStmtsTree options (nodeID fceNode) req	×
244	return $ Node [DN fceNode, DE edge] [prereqStmts]	×
245
246	-- A prerequisite concerning a given number of earned credits in a department
247	reqToStmtsTree _ parentID (Fces creds (Department dept)) = do	×
248	fceNode <- makeNode (pack $ show creds ++ " " ++ dept ++ " FCEs") Nothing	×
UNCOV 249	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
UNCOV 250	return $ Node [DN fceNode, DE edge] []	×
251
252	-- A prerequisite concerning a given number of earned credits at a given level
253	reqToStmtsTree _ parentID (Fces creds (Level level)) = do	×
254	fceNode <- makeNode (pack $ show creds ++ " FCEs at the " ++ level ++ " level" ++ paddingSpaces 18) Nothing	×
255	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
UNCOV 256	return $ Node [DN fceNode, DE edge] []	×
257
258	-- A prerequisite concerning a given number of earned credits with a combination
259	-- of some modifiers related through ModAnds
260	-- Assumes each modifier constructor appears in modifiers at most once
261	-- The ModOr constructor may appear more than once, but each occurrence
262	-- of ModOr contains exactly one constructor for all its elements
263	-- and such constructor does not appear anywhere else in ModAnd
264	reqToStmtsTree options parentID (Fces creds (ModAnd modifiers)) = do	×
265	fceNode <- makeNode (pack $ stringifyModAnd creds modifiers ++ paddingSpaces 10) Nothing	×
266	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
267
UNCOV 268	case maybeHead [req \| Requirement req <- modifiers] of	×
UNCOV 269	Nothing -> return $ Node [DN fceNode, DE edge] []	×
UNCOV 270	Just req -> do	×
UNCOV 271	prereqStmts <- reqToStmtsTree options (nodeID fceNode) req	×
UNCOV 272	return $ Node [DN fceNode, DE edge] [prereqStmts]	×
273
274	-- A prerequisite concerning a given number of earned credits with a combination
275	-- of some modifiers related through a ModOr
276	-- Assumes all modifiers in the list have the same constructor
277	reqToStmtsTree options parentID (Fces creds (ModOr modifiers)) = do	×
278	fceNode <- makeNode (pack $ formatModOr creds modifiers) Nothing	×
279	edge <- makeEdge (nodeID fceNode) parentID Nothing	×
280
UNCOV 281	case maybeHead [req \| Requirement req <- modifiers] of	×
282	Nothing -> return $ Node [DN fceNode, DE edge] []	×
283	Just req -> do	×
284	prereqStmts <- reqToStmtsTree options (nodeID fceNode) req	×
285	return $ Node [DN fceNode, DE edge] [prereqStmts]	×
286
287	-- A program requirement
UNCOV 288	reqToStmtsTree _ parentID (Program prog) = do	×
289	-- FIXME: weird width calculation from the library with the prog
290	-- so we padded the string with prog again to work around it
291	progNode <- makeNode (pack $ "Enrolled in " ++ prog ++ Prelude.replicate (Prelude.length prog) ' ') Nothing	×
292	edge <- makeEdge (nodeID progNode) parentID Nothing	×
293	return $ Node [DN progNode, DE edge] []	×
294
295	-- a cGPA requirement
296	reqToStmtsTree _ parentID (Gpa float string) = do	×
297	gpaNode <- makeNode (pack $ "Minimum cGPA of " ++ show float ++ string) Nothing	×
NEW 298	edge <- makeEdge (nodeID gpaNode) parentID Nothing	×
299	return $ Node [DN gpaNode, DE edge] []	×
300
301	prefixedByOneOf :: Text -> [Text] -> Bool
302	prefixedByOneOf name = any (`isPrefixOf` name)	48✔
303
304	makeNode :: Text -> Maybe Color -> State GeneratorState (DotNode Text)
305	makeNode name nodeCol = do	34✔
306	GeneratorState i nodesMap <- State.get	1✔
307	case Map.lookup name nodesMap of	34✔
308	Nothing -> do	20✔
309	let nodeId = mappendTextWithCounter name i	20✔
310	actualColor = case nodeCol of	20✔
311	Nothing -> toColor Gray	×
312	Just c -> c	20✔
313	node =
314	DotNode	20✔
315	nodeId	20✔
316	[ AC.Label $ toLabelValue name	20✔
317	, ID nodeId	20✔
318	, AC.FixedSize AC.GrowAsNeeded	20✔
319	, AC.FontSize nodeFontSize	20✔
320	, FillColor $ toColorList [actualColor]	20✔
321	]
322	nodesMap' = Map.insert name node nodesMap	19✔
323	State.put (GeneratorState (i + 1) nodesMap')	19✔
324	return node	20✔
325	Just node -> return node	14✔
326
327	makeBool :: Text -> [Req] -> State GeneratorState (DotNode Text, Text)
328	makeBool text1 reqs = do	5✔
329	GeneratorState i boolsMap <- State.get	1✔
330	reqsList <- mapM generateBoolKey reqs	2✔
331	let sortedList = toList (sort $ fromList reqsList)	2✔
332	let boolKey = Data.Text.Lazy.concat $ text1 : sortedList	5✔
333	case Map.lookup boolKey boolsMap of	5✔
334	Nothing -> do	4✔
335	let nodeId = mappendTextWithCounter text1 i	4✔
336	let boolNode =
337	DotNode	4✔
338	nodeId	4✔
339	([AC.Label (toLabelValue text1), ID nodeId] ++ ellipseAttrs)	4✔
340	boolsMap' = Map.insert boolKey boolNode boolsMap	4✔
341	State.put (GeneratorState (i + 1) boolsMap')	4✔
342
343	return (boolNode, boolKey)	4✔
344	Just node -> do	1✔
345	return (node, boolKey)	1✔
346
347	-- \| Create edge from two node ids. Also allow for potential edge label
348	makeEdge :: Text -> Text -> Maybe Text -> State GeneratorState (DotEdge Text)
349	makeEdge id1 id2 description =
350	return $	19✔
351	DotEdge	19✔
352	id1	19✔
353	id2	19✔
354	(ID (id1 `mappend` "\|" `mappend` id2) : textLabelList)	19✔
355	where
356	textLabelList = case description of	19✔
357	Nothing -> []	1✔
NEW 358	Just a -> [textLabel a]	×
359
360	mappendTextWithCounter :: Text -> Integer -> Text
361	mappendTextWithCounter text1 counter = text1 `mappend` "_counter_" `mappend` pack (show counter)	24✔
362
363	-- \| Generates a unique key for each boolean node
364	-- May generate lower level nodes that make up the boolean node
365	generateBoolKey :: Req -> State GeneratorState Text
366	generateBoolKey (J s1 _) = return $ pack ("_" ++ s1)	4✔
UNCOV 367	generateBoolKey (Grade _ req) = do	×
UNCOV 368	generateBoolKey req	×
UNCOV 369	generateBoolKey (ReqAnd reqs) = do	×
NEW 370	(_, boolKey) <- makeBool "and" reqs	×
UNCOV 371	return $ pack ("_[" ++ unpack boolKey ++ "]")	×
372	generateBoolKey (ReqOr reqs) = do	×
UNCOV 373	(_, boolKey) <- makeBool "or" reqs	×
UNCOV 374	return $ pack ("_[" ++ unpack boolKey ++ "]")	×
UNCOV 375	generateBoolKey _ = return ""	×
376
377	-- ** Graphviz configuration
378
379	-- \| With the dot statements converted from original requirement data as input, create the corresponding DotGraph
380	-- object with predefined hyperparameters (here, the hyperparameters defines that 1.graph can have multi-edges
381	-- 2.graph edges have directions 3.graphID not defined(not so clear) 4.the graph layout, node shape, edge shape
382	-- are defined by the attributes as below)
383	buildGraph :: [DotStatement Text] -> DotGraph Text
384	buildGraph statements =
385	DotGraph	8✔
386	{ strictGraph = False	8✔
387	, directedGraph = True	8✔
388	, graphID = Nothing	1✔
389	, graphStatements =
390	Seq.fromList $	8✔
391	[ GA graphAttrs	8✔
392	, GA nodeAttrs	1✔
393	, GA edgeAttrs	1✔
394	]
395	++ statements	8✔
396	}
397
398	graphProfileHash :: String
399	graphProfileHash = md5s . Str . show $ (buildGraph [], ellipseAttrs)	1✔
400
401	-- \| Means the layout of the full graph is from left to right.
402	graphAttrs :: GlobalAttributes
403	graphAttrs =
404	GraphAttrs	1✔
405	[ AC.RankDir AC.FromTop	1✔
406	, AC.Splines AC.Ortho	1✔
407	, AC.Concentrate False	1✔
408	]
409
410	nodeAttrs :: GlobalAttributes
411	nodeAttrs =
412	NodeAttrs	1✔
413	[ A.shape A.BoxShape	1✔
414	, AC.FixedSize GrowAsNeeded	1✔
415	, A.style A.filled	1✔
416	]
417
418	ellipseAttrs :: A.Attributes
419	ellipseAttrs =
420	[ A.shape A.Ellipse	1✔
421	, AC.Width 0.20 -- min 0.01	1✔
422	, AC.Height 0.15 -- min 0.01	1✔
423	, AC.FixedSize SetNodeSize	1✔
424	, A.fillColor White	1✔
425	, AC.FontSize 6.0 -- min 1.0	1✔
426	]
427
428	edgeAttrs :: GlobalAttributes
429	edgeAttrs =
430	EdgeAttrs	1✔
431	[ ArrowHead (AType [(ArrMod FilledArrow BothSides, Normal)])	1✔
432	]

Courseography / courseography / 5c00948b-e964-4355-a92e-635ceece6223

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous