zettelkast (empty) → 0.1.0.0

raw patch · 12 files changed

+512/−0 lines, 12 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, lens, mtl, optparse-generic, pandoc, pandoc-types, pointed, process, text, time, transformers, zettelkast

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• app/Main.hs +111/−0
• src/Data/Path.hs +66/−0
• src/Data/Zettel.hs +25/−0
• src/Data/ZettelGraph.hs +66/−0
• src/Data/ZettelID.hs +76/−0
• src/Data/ZettelMeta.hs +32/−0
• src/Data/ZettelPath.hs +25/−0
• test/MyLibTest.hs +4/−0
• zettelkast.cabal +70/−0

@@ -0,0 +1,5 @@+# Revision history for zettelkast++## 0.1.0.0 -- 2020-06-11++* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright (c) 2020, Mats Rauhala++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Mats Rauhala nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+module Main where++import Options.Generic++import GHC.Generics+       (Generic)++import System.Process++import System.Environment++import qualified Data.Text.IO as T++import Data.Maybe+       (catMaybes, fromMaybe)++import Data.Path+import Data.Zettel+       (readZettel, zettels)+import Data.ZettelGraph+import Data.ZettelID+import Data.ZettelMeta+import Data.ZettelPath++import qualified Data.Set as Set++import Data.Foldable+       (for_, traverse_)+import Data.List+       (sortOn)+import Data.Traversable+       (for)++import Control.Lens+       (from, (^.))++import Control.Monad.Trans.Maybe+       (MaybeT(..), runMaybeT)++import Data.Time+       (getCurrentTime, utctDay)++import System.Directory+       (createDirectoryIfMissing, setCurrentDirectory)++data Commands+  = New+  | Graph+  | Open Text+  | List+  deriving (Show, Generic)++instance ParseRecord Commands++getEditor :: IO FilePath+getEditor = fromMaybe "vim" <$> lookupEnv "EDITOR"++getZettelBase :: IO (Path Root Dir)+getZettelBase = fromPosixPath <$> getEnv "ZETTEL_ROOT"++withZettelRoot :: (ZettelRoot -> IO a) -> IO a+withZettelRoot f = do+  zettelBase <- getZettelBase+  let path = ZettelRoot zettelBase+  createDirectoryIfMissing True (toPosixPath zettelBase)+  setCurrentDirectory (toPosixPath zettelBase)+  f path++createNew :: ZettelRoot -> IO ()+createNew base = do+  editor <- getEditor+  nextZettel <- createZettelID <$> (concatSet <$> zettels base) <*> (utctDay <$> getCurrentTime)+  for_ nextZettel $ \zid ->+    callProcess editor [toPosixPath ((base ^. from _ZettelRoot) ./ toPath zid)]+  where+    concatSet = Set.foldl' (\acc -> maybe acc (`Set.insert` acc)) Set.empty++open :: ZettelRoot -> Text -> IO ()+open base name = for_ (parse name) $ \zid -> do+  editor <- getEditor+  callProcess editor [toPosixPath ((base ^. from _ZettelRoot) ./ toPath zid)]++createGraph :: ZettelRoot -> IO ()+createGraph base = do+  contents <- dot <$> zettelLinks base+  T.putStrLn contents++list :: ZettelRoot -> IO ()+list base = do+  zs <- zettels @[] base+  meta <- for zs $ \mzid -> runMaybeT $ do+    zid <- MaybeT (pure mzid)+    zettel <- MaybeT (either (const Nothing) pure <$> readZettel base zid)+    MaybeT $ pure $ zettelMeta zid zettel+  traverse_ (T.putStrLn . format) . sortOn zettelID . catMaybes $ meta+  where+    format :: ZettelMeta -> Text+    format ZettelMeta{..} = render zettelID <> ":\t\t" <> title++main :: IO ()+main = withZettelRoot $ \base ->+  getRecord "zettelkast" >>= \case+    New -> createNew base+    Graph -> createGraph base+    Open name -> open base name+    List -> list base

@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-}+module Data.Path where+-- https://github.com/Gabriel439/Haskell-Turtle-Library/issues/54++import Control.Category+import Data.Text+       (Text)+import qualified Data.Text as T+import Prelude hiding+       (id, (.))++import Data.List (foldl')++import qualified System.FilePath.Posix as FilePath++data Root+data Dir+data File++data Path a b where+  Nil ::                            Path a a+  ConsRoot ::        Path a Root -> Path a Dir+  ConsDir ::  Text -> Path a Dir -> Path a Dir+  ConsFile :: Text -> Path a Dir -> Path a File++deriving instance Show (Path a b)++instance Category Path where+  id = Nil+  p1 . p2 =+    case p1 of+         Nil -> p2+         ConsRoot p1' -> ConsRoot (p1' . p2)+         ConsDir str p1' -> ConsDir str (p1' . p2)+         ConsFile str p1' -> ConsFile str (p1' . p2)++root :: Path Root Dir+root = ConsRoot Nil++dir :: Text -> Path Dir Dir+dir p = ConsDir p Nil++file :: Text -> Path Dir File+file p = ConsFile p Nil+++toPosixPath :: Path a b -> FilePath+toPosixPath = \case+  Nil -> mempty+  ConsRoot p -> "/" <> toPosixPath p+  ConsDir path p -> toPosixPath p FilePath.</> T.unpack path+  ConsFile path p -> toPosixPath p FilePath.</> T.unpack path++-- Not entirely happy with this. It only supports root paths+fromPosixPath :: FilePath -> Path Root Dir+fromPosixPath = foldl' go root . FilePath.splitDirectories+  where+    go :: Path Root Dir -> FilePath -> Path Root Dir+    go _ "/" = root+    go p path = dir (T.pack path) . p++(./) :: Path a b -> Path b c -> Path a c+(./) = (>>>)

