ical support working

.gitignore

@@ -52,3 +52,4 @@ Temporary Items
 .apdisk
 
 schedule-maker-test.svg
+*.ics

src/CmdLineOpts.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 
-module CmdLineOpts (options, Options (..), execParser, ExampleYamlLanguage (..),) where
+module CmdLineOpts (options, Options (..), execParser, ExampleYamlLanguage (..)) where
 
 import Options.Applicative
 
@@ -9,7 +9,7 @@ data Options
       !FilePath --  yamlSource
       !Bool -- prettyPrintToStdout
       !FilePath -- outputFilePath
-      !(Maybe FilePath) -- create *.ical schedule
+      !Bool -- create *.ical schedule
   | PrintExampleYaml !ExampleYamlLanguage -- True english, False spanish
 
 data ExampleYamlLanguage
@@ -33,7 +33,7 @@ options =
     opts = languageParser <|> normalOpts
 
 normalOpts :: Parser Options
-normalOpts = NormalOptions <$> yamlPath <*> prettyPrintStdout <*> outputPath <*> icalPath
+normalOpts = NormalOptions <$> yamlPath <*> prettyPrintStdout <*> outputPath <*> writeICal
 
 languageParser :: Parser Options
 languageParser =
@@ -81,22 +81,10 @@ outputPath =
         <> short 'o'
     )
 
-icalPath :: Parser (Maybe FilePath)
-icalPath = optional first <|> second
-  where first = 
-          strOption
-            ( metavar "FILENAME"
-                <> help "Write output to FILE (.ical)"
-                <> action "directory"
-                <> action "file"
-                <> long "ical"
-                <> short 'i'
-            )
-        second = 
-          flag Nothing (Just "schedules.ical")
-            (
-                help "Write output to FILE (.ical)"
-                <> long "ical"
-                <> short 'i'
-
-            )
+writeICal :: Parser Bool
+writeICal =
+  switch
+    ( help "Write the schedules to iCal files (schedule1.ics, schedule2.ics)"
+        <> long "ical"
+        <> short 'i'
+    )

src/PPrint.hs

@@ -57,8 +57,8 @@ separateWith lineStyle lineChar numOfLines l r = l <> emptyLines <> separatingLi
 annotateErrors :: [Error] -> Doc AnsiStyle
 annotateErrors es =
   annotate
-    (color Red <> bold)
-    (concatWith (separateWith bold '-' 1) (map annotateError es))
+    (color Red <> bold) $
+    concatWith (separateWith bold '-' 1) (map annotateError es) <> line
 
 annotateSubjectList :: [IDandSubj] -> Doc AnsiStyle
 annotateSubjectList ss = concatWith (separateWith (colorDull Yellow) '-' 1) (map annotateSubject ss)

src/Validation.hs

@@ -17,7 +17,7 @@ import System.Console.Terminal.Size
 import System.IO (stdout)
 import Types
 import WriteXlsx (saveExcel)
-import WriteiCal (saveICal)
+import WriteiCal (saveMultipleICals)
 
 intervalsOverlap :: Interval -> Interval -> Bool
 intervalsOverlap (MkInterval a b) (MkInterval x y)
@@ -124,7 +124,7 @@ collectValidationResults xs = do
 runProgLogic :: Options -> IO ()
 runProgLogic = \case
   PrintExampleYaml lang -> printYaml lang
-  NormalOptions yamlSource prettyPrintToStdout outputFilePath mayICalFilePath -> do
+  NormalOptions yamlSource prettyPrintToStdout outputFilePath writeICals -> do
     res <- decodeFileEither yamlSource -- "test-english.yaml"
     sz <-
       size >>= \case
@@ -141,5 +141,6 @@ runProgLogic = \case
         Right lists -> do
           when prettyPrintToStdout $ prettyRender (annotateSubjectLists lists)
 
-          maybe (pure ()) (saveICal lists) mayICalFilePath
+          when writeICals $ saveMultipleICals lists
+
           saveExcel lists outputFilePath

src/WriteiCal.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module WriteiCal (saveICal) where
+module WriteiCal (saveMultipleICals) where
 
 import Data.ByteString.Lazy.Char8 qualified as BSL
 import Data.Default
+import Data.Foldable (traverse_)
 import Data.Function ((&))
 import Data.Map.Strict as M
 import Data.Text qualified as TS
@@ -54,49 +55,65 @@ emptyVEvent =
       veOther = def
     }
 
-toVCal :: Day -> [IDandSubj] -> VCalendar
-toVCal weekStartDay subjects =
-  emptyVCalendar
-    { vcEvents = vEventMap
-    }
+toVCal :: Day -> [IDandSubj] -> IO VCalendar
+toVCal weekStartDay subjects = do
+  emap <- vEventMap
+  pure $
+    emptyVCalendar
+      { vcEvents = emap
+      }
   where
-    vEventMap :: Map (TL.Text, Maybe (Either Date DateTime)) VEvent
-    vEventMap = ((\(txt, ev) -> ((txt, Nothing), ev)) <$> vEventList) & M.fromList
+    vEventMap :: IO (Map (TL.Text, Maybe (Either Date DateTime)) VEvent)
+    vEventMap = do
+      elist <- vEventList
+      pure $ ((\(txt, ev) -> ((txt, Nothing), ev)) <$> elist) & M.fromList
 
