Reformat w/newer ormolu; leaner nix closure

app/DevelMain.hs

@@ -29,16 +29,15 @@
 -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
 module DevelMain where
 
-import           Application              (getApplicationRepl, shutdownApp)
-import           Prelude
-
-import           Control.Concurrent
-import           Control.Exception        (finally)
-import           Control.Monad            ((>=>))
-import           Data.IORef
-import           Foreign.Store
-import           GHC.Word
-import           Network.Wai.Handler.Warp
+import Application (getApplicationRepl, shutdownApp)
+import Control.Concurrent
+import Control.Exception (finally)
+import Control.Monad ((>=>))
+import Data.IORef
+import Foreign.Store
+import GHC.Word
+import Network.Wai.Handler.Warp
+import Prelude
 
 -- | Start or restart the server.
 -- newStore is from foreign-store.
@@ -46,15 +45,15 @@ import           Network.Wai.Handler.Warp
 update :: IO ()
 update = do
   mtidStore <- lookupStore tidStoreNum
-  case mtidStore
-      -- no server running
-        of
+  case mtidStore of
+    -- no server running
+
     Nothing -> do
       done <- storeAction doneStore newEmptyMVar
       tid <- start done
       _ <- storeAction (Store tidStoreNum) (newIORef tid)
       return ()
-      -- server is already running
+    -- server is already running
     Just tidStore -> restartAppInNewThread tidStore
   where
     doneStore :: Store (MVar ())
@@ -66,27 +65,28 @@ update = do
         killThread tid
         withStore doneStore takeMVar
         readStore doneStore >>= start
-    -- | Start the server in a separate thread.
     start ::
-         MVar () -- ^ Written to when the thread is killed.
-      -> IO ThreadId
+      -- | Written to when the thread is killed.
+      MVar () ->
+      IO ThreadId
     start done = do
       (port, site, app) <- getApplicationRepl
       forkIO
-        (finally
-           (runSettings (setPort port defaultSettings) app)
-                        -- Note that this implies concurrency
-                        -- between shutdownApp and the next app that is starting.
-                        -- Normally this should be fine
-           (putMVar done () >> shutdownApp site))
+        ( finally
+            (runSettings (setPort port defaultSettings) app)
+            -- Note that this implies concurrency
+            -- between shutdownApp and the next app that is starting.
+            -- Normally this should be fine
+            (putMVar done () >> shutdownApp site)
+        )
 
 -- | kill the server
 shutdown :: IO ()
 shutdown = do
   mtidStore <- lookupStore tidStoreNum
-  case mtidStore
-      -- no server running
-        of
+  case mtidStore of
+    -- no server running
+
     Nothing -> putStrLn "no Yesod app running"
     Just tidStore -> do
       withStore tidStore $ readIORef >=> killThread

app/auth.hs

-import           Prelude       (IO)
-import           Settings.Auth (authorizeMain)
+import Settings.Auth (authorizeMain)
+import Prelude (IO)
 
 main :: IO ()
 main = authorizeMain

app/devel.hs

 {-# LANGUAGE PackageImports #-}
+
 import "bookme" Application (develMain)
 import Prelude (IO)
 

app/main.hs

-import           Application (appMain)
-import           Prelude     (IO)
+import Application (appMain)
+import Prelude (IO)
 
 main :: IO ()
 main = appMain

default.nix

@@ -12,9 +12,18 @@ let
     && ! (lib.elem (baseNameOf name) ignore)
     && ! (lib.hasPrefix ".ghc.environment" (baseNameOf name))
     && ! (lib.hasPrefix "autogen-" (baseNameOf name));
+
+  hp = haskellPackages.override {
+    overrides = self: super: {
+      mkDerivation = args: super.mkDerivation (args // {
+        doHaddock = false;
+        enableLibraryProfiling = false;
+      });
+    };
+  };
 in
 haskell.lib.overrideCabal
-  (haskellPackages.callPackage ./bookme.nix { })
+  (hp.callPackage ./bookme.nix { })
   (drv: {
     doCheck = false;
     doHaddock = false;

src/Application.hs

 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Application
@@ -12,12 +12,14 @@ module Application
     develMain,
     makeFoundation,
     makeLogWare,
+
     -- * for DevelMain
     getApplicationRepl,
     shutdownApp,
+
     -- * for GHCI
-    handler
-    )
+    handler,
+  )
 where
 
 import qualified Calendar as Cal
