add fourmolu config; reformat using fourmolu

This commit is contained in:
Christian Ulrich 2024-05-28 23:46:09 +02:00
parent dfe275eedf
commit 74f96dc563
No known key found for this signature in database
GPG Key ID: 8241BE099775A097
3 changed files with 204 additions and 140 deletions

View File

@ -2,11 +2,12 @@ module Main where
import Data.Text as T
import Data.Text.IO as T
-- import Data.Time.Clock
import Data.Time.LocalTime
import NCDeck
import Options.Applicative
import System.IO
import NCDeck
data Options = Options
{ hostname :: Text
@ -55,7 +56,8 @@ run (Options {..}) = do
parseListStacks :: Parser Command
parseListStacks =
ListStacks
<$> option auto
<$> option
auto
( long "board-id"
<> short 'b'
<> metavar "BOARD_ID"
@ -65,13 +67,15 @@ parseListStacks =
parseListCards :: Parser Command
parseListCards =
ListCards
<$> option auto
<$> option
auto
( long "board-id"
<> short 'b'
<> metavar "BOARD_ID"
<> help "the id of the kanban board"
)
<*> option auto
<*> option
auto
( long "stack-id"
<> short 's'
<> metavar "STACK_ID"
@ -81,13 +85,15 @@ parseListCards =
parseCreateCard :: Parser Command
parseCreateCard =
CreateCard
<$> option auto
<$> option
auto
( long "board-id"
<> short 'b'
<> metavar "BOARD_ID"
<> help "the id of the kanban board"
)
<*> option auto
<*> option
auto
( long "stack-id"
<> short 's'
<> metavar "STACK_ID"
@ -107,19 +113,22 @@ parseCreateCard =
<> showDefault
<> help "the card's description"
)
<*> option auto
<*> option
auto
( long "date" -- FIXME: make this optional?
<> short 'e'
<> metavar "DATE"
<> help "the card's date, format: YYYY-MM-DD hh:mm:ss"
)
<*> option auto
<*> option
auto
( long "weekly-repeats"
<> short 'w'
<> metavar "COUNT"
<> value 0
<> showDefault
<> help "repeat the card weekly COUNT times")
<> help "repeat the card weekly COUNT times"
)
parseOptions :: Parser Options
parseOptions =
@ -146,7 +155,9 @@ parseOptions =
main :: IO ()
main = run =<< execParser opts
where
opts = info (parseOptions <**> helper)
opts =
info
(parseOptions <**> helper)
( fullDesc
<> progDesc "Manage a Nextcloud Deck"
<> header "ncdeck - Manage a Nextcloud Deck"

16
fourmolu.yaml Normal file
View File

@ -0,0 +1,16 @@
indentation: 2
column-limit: none
function-arrows: leading
comma-style: leading
import-export-style: leading
indent-wheres: true
record-brace-space: true
newline-between-decls: true
haddock-style: multi-line
haddock-style-module: null
let-style: newline
in-style: left-align
single-constraint-parens: always
single-deriving-parens: always
unicode: never
respectful: true

View File

@ -8,21 +8,23 @@ module NCDeck
, createCard
) where
import Prelude hiding (id)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Prelude hiding (id)
-- import Data.Time.Clock
import Data.Time.LocalTime
import Control.Monad
import Control.Monad.IO.Class
import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Time.LocalTime
import GHC.Generics
import Network.HTTP.Req
import Control.Monad
import Control.Monad.IO.Class
data Board = Board
{ id :: Int
@ -30,7 +32,8 @@ data Board = Board
, deletedAt :: POSIXTime
, lastModified :: POSIXTime
, archived :: Bool
} deriving Generic
}
deriving (Generic)
data Stack = Stack
{ id :: Int
@ -39,38 +42,58 @@ data Stack = Stack
, deletedAt :: POSIXTime
, lastModified :: POSIXTime
, cards :: Maybe [Card]
} deriving Generic
}
deriving (Generic)
data Card = Card
{ id :: Int
, title :: Text
, description :: Text
, duedate :: Maybe LocalTime
} deriving Generic
}
deriving (Generic)
instance FromJSON Board
instance Show Board where
show :: Board -> String
show (Board {..}) =
T.unpack title <> "\n" <>
"------------------------------------------------------\n" <>
"id:\t\t" <> show id <> "\n" <>
"last modified:\t" <> show lastModified <> "\n" <>
"deleted at:\t" <> show deletedAt <> "\n" <>
"archived: \t" <> show archived <> "\n"
T.unpack title
<> "\n"
<> "------------------------------------------------------\n"
<> "id:\t\t"
<> show id
<> "\n"
<> "last modified:\t"
<> show lastModified
<> "\n"
<> "deleted at:\t"
<> show deletedAt
<> "\n"
<> "archived: \t"
<> show archived
<> "\n"
instance FromJSON Stack
instance Show Stack where
show :: Stack -> String
show (Stack {..}) =
T.unpack title <> "\n" <>
"------------------------------------------------------\n" <>
"id:\t\t" <> show id <> "\n" <>
"last modified:\t" <> show lastModified <> "\n" <>
"deleted at:\t" <> show deletedAt <> "\n" <>
"#cards: \t" <> show (length cards) <> "\n"
T.unpack title
<> "\n"
<> "------------------------------------------------------\n"
<> "id:\t\t"
<> show id
<> "\n"
<> "last modified:\t"
<> show lastModified
<> "\n"
<> "deleted at:\t"
<> show deletedAt
<> "\n"
<> "#cards: \t"
<> show (length cards)
<> "\n"
instance FromJSON Card
@ -81,15 +104,23 @@ instance Show Card where
desc = T.unpack $ truncateDesc description
dd = maybe "None" show duedate
in
T.unpack title <> "\n" <>
"----------------------------------------------------\n" <>
"id:\t\t" <> show id <> "\n" <>
"description: \t" <> desc <> "\n" <>
"due date: \t" <> dd <> "\n"
T.unpack title
<> "\n"
<> "----------------------------------------------------\n"
<> "id:\t\t"
<> show id
<> "\n"
<> "description: \t"
<> desc
<> "\n"
<> "due date: \t"
<> dd
<> "\n"
where
truncateDesc :: Text -> Text
truncateDesc input =
let (fstLine, _) = T.break (== '\n') input
let
(fstLine, _) = T.break (== '\n') input
in
if T.length fstLine > 30
then T.take 30 fstLine <> "..."
@ -100,7 +131,8 @@ authHeaders username password =
let
usernameBS = T.encodeUtf8 username
passwordBS = T.encodeUtf8 password
in header "OCS-APIRequest" "true" <> basicAuth usernameBS passwordBS
in
header "OCS-APIRequest" "true" <> basicAuth usernameBS passwordBS
baseUrl :: Text -> Url Https
baseUrl hostname =
@ -111,7 +143,8 @@ listBoards hostname username password =
let
headers = authHeaders username password
url = baseUrl hostname /: "boards"
in runReq defaultHttpConfig $ do
in
runReq defaultHttpConfig $ do
response <- req GET url NoReqBody jsonResponse headers
return $ responseBody response
@ -120,7 +153,8 @@ listStacks hostname username password boardId =
let
headers = authHeaders username password
url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks"
in runReq defaultHttpConfig $ do
in
runReq defaultHttpConfig $ do
response <- req GET url NoReqBody jsonResponse headers
return $ responseBody response
@ -129,9 +163,11 @@ listCards hostname username password boardId stackId =
let
headers = authHeaders username password
url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks" /: T.pack (show stackId)
in runReq defaultHttpConfig $ do
in
runReq defaultHttpConfig $ do
response <- req GET url NoReqBody jsonResponse headers
let stack :: Stack = responseBody response
let
stack :: Stack = responseBody response
return $ fromMaybe [] stack.cards
createCard :: Text -> Text -> Text -> Word -> Word -> Text -> Text -> LocalTime -> Word -> IO ()
@ -143,10 +179,11 @@ createCard hostname username password boardId stackId title description date wee
(_, dayOfYear) = toOrdinalDate date.localDay
(year, month, day) = toGregorian date.localDay
expandedTitle =
T.replace "%YY" (T.pack $ show year) $
T.replace "%MM" (T.pack $ show month) $
T.replace "%DD" (T.pack $ show day) title
body = object
T.replace "%YY" (T.pack $ show year)
$ T.replace "%MM" (T.pack $ show month)
$ T.replace "%DD" (T.pack $ show day) title
body =
object
[ "title" .= expandedTitle
, "type" .= ("plain" :: Text)
, "order" .= dayOfYear