2016-03-11 16:07:22 +03:00
|
|
|
|
{-# LANGUAGE
|
|
|
|
|
TemplateHaskell,
|
|
|
|
|
MultiParamTypeClasses,
|
|
|
|
|
FunctionalDependencies,
|
2016-04-09 00:50:13 +03:00
|
|
|
|
FlexibleContexts,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
FlexibleInstances,
|
|
|
|
|
RecordWildCards,
|
|
|
|
|
TypeFamilies,
|
|
|
|
|
OverloadedStrings,
|
|
|
|
|
RankNTypes,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
TupleSections,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
NoImplicitPrelude
|
|
|
|
|
#-}
|
|
|
|
|
|
|
|
|
|
|
2016-04-08 23:11:13 +03:00
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
|
|
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
module Types
|
|
|
|
|
(
|
|
|
|
|
Trait(..),
|
|
|
|
|
ItemKind(..),
|
2016-03-14 17:09:05 +03:00
|
|
|
|
hackageName,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
Item(..),
|
|
|
|
|
pros,
|
2016-03-24 21:16:14 +03:00
|
|
|
|
prosDeleted,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
cons,
|
2016-03-24 21:16:14 +03:00
|
|
|
|
consDeleted,
|
2016-03-17 02:52:40 +03:00
|
|
|
|
ecosystem,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
link,
|
|
|
|
|
kind,
|
|
|
|
|
Hue(..),
|
|
|
|
|
hueToDarkColor,
|
|
|
|
|
hueToLightColor,
|
|
|
|
|
Category(..),
|
|
|
|
|
title,
|
|
|
|
|
groups,
|
|
|
|
|
items,
|
2016-03-24 20:55:17 +03:00
|
|
|
|
itemsDeleted,
|
2016-03-19 21:36:21 +03:00
|
|
|
|
categorySlug,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
GlobalState(..),
|
|
|
|
|
categories,
|
2016-03-24 20:32:42 +03:00
|
|
|
|
categoriesDeleted,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
pendingEdits,
|
|
|
|
|
editIdCounter,
|
2016-05-01 16:28:10 +03:00
|
|
|
|
findCategoryByItem,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 00:50:13 +03:00
|
|
|
|
-- * Overloaded things
|
2016-03-11 16:07:22 +03:00
|
|
|
|
uid,
|
2016-04-09 00:50:13 +03:00
|
|
|
|
hasUid,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
content,
|
|
|
|
|
name,
|
|
|
|
|
description,
|
|
|
|
|
notes,
|
2016-03-18 21:32:33 +03:00
|
|
|
|
created,
|
2016-05-01 23:17:55 +03:00
|
|
|
|
group_,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- * Edits
|
|
|
|
|
Edit(..),
|
|
|
|
|
isVacuousEdit,
|
|
|
|
|
EditDetails(..),
|
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- * acid-state methods
|
|
|
|
|
-- ** query
|
|
|
|
|
GetGlobalState(..),
|
|
|
|
|
GetCategories(..),
|
2016-03-19 02:40:00 +03:00
|
|
|
|
GetCategory(..), GetCategoryMaybe(..),
|
2016-03-11 16:07:22 +03:00
|
|
|
|
GetCategoryByItem(..),
|
|
|
|
|
GetItem(..),
|
|
|
|
|
GetTrait(..),
|
|
|
|
|
|
|
|
|
|
-- ** add
|
|
|
|
|
AddCategory(..),
|
|
|
|
|
AddItem(..),
|
|
|
|
|
AddPro(..),
|
|
|
|
|
AddCon(..),
|
|
|
|
|
|
|
|
|
|
-- ** set
|
2016-03-19 02:52:44 +03:00
|
|
|
|
SetGlobalState(..),
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- *** 'Category'
|
|
|
|
|
SetCategoryTitle(..),
|
2016-05-01 23:17:55 +03:00
|
|
|
|
SetCategoryGroup(..),
|
2016-03-11 16:07:22 +03:00
|
|
|
|
SetCategoryNotes(..),
|
|
|
|
|
-- *** 'Item'
|
|
|
|
|
SetItemName(..),
|
|
|
|
|
SetItemLink(..),
|
|
|
|
|
SetItemGroup(..),
|
|
|
|
|
SetItemKind(..),
|
|
|
|
|
SetItemDescription(..),
|
|
|
|
|
SetItemNotes(..),
|
2016-03-17 02:52:40 +03:00
|
|
|
|
SetItemEcosystem(..),
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- *** 'Trait'
|
|
|
|
|
SetTraitContent(..),
|
|
|
|
|
|
|
|
|
|
-- ** delete
|
2016-04-07 15:54:11 +03:00
|
|
|
|
DeleteCategory(..),
|
2016-03-11 16:07:22 +03:00
|
|
|
|
DeleteItem(..),
|
|
|
|
|
DeleteTrait(..),
|
|
|
|
|
|
2016-04-08 18:05:52 +03:00
|
|
|
|
-- ** edits
|
2016-04-15 14:14:01 +03:00
|
|
|
|
GetEdit(..), GetEdits(..),
|
2016-04-08 18:05:52 +03:00
|
|
|
|
RegisterEdit(..),
|
2016-04-15 14:14:01 +03:00
|
|
|
|
RemovePendingEdit(..), RemovePendingEdits(..),
|
2016-04-08 18:05:52 +03:00
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- ** other
|
|
|
|
|
MoveItem(..),
|
|
|
|
|
MoveTrait(..),
|
2016-04-08 18:05:52 +03:00
|
|
|
|
RestoreCategory(..),
|
|
|
|
|
RestoreItem(..),
|
|
|
|
|
RestoreTrait(..),
|
2016-03-11 16:07:22 +03:00
|
|
|
|
)
|
|
|
|
|
where
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- General
|
|
|
|
|
import BasePrelude hiding (Category)
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- Monads and monad transformers
|
|
|
|
|
import Control.Monad.State
|
2016-04-07 18:35:04 +03:00
|
|
|
|
import Control.Monad.Reader
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- Lenses
|
2016-04-08 18:05:52 +03:00
|
|
|
|
import Lens.Micro.Platform hiding ((&))
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- Containers
|
|
|
|
|
import qualified Data.Map as M
|
|
|
|
|
import Data.Map (Map)
|
|
|
|
|
-- Text
|
2016-04-07 18:07:04 +03:00
|
|
|
|
import qualified Data.Text as T
|
2016-03-11 16:07:22 +03:00
|
|
|
|
import Data.Text (Text)
|
2016-03-18 21:32:33 +03:00
|
|
|
|
-- Time
|
|
|
|
|
import Data.Time
|
2016-04-08 23:11:13 +03:00
|
|
|
|
-- Network
|
|
|
|
|
import Data.IP
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- acid-state
|
|
|
|
|
import Data.SafeCopy hiding (kind)
|
|
|
|
|
import Data.Acid as Acid
|
|
|
|
|
|
|
|
|
|
-- Local
|
|
|
|
|
import Utils
|
2016-03-16 02:17:08 +03:00
|
|
|
|
import Markdown
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
|
2016-05-01 23:17:55 +03:00
|
|
|
|
{- Note [extending types]
|
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
|
|
|
|
Here's what you should do if you add a new field to 'Trait', 'Item', or 'Category'.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Types.hs
|
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
|
|
|
|
1. Fix all warnings about uninitialised fields that might appear (by e.g. providing a default value).
|
|
|
|
|
|
|
|
|
|
2. Update the migration code; see Note [acid-state]. (Usually updating the migration code means simply copying and pasting the old version of the type and adding “_n” to all fields, where ‘n’ is ‘previous n’ + 1.)
|
|
|
|
|
|
|
|
|
|
3. If the field is user-editable: add a new constructor to 'Edit' and update the migration code for 'Edit'. Update 'isVacuousEdit', too.
|
|
|
|
|
|
|
|
|
|
4. Create a method for updating the field (setSomethingField), add it to the “makeAcidic ''GlobalState” declaration, and export the SetSomethingField type.
|
|
|
|
|
|
|
|
|
|
5. Export a lens for the field (if it shares the name with some other field, move it to the “* Overloaded things” heading).
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Cache.hs
|
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
|
|
|
|
1. If the field is non-trivial (e.g. “notes”) and it makes sense to cache it, add it to 'CacheKey'.
|
|
|
|
|
|
|
|
|
|
2. Update 'cacheDepends'.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
JS.hs
|
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
|
|
|
|
1. If the field is user-editable, add a method for setting it and don't forget to add it to the 'allJSFunctions' list.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
View.hs
|
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
|
|
|
|
1. If the field is non-trivial, add a method for rendering it.
|
|
|
|
|
|
|
|
|
|
2. Don't forget to actually render it if the user is supposed to see it.
|
|
|
|
|
|
|
|
|
|
3. Add a branch for the constructor you made in Types.hs/#3 to 'renderEdit'.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Main.hs
|
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
|
|
|
|
1. Add a case to 'invalidateCacheForEdit'.
|
|
|
|
|
|
|
|
|
|
2. Add a case to 'undoEdit'.
|
|
|
|
|
|
|
|
|
|
3. If the field is user-editable, add a method for changing it to 'setMethods'.
|
|
|
|
|
|
|
|
|
|
-}
|
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
data Trait = Trait {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
_traitUid :: Uid Trait,
|
2016-03-16 02:17:08 +03:00
|
|
|
|
_traitContent :: MarkdownInline }
|
2016-04-22 01:06:02 +03:00
|
|
|
|
deriving (Show)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-03-28 23:52:20 +03:00
|
|
|
|
-- See Note [acid-state]
|
2016-04-11 16:05:45 +03:00
|
|
|
|
deriveSafeCopySimple 2 'extension ''Trait
|
2016-03-11 16:07:22 +03:00
|
|
|
|
makeFields ''Trait
|
|
|
|
|
|
2016-03-16 02:17:08 +03:00
|
|
|
|
-- Old version, needed for safe migration. It can most likely be already
|
|
|
|
|
-- deleted (if a checkpoint has been created), but it's been left here as a
|
|
|
|
|
-- template for future migrations.
|
2016-03-28 23:52:20 +03:00
|
|
|
|
--
|
|
|
|
|
-- Again, see Note [acid-state].
|
2016-04-11 16:05:45 +03:00
|
|
|
|
data Trait_v1 = Trait_v1 {
|
|
|
|
|
_traitUid_v1 :: Uid Trait,
|
|
|
|
|
_traitContent_v1 :: MarkdownInline }
|
2016-03-16 02:17:08 +03:00
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
-- TODO: at the next migration change this to deriveSafeCopySimple!
|
|
|
|
|
deriveSafeCopy 1 'base ''Trait_v1
|
2016-03-16 02:17:08 +03:00
|
|
|
|
|
|
|
|
|
instance Migrate Trait where
|
2016-04-11 16:05:45 +03:00
|
|
|
|
type MigrateFrom Trait = Trait_v1
|
|
|
|
|
migrate Trait_v1{..} = Trait {
|
|
|
|
|
_traitUid = _traitUid_v1,
|
|
|
|
|
_traitContent = _traitContent_v1 }
|
2016-03-16 02:17:08 +03:00
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
--
|
|
|
|
|
|
|
|
|
|
data ItemKind
|
2016-03-14 17:09:05 +03:00
|
|
|
|
= Library {_itemKindHackageName :: Maybe Text}
|
|
|
|
|
| Tool {_itemKindHackageName :: Maybe Text}
|
2016-03-11 16:07:22 +03:00
|
|
|
|
| Other
|
2016-03-24 22:20:25 +03:00
|
|
|
|
deriving (Eq, Show)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
deriveSafeCopySimple 3 'extension ''ItemKind
|
2016-03-11 16:07:22 +03:00
|
|
|
|
makeFields ''ItemKind
|
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
data ItemKind_v2
|
|
|
|
|
= Library_v2 {_itemKindHackageName_v2 :: Maybe Text}
|
|
|
|
|
| Tool_v2 {_itemKindHackageName_v2 :: Maybe Text}
|
|
|
|
|
| Other_v2
|
|
|
|
|
|
|
|
|
|
-- TODO: at the next migration change this to deriveSafeCopySimple!
|
|
|
|
|
deriveSafeCopy 2 'base ''ItemKind_v2
|
|
|
|
|
|
|
|
|
|
instance Migrate ItemKind where
|
|
|
|
|
type MigrateFrom ItemKind = ItemKind_v2
|
|
|
|
|
migrate Library_v2{..} = Library {
|
|
|
|
|
_itemKindHackageName = _itemKindHackageName_v2 }
|
|
|
|
|
migrate Tool_v2{..} = Tool {
|
|
|
|
|
_itemKindHackageName = _itemKindHackageName_v2 }
|
|
|
|
|
migrate Other_v2 = Other
|
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
--
|
|
|
|
|
|
|
|
|
|
-- TODO: add a field like “people to ask on IRC about this library if you
|
|
|
|
|
-- need help”
|
|
|
|
|
data Item = Item {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
_itemUid :: Uid Item,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemName :: Text,
|
2016-03-18 21:32:33 +03:00
|
|
|
|
_itemCreated :: UTCTime,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemGroup_ :: Maybe Text,
|
2016-03-16 02:17:08 +03:00
|
|
|
|
_itemDescription :: MarkdownBlock,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemPros :: [Trait],
|
2016-03-24 21:16:14 +03:00
|
|
|
|
_itemProsDeleted :: [Trait],
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemCons :: [Trait],
|
2016-03-24 21:16:14 +03:00
|
|
|
|
_itemConsDeleted :: [Trait],
|
2016-03-17 15:29:45 +03:00
|
|
|
|
_itemEcosystem :: MarkdownBlock,
|
2016-04-22 01:06:02 +03:00
|
|
|
|
_itemNotes :: MarkdownBlockWithTOC,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemLink :: Maybe Url,
|
|
|
|
|
_itemKind :: ItemKind }
|
2016-04-22 01:06:02 +03:00
|
|
|
|
deriving (Show)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-22 01:06:02 +03:00
|
|
|
|
deriveSafeCopySimple 9 'extension ''Item
|
2016-03-11 16:07:22 +03:00
|
|
|
|
makeFields ''Item
|
|
|
|
|
|
2016-03-16 02:17:08 +03:00
|
|
|
|
-- Old version, needed for safe migration. It can most likely be already
|
|
|
|
|
-- deleted (if a checkpoint has been created), but it's been left here as a
|
|
|
|
|
-- template for future migrations.
|
2016-04-22 01:06:02 +03:00
|
|
|
|
data Item_v8 = Item_v8 {
|
|
|
|
|
_itemUid_v8 :: Uid Item,
|
|
|
|
|
_itemName_v8 :: Text,
|
|
|
|
|
_itemCreated_v8 :: UTCTime,
|
|
|
|
|
_itemGroup__v8 :: Maybe Text,
|
|
|
|
|
_itemDescription_v8 :: MarkdownBlock,
|
|
|
|
|
_itemPros_v8 :: [Trait],
|
|
|
|
|
_itemProsDeleted_v8 :: [Trait],
|
|
|
|
|
_itemCons_v8 :: [Trait],
|
|
|
|
|
_itemConsDeleted_v8 :: [Trait],
|
|
|
|
|
_itemEcosystem_v8 :: MarkdownBlock,
|
|
|
|
|
_itemNotes_v8 :: MarkdownBlock,
|
|
|
|
|
_itemLink_v8 :: Maybe Url,
|
|
|
|
|
_itemKind_v8 :: ItemKind }
|
|
|
|
|
|
|
|
|
|
deriveSafeCopySimple 8 'base ''Item_v8
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
instance Migrate Item where
|
2016-04-22 01:06:02 +03:00
|
|
|
|
type MigrateFrom Item = Item_v8
|
|
|
|
|
migrate Item_v8{..} = Item {
|
|
|
|
|
_itemUid = _itemUid_v8,
|
|
|
|
|
_itemName = _itemName_v8,
|
|
|
|
|
_itemCreated = _itemCreated_v8,
|
|
|
|
|
_itemGroup_ = _itemGroup__v8,
|
|
|
|
|
_itemDescription = _itemDescription_v8,
|
|
|
|
|
_itemPros = _itemPros_v8,
|
|
|
|
|
_itemProsDeleted = _itemProsDeleted_v8,
|
|
|
|
|
_itemCons = _itemCons_v8,
|
|
|
|
|
_itemConsDeleted = _itemConsDeleted_v8,
|
|
|
|
|
_itemEcosystem = _itemEcosystem_v8,
|
|
|
|
|
_itemNotes = let pref = "item-notes-" <> uidToText _itemUid_v8 <> "-"
|
|
|
|
|
md = _itemNotes_v8 ^. mdText
|
|
|
|
|
in renderMarkdownBlockWithTOC pref md,
|
|
|
|
|
_itemLink = _itemLink_v8,
|
|
|
|
|
_itemKind = _itemKind_v8 }
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
--
|
|
|
|
|
|
|
|
|
|
data Hue = NoHue | Hue Int
|
2016-03-24 22:20:25 +03:00
|
|
|
|
deriving (Eq, Ord)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
deriveSafeCopySimple 1 'extension ''Hue
|
|
|
|
|
|
|
|
|
|
data Hue_v0 = NoHue_v0 | Hue_v0 Int
|
|
|
|
|
|
|
|
|
|
-- TODO: at the next migration change this to deriveSafeCopySimple!
|
|
|
|
|
deriveSafeCopy 0 'base ''Hue_v0
|
|
|
|
|
|
|
|
|
|
instance Migrate Hue where
|
|
|
|
|
type MigrateFrom Hue = Hue_v0
|
|
|
|
|
migrate NoHue_v0 = NoHue
|
|
|
|
|
migrate (Hue_v0 i) = Hue i
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
instance Show Hue where
|
|
|
|
|
show NoHue = "0"
|
|
|
|
|
show (Hue n) = show n
|
|
|
|
|
|
2016-04-16 21:47:38 +03:00
|
|
|
|
-- Colors taken from:
|
|
|
|
|
-- <https://www.google.com/design/spec/style/color.html#color-color-palette>
|
2016-03-11 16:07:22 +03:00
|
|
|
|
hueToDarkColor :: Hue -> Text
|
|
|
|
|
hueToDarkColor NoHue = "#D6D6D6" -- the color for gray isn't from Google's
|
|
|
|
|
-- palette, since their “100” is too light
|
|
|
|
|
hueToDarkColor (Hue i) = table !! ((i-1) `mod` length table)
|
|
|
|
|
where
|
|
|
|
|
-- the “100” colors
|
|
|
|
|
table = ["#D1C4E9", -- deep purple
|
|
|
|
|
"#C8E6C9", -- green
|
|
|
|
|
"#FFECB3", -- amber
|
2016-04-16 21:47:38 +03:00
|
|
|
|
"#BBDEFB", -- blue
|
|
|
|
|
"#FFCDD2", -- red
|
|
|
|
|
"#D7CCC8", -- brown
|
|
|
|
|
"#B2DFDB", -- teal
|
|
|
|
|
"#F0F4C3"] -- lime
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
hueToLightColor :: Hue -> Text
|
|
|
|
|
hueToLightColor NoHue = "#F0F0F0" -- the color for gray isn't from Google's
|
|
|
|
|
-- palette, since their “50” is too light
|
|
|
|
|
hueToLightColor (Hue i) = table !! ((i-1) `mod` length table)
|
|
|
|
|
where
|
|
|
|
|
-- the “50” colors
|
2016-04-16 21:47:38 +03:00
|
|
|
|
table = ["#EDE7F6", -- deep purple
|
|
|
|
|
"#E8F5E9", -- green
|
|
|
|
|
"#FFF8E1", -- amber
|
|
|
|
|
"#E3F2FD", -- blue
|
|
|
|
|
"#FFEBEE", -- red
|
|
|
|
|
"#EFEBE9", -- brown
|
|
|
|
|
"#E0F2F1", -- teal
|
|
|
|
|
"#F9FBE7"] -- lime
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
--
|
|
|
|
|
|
|
|
|
|
data Category = Category {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
_categoryUid :: Uid Category,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_categoryTitle :: Text,
|
2016-05-01 23:17:55 +03:00
|
|
|
|
_categoryGroup_ :: Text,
|
2016-03-18 21:32:33 +03:00
|
|
|
|
_categoryCreated :: UTCTime,
|
2016-03-16 02:17:08 +03:00
|
|
|
|
_categoryNotes :: MarkdownBlock,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_categoryGroups :: Map Text Hue,
|
2016-03-24 20:55:17 +03:00
|
|
|
|
_categoryItems :: [Item],
|
|
|
|
|
_categoryItemsDeleted :: [Item] }
|
2016-04-22 01:06:02 +03:00
|
|
|
|
deriving (Show)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-05-01 23:17:55 +03:00
|
|
|
|
deriveSafeCopySimple 5 'extension ''Category
|
2016-03-11 16:07:22 +03:00
|
|
|
|
makeFields ''Category
|
|
|
|
|
|
2016-03-19 21:36:21 +03:00
|
|
|
|
categorySlug :: Category -> Text
|
|
|
|
|
categorySlug category =
|
|
|
|
|
format "{}-{}" (makeSlug (category^.title), category^.uid)
|
|
|
|
|
|
2016-03-16 02:17:08 +03:00
|
|
|
|
-- Old version, needed for safe migration. It can most likely be already
|
|
|
|
|
-- deleted (if a checkpoint has been created), but it's been left here as a
|
|
|
|
|
-- template for future migrations.
|
2016-05-01 23:17:55 +03:00
|
|
|
|
data Category_v4 = Category_v4 {
|
|
|
|
|
_categoryUid_v4 :: Uid Category,
|
|
|
|
|
_categoryTitle_v4 :: Text,
|
|
|
|
|
_categoryCreated_v4 :: UTCTime,
|
|
|
|
|
_categoryNotes_v4 :: MarkdownBlock,
|
|
|
|
|
_categoryGroups_v4 :: Map Text Hue,
|
|
|
|
|
_categoryItems_v4 :: [Item],
|
|
|
|
|
_categoryItemsDeleted_v4 :: [Item] }
|
2016-04-11 16:05:45 +03:00
|
|
|
|
|
2016-05-01 23:17:55 +03:00
|
|
|
|
deriveSafeCopySimple 4 'base ''Category_v4
|
2016-03-16 02:17:08 +03:00
|
|
|
|
|
|
|
|
|
instance Migrate Category where
|
2016-05-01 23:17:55 +03:00
|
|
|
|
type MigrateFrom Category = Category_v4
|
|
|
|
|
migrate Category_v4{..} = Category {
|
|
|
|
|
_categoryUid = _categoryUid_v4,
|
|
|
|
|
_categoryTitle = _categoryTitle_v4,
|
|
|
|
|
_categoryGroup_ = "Miscellaneous",
|
|
|
|
|
_categoryCreated = _categoryCreated_v4,
|
|
|
|
|
_categoryNotes = _categoryNotes_v4,
|
|
|
|
|
_categoryGroups = _categoryGroups_v4,
|
|
|
|
|
_categoryItems = _categoryItems_v4,
|
|
|
|
|
_categoryItemsDeleted = _categoryItemsDeleted_v4 }
|
2016-03-16 02:17:08 +03:00
|
|
|
|
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- Edits
|
|
|
|
|
|
|
|
|
|
-- | Edits made by users. It should always be possible to undo an edit.
|
|
|
|
|
data Edit
|
|
|
|
|
-- Add
|
|
|
|
|
= Edit'AddCategory {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editCategoryUid :: Uid Category,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editCategoryTitle :: Text }
|
|
|
|
|
| Edit'AddItem {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editCategoryUid :: Uid Category,
|
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemName :: Text }
|
|
|
|
|
| Edit'AddPro {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
|
|
|
|
editTraitId :: Uid Trait,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editTraitContent :: Text }
|
|
|
|
|
| Edit'AddCon {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
|
|
|
|
editTraitId :: Uid Trait,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editTraitContent :: Text }
|
|
|
|
|
|
|
|
|
|
-- Change category properties
|
|
|
|
|
| Edit'SetCategoryTitle {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editCategoryUid :: Uid Category,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editCategoryTitle :: Text,
|
|
|
|
|
editCategoryNewTitle :: Text }
|
2016-05-01 23:17:55 +03:00
|
|
|
|
| Edit'SetCategoryGroup {
|
|
|
|
|
editCategoryUid :: Uid Category,
|
|
|
|
|
editCategoryGroup :: Text,
|
|
|
|
|
editCategoryNewGroup :: Text }
|
2016-04-03 23:57:01 +03:00
|
|
|
|
| Edit'SetCategoryNotes {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editCategoryUid :: Uid Category,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editCategoryNotes :: Text,
|
|
|
|
|
editCategoryNewNotes :: Text }
|
|
|
|
|
|
|
|
|
|
-- Change item properties
|
|
|
|
|
| Edit'SetItemName {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemName :: Text,
|
|
|
|
|
editItemNewName :: Text }
|
|
|
|
|
| Edit'SetItemLink {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemLink :: Maybe Url,
|
|
|
|
|
editItemNewLink :: Maybe Url }
|
|
|
|
|
| Edit'SetItemGroup {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemGroup :: Maybe Text,
|
|
|
|
|
editItemNewGroup :: Maybe Text }
|
|
|
|
|
| Edit'SetItemKind {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemKind :: ItemKind,
|
|
|
|
|
editItemNewKind :: ItemKind }
|
|
|
|
|
| Edit'SetItemDescription {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemDescription :: Text,
|
|
|
|
|
editItemNewDescription :: Text }
|
|
|
|
|
| Edit'SetItemNotes {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemNotes :: Text,
|
|
|
|
|
editItemNewNotes :: Text }
|
|
|
|
|
| Edit'SetItemEcosystem {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editItemEcosystem :: Text,
|
|
|
|
|
editItemNewEcosystem :: Text }
|
|
|
|
|
|
|
|
|
|
-- Change trait properties
|
|
|
|
|
| Edit'SetTraitContent {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
|
|
|
|
editTraitUid :: Uid Trait,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editTraitContent :: Text,
|
|
|
|
|
editTraitNewContent :: Text }
|
|
|
|
|
|
|
|
|
|
-- Delete
|
2016-04-07 15:54:11 +03:00
|
|
|
|
| Edit'DeleteCategory {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editCategoryUid :: Uid Category,
|
2016-04-07 15:54:11 +03:00
|
|
|
|
editCategoryPosition :: Int }
|
2016-04-03 23:57:01 +03:00
|
|
|
|
| Edit'DeleteItem {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-07 15:54:11 +03:00
|
|
|
|
editItemPosition :: Int }
|
2016-04-03 23:57:01 +03:00
|
|
|
|
| Edit'DeleteTrait {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
|
|
|
|
editTraitUid :: Uid Trait,
|
2016-04-07 15:54:11 +03:00
|
|
|
|
editTraitPosition :: Int }
|
2016-04-03 23:57:01 +03:00
|
|
|
|
|
|
|
|
|
-- Other
|
|
|
|
|
| Edit'MoveItem {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editDirection :: Bool }
|
|
|
|
|
| Edit'MoveTrait {
|
2016-04-09 11:13:26 +03:00
|
|
|
|
editItemUid :: Uid Item,
|
|
|
|
|
editTraitUid :: Uid Trait,
|
2016-04-03 23:57:01 +03:00
|
|
|
|
editDirection :: Bool }
|
|
|
|
|
|
|
|
|
|
deriving (Eq, Show)
|
|
|
|
|
|
2016-05-01 23:17:55 +03:00
|
|
|
|
deriveSafeCopySimple 3 'extension ''Edit
|
2016-04-07 15:54:11 +03:00
|
|
|
|
|
2016-05-01 23:17:55 +03:00
|
|
|
|
genVer ''Edit 2 [
|
2016-04-07 15:54:11 +03:00
|
|
|
|
-- Add
|
|
|
|
|
Copy 'Edit'AddCategory,
|
|
|
|
|
Copy 'Edit'AddItem,
|
|
|
|
|
Copy 'Edit'AddPro,
|
|
|
|
|
Copy 'Edit'AddCon,
|
|
|
|
|
-- Change category properties
|
|
|
|
|
Copy 'Edit'SetCategoryTitle,
|
|
|
|
|
Copy 'Edit'SetCategoryNotes,
|
|
|
|
|
-- Change item properties
|
|
|
|
|
Copy 'Edit'SetItemName,
|
|
|
|
|
Copy 'Edit'SetItemLink,
|
|
|
|
|
Copy 'Edit'SetItemGroup,
|
|
|
|
|
Copy 'Edit'SetItemKind,
|
|
|
|
|
Copy 'Edit'SetItemDescription,
|
|
|
|
|
Copy 'Edit'SetItemNotes,
|
|
|
|
|
Copy 'Edit'SetItemEcosystem,
|
|
|
|
|
-- Change trait properties
|
|
|
|
|
Copy 'Edit'SetTraitContent,
|
|
|
|
|
-- Delete
|
|
|
|
|
Copy 'Edit'DeleteCategory,
|
|
|
|
|
Copy 'Edit'DeleteItem,
|
|
|
|
|
Copy 'Edit'DeleteTrait,
|
|
|
|
|
-- Other
|
|
|
|
|
Copy 'Edit'MoveItem,
|
|
|
|
|
Copy 'Edit'MoveTrait ]
|
|
|
|
|
|
2016-05-01 23:17:55 +03:00
|
|
|
|
deriveSafeCopySimple 2 'base ''Edit_v2
|
2016-04-07 15:54:11 +03:00
|
|
|
|
|
|
|
|
|
instance Migrate Edit where
|
2016-05-01 23:17:55 +03:00
|
|
|
|
type MigrateFrom Edit = Edit_v2
|
|
|
|
|
migrate = $(migrateVer ''Edit 2 [
|
2016-04-07 15:54:11 +03:00
|
|
|
|
CopyM 'Edit'AddCategory,
|
|
|
|
|
CopyM 'Edit'AddItem,
|
|
|
|
|
CopyM 'Edit'AddPro,
|
|
|
|
|
CopyM 'Edit'AddCon,
|
|
|
|
|
-- Change category properties
|
|
|
|
|
CopyM 'Edit'SetCategoryTitle,
|
|
|
|
|
CopyM 'Edit'SetCategoryNotes,
|
|
|
|
|
-- Change item properties
|
|
|
|
|
CopyM 'Edit'SetItemName,
|
|
|
|
|
CopyM 'Edit'SetItemLink,
|
|
|
|
|
CopyM 'Edit'SetItemGroup,
|
|
|
|
|
CopyM 'Edit'SetItemKind,
|
|
|
|
|
CopyM 'Edit'SetItemDescription,
|
|
|
|
|
CopyM 'Edit'SetItemNotes,
|
|
|
|
|
CopyM 'Edit'SetItemEcosystem,
|
|
|
|
|
-- Change trait properties
|
|
|
|
|
CopyM 'Edit'SetTraitContent,
|
|
|
|
|
-- Delete
|
|
|
|
|
CopyM 'Edit'DeleteCategory,
|
|
|
|
|
CopyM 'Edit'DeleteItem,
|
|
|
|
|
CopyM 'Edit'DeleteTrait,
|
|
|
|
|
-- Other
|
|
|
|
|
CopyM 'Edit'MoveItem,
|
|
|
|
|
CopyM 'Edit'MoveTrait
|
|
|
|
|
])
|
2016-04-03 23:57:01 +03:00
|
|
|
|
|
|
|
|
|
-- | Determine whether the edit doesn't actually change anything and so isn't
|
|
|
|
|
-- worth recording in the list of pending edits.
|
|
|
|
|
isVacuousEdit :: Edit -> Bool
|
|
|
|
|
isVacuousEdit Edit'SetCategoryTitle{..} =
|
|
|
|
|
editCategoryTitle == editCategoryNewTitle
|
2016-05-01 23:17:55 +03:00
|
|
|
|
isVacuousEdit Edit'SetCategoryGroup{..} =
|
|
|
|
|
editCategoryGroup == editCategoryNewGroup
|
2016-04-03 23:57:01 +03:00
|
|
|
|
isVacuousEdit Edit'SetCategoryNotes{..} =
|
|
|
|
|
editCategoryNotes == editCategoryNewNotes
|
|
|
|
|
isVacuousEdit Edit'SetItemName{..} =
|
|
|
|
|
editItemName == editItemNewName
|
|
|
|
|
isVacuousEdit Edit'SetItemLink{..} =
|
|
|
|
|
editItemLink == editItemNewLink
|
|
|
|
|
isVacuousEdit Edit'SetItemGroup{..} =
|
|
|
|
|
editItemGroup == editItemNewGroup
|
|
|
|
|
isVacuousEdit Edit'SetItemKind{..} =
|
|
|
|
|
editItemKind == editItemNewKind
|
|
|
|
|
isVacuousEdit Edit'SetItemDescription{..} =
|
|
|
|
|
editItemDescription == editItemNewDescription
|
|
|
|
|
isVacuousEdit Edit'SetItemNotes{..} =
|
|
|
|
|
editItemNotes == editItemNewNotes
|
|
|
|
|
isVacuousEdit Edit'SetItemEcosystem{..} =
|
|
|
|
|
editItemEcosystem == editItemNewEcosystem
|
|
|
|
|
isVacuousEdit Edit'SetTraitContent{..} =
|
|
|
|
|
editTraitContent == editTraitNewContent
|
|
|
|
|
isVacuousEdit _ = False
|
|
|
|
|
|
|
|
|
|
data EditDetails = EditDetails {
|
|
|
|
|
editIP :: Maybe IP,
|
|
|
|
|
editDate :: UTCTime,
|
|
|
|
|
editId :: Int }
|
|
|
|
|
deriving (Eq, Show)
|
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
deriveSafeCopySimple 2 'extension ''EditDetails
|
2016-04-08 23:11:13 +03:00
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
data EditDetails_v1 = EditDetails_v1 {
|
|
|
|
|
editIP_v1 :: Maybe IP,
|
|
|
|
|
editDate_v1 :: UTCTime,
|
|
|
|
|
editId_v1 :: Int }
|
2016-04-08 23:11:13 +03:00
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
-- TODO: at the next migration change this to deriveSafeCopySimple!
|
|
|
|
|
deriveSafeCopy 1 'base ''EditDetails_v1
|
2016-04-08 23:11:13 +03:00
|
|
|
|
|
|
|
|
|
instance Migrate EditDetails where
|
2016-04-11 16:05:45 +03:00
|
|
|
|
type MigrateFrom EditDetails = EditDetails_v1
|
|
|
|
|
migrate EditDetails_v1{..} = EditDetails {
|
|
|
|
|
editIP = editIP_v1,
|
|
|
|
|
editDate = editDate_v1,
|
|
|
|
|
editId = editId_v1 }
|
2016-04-08 23:11:13 +03:00
|
|
|
|
|
2016-03-28 23:52:20 +03:00
|
|
|
|
-- See Note [acid-state]
|
2016-04-03 23:57:01 +03:00
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
data GlobalState = GlobalState {
|
2016-03-24 20:32:42 +03:00
|
|
|
|
_categories :: [Category],
|
2016-04-03 23:57:01 +03:00
|
|
|
|
_categoriesDeleted :: [Category],
|
2016-04-15 14:14:01 +03:00
|
|
|
|
-- | Pending edits, newest first
|
2016-04-03 23:57:01 +03:00
|
|
|
|
_pendingEdits :: [(Edit, EditDetails)],
|
2016-04-15 14:14:01 +03:00
|
|
|
|
-- | ID of next edit that will be made
|
|
|
|
|
_editIdCounter :: Int }
|
2016-04-09 23:34:24 +03:00
|
|
|
|
deriving (Show)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
deriveSafeCopySimple 3 'extension ''GlobalState
|
2016-03-11 16:07:22 +03:00
|
|
|
|
makeLenses ''GlobalState
|
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
data GlobalState_v2 = GlobalState_v2 {
|
|
|
|
|
_categories_v2 :: [Category],
|
|
|
|
|
_categoriesDeleted_v2 :: [Category],
|
|
|
|
|
_pendingEdits_v2 :: [(Edit, EditDetails)],
|
|
|
|
|
_editIdCounter_v2 :: Int }
|
2016-03-24 20:32:42 +03:00
|
|
|
|
|
2016-04-11 16:05:45 +03:00
|
|
|
|
-- TODO: at the next migration change this to deriveSafeCopySimple!
|
|
|
|
|
deriveSafeCopy 2 'base ''GlobalState_v2
|
2016-03-24 20:32:42 +03:00
|
|
|
|
|
|
|
|
|
instance Migrate GlobalState where
|
2016-04-11 16:05:45 +03:00
|
|
|
|
type MigrateFrom GlobalState = GlobalState_v2
|
|
|
|
|
migrate GlobalState_v2{..} = GlobalState {
|
|
|
|
|
_categories = _categories_v2,
|
|
|
|
|
_categoriesDeleted = _categoriesDeleted_v2,
|
|
|
|
|
_pendingEdits = _pendingEdits_v2,
|
|
|
|
|
_editIdCounter = _editIdCounter_v2 }
|
2016-03-24 20:32:42 +03:00
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
addGroupIfDoesNotExist :: Text -> Map Text Hue -> Map Text Hue
|
|
|
|
|
addGroupIfDoesNotExist g gs
|
|
|
|
|
| M.member g gs = gs
|
|
|
|
|
| otherwise = M.insert g firstNotTaken gs
|
|
|
|
|
where
|
|
|
|
|
firstNotTaken = head $ map Hue [1..] \\ M.elems gs
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
traitById :: Uid Trait -> Lens' Item Trait
|
2016-03-11 16:07:22 +03:00
|
|
|
|
traitById uid' = singular $
|
2016-04-09 00:50:13 +03:00
|
|
|
|
(pros.each . filtered (hasUid uid')) `failing`
|
|
|
|
|
(cons.each . filtered (hasUid uid')) `failing`
|
2016-04-07 18:07:04 +03:00
|
|
|
|
error ("traitById: couldn't find trait with uid " ++
|
|
|
|
|
T.unpack (uidToText uid'))
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
categoryById :: Uid Category -> Lens' GlobalState Category
|
2016-03-11 16:07:22 +03:00
|
|
|
|
categoryById catId = singular $
|
2016-04-09 00:50:13 +03:00
|
|
|
|
categories.each . filtered (hasUid catId) `failing`
|
2016-04-07 18:07:04 +03:00
|
|
|
|
error ("categoryById: couldn't find category with uid " ++
|
|
|
|
|
T.unpack (uidToText catId))
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
itemById :: Uid Item -> Lens' GlobalState Item
|
2016-03-11 16:07:22 +03:00
|
|
|
|
itemById itemId = singular $
|
2016-04-09 00:50:13 +03:00
|
|
|
|
categories.each . items.each . filtered (hasUid itemId) `failing`
|
2016-04-07 18:07:04 +03:00
|
|
|
|
error ("itemById: couldn't find item with uid " ++
|
|
|
|
|
T.unpack (uidToText itemId))
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
findCategoryByItem :: Uid Item -> GlobalState -> Category
|
2016-04-07 18:35:04 +03:00
|
|
|
|
findCategoryByItem itemId s =
|
|
|
|
|
fromMaybe (error err) (find hasItem (s^.categories))
|
|
|
|
|
where
|
|
|
|
|
err = "findCategoryByItem: couldn't find category with item with uid " ++
|
|
|
|
|
T.unpack (uidToText itemId)
|
|
|
|
|
hasItem category = itemId `elem` (category^..items.each.uid)
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
hasUid :: HasUid a (Uid u) => Uid u -> a -> Bool
|
2016-04-09 00:50:13 +03:00
|
|
|
|
hasUid u x = x^.uid == u
|
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- get
|
|
|
|
|
|
|
|
|
|
getGlobalState :: Acid.Query GlobalState GlobalState
|
|
|
|
|
getGlobalState = view id
|
|
|
|
|
|
|
|
|
|
getCategories :: Acid.Query GlobalState [Category]
|
|
|
|
|
getCategories = view categories
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
getCategory :: Uid Category -> Acid.Query GlobalState Category
|
2016-03-11 16:07:22 +03:00
|
|
|
|
getCategory uid' = view (categoryById uid')
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
getCategoryMaybe :: Uid Category -> Acid.Query GlobalState (Maybe Category)
|
2016-03-19 02:40:00 +03:00
|
|
|
|
getCategoryMaybe uid' = preview (categoryById uid')
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
getCategoryByItem :: Uid Item -> Acid.Query GlobalState Category
|
2016-04-07 18:35:04 +03:00
|
|
|
|
getCategoryByItem uid' = findCategoryByItem uid' <$> ask
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
getItem :: Uid Item -> Acid.Query GlobalState Item
|
2016-03-11 16:07:22 +03:00
|
|
|
|
getItem uid' = view (itemById uid')
|
|
|
|
|
|
|
|
|
|
-- TODO: this doesn't need the item id, but then we have to be a bit cleverer
|
|
|
|
|
-- and store a (TraitId -> ItemId) map in global state (and update it
|
|
|
|
|
-- accordingly whenever anything happens, so perhaps let's not do it!)
|
2016-04-09 11:13:26 +03:00
|
|
|
|
getTrait :: Uid Item -> Uid Trait -> Acid.Query GlobalState Trait
|
2016-03-11 16:07:22 +03:00
|
|
|
|
getTrait itemId traitId = view (itemById itemId . traitById traitId)
|
|
|
|
|
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- | A useful lens operator that modifies something and returns the old value.
|
|
|
|
|
(<<.=) :: MonadState s m => LensLike ((,) a) s s a b -> b -> m a
|
|
|
|
|
(<<.=) l b = state (l (,b))
|
|
|
|
|
{-# INLINE (<<.=) #-}
|
|
|
|
|
infix 4 <<.=
|
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- add
|
|
|
|
|
|
|
|
|
|
addCategory
|
2016-04-09 11:13:26 +03:00
|
|
|
|
:: Uid Category -- ^ New category's id
|
|
|
|
|
-> Text -- ^ Title
|
|
|
|
|
-> UTCTime -- ^ Creation time
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-> Acid.Update GlobalState (Edit, Category)
|
2016-03-18 21:32:33 +03:00
|
|
|
|
addCategory catId title' created' = do
|
2016-03-11 16:07:22 +03:00
|
|
|
|
let newCategory = Category {
|
|
|
|
|
_categoryUid = catId,
|
|
|
|
|
_categoryTitle = title',
|
2016-05-01 23:17:55 +03:00
|
|
|
|
_categoryGroup_ = "Miscellaneous",
|
2016-03-18 21:32:33 +03:00
|
|
|
|
_categoryCreated = created',
|
2016-04-22 01:06:02 +03:00
|
|
|
|
_categoryNotes = renderMarkdownBlock "",
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_categoryGroups = mempty,
|
2016-03-24 20:55:17 +03:00
|
|
|
|
_categoryItems = [],
|
|
|
|
|
_categoryItemsDeleted = [] }
|
2016-03-11 16:07:22 +03:00
|
|
|
|
categories %= (newCategory :)
|
2016-04-03 23:57:01 +03:00
|
|
|
|
let edit = Edit'AddCategory catId title'
|
|
|
|
|
return (edit, newCategory)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
addItem
|
2016-04-09 11:13:26 +03:00
|
|
|
|
:: Uid Category -- ^ Category id
|
|
|
|
|
-> Uid Item -- ^ New item's id
|
|
|
|
|
-> Text -- ^ Name
|
|
|
|
|
-> UTCTime -- ^ Creation time
|
|
|
|
|
-> ItemKind -- ^ Kind
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-> Acid.Update GlobalState (Edit, Item)
|
2016-03-18 21:32:33 +03:00
|
|
|
|
addItem catId itemId name' created' kind' = do
|
2016-03-11 16:07:22 +03:00
|
|
|
|
let newItem = Item {
|
|
|
|
|
_itemUid = itemId,
|
|
|
|
|
_itemName = name',
|
2016-03-18 21:32:33 +03:00
|
|
|
|
_itemCreated = created',
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemGroup_ = Nothing,
|
2016-04-22 01:06:02 +03:00
|
|
|
|
_itemDescription = renderMarkdownBlock "",
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemPros = [],
|
2016-03-24 21:16:14 +03:00
|
|
|
|
_itemProsDeleted = [],
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemCons = [],
|
2016-03-24 21:16:14 +03:00
|
|
|
|
_itemConsDeleted = [],
|
2016-04-22 01:06:02 +03:00
|
|
|
|
_itemEcosystem = renderMarkdownBlock "",
|
|
|
|
|
_itemNotes = let pref = "item-notes-" <> uidToText itemId <> "-"
|
|
|
|
|
in renderMarkdownBlockWithTOC pref "",
|
2016-03-11 16:07:22 +03:00
|
|
|
|
_itemLink = Nothing,
|
|
|
|
|
_itemKind = kind' }
|
|
|
|
|
categoryById catId . items %= (++ [newItem])
|
2016-04-03 23:57:01 +03:00
|
|
|
|
let edit = Edit'AddItem catId itemId name'
|
|
|
|
|
return (edit, newItem)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
addPro
|
2016-04-09 11:13:26 +03:00
|
|
|
|
:: Uid Item -- ^ Item id
|
|
|
|
|
-> Uid Trait -- ^ New trait's id
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-> Text
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-> Acid.Update GlobalState (Edit, Trait)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
addPro itemId traitId text' = do
|
2016-03-16 02:17:08 +03:00
|
|
|
|
let newTrait = Trait traitId (renderMarkdownInline text')
|
2016-03-11 16:07:22 +03:00
|
|
|
|
itemById itemId . pros %= (++ [newTrait])
|
2016-04-03 23:57:01 +03:00
|
|
|
|
let edit = Edit'AddPro itemId traitId text'
|
|
|
|
|
return (edit, newTrait)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
addCon
|
2016-04-09 11:13:26 +03:00
|
|
|
|
:: Uid Item -- ^ Item id
|
|
|
|
|
-> Uid Trait -- ^ New trait's id
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-> Text
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-> Acid.Update GlobalState (Edit, Trait)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
addCon itemId traitId text' = do
|
2016-03-16 02:17:08 +03:00
|
|
|
|
let newTrait = Trait traitId (renderMarkdownInline text')
|
2016-03-11 16:07:22 +03:00
|
|
|
|
itemById itemId . cons %= (++ [newTrait])
|
2016-04-03 23:57:01 +03:00
|
|
|
|
let edit = Edit'AddCon itemId traitId text'
|
|
|
|
|
return (edit, newTrait)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
-- set
|
|
|
|
|
|
2016-04-15 14:14:01 +03:00
|
|
|
|
-- Almost all of these return an 'Edit' that corresponds to the edit that has
|
|
|
|
|
-- been performed.
|
2016-04-03 23:57:01 +03:00
|
|
|
|
|
2016-03-19 02:52:44 +03:00
|
|
|
|
-- | Can be useful sometimes (e.g. if you want to regenerate all uids), but
|
|
|
|
|
-- generally shouldn't be used.
|
|
|
|
|
setGlobalState :: GlobalState -> Acid.Update GlobalState ()
|
|
|
|
|
setGlobalState = (id .=)
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setCategoryTitle :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setCategoryTitle catId title' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldTitle <- categoryById catId . title <<.= title'
|
|
|
|
|
let edit = Edit'SetCategoryTitle catId oldTitle title'
|
|
|
|
|
(edit,) <$> use (categoryById catId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-05-01 23:17:55 +03:00
|
|
|
|
setCategoryGroup :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
|
|
|
|
|
setCategoryGroup catId group' = do
|
|
|
|
|
oldGroup <- categoryById catId . group_ <<.= group'
|
|
|
|
|
let edit = Edit'SetCategoryGroup catId oldGroup group'
|
|
|
|
|
(edit,) <$> use (categoryById catId)
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setCategoryNotes :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setCategoryNotes catId notes' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldNotes <- categoryById catId . notes <<.= renderMarkdownBlock notes'
|
2016-04-16 02:02:43 +03:00
|
|
|
|
let edit = Edit'SetCategoryNotes catId (oldNotes ^. mdText) notes'
|
2016-04-03 23:57:01 +03:00
|
|
|
|
(edit,) <$> use (categoryById catId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setItemName :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setItemName itemId name' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldName <- itemById itemId . name <<.= name'
|
|
|
|
|
let edit = Edit'SetItemName itemId oldName name'
|
|
|
|
|
(edit,) <$> use (itemById itemId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setItemLink :: Uid Item -> Maybe Url -> Acid.Update GlobalState (Edit, Item)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setItemLink itemId link' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldLink <- itemById itemId . link <<.= link'
|
|
|
|
|
let edit = Edit'SetItemLink itemId oldLink link'
|
|
|
|
|
(edit,) <$> use (itemById itemId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
-- Also updates the list of groups in the category
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setItemGroup :: Uid Item -> Maybe Text -> Acid.Update GlobalState (Edit, Item)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setItemGroup itemId newGroup = do
|
2016-04-07 18:35:04 +03:00
|
|
|
|
catId <- view uid . findCategoryByItem itemId <$> get
|
2016-03-11 16:07:22 +03:00
|
|
|
|
let categoryLens :: Lens' GlobalState Category
|
2016-04-07 18:35:04 +03:00
|
|
|
|
categoryLens = categoryById catId
|
2016-03-11 16:07:22 +03:00
|
|
|
|
let itemLens :: Lens' GlobalState Item
|
|
|
|
|
itemLens = itemById itemId
|
|
|
|
|
-- If the group is new, add it to the list of groups in the category (which
|
|
|
|
|
-- causes a new hue to be generated, too)
|
|
|
|
|
case newGroup of
|
|
|
|
|
Nothing -> return ()
|
|
|
|
|
Just x -> categoryLens.groups %= addGroupIfDoesNotExist x
|
|
|
|
|
-- Update list of groups if the group is going to be empty after the item
|
|
|
|
|
-- is moved to a different group. Note that this is done after adding a new
|
|
|
|
|
-- group because we also want the color to change. So, if the item was the
|
|
|
|
|
-- only item in its group, the sequence of actions is as follows:
|
|
|
|
|
--
|
|
|
|
|
-- * new group is added (and hence a new color is assigned)
|
|
|
|
|
-- * old group is deleted (and now the old color is unused)
|
|
|
|
|
oldGroup <- use (itemLens.group_)
|
|
|
|
|
case oldGroup of
|
|
|
|
|
Nothing -> return ()
|
|
|
|
|
Just g -> when (oldGroup /= newGroup) $ do
|
|
|
|
|
allItems <- use (categoryLens.items)
|
|
|
|
|
let inOurGroup item = item^.group_ == Just g
|
|
|
|
|
when (length (filter inOurGroup allItems) == 1) $
|
|
|
|
|
categoryLens.groups %= M.delete g
|
|
|
|
|
-- Now we can actually change the group
|
|
|
|
|
itemLens.group_ .= newGroup
|
2016-04-03 23:57:01 +03:00
|
|
|
|
let edit = Edit'SetItemGroup itemId oldGroup newGroup
|
|
|
|
|
(edit,) <$> use itemLens
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setItemKind :: Uid Item -> ItemKind -> Acid.Update GlobalState (Edit, Item)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setItemKind itemId kind' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldKind <- itemById itemId . kind <<.= kind'
|
|
|
|
|
let edit = Edit'SetItemKind itemId oldKind kind'
|
|
|
|
|
(edit,) <$> use (itemById itemId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setItemDescription :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setItemDescription itemId description' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldDescr <- itemById itemId . description <<.=
|
|
|
|
|
renderMarkdownBlock description'
|
|
|
|
|
let edit = Edit'SetItemDescription itemId
|
2016-04-16 02:02:43 +03:00
|
|
|
|
(oldDescr ^. mdText) description'
|
2016-04-03 23:57:01 +03:00
|
|
|
|
(edit,) <$> use (itemById itemId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setItemNotes itemId notes' = do
|
2016-04-22 01:06:02 +03:00
|
|
|
|
let pref = "item-notes-" <> uidToText itemId <> "-"
|
|
|
|
|
oldNotes <- itemById itemId . notes <<.=
|
|
|
|
|
renderMarkdownBlockWithTOC pref notes'
|
2016-04-16 02:02:43 +03:00
|
|
|
|
let edit = Edit'SetItemNotes itemId (oldNotes ^. mdText) notes'
|
2016-04-03 23:57:01 +03:00
|
|
|
|
(edit,) <$> use (itemById itemId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setItemEcosystem :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
|
2016-03-17 02:52:40 +03:00
|
|
|
|
setItemEcosystem itemId ecosystem' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldEcosystem <- itemById itemId . ecosystem <<.=
|
|
|
|
|
renderMarkdownBlock ecosystem'
|
|
|
|
|
let edit = Edit'SetItemEcosystem itemId
|
2016-04-16 02:02:43 +03:00
|
|
|
|
(oldEcosystem ^. mdText) ecosystem'
|
2016-04-03 23:57:01 +03:00
|
|
|
|
(edit,) <$> use (itemById itemId)
|
2016-03-17 02:52:40 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
setTraitContent :: Uid Item -> Uid Trait -> Text -> Acid.Update GlobalState (Edit, Trait)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
setTraitContent itemId traitId content' = do
|
2016-04-03 23:57:01 +03:00
|
|
|
|
oldContent <- itemById itemId . traitById traitId . content <<.=
|
|
|
|
|
renderMarkdownInline content'
|
|
|
|
|
let edit = Edit'SetTraitContent itemId traitId
|
2016-04-16 02:02:43 +03:00
|
|
|
|
(oldContent ^. mdText) content'
|
2016-04-03 23:57:01 +03:00
|
|
|
|
(edit,) <$> use (itemById itemId . traitById traitId)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
-- delete
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
deleteCategory :: Uid Category -> Acid.Update GlobalState (Either String Edit)
|
2016-04-07 15:54:11 +03:00
|
|
|
|
deleteCategory catId = do
|
|
|
|
|
mbCategory <- preuse (categoryById catId)
|
|
|
|
|
case mbCategory of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "category not found")
|
2016-04-07 15:54:11 +03:00
|
|
|
|
Just category -> do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
mbCategoryPos <- findIndex (hasUid catId) <$> use categories
|
2016-04-07 15:54:11 +03:00
|
|
|
|
case mbCategoryPos of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "category not found")
|
2016-04-07 15:54:11 +03:00
|
|
|
|
Just categoryPos -> do
|
|
|
|
|
categories %= deleteAt categoryPos
|
|
|
|
|
categoriesDeleted %= (category:)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
return (Right (Edit'DeleteCategory catId categoryPos))
|
2016-04-07 15:54:11 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
deleteItem :: Uid Item -> Acid.Update GlobalState (Either String Edit)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
deleteItem itemId = do
|
2016-04-07 18:35:04 +03:00
|
|
|
|
catId <- view uid . findCategoryByItem itemId <$> get
|
2016-03-11 16:07:22 +03:00
|
|
|
|
let categoryLens :: Lens' GlobalState Category
|
2016-04-07 18:35:04 +03:00
|
|
|
|
categoryLens = categoryById catId
|
2016-03-11 16:07:22 +03:00
|
|
|
|
let itemLens :: Lens' GlobalState Item
|
|
|
|
|
itemLens = itemById itemId
|
2016-03-24 20:55:17 +03:00
|
|
|
|
mbItem <- preuse itemLens
|
2016-04-03 23:57:01 +03:00
|
|
|
|
case mbItem of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "item not found")
|
2016-04-03 23:57:01 +03:00
|
|
|
|
Just item -> do
|
|
|
|
|
allItems <- use (categoryLens.items)
|
|
|
|
|
-- If the item was the only item in its group, delete the group (and
|
|
|
|
|
-- make the hue available for new items)
|
|
|
|
|
case item^.group_ of
|
|
|
|
|
Nothing -> return ()
|
|
|
|
|
Just oldGroup -> do
|
|
|
|
|
let itemsInOurGroup = [item' | item' <- allItems,
|
|
|
|
|
item'^.group_ == Just oldGroup]
|
|
|
|
|
when (length itemsInOurGroup == 1) $
|
|
|
|
|
categoryLens.groups %= M.delete oldGroup
|
|
|
|
|
-- And now delete the item (i.e. move it to “deleted”)
|
2016-04-09 00:50:13 +03:00
|
|
|
|
case findIndex (hasUid itemId) allItems of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "item not found")
|
2016-04-03 23:57:01 +03:00
|
|
|
|
Just itemPos -> do
|
|
|
|
|
categoryLens.items %= deleteAt itemPos
|
|
|
|
|
categoryLens.itemsDeleted %= (item:)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
return (Right (Edit'DeleteItem itemId itemPos))
|
2016-04-03 23:57:01 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
deleteTrait :: Uid Item -> Uid Trait -> Acid.Update GlobalState (Either String Edit)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
deleteTrait itemId traitId = do
|
2016-03-24 21:16:14 +03:00
|
|
|
|
let itemLens :: Lens' GlobalState Item
|
|
|
|
|
itemLens = itemById itemId
|
2016-03-25 00:26:10 +03:00
|
|
|
|
mbItem <- preuse itemLens
|
2016-04-03 23:57:01 +03:00
|
|
|
|
case mbItem of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "item not found")
|
2016-04-03 23:57:01 +03:00
|
|
|
|
Just item -> do
|
|
|
|
|
-- Determine whether the trait is a pro or a con, and proceed accordingly
|
2016-04-09 00:50:13 +03:00
|
|
|
|
case (find (hasUid traitId) (item^.pros),
|
|
|
|
|
find (hasUid traitId) (item^.cons)) of
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- It's in neither group, which means it was deleted. Do nothing.
|
2016-04-08 18:05:52 +03:00
|
|
|
|
(Nothing, Nothing) -> return (Left "trait not found")
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- It's a pro
|
|
|
|
|
(Just trait, _) -> do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
mbTraitPos <- findIndex (hasUid traitId) <$> use (itemLens.pros)
|
2016-04-03 23:57:01 +03:00
|
|
|
|
case mbTraitPos of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "trait not found")
|
2016-04-03 23:57:01 +03:00
|
|
|
|
Just traitPos -> do
|
|
|
|
|
itemLens.pros %= deleteAt traitPos
|
|
|
|
|
itemLens.prosDeleted %= (trait:)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
return (Right (Edit'DeleteTrait itemId traitId traitPos))
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- It's a con
|
|
|
|
|
(_, Just trait) -> do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
mbTraitPos <- findIndex (hasUid traitId) <$> use (itemLens.cons)
|
2016-04-03 23:57:01 +03:00
|
|
|
|
case mbTraitPos of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "trait not found")
|
2016-04-03 23:57:01 +03:00
|
|
|
|
Just traitPos -> do
|
|
|
|
|
itemLens.cons %= deleteAt traitPos
|
|
|
|
|
itemLens.consDeleted %= (trait:)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
return (Right (Edit'DeleteTrait itemId traitId traitPos))
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
-- other methods
|
|
|
|
|
|
|
|
|
|
moveItem
|
2016-04-09 11:13:26 +03:00
|
|
|
|
:: Uid Item
|
|
|
|
|
-> Bool -- ^ 'True' means up, 'False' means down
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-> Acid.Update GlobalState Edit
|
2016-03-11 16:07:22 +03:00
|
|
|
|
moveItem itemId up = do
|
|
|
|
|
let move = if up then moveUp else moveDown
|
2016-04-07 18:35:04 +03:00
|
|
|
|
catId <- view uid . findCategoryByItem itemId <$> get
|
2016-04-09 00:50:13 +03:00
|
|
|
|
categoryById catId . items %= move (hasUid itemId)
|
2016-04-03 23:57:01 +03:00
|
|
|
|
return (Edit'MoveItem itemId up)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
|
|
|
|
moveTrait
|
2016-04-09 11:13:26 +03:00
|
|
|
|
:: Uid Item
|
|
|
|
|
-> Uid Trait
|
|
|
|
|
-> Bool -- ^ 'True' means up, 'False' means down
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-> Acid.Update GlobalState Edit
|
2016-03-11 16:07:22 +03:00
|
|
|
|
moveTrait itemId traitId up = do
|
|
|
|
|
let move = if up then moveUp else moveDown
|
|
|
|
|
-- The trait is only going to be present in one of the lists so let's do it
|
|
|
|
|
-- in each list because we're too lazy to figure out whether it's a pro or
|
|
|
|
|
-- a con
|
2016-04-09 00:50:13 +03:00
|
|
|
|
itemById itemId . pros %= move (hasUid traitId)
|
|
|
|
|
itemById itemId . cons %= move (hasUid traitId)
|
2016-04-03 23:57:01 +03:00
|
|
|
|
return (Edit'MoveTrait itemId traitId up)
|
2016-03-11 16:07:22 +03:00
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
restoreCategory :: Uid Category -> Int -> Acid.Update GlobalState (Either String ())
|
2016-04-08 18:05:52 +03:00
|
|
|
|
restoreCategory catId pos = do
|
|
|
|
|
deleted <- use categoriesDeleted
|
2016-04-09 00:50:13 +03:00
|
|
|
|
case find (hasUid catId) deleted of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
Nothing -> return (Left "category not found in deleted categories")
|
|
|
|
|
Just category -> do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
categoriesDeleted %= deleteFirst (hasUid catId)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
categories %= insertAt pos category
|
|
|
|
|
return (Right ())
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
restoreItem :: Uid Item -> Int -> Acid.Update GlobalState (Either String ())
|
2016-04-08 18:05:52 +03:00
|
|
|
|
restoreItem itemId pos = do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
let ourCategory = any (hasUid itemId) . view itemsDeleted
|
2016-04-08 18:05:52 +03:00
|
|
|
|
allCategories <- use (categories <> categoriesDeleted)
|
|
|
|
|
case find ourCategory allCategories of
|
|
|
|
|
Nothing -> return (Left "item not found in deleted items")
|
|
|
|
|
Just category -> do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
let item = fromJust (find (hasUid itemId) (category^.itemsDeleted))
|
2016-04-08 18:05:52 +03:00
|
|
|
|
let category' = category
|
2016-04-09 00:50:13 +03:00
|
|
|
|
& itemsDeleted %~ deleteFirst (hasUid itemId)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
& items %~ insertAt pos item
|
|
|
|
|
categories . each . filtered ourCategory .= category'
|
|
|
|
|
categoriesDeleted . each . filtered ourCategory .= category'
|
|
|
|
|
return (Right ())
|
|
|
|
|
|
2016-04-09 11:13:26 +03:00
|
|
|
|
restoreTrait :: Uid Item -> Uid Trait -> Int -> Acid.Update GlobalState (Either String ())
|
2016-04-08 18:05:52 +03:00
|
|
|
|
restoreTrait itemId traitId pos = do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
let getItems = view (items <> itemsDeleted)
|
|
|
|
|
ourCategory = any (hasUid itemId) . getItems
|
2016-04-08 18:05:52 +03:00
|
|
|
|
allCategories <- use (categories <> categoriesDeleted)
|
|
|
|
|
case find ourCategory allCategories of
|
|
|
|
|
Nothing -> return (Left "item -that the trait belongs to- not found")
|
|
|
|
|
Just category -> do
|
2016-04-09 00:50:13 +03:00
|
|
|
|
let item = fromJust (find (hasUid itemId) (getItems category))
|
|
|
|
|
case (find (hasUid traitId) (item^.prosDeleted),
|
|
|
|
|
find (hasUid traitId) (item^.consDeleted)) of
|
2016-04-08 18:05:52 +03:00
|
|
|
|
(Nothing, Nothing) -> return (Left "trait not found in deleted traits")
|
|
|
|
|
(Just trait, _) -> do
|
|
|
|
|
let item' = item
|
2016-04-09 00:50:13 +03:00
|
|
|
|
& prosDeleted %~ deleteFirst (hasUid traitId)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
& pros %~ insertAt pos trait
|
|
|
|
|
let category' = category
|
2016-04-09 00:50:13 +03:00
|
|
|
|
& items . each . filtered (hasUid itemId) .~ item'
|
|
|
|
|
& itemsDeleted . each . filtered (hasUid itemId) .~ item'
|
2016-04-08 18:05:52 +03:00
|
|
|
|
categories . each . filtered ourCategory .= category'
|
|
|
|
|
categoriesDeleted . each . filtered ourCategory .= category'
|
|
|
|
|
return (Right ())
|
|
|
|
|
(_, Just trait) -> do
|
|
|
|
|
let item' = item
|
2016-04-09 00:50:13 +03:00
|
|
|
|
& consDeleted %~ deleteFirst (hasUid traitId)
|
2016-04-08 18:05:52 +03:00
|
|
|
|
& cons %~ insertAt pos trait
|
|
|
|
|
let category' = category
|
2016-04-09 00:50:13 +03:00
|
|
|
|
& items . each . filtered (hasUid itemId) .~ item'
|
|
|
|
|
& itemsDeleted . each . filtered (hasUid itemId) .~ item'
|
2016-04-08 18:05:52 +03:00
|
|
|
|
categories . each . filtered ourCategory .= category'
|
|
|
|
|
categoriesDeleted . each . filtered ourCategory .= category'
|
|
|
|
|
return (Right ())
|
|
|
|
|
|
|
|
|
|
-- TODO: maybe have a single list of traits with pro/con being signified by
|
|
|
|
|
-- something like TraitType? or maybe TraitType could even be a part of the
|
|
|
|
|
-- trait itself?
|
|
|
|
|
|
|
|
|
|
getEdit :: Int -> Acid.Query GlobalState (Edit, EditDetails)
|
|
|
|
|
getEdit n = do
|
|
|
|
|
edits <- view pendingEdits
|
|
|
|
|
case find ((== n) . editId . snd) edits of
|
|
|
|
|
Nothing -> error ("no edit with id " ++ show n)
|
|
|
|
|
Just edit -> return edit
|
|
|
|
|
|
2016-04-15 14:14:01 +03:00
|
|
|
|
-- | Returns edits in order from latest to earliest.
|
|
|
|
|
getEdits
|
|
|
|
|
:: Int -- ^ Id of latest edit
|
|
|
|
|
-> Int -- ^ Id of earliest edit
|
|
|
|
|
-> Acid.Query GlobalState [(Edit, EditDetails)]
|
|
|
|
|
getEdits m n =
|
|
|
|
|
filter (\(_, d) -> n <= editId d && editId d <= m) <$> view pendingEdits
|
|
|
|
|
|
2016-04-03 23:57:01 +03:00
|
|
|
|
-- | The edit won't be registered if it's vacuous (see 'isVacuousEdit').
|
|
|
|
|
registerEdit
|
|
|
|
|
:: Edit
|
|
|
|
|
-> Maybe IP
|
|
|
|
|
-> UTCTime
|
|
|
|
|
-> Acid.Update GlobalState ()
|
|
|
|
|
registerEdit ed ip date = do
|
|
|
|
|
id' <- use editIdCounter
|
|
|
|
|
let details = EditDetails {
|
|
|
|
|
editIP = ip,
|
|
|
|
|
editDate = date,
|
|
|
|
|
editId = id' }
|
|
|
|
|
pendingEdits %= ((ed, details):)
|
|
|
|
|
editIdCounter += 1
|
|
|
|
|
|
2016-04-08 18:05:52 +03:00
|
|
|
|
removePendingEdit :: Int -> Acid.Update GlobalState (Edit, EditDetails)
|
|
|
|
|
removePendingEdit n = do
|
|
|
|
|
edits <- use pendingEdits
|
|
|
|
|
case find ((== n) . editId . snd) edits of
|
|
|
|
|
Nothing -> error ("no edit with id " ++ show n)
|
|
|
|
|
Just edit -> do
|
|
|
|
|
pendingEdits %= deleteFirst ((== n) . editId . snd)
|
|
|
|
|
return edit
|
|
|
|
|
|
2016-04-15 14:14:01 +03:00
|
|
|
|
removePendingEdits
|
|
|
|
|
:: Int -- ^ Id of latest edit
|
|
|
|
|
-> Int -- ^ Id of earliest edit
|
|
|
|
|
-> Acid.Update GlobalState ()
|
|
|
|
|
removePendingEdits m n = do
|
|
|
|
|
pendingEdits %= filter (\(_, d) -> editId d < n || m < editId d)
|
|
|
|
|
|
2016-03-11 16:07:22 +03:00
|
|
|
|
makeAcidic ''GlobalState [
|
|
|
|
|
-- queries
|
|
|
|
|
'getGlobalState,
|
|
|
|
|
'getCategories,
|
2016-03-19 02:40:00 +03:00
|
|
|
|
'getCategory, 'getCategoryMaybe,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
'getCategoryByItem,
|
|
|
|
|
'getItem,
|
|
|
|
|
'getTrait,
|
|
|
|
|
-- add
|
|
|
|
|
'addCategory,
|
|
|
|
|
'addItem,
|
|
|
|
|
'addPro, 'addCon,
|
|
|
|
|
-- set
|
2016-03-19 02:52:44 +03:00
|
|
|
|
'setGlobalState,
|
2016-05-01 23:17:55 +03:00
|
|
|
|
'setCategoryTitle, 'setCategoryGroup, 'setCategoryNotes,
|
2016-03-14 17:09:05 +03:00
|
|
|
|
'setItemName, 'setItemLink, 'setItemGroup, 'setItemKind,
|
2016-03-17 02:52:40 +03:00
|
|
|
|
'setItemDescription, 'setItemNotes, 'setItemEcosystem,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
'setTraitContent,
|
|
|
|
|
-- delete
|
2016-04-07 15:54:11 +03:00
|
|
|
|
'deleteCategory,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
'deleteItem,
|
|
|
|
|
'deleteTrait,
|
2016-04-08 18:05:52 +03:00
|
|
|
|
-- edits
|
2016-04-15 14:14:01 +03:00
|
|
|
|
'getEdit, 'getEdits,
|
2016-04-08 18:05:52 +03:00
|
|
|
|
'registerEdit,
|
2016-04-15 14:14:01 +03:00
|
|
|
|
'removePendingEdit, 'removePendingEdits,
|
2016-03-11 16:07:22 +03:00
|
|
|
|
-- other
|
2016-04-03 23:57:01 +03:00
|
|
|
|
'moveItem, 'moveTrait,
|
2016-04-08 18:05:52 +03:00
|
|
|
|
'restoreCategory, 'restoreItem, 'restoreTrait
|
2016-03-11 16:07:22 +03:00
|
|
|
|
]
|