@@ -36,21 +38,21 @@ import Network.Wai.Handler.Warp
     runSettings,
     setHost,
     setOnException,
-    setPort
-    )
+    setPort,
+  )
 import Network.Wai.Middleware.RequestLogger
   ( Destination (Logger),
     IPAddrSource (..),
     OutputFormat (..),
     destination,
     mkRequestLogger,
-    outputFormat
-    )
+    outputFormat,
+  )
 import System.Log.FastLogger
   ( defaultBufSize,
     newStdoutLoggerSet,
-    toLogStr
-    )
+    toLogStr,
+  )
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -84,8 +86,8 @@ makeFoundation appSettings@AppSettings {..} = do
       $ FC.newCache appCacheExpiry
       $ do
         logInfoN "Refreshing calendar cache"
-        Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId
-          $ fromWeeks appLookaheadWeeks
+        Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
+          fromWeeks appLookaheadWeeks
   return App {..}
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
@@ -109,9 +111,9 @@ makeLogWare foundation =
                 ( if appIpFromHeader $ appSettings foundation
                     then FromFallback
                     else FromSocket
-                  ),
+                ),
         destination = Logger $ loggerSet $ appLogger foundation
-        }
+      }
 
 -- | Warp settings for the given foundation value.
 warpSettings :: App -> Settings
@@ -119,17 +121,17 @@ warpSettings foundation =
   setPort (appPort $ appSettings foundation)
     $ setHost (appHost $ appSettings foundation)
     $ setOnException
-        ( \_req e ->
-            when (defaultShouldDisplayException e)
-              $ messageLoggerSource
-                  foundation
-                  (appLogger foundation)
-                  $(qLocation >>= liftLoc)
-                  "yesod"
-                  LevelError
-                  (toLogStr $ "Exception from Warp: " ++ show e)
-          )
-        defaultSettings
+      ( \_req e ->
+          when (defaultShouldDisplayException e) $
+            messageLoggerSource
+              foundation
+              (appLogger foundation)
+              $(qLocation >>= liftLoc)
+              "yesod"
+              LevelError
+              (toLogStr $ "Exception from Warp: " ++ show e)
+      )
+      defaultSettings
 
 -- | For yesod devel, return the Warp settings and WAI Application.
 getApplicationDev :: IO (Settings, Application)
@@ -182,6 +184,7 @@ shutdownApp _ = return ()
 ---------------------------------------------
 -- Functions for use in development with GHCi
 ---------------------------------------------
+
 -- | Run a handler
 handler :: Handler a -> IO a
 handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h

src/BookingForm.hs

 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
-{-|
-Module: BookingForm
-Description: TODO
-
-TODO
--}
+-- |
+-- Module: BookingForm
+-- Description: TODO
+--
+-- TODO
 module BookingForm
   ( Booking (..),
     bookingMForm,
@@ -19,8 +18,8 @@ module BookingForm
     fromSession,
     b3Class,
     inputSize,
-    labelSize
-    )
+    labelSize,
+  )
 where
 
 import Calendar
@@ -41,7 +40,7 @@ data Booking
         bookEmail :: Text,
         bookSubject :: Text,
         bookContact :: Maybe Text
-        }
+      }
   deriving (Show)
 
 toSession :: MonadHandler m => Booking -> m ()
@@ -97,11 +96,10 @@ data RecaptchaResponse
   = RecaptchaResponse
       { rrSuccess :: Bool,
         rrErrors :: [Text]
-        }
+      }
   deriving (Show)
 
 instance Js.FromJSON RecaptchaResponse where
-
   parseJSON =
     Js.withObject "RecaptchaResponse" $ \o -> do
       rrSuccess <- o .: "success"
@@ -123,9 +121,9 @@ recaptcha =
           let req =
                 req' & H.setRequestManager mgr
                   & H.setRequestBodyURLEncoded
-                      [ ("secret", encodeUtf8 secret),
-                        ("response", encodeUtf8 response)
-                        ]
+                    [ ("secret", encodeUtf8 secret),
+                      ("response", encodeUtf8 response)
+                    ]
           resp <- H.getResponseBody <$> H.httpJSON req
           if rrSuccess resp
             then return (FormSuccess (), [])
