Skip to content

Commit

Permalink
Implement tag indexes; closes #2
Browse files Browse the repository at this point in the history
  • Loading branch information
@srid
srid committed Apr 22, 2021
1 parent 94b41e9 commit f75d9d7
Show file tree
Hide file tree
Showing 2 changed files with 92 additions and 38 deletions.
80 changes: 46 additions & 34 deletions src/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,11 +10,11 @@ import qualified Data.Map.Strict as Map
import Data.Org (OrgFile)
import qualified Data.Org as Org
import qualified Data.Set as Set
import Data.Time.Calendar (addDays)
import Data.Time.Calendar (Day, addDays)
import Ema.App (runEma)
import qualified Ema.Helper.Tailwind as Tailwind
import Ema.Route (IsRoute (routeUrl))
import Memoir.Data (Diary, diaryCal)
import Memoir.Data (Diary (diaryTags), diaryCal)
import qualified Memoir.Data as Data
import Memoir.Data.Measure
import Memoir.Route (Route (..))
Expand Down Expand Up @@ -44,31 +44,12 @@ render :: Diary -> Route -> LByteString
render diary r =
Tailwind.layout (H.title "My Diary") $
H.div ! A.class_ "container mx-auto" $ do
let heading =
H.header
! A.class_ "text-4xl my-2 py-2 font-bold text-center bg-purple-600 text-gray-100 shadow"
case r of
Index -> do
heading "My Diary"
H.div ! A.class_ "flex flex-col" $ do
let usedMeasures = Set.toList $ Set.fromList $ concat $ Map.elems (diaryCal diary) <&> \(_, measures) -> DMap.keys measures
td cls = H.td ! A.class_ ("border px-4 py-2 " <> cls)
th cls = H.td ! A.class_ ("border px-4 py-2 " <> cls)
-- Render diary index along with self-tracking measures, as a table.
H.table ! A.class_ "table-auto" $ do
H.tr ! A.class_ "bg-gray-50" $ do
th "" ""
forM_ usedMeasures $ \m -> do
th "font-bold" $ H.toHtml $ measureName m
forM_ (sortOn (Down . fst) $ Map.toList $ diaryCal diary) $ \(day, (_, dayMeasures)) -> do
H.tr $ do
th "font-bold" $ routeDay day
forM_ (flip lookupMeasure dayMeasures <$> usedMeasures) $ \case
Nothing -> td "" ""
Just measure -> td "" $ renderMeasureValue measure
renderDiaryListing "My Diary" (diaryCal diary)
OnDay day -> do
heading $ show day
routeElem Index "Back to Index"
heading $ show day
H.div ! A.class_ "text-center text-3xl " $ do
let yesterday = addDays (-1) day
tomorrow = addDays 1 day
Expand All @@ -82,8 +63,13 @@ render diary r =
" | "
renderOtherDay tomorrow
maybe "not found" renderDay (Map.lookup day $ diaryCal diary)
Tag _tag -> do
"TODO"
Tag tag -> do
routeElem Index "Back to Index"
case Map.lookup tag (diaryTags diary) of
Nothing -> "Tag not found"
Just days -> do
let tagCal = Map.filterWithKey (\day _ -> Set.member day days) (diaryCal diary)
renderDiaryListing (H.toHtml $ "Days tagged with #" <> tag) tagCal
H.footer
! A.class_ "text-xs my-4 py-2 text-center bg-gray-200"
$ do
Expand All @@ -93,11 +79,38 @@ render diary r =
! A.target "blank_"
! A.class_ "text-purple font-bold"
$ "memoir"
where
routeDay day =
routeElem (OnDay day) $ H.toMarkup @Text (show day)
routeElem r' w =
H.a ! A.class_ "text-purple-500 hover:underline" ! routeHref r' $ w

routeDay :: Day -> H.Html
routeDay day =
routeElem (OnDay day) $ H.toMarkup @Text (show day)

routeElem :: IsRoute r => r -> H.Html -> H.Html
routeElem r' = H.a ! A.class_ "text-purple-500 hover:underline" ! routeHref r'

heading :: H.Html -> H.Html
heading =
H.header
! A.class_ "text-4xl my-2 py-2 font-bold text-center bg-purple-600 text-gray-100 shadow"

renderDiaryListing :: H.Html -> Map Day (OrgFile, Measures) -> H.Html
renderDiaryListing h cal = do
heading h
H.div ! A.class_ "flex flex-col" $ do
let usedMeasures = Set.toList $ Set.fromList $ concat $ Map.elems cal <&> \(_, measures) -> DMap.keys measures
td cls = H.td ! A.class_ ("border px-4 py-2 " <> cls)
th cls = H.td ! A.class_ ("border px-4 py-2 " <> cls)
-- Render diary index along with self-tracking measures, as a table.
H.table ! A.class_ "table-auto" $ do
H.tr ! A.class_ "bg-gray-50" $ do
th "" ""
forM_ usedMeasures $ \m -> do
th "font-bold" $ H.toHtml $ measureName m
forM_ (sortOn (Down . fst) $ Map.toList cal) $ \(day, (_, dayMeasures)) -> do
H.tr $ do
th "font-bold" $ routeDay day
forM_ (flip lookupMeasure dayMeasures <$> usedMeasures) $ \case
Nothing -> td "" ""
Just measure -> td "" $ renderMeasureValue measure

