Removed head and tail calls from codebase (#1567)

Also removed the `-Wwarn=x-partial` compilation flag on CircleCI: future uses of head/tail will be marked as errors.

Author: yoonieaj

.circleci/config.yml

@@ -46,7 +46,7 @@ jobs:
           command: |
             stack --no-terminal setup
             rm -fr $(stack path --dist-dir) $(stack path --local-install-root)
-            stack --no-terminal build --fast -j1 --ghc-options -Werror --ghc-options -Wwarn=x-partial
+            stack --no-terminal build --fast -j1 --ghc-options -Werror
             stack build hlint
             stack build hpc-lcov
             yarn install
@@ -75,7 +75,7 @@ jobs:
       - run:
           name: Generate documentation
           command: |
-            stack exec haddock -- -o doc -h --optghc=-iapp --optghc=-XOverloadedStrings --optghc=-XPartialTypeSignatures --optghc=-XScopedTypeVariables --ignore-all-exports app/Main.hs
+            stack exec haddock -- -o doc -h --optghc=-iapp --optghc=-XOverloadedStrings --optghc=-XPartialTypeSignatures --optghc=-XScopedTypeVariables --optghc=-XLambdaCase --ignore-all-exports app/Main.hs
 
       - store_artifacts:
           path: doc

CHANGELOG.md

@@ -91,6 +91,7 @@
 - Added `Models` folder and a new `Course.hs` module within it
 - Added the `Graph.hs` module in the `App/Models`
 - Updated eslint configuration for eslint v9
+- Removed calls to `head` and `tail`
 
 ## [0.6.0] - 2024-06-24
 

app/Controllers/Timetable.hs

@@ -27,6 +27,7 @@ import Text.Blaze ((!))
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
 import Text.Read (readMaybe)
+import Util.Helpers
 
 gridResponse :: ServerPart Response
 gridResponse =
@@ -132,12 +133,15 @@ getCoursesInfo courses = map courseInfo allCourses
         allCourses = map (T.splitOn "-") (T.splitOn "_" courses)
 
 -- | Pulls either a Lecture, Tutorial or Pratical from the database.
-pullDatabase :: (Code, Section, Session) -> IO MeetTime'
+pullDatabase :: (Code, Section, Session) -> IO (Maybe MeetTime')
 pullDatabase (code, section, session) = runDb $ do
     meet <- returnMeeting code fullSection session
-    allTimes <- selectList [TimesMeeting ==. entityKey meet] []
-    parsedTime <- mapM (buildTime . entityVal) allTimes
-    return $ MeetTime' (entityVal meet) parsedTime
+    case meet of
+        Nothing -> return Nothing
+        Just x -> do
+            allTimes <- selectList [TimesMeeting ==. entityKey x] []
+            parsedTime <- mapM (buildTime . entityVal) allTimes
+            return $ Just (MeetTime' (entityVal x) parsedTime)
     where
     fullSection
         | T.isPrefixOf "L" section = T.append "LEC" sectCode
@@ -150,9 +154,10 @@ pullDatabase (code, section, session) = runDb $ do
 type SystemTime = String
 
 -- | Creates all the events for a course.
-getEvents :: SystemTime -> MeetTime' -> IO [String]
-getEvents systemTime lect = do
-    courseInfo <- getCourseInfo lect  -- Get the course information
+getEvents :: SystemTime -> Maybe MeetTime' -> IO [String]
+getEvents _ Nothing = return []
+getEvents systemTime (Just courseTime) = do
+    courseInfo <- getCourseInfo courseTime  -- Get the course information
     let startTimes = third courseInfo   -- Extract start times
         endTimes = fourth courseInfo     -- Extract end times
         dates = fifth courseInfo         -- Extract dates
@@ -290,7 +295,7 @@ formatTimes fullTime =
     else hour ++ maybe "0000" formatMinutes minutes ++ "00"
     where
         hours = splitOn "." (show fullTime)
-        hour = head hours
+        hour = safeHead "" hours
         minutes = readMaybe $ hours !! 1
 
 -- | The string representaion for minutes.
@@ -324,15 +329,17 @@ type EndDate = String
 -- | Gives the appropriate starting and ending dates for each day, in which the
 -- course takes place, depending on the course session.
 getDatesByDay :: Session -> [Time] -> IO (StartDate, EndDate)
-getDatesByDay session dataByDay
+getDatesByDay _ [] = error "Failed to fetch dates"
+getDatesByDay session (firstDate:_)
     | session == "F" = do
         fallStart <- fallStartDate
         fallEnd <- fallEndDate
-        formatDates $ getDates fallStart fallEnd (weekDay $ head dataByDay)
+        formatDates $ getDates fallStart fallEnd dayOfWeek
     | otherwise = do
         winterStart <- winterStartDate
         winterEnd <- winterEndDate
-        formatDates $ getDates winterStart winterEnd (weekDay $ head dataByDay)
+        formatDates $ getDates winterStart winterEnd dayOfWeek
+    where dayOfWeek = weekDay firstDate
 
 -- | Formats the date in the following way: YearMonthDayT.
 -- For instance, 20150720T corresponds to July 20th, 2015.

app/Database/CourseInsertion.hs

@@ -25,15 +25,15 @@ getDistributionKey description_ = do
     -- option: keyListDistribution :: [DistributionId] <- selectKeysList [ DistributionDescription `contains'` description] []
     return $ case keyListDistribution of
         [] -> Nothing
-        _ -> Just (head keyListDistribution)
+        (x:_) -> Just x
 
 getBreadthKey :: T.Text -> SqlPersistM (Maybe (Key Breadth))
 getBreadthKey description_ = do
     keyListBreadth :: [Key Breadth] <- selectKeysList [ BreadthDescription ==. description_ ] []
     -- option: selectKeysList [ BreadthDescription `contains'` description] []
     return $ case keyListBreadth of
         [] -> Nothing
-        _ -> Just (head keyListBreadth)
+        (x:_) -> Just x
 
 -- | Inserts course into the Courses table.
 insertCourse :: (Courses, T.Text, T.Text) -> SqlPersistM ()

app/Database/CourseQueries.hs

@@ -56,13 +56,12 @@ reqsForPost post = do
 
 -- | Queries the database for all information regarding a specific meeting for
 --  a @course@, returns a Meeting.
-returnMeeting :: T.Text -> T.Text -> T.Text -> SqlPersistM (Entity Meeting)
+returnMeeting :: T.Text -> T.Text -> T.Text -> SqlPersistM (Maybe (Entity Meeting))
 returnMeeting lowerStr sect session = do
-    entityMeetings <- selectList [MeetingCode ==. T.toUpper lowerStr,
+    selectFirst [MeetingCode ==. T.toUpper lowerStr,
                                   MeetingSection ==. sect,
                                   MeetingSession ==. session]
                                  []
-    return $ head entityMeetings
 
 -- ** Other queries
 

app/Database/Tables.hs

@@ -224,10 +224,14 @@ instance FromJSON SvgJSON
 
 instance ToJSON Meeting where
   toJSON = genericToJSON defaultOptions {
-    fieldLabelModifier =
-      (\field -> toLower (head field): tail field) .
-      drop 7
-  }
+      fieldLabelModifier =
+        lowerFirst .
+        drop 7
+    }
+    where
+      lowerFirst :: [Char] -> String
+      lowerFirst [] = ""
+      lowerFirst (fieldHead: fieldTail) = toLower fieldHead: fieldTail
 
 instance FromJSON Meeting where
   parseJSON = withObject "Expected Object for Lecture, Tutorial or Practical" $ \o -> do

app/Models/Graph.hs

@@ -12,6 +12,7 @@ import Database.Persist.Sqlite (Entity, PersistEntity, PersistValue (PersistInt6
                                 selectList, (<-.), (==.))
 import Database.Tables hiding (paths, shapes, texts)
 import Svg.Builder (buildEllipses, buildPath, buildRect, intersectsWithShape)
+import Util.Helpers
 
 getGraph :: T.Text -> IO (Maybe Value)
 getGraph graphName = runDb $ do
@@ -31,7 +32,7 @@ getGraph graphName = runDb $ do
 
             let
                 keyAsInt :: PersistEntity a => Entity a -> Integer
-                keyAsInt = fromIntegral . (\(PersistInt64 x) -> x) . head . keyToValues . entityKey
+                keyAsInt = fromIntegral . (\(PersistInt64 x) -> x) . safeHead (PersistInt64 0) . keyToValues . entityKey
 
                 graphtexts          = map entityVal sqlTexts
                 rects          = zipWith (buildRect graphtexts)

app/Svg/Builder.hs

@@ -23,6 +23,7 @@ import qualified Data.Text as T
 import Database.DataType
 import Database.Tables hiding (shapes, texts)
 import Svg.Parser (matrixPointMultiply)
+import Util.Helpers
 
 -- * Builder functions
 
@@ -41,7 +42,7 @@ buildPath rects ellipses entity elementId
                   pathTarget = ""}
     | otherwise =
           let coords = pathPoints entity
-              start = head coords
+              start = safeHead (0.0, 0.0) coords
               end = last coords
               nodes = rects ++ ellipses
               sourceNode =
@@ -144,9 +145,9 @@ intersects :: Double -- ^ The region's width.
 intersects width height (rx, ry) offset (px, py) =
     let dx = px - rx
         dy = py - ry
-    in  dx >= -1 * offset &&
+    in  dx >= -offset &&
         dx <= width + offset &&
-        dy >= -1 * offset &&
+        dy >= -offset &&
         dy <= height + offset;
 
 -- | Determines if a point is contained in a shape.

app/Svg/Generator.hs

@@ -29,6 +29,7 @@ import Text.Blaze.Svg.Renderer.String (renderSvg)
 import qualified Text.Blaze.Svg11 as S
 import Text.Blaze.Svg11 ((!))
 import qualified Text.Blaze.Svg11.Attributes as A
+import Util.Helpers
 
 
 -- | This is the main function that retrieves a stored graph
@@ -45,9 +46,25 @@ buildSVG :: T.Text               -- ^ The name of the graph that is being built.
          -> Bool                 -- ^ Whether to include inline styles.
          -> IO ()
 buildSVG graphName courseMap filename styled = runDb $ do
-        gIds        :: [Key Graph]    <- selectKeysList [GraphTitle ==. graphName] []
-        let gId = if null gIds then toSqlKey 1 else head gIds
+        maybeGraph  :: Maybe (Entity Graph) <- selectFirst [GraphTitle ==. graphName] []
+        case maybeGraph of
+            Nothing -> return ()
+            Just val -> do
+                liftIO $ buildSVGHelper courseMap filename styled (entityVal val) (entityKey val)
 
+buildSVGHelper :: M.Map T.Text T.Text   -- ^ A map of courses that holds the course
+                                        --   ID as a key, and the data-active
+                                        --   attribute as the course's value.
+                                        --   The data-active attribute is used in the
+                                        --   interactive graph to indicate which
+                                        --   courses the user has selected.
+         -> String                      -- ^ The filename that this graph will be
+                                        --   written to.
+         -> Bool                        -- ^ Whether to include inline styles.
+         -> Graph
+         -> Key Graph
+         -> IO ()
+buildSVGHelper courseMap filename styled sqlGraph gId = runDb $ do
         sqlRects    :: [Entity Shape] <- selectList
                                              [ShapeType_ <-. [Node, Hybrid],
                                               ShapeGraph ==. gId] []
@@ -56,7 +73,6 @@ buildSVG graphName courseMap filename styled = runDb $ do
         sqlEllipses :: [Entity Shape] <- selectList
                                              [ShapeType_ ==. BoolNode,
                                               ShapeGraph ==. gId] []
-        sqlGraph    :: [Entity Graph] <- selectList [GraphId ==. gId] []
         let courseStyleMap = M.map convertSelectionToStyle courseMap
             texts          = map entityVal sqlTexts
             -- TODO: Ideally, we would do these "build" steps *before*
@@ -75,8 +91,8 @@ buildSVG graphName courseMap filename styled = runDb $ do
             regionTexts    = filter (not .
                                      intersectsWithShape (rects ++ ellipses))
                                     texts
-            width          = graphWidth $ entityVal (head sqlGraph)
-            height         = graphHeight $ entityVal (head sqlGraph)
+            width          = graphWidth sqlGraph
+            height         = graphHeight sqlGraph
             stringSVG      = renderSvg $ makeSVGDoc courseStyleMap
                                                     rects
                                                     ellipses
@@ -89,7 +105,7 @@ buildSVG graphName courseMap filename styled = runDb $ do
         liftIO $ writeFile filename stringSVG :: SqlPersistM ()
     where
         keyAsInt :: PersistEntity a => Entity a -> Integer
-        keyAsInt = fromIntegral . (\(PersistInt64 x) -> x) . head . keyToValues . entityKey
+        keyAsInt = fromIntegral . (\(PersistInt64 x) -> x) . safeHead (PersistInt64 0) . keyToValues . entityKey
 
         convertSelectionToStyle :: T.Text -> T.Text
         convertSelectionToStyle courseStatus =