1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Settings
( Settings (..),
readSettings,
writeSettings,
SuggestedTag (..),
)
where
import Data.Aeson qualified as A
import Data.Function (on)
import Data.List (nub)
import Data.Text qualified as T
import Data.Vector qualified as V
import Data.Yaml (decodeFileThrow, encodeFile)
import GHC.Generics (Generic)
import System.Directory (doesFileExist)
import System.Environment.XDG.BaseDir (getSystemConfigFiles, getUserConfigFile)
import Text.RE.TDFA.Text qualified as R
data Settings = Settings
{ suggestedTags :: [SuggestedTag],
defaultLanguage :: String
}
deriving (Show, Generic)
instance Semigroup Settings where
a <> b =
Settings
{ suggestedTags = nub (a.suggestedTags <> b.suggestedTags),
defaultLanguage = b.defaultLanguage
}
instance Monoid Settings where
mempty =
Settings
{ suggestedTags =
[ -- TODO Add `SuggestedTagByDate`
--
-- By having a dedicated constructor for dates wie can take the following improvements into account:
--
-- - date formats that spell out the month name, ie. `1 Januar 1970` or `1 Jan 1970`
-- - perform minor corrections on OCR, ie. parse `0 1.01.1970`
--
-- @topic suggested-tags
SuggestTagByRE
"createdAt"
[R.ed|${d}([0-9]{2})\.${m}([0-9]{2})\.${y}([0-9]{4})///${y}-${m}-${d}|],
SuggestTagByTags "correspondent"
],
defaultLanguage = "deu+eng"
}
instance A.FromJSON Settings
instance A.ToJSON Settings
data SuggestedTag
= SuggestTagByRE T.Text (R.SearchReplace R.RE T.Text)
| SuggestTagByTags T.Text
deriving (Show, Generic, Eq)
instance Show R.RE where
show = R.reSource
instance Eq R.RE where
(==) = (==) `on` show
instance (Eq re, Eq s) => Eq (R.SearchReplace re s) where
a == b =
((==) `on` R.getSearch) a b && (((==) `on` R.getTemplate) a b)
instance A.FromJSON SuggestedTag
instance A.ToJSON SuggestedTag
instance A.FromJSON R.RE where
parseJSON = A.withText "regular expression (POSIX)" (R.compileRegex . T.unpack)
instance A.ToJSON R.RE where
toJSON = A.toJSON . R.reSource
instance (A.FromJSON re, A.FromJSON s) => A.FromJSON (R.SearchReplace re s) where
parseJSON =
A.withArray
"regular search/replace expression (POSIX)"
( \a -> do
re <- a `V.indexM` 0
s <- a `V.indexM` 1
R.SearchReplace <$> A.parseJSON re <*> A.parseJSON s
)
instance (A.ToJSON re, A.ToJSON s) => A.ToJSON (R.SearchReplace re s) where
toJSON (R.SearchReplace re s) =
A.Array (V.fromList [A.toJSON re, A.toJSON s])
readSettings :: IO Settings
readSettings =
fmap mconcat
. mapM
( \fp ->
doesFileExist fp >>= \case
True -> decodeFileThrow fp
False -> pure mempty
)
=<< concat
<$> sequence
[ getSystemConfigFiles "apaperless" "settings.yaml",
((: []) <$> getUserConfigFile "apaperless" "settings.yaml"),
pure ["apaperless.yaml"]
]
writeSettings :: FilePath -> Settings -> IO ()
writeSettings =
encodeFile
|