routeHref :: IsRoute r => r -> H.Attribute
routeHref r' =
Expand All @@ -112,8 +125,7 @@ renderDay (orgFile, measures) = do
-- Even make it a separate library, as long as CSS classes can be customized!
renderOrg :: OrgFile -> H.Html
renderOrg _org@(Org.OrgFile _meta doc) = do
let heading = H.header ! A.class_ "text-2xl my-2 font-bold"
heading "Doc"
H.header ! A.class_ "text-2xl my-2 font-bold" $ "Doc"
-- renderAST "AST" org
renderOrgDoc doc

Expand Down Expand Up @@ -175,10 +187,10 @@ renderBlock blk = case blk of
Org.Paragraph ws -> H.p $ renderWordsList ws

renderSection :: Org.Section -> H.Html
renderSection (Org.Section heading tags (Org.OrgDoc blocks sections)) = do
renderSection (Org.Section h tags (Org.OrgDoc blocks sections)) = do
H.li ! A.class_ "my-2" $ do
H.div ! A.class_ ("py-1 text-xl cursor-default " <> "hover:" <> itemHoverClass) $ do
renderWordsList heading
renderWordsList h
forM_ tags renderTag
whenNotNull blocks $ \_ -> do
H.div ! A.class_ "border-l-2 pl-2 text-gray-700 bg-gray-50 mt-2" $
Expand Down
50 changes: 46 additions & 4 deletions src/Memoir/Data.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@ import qualified Data.LVar as LVar
import qualified Data.Map.Strict as Map
import Data.Org (OrgFile)
import qualified Data.Org as Org
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time (Day, defaultTimeLocale, parseTimeM)
import Memoir.Data.Measure (Measures, parseMeasures)
Expand All @@ -21,7 +22,7 @@ import System.FilePattern.Directory (getDirectoryFiles)

data Diary = Diary
{ diaryCal :: Map Day (OrgFile, Measures),
diaryTags :: Map Text (NonEmpty Day)
diaryTags :: Map Text (Set Day)
}
deriving (Eq)

Expand All @@ -33,20 +34,38 @@ data DiaryUpdate
| DiaryDel Day
deriving (Eq)

-- TODO: Update @diaryTags@ !
diaryUpdate :: DiaryUpdate -> Diary -> Diary
diaryUpdate action diary =
case action of
DiaryAdd day orgFile ->
diary
{ diaryCal =
Map.insert day (orgFile, parseMeasures $ Org.orgMeta orgFile) $ diaryCal diary
Map.insert day (orgFile, parseMeasures $ Org.orgMeta orgFile) $ diaryCal diary,
diaryTags = foldl' (addTag day) (diaryTags diary) (extractTags orgFile)
}
DiaryDel day ->
diary
{ diaryCal =
Map.delete day $ diaryCal diary
Map.delete day $ diaryCal diary,
diaryTags =
maybe
(diaryTags diary)
(foldl' (delTag day) (diaryTags diary) . extractTags . fst)
(Map.lookup day $ diaryCal diary)
}
where
addTag :: Day -> Map Text (Set Day) -> Text -> Map Text (Set Day)
addTag v m k =
let vs = fromMaybe mempty $ Map.lookup k m
in Map.insert k (Set.insert v vs) m
delTag :: Day -> Map Text (Set Day) -> Text -> Map Text (Set Day)
delTag v m k =
case Map.lookup k m of
Nothing -> m
Just vs ->
if Set.member v vs
then Map.insert k (Set.delete v vs) m
else m

parseDay :: String -> Maybe Day
parseDay =
Expand Down Expand Up @@ -97,3 +116,26 @@ watchAndUpdateDiary folder model = do
Unknown fp _ _ -> updateFile fp
threadDelay maxBound
`finally` stop

extractTags :: OrgFile -> Set Text
extractTags (Org.OrgFile _meta (Org.OrgDoc blocks sections)) =
foldMap fromBlocks blocks <> foldMap fromSections sections
where
fromSections :: Org.Section -> Set Text
fromSections (Org.Section heading tags (Org.OrgDoc bs ss)) =
Set.fromList tags
<> foldMap fromWords heading
<> foldMap fromBlocks bs
<> foldMap fromSections ss

fromBlocks :: Org.Block -> Set Text
fromBlocks = \case
Org.Paragraph ws ->
foldMap fromWords ws
_ ->
mempty

fromWords :: Org.Words -> Set Text
fromWords = \case
Org.Tags ts -> Set.fromList (toList ts)
_ -> mempty

0 comments on commit f75d9d7

Please sign in to comment.