@@ -0,0 +1,25 @@+module Data.Zettel where++import qualified Data.Text as T+import qualified Data.Text.IO as T++import System.Directory (listDirectory)++import Data.Path+import Data.ZettelID+import Data.ZettelPath++import Data.Pointed (Pointed, point)++import Text.Pandoc++zettels :: (Monoid (f (Maybe ZettelID)), Pointed f) => ZettelRoot -> IO (f (Maybe ZettelID))+zettels (ZettelRoot r) = do+  paths <- listDirectory (toPosixPath r)+  let files = map (\p -> r ./ file (T.pack p))  paths+  pure $ foldMap (point . fromPath) files++readZettel :: ZettelRoot -> ZettelID -> IO (Either PandocError Pandoc)+readZettel (ZettelRoot base) zid = do+  contents <- T.readFile (toPosixPath (base ./ toPath zid))+  runIO (readMarkdown def contents)

@@ -0,0 +1,66 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module Data.ZettelGraph where++import Data.Text+       (Text)+import qualified Data.Text as T++import Text.Pandoc+-- import Text.Pandoc.Readers.Markdown+import Text.Pandoc.Walk++import Data.Path+import Data.Zettel+import Data.ZettelID+import Data.ZettelMeta+import Data.ZettelPath++import Data.Maybe+       (catMaybes, fromMaybe)++import System.FilePath+       (takeFileName)++import System.Directory+       (listDirectory)++import Control.Lens+       (from, (^.))++zettelLinks :: ZettelRoot -> IO [(ZettelMeta, [ZettelID])]+zettelLinks base = do+  paths <- listDirectory (toPosixPath (base ^. from _ZettelRoot))+  catMaybes <$> traverse go paths+  where+    go :: FilePath -> IO (Maybe (ZettelMeta, [ZettelID]))+    go (fromPath . file . T.pack -> Just zid) = do+      zettel <- readZettel base zid+      pure $ either (const Nothing) (Just . internalLinks zid) zettel+    go _ = pure Nothing++extractLink :: Inline -> [ZettelID]+extractLink = \case+  Link _ _ (u, _) -> catMaybes [fromPath (path u)]+  _ -> []+  where+    path = file . T.pack . takeFileName++internalLinks :: ZettelID -> Pandoc -> (ZettelMeta, [ZettelID])+internalLinks f p = (fromMaybe unknown (zettelMeta f p), query extractLink p)+  where+    unknown = ZettelMeta f "No title"++dot :: [(ZettelMeta, [ZettelID])] -> Text+dot links = header <> nodes <> "\n" <> edges <> footer+  where+    nodes = T.unlines (map (\(f,_) -> node f) links)+    edges = T.unlines (concatMap (\(f,ts) -> map (edge (zettelID f)) ts) links)+    node :: ZettelMeta -> Text+    node ZettelMeta{..} = render zettelID <> " [label=\""<> title <>"\"];"+    edge :: ZettelID -> ZettelID -> Text+    edge f t = render f <> " -> " <> render t <> ";"+    header = "digraph g {\n"+    footer = "}"

@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Data.ZettelID where++import Text.Read+       (readMaybe)++import Data.Path++import Data.Text+       (Text)+import qualified Data.Text as T++import Text.Printf+       (printf)++import Data.Set+       (Set)+import qualified Data.Set as Set++import Data.Monoid+       (First(..))++import Data.Time+       (Day, defaultTimeLocale)+import Data.Time.Format+       (formatTime, parseTimeM)++-- | Uniquely identifying zettel+data ZettelID+  = ZettelID { day :: Day -- ^ The day when it was authored+             , counter :: Int -- ^ Increasing counter+             }+  deriving (Show, Eq, Ord)++-- | Render a zettel id as a text+--+-- The rendered id is "%y%m%d0000" where the latter number is the counter.+-- For example the second zettel for 11.6.2020 would be "2006110002"+render :: ZettelID -> Text+render ZettelID{..} = T.pack (dayFormat <> counterFormat)+  where+    dayFormat = formatTime defaultTimeLocale "%y%m%d" day+    counterFormat = printf "%03d" counter++-- | Parse the rendered zetteled id back into a 'ZettelID'+--+-- See 'render' for the format+parse :: Text -> Maybe ZettelID+parse path = ZettelID <$> dayParse path <*> counterParse path+  where+    dayParse = parseTimeM False defaultTimeLocale "%y%m%d" . T.unpack . T.take 6+    counterParse = readMaybe . T.unpack . T.drop 6 . T.takeWhile (/= '.')++-- | Convert a zettel id into a filename+toPath :: ZettelID -> Path Dir File+toPath zid = file (render zid <> ".md")++-- | Parse a filename into a zettel id+fromPath :: Path a File -> Maybe ZettelID+fromPath = \case+  ConsFile path _ -> parse (T.dropEnd 2 path)+  Nil -> Nothing++-- | Create a new unique zettel id+createZettelID :: Set ZettelID -> Day -> Maybe ZettelID+createZettelID history today = getFirst (foldMap firstFree zettelIDs)+  where+    firstFree :: ZettelID -> First ZettelID+    firstFree zid | zid `Set.member` history = First Nothing+                  | otherwise = First (Just zid)+    zettelIDs :: [ZettelID]+    zettelIDs = ZettelID today <$> [0..]