@@ -170,8 +168,8 @@ b3Class g =
     B3.ColMd n -> "col-md-" <> tshow n
     B3.ColLg n -> "col-lg-" <> tshow n
 
-bookingMForm
-  :: Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget)
+bookingMForm ::
+  Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget)
 bookingMForm = B3.renderBootstrap3 horiz . bookingAForm
   where
     horiz =

src/Calendar.hs

 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
-{-|
-Module: Calendar
-Description: Query and manipulate calendars and events.
-
-This module contains facilities for querying and manipulating
-calendars and their events. It supports both Google calendars and a
-mock calendar for used for testing and debugging.
--}
+-- |
+-- Module: Calendar
+-- Description: Query and manipulate calendars and events.
+--
+-- This module contains facilities for querying and manipulating
+-- calendars and their events. It supports both Google calendars and a
+-- mock calendar for used for testing and debugging.
 module Calendar
   ( CalendarScope,
     CalendarCredentials,
@@ -29,8 +28,8 @@ module Calendar
     partitionSlots,
     summaryMatches,
     isWithin,
-    addEvent
-    )
+    addEvent,
+  )
 where
 
 import ClassyPrelude.Yesod
@@ -39,8 +38,8 @@ import Control.Monad.Logger
   ( Loc,
     LogSource,
     LogStr,
-    defaultLoc
-    )
+    defaultLoc,
+  )
 import qualified Data.Aeson as Js
 import Data.ByteString.Builder (toLazyByteString)
 import Data.Function ((&))
@@ -49,8 +48,8 @@ import qualified Data.SortedList as SL
 import Data.Time.Clock
   ( DiffTime,
     NominalDiffTime,
-    addUTCTime
-    )
+    addUTCTime,
+  )
 import Data.Time.LocalTime (LocalTime (..))
 import Data.Time.Zones (TZ, utcToLocalTimeTZ)
 import qualified Network.Google as Google
@@ -70,7 +69,6 @@ data CalendarCredentials
 -- | Doesn't reveal the credentials, but simply allows to distinguish
 -- whether they are for Google or mocked.
 instance Show CalendarCredentials where
-
   show MockCreds = "<mock>"
   show (GoogleCreds _) = "<google>"
 
@@ -78,7 +76,6 @@ instance Show CalendarCredentials where
 -- a mock calender. Otherwise, we attempt to use @client_id@,
 -- @client_secret@, and @refresh_token@ as Google credentials.
 instance FromJSON CalendarCredentials where
-
   parseJSON =
     Js.withObject "CalendarCredentials" $ \o ->
       o .: "client_id" >>= \c ->
@@ -105,41 +102,41 @@ mockFreeId = "mock-free"
 -- calendar operations. The Google environment requires a logging
 -- function and an HTTP manager. If using a mock calendar, a warning is
 -- printed using the logging function.
