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
|
{-# 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.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`
SuggestTagByRE "createdAt" [R.re|[0-9]{2}\.[0-9]{2}\.[0-9]{4}|],
SuggestTagByTags "correspondent"
],
defaultLanguage = "deu+eng"
}
instance A.FromJSON Settings
instance A.ToJSON Settings
data SuggestedTag
= SuggestTagByRE T.Text R.RE
| SuggestTagByTags T.Text
deriving (Show, Generic, Eq)
instance Show R.RE where
show = R.reSource
instance Eq R.RE where
(==) = (==) `on` show
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
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
|