@@ -0,0 +1,32 @@+{-# LANGUAGE LambdaCase #-}+module Data.ZettelMeta where++import Text.Pandoc+import Text.Pandoc.Walk++import Data.Text+       (Text)+import qualified Data.Text as T++import Data.Maybe+       (listToMaybe)++import Data.ZettelID++data ZettelMeta+  = ZettelMeta { zettelID :: ZettelID+               , title :: Text+               }+  deriving Show++extractTitle :: Block -> [Text]+extractTitle = \case+  Header 1 _attr inlines -> [T.unwords (query strings inlines)]+  _ -> []+  where+    strings = \case+      Str x -> [T.pack x]+      _ -> []++zettelMeta :: ZettelID -> Pandoc -> Maybe ZettelMeta+zettelMeta zid p = ZettelMeta zid <$> listToMaybe (query extractTitle p)

@@ -0,0 +1,25 @@+module Data.ZettelPath where++import Data.Path++import Control.Lens+       (Iso', Lens', iso, lens, set, view)++newtype ZettelRoot = ZettelRoot (Path Root Dir)++_ZettelRoot :: Iso' (Path Root Dir) ZettelRoot+_ZettelRoot = iso ZettelRoot (\(ZettelRoot r) -> r)++class HasZettelRoot a where+  {-# MINIMAL getZettelRoot, setZettelRoot | zettelRoot #-}+  getZettelRoot :: a -> ZettelRoot+  getZettelRoot = view zettelRoot++  setZettelRoot :: a -> ZettelRoot -> a+  setZettelRoot = flip (set zettelRoot)++  zettelRoot :: Lens' a ZettelRoot+  zettelRoot = lens getZettelRoot setZettelRoot++instance HasZettelRoot ZettelRoot where+  zettelRoot = lens id (\_ b -> b)

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."

@@ -0,0 +1,70 @@+cabal-version:       2.4++name:                zettelkast+version:             0.1.0.0+synopsis: Command-line utility for working with zettelkast files+description:+  Command-line tool for managing zettelkast documents. The tool primarily focuses+  on providing unique ids and showing a graph of document connections. It tries+  to be as unintrusive as possible.+-- bug-reports:+license:             BSD-3-Clause+license-file:        LICENSE+author:              Mats Rauhala+maintainer:          mats.rauhala@iki.fi+-- copyright:+category:            Text+extra-source-files:  CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/MasseR/zettelkast++library+  exposed-modules:     Data.ZettelID+                       Data.ZettelPath+                       Data.ZettelMeta+                       Data.Zettel+                       Data.Path+                       Data.ZettelGraph+  -- other-modules:+  -- other-extensions:+  build-depends:       base ^>=4.12.0.0+                     , containers >= 0.6.0 && < 0.7+                     , directory >= 1.3.3 && < 1.4+                     , filepath >= 1.4.2 && < 1.5+                     , lens >= 4.17 && < 4.18+                     , mtl  >= 2.2.2 && < 2.3+                     , pandoc >= 2.7.1 && < 2.8+                     , pandoc-types >= 1.17.5 && < 1.18+                     , pointed >= 5.0.1 && < 5.1+                     , process >= 1.6.5 && < 1.7+                     , text >= 1.2.3 && < 1.3+                     , time >= 1.8.0 && < 1.9+  hs-source-dirs:      src+  default-language:    Haskell2010++executable zettelkast+  main-is:             Main.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base ^>=4.12.0.0+                     , zettelkast+                     , containers >= 0.6.0 && < 0.7+                     , directory >= 1.3.3 && < 1.4+                     , lens >= 4.17 && < 4.18+                     , optparse-generic >= 1.3.0 && < 1.4+                     , process >= 1.6.5 && < 1.7+                     , text >= 1.2.3 && < 1.3+                     , time >= 1.8.0 && < 1.9+                     , transformers >= 0.5.6 && < 0.6+  hs-source-dirs:      app+  default-language:    Haskell2010+  ghc-options:       -threaded++test-suite zettelkast-test+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             MyLibTest.hs+  build-depends:       base ^>=4.12.0.0