-    vEventList :: [(TL.Text, VEvent)]
-    vEventList = concatMap idandsubjToVEvents subjects
+    vEventList :: IO [(TL.Text, VEvent)]
+    vEventList = concat <$> traverse idandsubjToVEvents subjects
 
-    idandsubjToVEvents :: IDandSubj -> [(TL.Text, VEvent)]
-    idandsubjToVEvents (IDandSubj (subId, subj)) = fmap (classToEvent subId subj.subjName subj.subjProfessor) subj.subjclasses
+    idandsubjToVEvents :: IDandSubj -> IO [(TL.Text, VEvent)]
+    idandsubjToVEvents (IDandSubj (subId, subj)) = traverse (classToEvent subId subj.subjName subj.subjProfessor) subj.subjclasses
 
-    classToEvent :: TS.Text -> TS.Text -> TS.Text -> Class -> (TL.Text, VEvent) -- T.Text: UID value
-    classToEvent subId name teacher individualClass =
-      ( uidText,
-        emptyVEvent
-          { veSummary =
-              Just $
-                Summary
-                  { summaryValue = TL.fromStrict (name <> "(" <> subId <> ")"),
-                    summaryLanguage = def,
-                    summaryAltRep = def,
-                    summaryOther = def
-                  },
-            veUID = UID uidText def,
-            veDTStart = Just startDatetime,
-            veDTEndDuration = Just $ Left endDatetime,
-            veDescription =
-              Just $
-                Description
-                  { descriptionValue = TL.fromStrict teacher,
-                    descriptionLanguage = def,
-                    descriptionAltRep = def,
-                    descriptionOther = def
-                  }
-          }
-      )
+    classToEvent :: TS.Text -> TS.Text -> TS.Text -> Class -> IO (TL.Text, VEvent) -- T.Text: UID value
+    classToEvent subId name teacher individualClass = do
+      uidText <- getUidText
+      pure $
+        ( uidText,
+          emptyVEvent
+            { veSummary =
+                Just $
+                  Summary
+                    { summaryValue = TL.fromStrict (name <> "(" <> subId <> ")"),
+                      summaryLanguage = def,
+                      summaryAltRep = def,
+                      summaryOther = def
+                    },
+              veUID = UID uidText def,
+              veDTStart = Just startDatetime,
+              veDTEndDuration = Just $ Left endDatetime,
+              veDescription =
+                Just $
+                  Description
+                    { descriptionValue = TL.fromStrict teacher,
+                      descriptionLanguage = def,
+                      descriptionAltRep = def,
+                      descriptionOther = def
+                    }
+            }
+        )
       where
-        uidText :: TL.Text
-        uidText = TL.fromStrict subId <> TL.pack (show $ getClassDayOffset individualClass)
+        getUidText :: IO TL.Text
+        getUidText = do
+          time <- TL.pack . show <$> getSystemTime
+          let res =
+                TL.fromStrict subId
+                  <> "-"
+                  <> TL.replace " " "_" (TL.fromStrict name)
+                  <> "-"
+                  <> TL.pack (show $ getClassDayOffset individualClass)
+                  <> "-"
+                  <> time
+          pure res
 
         dayOfClass :: Day
         dayOfClass = addDays (getClassDayOffset individualClass) weekStartDay
@@ -136,11 +153,19 @@ renderICal :: [IDandSubj] -> IO BSL.ByteString
 renderICal idAndSubj = do
   (LocalTime today _) <- getLocalTime
   let nextMonday = addDays 1 $ sundayAfter today
-  let vcal = toVCal nextMonday idAndSubj
+  vcal <- toVCal nextMonday idAndSubj
   pure $ printICalendar def vcal
 
-
 saveICal :: [IDandSubj] -> FilePath -> IO ()
 saveICal idAndSubj filepath = do
   renderedICal <- renderICal idAndSubj
   BSL.writeFile filepath renderedICal
+
+saveMultipleICals :: [[IDandSubj]] -> IO ()
+saveMultipleICals schedules = traverse_ (uncurry saveICal) schedulesWithNames
+  where
+    joinLists :: [IDandSubj] -> Int -> ([IDandSubj], FilePath)
+    joinLists singleSchedule scheduleNumber = (singleSchedule, "schedule" <> show scheduleNumber <> ".ics")
+
+    schedulesWithNames :: [([IDandSubj], FilePath)]
+    schedulesWithNames = zipWith joinLists schedules [1 ..]

stack.yaml

@@ -44,7 +44,7 @@ ghc-options:
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
 extra-deps:
-  - git: git@github.com:0rphee/iCalendar.git
+  - git: https://github.com/0rphee/iCalendar.git
     commit: "b31ccf7c1f68532f5c6beb0e50128290fa5d03f3"
   - mime-0.4.0.2@sha256:208947d9d1a19d08850be67ecb28c6e776db697f3bba05bd9d682e51a59f241f,983