-initialize
-  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-  -> Manager
-  -> CalendarCredentials
-  -> IO CalendarContext
+initialize ::
+  (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->
+  Manager ->
+  CalendarCredentials ->
+  IO CalendarContext
 initialize appLog _ MockCreds = do
   appLog defaultLoc "" LevelWarn "Using mock calendar"
   day <- succ . utctDay <$> getCurrentTime
   let free =
-        SL.toSortedList
-          $ map
-              (sampleEvent day)
-              [ ("free1a", fwd 0, 1100, 1155),
-                ("free1b #office", fwd 0, 1300, 1450),
-                ("free1c #office", fwd 0, 1530, 1800),
-                ("free2a #home", fwd 1, 1200, 1600),
-                ("free2b #office", fwd 1, 1700, 1800),
-                ("free3a #office", fwd 2, 1000, 1200),
-                ("free3b #home", fwd 2, 1500, 1930)
-                ]
+        SL.toSortedList $
+          map
+            (sampleEvent day)
+            [ ("free1a", fwd 0, 1100, 1155),
+              ("free1b #office", fwd 0, 1300, 1450),
+              ("free1c #office", fwd 0, 1530, 1800),
+              ("free2a #home", fwd 1, 1200, 1600),
+              ("free2b #office", fwd 1, 1700, 1800),
+              ("free3a #office", fwd 2, 1000, 1200),
+              ("free3b #home", fwd 2, 1500, 1930)
+            ]
       busy =
-        SL.toSortedList
-          $ map
-              (sampleEvent day)
-              [ ("busy1a", fwd 0, 1210, 1300),
-                ("busy1b", fwd 0, 1330, 1430),
-                ("busy1c", fwd 0, 1500, 1550),
-                ("busy1d", fwd 0, 1730, 1830),
-                ("busy2a", fwd 1, 1130, 1215),
-                ("busy2b", fwd 1, 1330, 1400),
-                ("busy2c", fwd 1, 1430, 1500),
-                ("busy2d", fwd 1, 1610, 1650),
-                ("busy3a", fwd 2, 1100, 1400),
-                ("busy3b", fwd 2, 1900, 2100)
-                ]
+        SL.toSortedList $
+          map
+            (sampleEvent day)
+            [ ("busy1a", fwd 0, 1210, 1300),
+              ("busy1b", fwd 0, 1330, 1430),
+              ("busy1c", fwd 0, 1500, 1550),
+              ("busy1d", fwd 0, 1730, 1830),
+              ("busy2a", fwd 1, 1130, 1215),
+              ("busy2b", fwd 1, 1330, 1400),
+              ("busy2c", fwd 1, 1430, 1500),
+              ("busy2d", fwd 1, 1610, 1650),
+              ("busy3a", fwd 2, 1100, 1400),
+              ("busy3b", fwd 2, 1900, 2100)
+            ]
   MockCxt <$> newMVar (Map.fromList [(mockFreeId, free), (mockBusyId, busy)])
 initialize appLog manager (GoogleCreds creds) =
   GoogleCxt
@@ -165,11 +162,10 @@ data SimpleEvent t
         seDescr :: Text,
         seLocation :: Text,
         seAttendees :: [Attendee]
-        }
+      }
   deriving (Eq, Show)
 
 instance Ord t => Ord (SimpleEvent t) where
-
   compare x y = compare (seStart x) (seStart y)
 
 type SimpleEventUTC = SimpleEvent UTCTime
@@ -180,7 +176,7 @@ data Attendee
   = Attendee
       { atName :: Text,
         atEmail :: Text
-        }
+      }
   deriving (Show, Eq)
 
 -- | Extract essential event data from a Google @Event@ object.
@@ -209,16 +205,16 @@ expandEvent SimpleEvent {..} =
     .~ map expandAttendee seAttendees
     & eReminders
     .~ Just
-         ( eventReminders & erOverrides .~ defaultReminders
-             & erUseDefault
-             .~ Just False
-           )
+      ( eventReminders & erOverrides .~ defaultReminders
+          & erUseDefault
+          .~ Just False
+      )
 
 defaultReminders :: [EventReminder]
 defaultReminders =
   [ eventReminder & erMethod .~ Just "email" & erMinutes .~ Just 1440,
     eventReminder & erMethod .~ Just "popup" & erMinutes .~ Just 10
-    ]
+  ]
 
 simplifyAttendee :: EventAttendee -> Maybe Attendee
 simplifyAttendee at = do
@@ -260,15 +256,16 @@ sampleEvent d (summary, f, hmm1, hmm2) =
       seDescr = "",
       seLocation = "",
       seAttendees = []
-      }
+    }
 
 -- | Fetch events from a single calendar.
-listUpcoming
-  :: MonadResource m
-  => CalendarContext
-  -> CalendarId
-  -> NominalDiffTime -- ^How far to look ahead
-  -> m (SL.SortedList SimpleEventUTC)
+listUpcoming ::
+  MonadResource m =>
+  CalendarContext ->
+  CalendarId ->
+  -- | How far to look ahead
+  NominalDiffTime ->
+  m (SL.SortedList SimpleEventUTC)
 listUpcoming (MockCxt v) cid _ =
   fromMaybe mempty . Map.lookup cid <$> readMVar v
 listUpcoming (GoogleCxt env) cid lookahead = do
@@ -278,12 +275,12 @@ listUpcoming (GoogleCxt env) cid lookahead = do
     Google.runGoogle env
       $ Google.send
       $ eventsList cid
