Skip to content

Commit

Permalink
Update ron to 0.8 (#163, #165)
Browse files Browse the repository at this point in the history
  • Loading branch information
@cblp
cblp authored Aug 14, 2019
1 parent 838fdef commit 243fb41
Show file tree
Hide file tree
Showing 11 changed files with 190 additions and 168 deletions.
114 changes: 60 additions & 54 deletions ff-core/lib/FF.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

module FF
( cmdDeleteNote,
Expand All @@ -19,6 +20,8 @@ module FF
cmdSearch,
cmdShow,
cmdUnarchive,
fromRga,
fromRgaM,
getContactSamples,
getDataDir,
getTaskSamples,
Expand Down Expand Up @@ -94,7 +97,7 @@ import RON.Data
ObjectStateT,
evalObjectState,
getObject,
newObjectState,
newObjectFrame,
runObjectState
)
import RON.Data.RGA (RGA (RGA))
Expand All @@ -109,14 +112,12 @@ import RON.Storage
loadDocument
)
import RON.Storage.Backend
( Document (Document),
MonadStorage,
createVersion,
getDocuments,
value
( Document (Document, objectFrame),
MonadStorage (getDocuments),
createVersion
)
import RON.Storage.FS (Storage)
import RON.Types (ObjectState (ObjectState, uuid))
import RON.Types (ObjectFrame (ObjectFrame, uuid))
import System.Directory
( doesDirectoryExist,
findExecutable,
Expand All @@ -133,8 +134,8 @@ import Prelude hiding (id)

load :: (Collection a, MonadStorage m) => DocId a -> m (Entity a)
load docid = do
Document {value = obj} <- loadDocument docid
entityVal <- evalObjectState obj getObject
Document {objectFrame} <- loadDocument docid
entityVal <- evalObjectState objectFrame getObject
pure $ Entity docid entityVal

loadAll :: (Collection a, MonadStorage m) => m [Entity a]
Expand All @@ -145,7 +146,8 @@ searchStatus = bool Active Archived

loadContacts :: MonadStorage m => Bool -> m [Entity Contact]
loadContacts isArchived =
filter ((== searchStatus isArchived) . contact_status . entityVal) <$> loadAll
filter ((== Just (searchStatus isArchived)) . contact_status . entityVal)
<$> loadAll

getContactSamples :: MonadStorage m => Bool -> m ContactSample
getContactSamples = getContactSamplesWith $ const True
Expand All @@ -157,21 +159,24 @@ getContactSamplesWith
-> m ContactSample
getContactSamplesWith predicate isArchived = do
contacts <- loadContacts isArchived
pure . (\ys -> Sample ys $ genericLength ys)
$ filter
(predicate . Text.pack . fromRga . contact_name . entityVal)
contacts
pure . (\ys -> Sample ys $ genericLength ys) $ filter predicate' contacts
where
predicate' = predicate . Text.pack . fromRgaM . contact_name . entityVal

fromRga :: RGA a -> [a]
fromRga (RGA xs) = xs

fromRgaM :: Maybe (RGA a) -> [a]
fromRgaM = maybe [] fromRga

loadTasks :: MonadStorage m => Bool -> m [Entity Note]
loadTasks isArchived =
filter ((TaskStatus (searchStatus isArchived) ==) . note_status . entityVal)
<$> loadAll
loadTasks isArchived = filter isArchived' <$> loadAll
where
isArchived' =
(Just (TaskStatus $ searchStatus isArchived) ==) . note_status . entityVal

loadWikis :: MonadStorage m => m [Entity Note]
loadWikis = filter ((Wiki ==) . note_status . entityVal) <$> loadAll
loadWikis = filter ((Just Wiki ==) . note_status . entityVal) <$> loadAll

getTaskSamples
:: MonadStorage m
Expand All @@ -196,7 +201,7 @@ getTaskSamplesWith predicate isArchived ConfigUI {shuffle} limit today = do
. takeSamples limit
. shuffleOrSort
. splitModesBy entityVal today
$ filter (predicate . Text.pack . fromRga . note_text . entityVal) tasks
$ filter (predicate . Text.pack . fromRgaM . note_text . entityVal) tasks
where
gen = mkStdGen . fromIntegral $ toModifiedJulianDay today
shuffleOrSort
Expand Down Expand Up @@ -229,15 +234,13 @@ getWikiSamplesWith predicate archive ConfigUI {shuffle} limit today =
else
do
wikis0 <- loadWikis
let wikis1 =
filter
(predicate . Text.pack . fromRga . note_text . entityVal)
wikis0
let wikis1 = filter predicate' wikis0
let wikis2 = case limit of
Nothing -> wikis1
Just l -> take (fromIntegral l) wikis1
pure . toSample $ shuffleOrSort wikis2
where
predicate' = predicate . Text.pack . fromRgaM . note_text . entityVal
toSample ys = Sample ys $ genericLength ys
gen = mkStdGen . fromIntegral $ toModifiedJulianDay today
shuffleOrSort
Expand Down Expand Up @@ -288,14 +291,14 @@ updateTrackedNote
updateTrackedNote oldNotes note = case note of
Note {note_track = Just track} -> case HashMap.lookup track oldNotes of
Nothing -> do
obj <- newObjectState note
obj <- newObjectFrame note
createDocument obj
Just noteid -> void $ modify noteid $ do
note_status_assignIfDiffer note_status
note_text_zoom $ RGA.edit text
_ -> throwError "External note is expected to be supplied with tracking"
where
Note {note_status, note_text = RGA text} = note
Note {note_status, note_text = (fromRgaM -> text)} = note

updateTrackedNotes :: [Note] -> Storage ()
updateTrackedNotes newNotes = do
Expand All @@ -304,8 +307,8 @@ updateTrackedNotes newNotes = do
notes <- getDocuments
oldNotesM <-
for notes $ \noteId -> do
Document {value = obj} <- loadDocument noteId
mTrack <- evalObjectState obj note_track_read
Document {objectFrame} <- loadDocument noteId
mTrack <- evalObjectState objectFrame note_track_read
pure $ (,noteId) <$> mTrack
let oldNotes = HashMap.fromList $ catMaybes oldNotesM
for_ newNotes $ updateTrackedNote oldNotes
Expand All @@ -314,36 +317,36 @@ cmdNewNote :: MonadStorage m => New -> Day -> m (Entity Note)
cmdNewNote New {text, start, end, isWiki} today = do
let start' = fromMaybe today start
whenJust end $ assertStartBeforeEnd start'
(note_status, note_end, note_start) <-
(status, note_end, noteStart) <-
case end of
_ | not isWiki -> pure (TaskStatus Active, end, start')
Nothing -> pure (Wiki, Nothing, today)
Just _ -> throwError "A wiki must have no end date."
let note = Note
{ note_end,
note_start,
note_status,
note_text = RGA $ Text.unpack text,
note_track = Nothing
note_start = Just noteStart,
note_status = Just status,
note_text = Just $ RGA $ Text.unpack text,
note_track = Nothing
}
obj@ObjectState {uuid} <- newObjectState note
obj@ObjectFrame {uuid} <- newObjectFrame note
createDocument obj
pure $ Entity (docIdFromUuid uuid) note

cmdNewContact :: MonadStorage m => Text -> m (Entity Contact)
cmdNewContact name = do
let contact =
Contact
{ contact_name = RGA $ Text.unpack name,
contact_status = Active
{ contact_name = Just $ RGA $ Text.unpack name,
contact_status = Just Active
}
obj@ObjectState {uuid} <- newObjectState contact
obj@ObjectFrame {uuid} <- newObjectFrame contact
createDocument obj
pure $ Entity (docIdFromUuid uuid) contact

cmdDeleteContact :: MonadStorage m => ContactId -> m (Entity Contact)
cmdDeleteContact cid = modifyAndView cid $ do
contact_status_assign Deleted
contact_status_assign $ Just Deleted
contact_name_zoom $ RGA.editText ""

cmdSearch
Expand All @@ -368,18 +371,19 @@ cmdShow = load
cmdDeleteNote :: MonadStorage m => NoteId -> m (Entity Note)
cmdDeleteNote nid = modifyAndView nid $ do
assertNoteIsNative
note_status_assign $ TaskStatus Deleted
note_status_assign $ Just $ TaskStatus Deleted
note_text_zoom $ RGA.editText ""
note_start_assign $ fromGregorian 0 1 1
note_start_assign $ Just $ fromGregorian 0 1 1
note_end_assign Nothing

cmdDone :: MonadStorage m => NoteId -> m (Entity Note)
cmdDone nid = modifyAndView nid $ do
assertNoteIsNative
note_status_assign $ TaskStatus Archived
note_status_assign $ Just $ TaskStatus Archived

cmdUnarchive :: MonadStorage m => NoteId -> m (Entity Note)
cmdUnarchive nid = modifyAndView nid $ note_status_assign $ TaskStatus Active
cmdUnarchive nid =
modifyAndView nid $ note_status_assign $ Just $ TaskStatus Active

cmdEdit :: Edit -> Storage [Entity Note]
cmdEdit edit = case edit of
Expand All @@ -404,30 +408,30 @@ cmdEdit edit = case edit of
-- check start and end editability
when (isJust start || isJust end) $ do
status <- note_status_read
when (status == Wiki)
when (status == Just Wiki)
$ throwError "Wiki dates are immutable"
-- check start and end relation
do
curStart <- note_start_read
curEnd <- note_end_read
curEnd <- note_end_read
let newStartEnd =
(,)
<$> (start <|> Just curStart)
<*> (end' <|> curEnd)
<$> (start <|> curStart)
<*> (end' <|> curEnd)
end' = end >>= maybeClearToMaybe
whenJust newStartEnd
$ uncurry assertStartBeforeEnd
-- update
whenJust end $ note_end_assign . maybeClearToMaybe
whenJust start note_start_assign
whenJust text $ note_text_zoom . RGA.editText
whenJust end $ note_end_assign . maybeClearToMaybe
whenJust start $ note_start_assign . Just
whenJust text $ note_text_zoom . RGA.editText

cmdPostpone :: NoteId -> Storage (Entity Note)
cmdPostpone nid = modifyAndView nid $ do
today <- getUtcToday
start <- note_start_read
let start' = addDays 1 $ max today start
note_start_assign start'
let start' = addDays 1 $ maybe today (max today) start
note_start_assign $ Just start'
mEnd <- note_end_read
case mEnd of
Just end | end < start' -> note_end_assign $ Just start'
Expand All @@ -442,8 +446,8 @@ modify
-> m b
modify docid f = do
oldDoc <- loadDocument docid
(b, value') <- runObjectState (value oldDoc) f
createVersion (Just (docid, oldDoc)) value'
(b, objectFrame') <- runObjectState (objectFrame oldDoc) f
createVersion (Just (docid, oldDoc)) objectFrame'
pure b

modifyAndView
Expand Down Expand Up @@ -485,7 +489,7 @@ assertStartBeforeEnd start end =

note_status_assignIfDiffer
:: (ReplicaClock m, MonadE m, MonadObjectState Note m)
=> NoteStatus
=> Maybe NoteStatus
-> m ()
note_status_assignIfDiffer newStatus = do
curStatus <- note_status_read
Expand All @@ -498,7 +502,9 @@ assertNoteIsNative = do
-- `some`
tracking <- note_track_read
whenJust tracking $ \Track {track_url} ->
throwErrorText $ "A tracked note must be edited in its source: " <> track_url
throwErrorText
$ "A tracked note must be edited in its source"
<> maybe "" (" :" <>) track_url

getDataDir :: Config -> IO (Maybe FilePath)
getDataDir Config {dataDir} = do
Expand Down
21 changes: 10 additions & 11 deletions ff-core/lib/FF/Github.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -107,15 +107,15 @@ noteViewList address mlimit =

issueToNote :: Text -> Issue -> Note
issueToNote address issue = Note
{ note_status = toStatus issueState
, note_text = RGA $ Text.unpack $ issueTitle <> body
, note_start = utctDay issueCreatedAt
{ note_status = Just $ toStatus issueState
, note_text = Just $ RGA $ Text.unpack $ issueTitle <> body
, note_start = Just $ utctDay issueCreatedAt
, note_end
, note_track = Just Track
{ track_provider = "github"
, track_source = address
, track_externalId
, track_url
{ track_provider = Just "github"
, track_source = Just address
, track_externalId = Just externalId
, track_url = Just trackUrl
}
}
where
Expand All @@ -128,11 +128,10 @@ issueToNote address issue = Note
, issueTitle
}
= issue
track_externalId = Text.pack . show @Int $ unIssueNumber issueNumber
track_url = case issueHtmlUrl of
externalId = Text.pack . show @Int $ unIssueNumber issueNumber
trackUrl = case issueHtmlUrl of
Just (URL url) -> url
Nothing ->
"https://github.com/" <> address <> "/issues/" <> track_externalId
Nothing -> "https://github.com/" <> address <> "/issues/" <> externalId
note_end = case issueMilestone of
Just Milestone { milestoneDueOn = Just UTCTime { utctDay } } ->
Just utctDay
Expand Down
Loading

0 comments on commit 243fb41

Please sign in to comment.