t wip
Some checks failed
Nix build / nix-build (nixosConfigurations.apollo.config.system.build.toplevel) (push) Failing after 6m0s
Nix build / nix-build (nixosConfigurations.athene.config.system.build.toplevel) (push) Failing after 44s
Nix build / nix-build (nixosConfigurations.hephaistos.config.system.build.toplevel) (push) Failing after 1m0s
Nix build / nix-build (nixosConfigurations.hera.config.system.build.toplevel) (push) Failing after 42s
Nix build / nix-build (nixosConfigurations.zeus.config.system.build.toplevel) (push) Failing after 1m0s
Nix build / nix-flake-check (push) Successful in 1m6s

This commit is contained in:
maralorn 2023-11-01 23:27:45 +01:00
parent f69b51f89e
commit 88e3e0df2a
No known key found for this signature in database
6 changed files with 213 additions and 46 deletions

View file

@ -1,5 +1,6 @@
{ mkDerivation, base, directory, filepath, lens, lib, megaparsec
, relude, time, unix
{ mkDerivation, base, directory, filepath, generic-lens, lens, lib
, megaparsec, mtl, streamly, streamly-core, string-interpolate
, text, time, unix, witch
}:
mkDerivation {
pname = "t";
@ -7,11 +8,14 @@ mkDerivation {
src = ./.;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [ base ];
executableHaskellDepends = [
base directory filepath lens megaparsec relude time unix
libraryHaskellDepends = [
base generic-lens lens mtl streamly streamly-core
string-interpolate text time witch
];
executableHaskellDepends = [
base directory filepath megaparsec streamly streamly-core text time
unix
];
doHaddock = false;
license = lib.licenses.agpl3Plus;
mainProgram = "t";
}

View file

@ -1,24 +1,29 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main (main) where
import Control.Lens (Prism', each, folded, itoList, makeFieldsNoPrefix, preview, to, view, (%=), (%~), (.~), (^.), (^..), (^?), _1, _Just, _Right)
import Data.Foldable qualified as Foldable
import Data.List qualified as List
import Data.Text qualified as Text
import Data.Time qualified as Time
import Relude
import Maralude
import Streamly.Data.Fold qualified as Fold
import Streamly.Data.Stream qualified as Stream
import Streamly.Data.StreamK qualified as StreamK
import Streamly.Internal.Data.Stream.StreamD qualified as Stream
import System.Directory qualified as Dir
import System.FilePath ((</>))
import System.Posix (getEnv)
import Text.Megaparsec qualified as P
import Text.Megaparsec.Char qualified as P
import Prelude ()
data TaskStatus = ToDo | Done | Deleted | Category | Maybe deriving (Show, Eq)
@ -32,8 +37,6 @@ data Task = MkTask
_path :: [Text]
}
makeFieldsNoPrefix ''Task
data ParseState = MkParseState
{ _file :: [Text]
, _section :: [Text]
@ -41,62 +44,73 @@ data ParseState = MkParseState
-- ^ Incremental Indentation and name of Task
}
makeFieldsNoPrefix ''ParseState
main :: IO ()
main = do
now <- Time.getCurrentTime
getArgs >>= \case
[] -> showTasks active
["unsorted"] -> showTasks (pall [active, pany [inbox, outdated now]])
["inbox"] -> showTasks (pall [null . (view tags), active])
["unsorted"] -> showTasks (all [active, any [inbox, outdated now]])
["inbox"] -> showTasks (all [hasn't (#tags . folded), active])
_ -> putTextLn "Unknown command"
active :: Task -> Bool
active = (== ToDo) . view status
active = has (#status . #_ToDo)
inbox :: Task -> Bool
inbox = elem "Inbox" . view path
inbox = has (#path . ix "Inbox")
outdated :: Time.UTCTime -> Task -> Bool
outdated now t = (t ^? (path . folded . to parseDate . _Just)) & maybe False (< now.utctDay)
outdated now t = (t ^? (#path . folded . to parseDate . _Just)) & maybe False (< now.utctDay)
pall :: [(a -> Bool)] -> a -> Bool
pall preds = \x -> all ($ x) preds
all :: [(a -> Bool)] -> a -> Bool
all preds = \x -> List.all ($ x) preds
pany :: [(a -> Bool)] -> a -> Bool
pany preds = \x -> any ($ x) preds
any :: [(a -> Bool)] -> a -> Bool
any preds = \x -> List.any ($ x) preds
showTasks :: (Task -> Bool) -> IO ()
showTasks pre = getTasks >>= printTree . filter pre
showTasks pre =
getTasks
& Stream.filter pre
% printTree
printList :: [Task] -> IO ()
printList = (mapM_ \t -> putTextLn $ printStatus (t ^. status) <> " " <> t ^. description <> " " <> Text.intercalate "." (t ^. path) <> " " <> Text.unwords (t ^. tags))
printList :: Stream IO Task -> IO ()
printList =
mapM_
(\t -> putTextLn [i|#{printStatus (t ^. #status)} #{t ^. #description} #{Text.intercalate "." (t ^. #path)} #{t ^. (#tags . from worded)}|])
printTree :: [Task] -> IO ()
printTree = (mapM_ (uncurry printRow)) . (\t -> zip t ([] : ((^. path) <$> t))) . sortOn (^. path)
printTree :: Stream IO Task -> IO ()
printTree tasks =
Stream.zipWith printRow sorted (Stream.cons [] ((^. #path) <$> sorted))
& sequence_
where
sorted :: Stream IO Task
sorted = tasks & Stream.toStreamK & StreamK.sortBy (compare `on` (^. #path)) & Stream.fromStreamK
printRow :: Task -> [Text] -> IO ()
printRow = \cases
task prepath -> putTextLn $ ((each .~ ' ') (Text.intercalate " " prefix) <> connection <> Text.intercalate "." own) <-> (" " <> printStatus (task ^. status) <-> (task ^. description) <-> Text.unwords (task ^. tags))
task prepath -> putTextLn $ ((each .~ ' ') (Text.intercalate " " prefix) <> connection <> Text.intercalate "." own) <-> (" " <> printStatus (task ^. #status) <-> (task ^. #description) <-> Text.unwords (task ^. #tags))
where
(prefix, own) = splitSharedPrefix prepath (task ^. path)
(prefix, own) = splitSharedPrefix prepath (task ^. #path)
connection :: Text
connection
| null prefix || null own = ""
| hasn't folded prefix || hasn't folded own = ""
| otherwise = "."
(<->) :: Text -> Text -> Text
"" <-> b = b
a <-> "" = a
a <-> b | Text.isPrefixOf " " b || Text.isSuffixOf " " a = a <> b
a <-> b = a <> " " <> b
-- >>> splitSharedPrefix "Foo" "Foobar"
splitSharedPrefix :: (Eq a) => [a] -> [a] -> ([a], [a])
splitSharedPrefix = \cases
(a : as) (x : xs) | a == x -> splitSharedPrefix as xs & _1 %~ (x :)
_ xs -> ([], xs)
parseDate :: Text -> Maybe Time.Day
parseDate = Time.parseTimeM True Time.defaultTimeLocale "%Y-%m-%d" . toString
parseDate = Time.parseTimeM True Time.defaultTimeLocale "%Y-%m-%d" . view to'
printStatus :: TaskStatus -> Text
printStatus = \case
ToDo -> "o"
Done -> "x"
@ -104,14 +118,14 @@ printStatus = \case
Category -> "*"
Maybe -> "?"
getTasks :: IO [Task]
getTasks :: Stream IO Task
getTasks = do
home <- Dir.getHomeDirectory
let dir = (home <> "/git/notes")
paths <- getFilePaths dir
paths & fmap concat . mapM (\name -> parseFile (toText . drop (length dir + 1) $ name) . decodeUtf8 <$> readFileBS name)
getFilePaths :: FilePath -> IO [FilePath]
getFilePaths :: String -> IO [String]
getFilePaths dir =
Dir.listDirectory dir
>>= fmap concat
@ -176,4 +190,6 @@ parseFile name file =
(\(i, line) -> P.runParserT parseLine (toString name <> " line: " <> show i) line)
)
(MkParseState (Text.splitOn "/" name) [] [])
^.. folded . _Right . _Just
^.. folded
. _Right
. _Just

2
packages/t/hie.yaml Normal file
View file

@ -0,0 +1,2 @@
cradle:
cabal: {}

137
packages/t/lib/Maralude.hs Normal file
View file

@ -0,0 +1,137 @@
module Maralude (
Eq,
Show,
Maybe,
Text,
Bool (False, True),
IO,
String,
Identity,
State,
MonadIO,
Stream,
liftIO,
to,
view,
fmap,
Functor,
Monad,
Applicative,
(>>),
(>>=),
(=<<),
(.),
(==),
_Just,
_Nothing,
_Right,
_Left,
maybe,
(&),
(^?),
(^.),
(^..),
(<),
(<=),
(>),
(>=),
(<>),
($),
(<$>),
id,
Contravariant,
Iso',
Prism',
in',
to',
ix,
hasn't,
has,
folded,
from,
into,
getArgs,
putTextLn,
pure,
worded,
lined,
flip,
(%),
i,
mapM_,
mapM,
compare,
sequence_,
each,
(.~),
(||),
(&&),
(%~),
_1,
_2,
_3,
otherwise,
on,
)
where
import Control.Applicative (Applicative, pure)
import Control.Lens (Contravariant, Iso', LensLike', Prism', each, folded, from, has, hasn't, iso, ix, preview, prism', to, view, (%~), (.~), (^.), (^..), (^?), _1, _2, _3, _Just, _Left, _Nothing, _Right)
import Control.Monad (Monad, (=<<), (>>), (>>=))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Strict (State)
import Data.Bool (Bool (False, True), otherwise, (&&), (||))
import Data.Either (Either)
import Data.Eq (Eq, (==))
import Data.Function (flip, id, on, ($), (&), (.))
import Data.Functor (Functor, fmap, (<$>))
import Data.Functor.Identity (Identity)
import Data.Maybe (Maybe, maybe)
import Data.Ord (compare, (<), (<=), (>), (>=))
import Data.Semigroup ((<>))
import Data.String (String)
import Data.String.Interpolate (i)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Streamly.Data.Fold qualified as Fold
import Streamly.Data.Stream (mapM)
import Streamly.Data.Stream qualified as Stream
import Streamly.Data.Stream.Prelude (Stream)
import Streamly.Internal.Data.Stream.StreamD.Eliminate (mapM_)
import System.Environment qualified as Env
import System.IO (IO)
import Text.Show (Show)
import Witch qualified
worded :: Iso' Text [Text]
worded = iso Text.words Text.unwords
lined :: Iso' Text [Text]
lined = iso Text.lines Text.unlines
putTextLn :: (MonadIO m) => Text -> m ()
putTextLn = liftIO . Text.putStrLn
{-# SPECIALIZE putTextLn :: Text -> IO () #-}
{-# INLINE putTextLn #-}
getArgs :: (MonadIO m) => m [Text]
getArgs = fmap (view to') <$> liftIO Env.getArgs
into :: forall target source f. (Witch.From target source, Contravariant f) => LensLike' f target source
into = to (Witch.from)
to' :: forall a b. (Witch.From a b, Witch.From b a) => Iso' a b
to' = iso Witch.into Witch.into
hush :: Either b a -> Maybe a
hush = preview folded
in' :: forall source target. (Witch.TryFrom source target, Witch.From target source) => Prism' source target
in' = prism' Witch.into (hush . Witch.tryInto)
sequence_ :: (Monad m) => Stream m (m a) -> m ()
sequence_ = Stream.sequence % Stream.fold Fold.drain
(%) :: (a -> b) -> (b -> c) -> (a -> c)
(%) = flip (.)

View file

@ -1,4 +0,0 @@
module MyLib (someFunc) where
someFunc :: IO ()
someFunc = putStrLn "someFunc"

View file

@ -57,7 +57,7 @@ library
import: common
-- Modules exported by the library.
exposed-modules:
exposed-modules: Maralude
-- Modules included in this library but not exported.
-- other-modules:
@ -66,7 +66,17 @@ library
-- other-extensions:
-- Other library packages from which modules are imported.
build-depends: base ^>=4.17.2.0
build-depends:
, base ^>=4.17.2.0
, generic-lens
, lens
, mtl
, streamly
, streamly-core
, string-interpolate
, text
, time
, witch
-- Directories containing source files.
hs-source-dirs: lib
@ -89,12 +99,14 @@ executable t
-- Other library packages from which modules are imported.
build-depends:
, base ^>=4.17.2.0
, base ^>=4.17.2.0
, directory
, filepath
, lens
, megaparsec
, relude
, streamly
, streamly-core
, t
, text
, time
, unix