-      & elTimeMin
-      .~ Just now
-      & elTimeMax
-      .~ Just end
-      & elSingleEvents
-      .~ Just True
+        & elTimeMin
+        .~ Just now
+        & elTimeMax
+        .~ Just end
+        & elSingleEvents
+        .~ Just True
   let es = SL.toSortedList $ mapMaybe simplifyEvent $ xs ^. eveItems
   --forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
   return es
@@ -291,13 +288,14 @@ listUpcoming (GoogleCxt env) cid lookahead = do
 -- sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
 -- sayEvent prefix SimpleEvent {..} =
 --   say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary
+
 -- | Convert an event into a local time zone.
 applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal
 applyTz tz ev =
   ev
     { seStart = utcToLocalTimeTZ tz (seStart ev),
       seEnd = utcToLocalTimeTZ tz (seEnd ev)
-      }
+    }
 
 groupByDay :: SL.SortedList SimpleEventLocal -> [[SimpleEventLocal]]
 groupByDay = groupAllOn (localDay . seStart) . SL.fromSortedList
@@ -305,11 +303,14 @@ groupByDay = groupAllOn (localDay . seStart) . SL.fromSortedList
 -- | Construct a stream of events that represent available times with
 -- chunks of busy times removed. Requires that the event streams are
 -- already ordered.
-availMinusBusy
-  :: Ord t
-  => SL.SortedList (SimpleEvent t) -- ^Available times
-  -> SL.SortedList (SimpleEvent t) -- ^Busy times
-  -> SL.SortedList (SimpleEvent t) -- ^Remaining available times
+availMinusBusy ::
+  Ord t =>
+  -- | Available times
+  SL.SortedList (SimpleEvent t) ->
+  -- | Busy times
+  SL.SortedList (SimpleEvent t) ->
+  -- | Remaining available times
+  SL.SortedList (SimpleEvent t)
 availMinusBusy aaa bbb =
   case (SL.uncons aaa, SL.uncons bbb) of
     (Nothing, _) -> mempty -- No available times
@@ -331,19 +332,22 @@ availMinusBusy aaa bbb =
         let a' = a {seStart = seEnd b}
          in availMinusBusy (SL.insert a' aa) bb
       -- B overlaps end of A, so keep truncated A and consider next A
-      | otherwise -> {-seStart a <= seStart b && seEnd a <= seEnd b-}
+      | otherwise {-seStart a <= seStart b && seEnd a <= seEnd b-} ->
         let a' = a {seEnd = seStart b}
          in SL.insert a' $ availMinusBusy aa bbb
 
 -- | Simultaneously fetch two calendars and return the difference
 -- between them.
-listAvailMinusBusy
-  :: (MonadResource m, MonadUnliftIO m)
-  => CalendarContext
-  -> CalendarId -- ^Calendar with available times
-  -> CalendarId -- ^Calendar with busy times
-  -> NominalDiffTime -- ^How far to look ahead
-  -> m (SL.SortedList SimpleEventUTC)
+listAvailMinusBusy ::
+  (MonadResource m, MonadUnliftIO m) =>
+  CalendarContext ->
+  -- | Calendar with available times
+  CalendarId ->
+  -- | Calendar with busy times
+  CalendarId ->
+  -- | How far to look ahead
+  NominalDiffTime ->
+  m (SL.SortedList SimpleEventUTC)
 listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
   availT <- async $ listUpcoming cxt cidAvail lookahead
   busyT <- async $ listUpcoming cxt cidBusy (lookahead + 86400)
@@ -353,11 +357,13 @@ listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
 
 -- | Take a stream of available times and split them into slots exactly
 -- N minutes long.
-partitionSlots
-  :: Maybe Int -- ^ Offset of each new slot, in minutes
-  -> Int -- ^ Length of each slot, in minutes
-  -> SL.SortedList SimpleEventUTC
-  -> SL.SortedList SimpleEventUTC
+partitionSlots ::
+  -- | Offset of each new slot, in minutes
+  Maybe Int ->
+  -- | Length of each slot, in minutes
+  Int ->
+  SL.SortedList SimpleEventUTC ->
+  SL.SortedList SimpleEventUTC
 partitionSlots offsetM lengthM evs = loop evs
   where
     lengthT = fromIntegral $ lengthM * 60
@@ -381,12 +387,12 @@ summaryMatches search = isInfixOf search . seSummary