Add initial implementation of Dot graph

5 files changed, 63 insertions, 67 deletions

diff --git a/.envrc b/.envrc
index c9c0b69..1d953f4 100644
--- a/.envrc
+++ b/.envrc
@@ -1,8 +1 @@
-if type lorri &>/dev/null; then
-    echo "direnv: using lorri"
-    eval "$(lorri direnv)"
-else
-    # fall back to using direnv's builtin nix support
-    # to prevent bootstrapping problems.
-    use nix
-fi
+use nix
diff --git a/README.md b/README.md
index 34523f6..fe5cfcd 100644
--- a/README.md
+++ b/README.md
@@ -1,26 +1 @@
-# org-zk
-
-Haskell project template optimized for a fully reproducible and friendly development environment. Based on [Nix](https://notes.srid.ca/haskell-nix) + [Flakes](https://serokell.io/blog/practical-nix-flakes) + VSCode ([HLS](https://github.com/haskell/haskell-language-server)) + [ormolu](https://github.com/tweag/ormolu) autoformatting + [Relude](https://github.com/kowainik/relude#relude) as Prelude.
-
-## Getting Started
-
-- [Install Nix](https://nixos.org/download.html) & [enable Flakes](https://nixos.wiki/wiki/Flakes)
-- Run `nix-shell --run haskell-language-server` to sanity check your environment 
-- [Open as single-folder workspace](https://code.visualstudio.com/docs/editor/workspaces#_singlefolder-workspaces) in Visual Studio Code
-    - Install the [workspace recommended](https://code.visualstudio.com/docs/editor/extension-marketplace#_workspace-recommended-extensions) extensions
-    - <kbd>Ctrl+Shift+P</kbd> to run command "Nix-Env: Select Environment" and select `shell.nix`. The extension will ask you to reload VSCode at the end.
-- Press <kbd>Ctrl+Shift+B</kbd> in VSCode, or run `bin/run` (`bin/run-via-tmux` if you have tmux installed) in terminal, to launch Ghcid running your program.
-
-All but the final step need to be done only once.
-
-Then, before using it for real,
-
-- Rename all occurrences of `org-zk` to `myproject`, as well as rename the cabal file to `myproject.cabal`. 
-- Run `git add . && git commit -m rename` followed by `nix develop` (or `bin/run`) to verify that everything continues to work.
-
-## Other templates
-
-Some related templates include,
-
-- [Serokell's Flake template](https://github.com/serokell/templates/tree/master/haskell-cabal2nix)
-  - [Same, but using haskell.nix](https://github.com/serokell/templates/pull/2)
+# Org zettelkasten
diff --git a/flake.nix b/flake.nix
index 32b480d..4c1d5a6 100644
--- a/flake.nix
+++ b/flake.nix
@@ -33,6 +33,8 @@
                 haskell-language-server
                 ormolu
                 pkgs.nixpkgs-fmt
+                pkgs.zlib.dev
+                pkgs.zlib
               ]);
           };
       in
diff --git a/org-zk.cabal b/org-zk.cabal
index 6ef80cf..d1c7d3e 100644
--- a/org-zk.cabal
+++ b/org-zk.cabal
@@ -2,9 +2,9 @@ cabal-version:      2.4
 name:               org-zk
 version:            0.1.0.0
 license:            AGPL-3.0-only
-copyright:          2021 Sridhar Ratnakumar
-maintainer:         srid@srid.ca
-author:             Sridhar Ratnakumar
+copyright:          2021 Yann Herklotz
+maintainer:         yann@ymhg.org
+author:             Yann Herklotz
 category:           Web
 
 -- TODO: Before hackage release.
@@ -23,26 +23,12 @@ extra-source-files:
 
 executable org-zk
   build-depends:
-    , aeson
-    , async
-    , base
-    , bytestring
-    , containers
+      base
     , data-default
-    , directory
-    , filepath
-    , lens
-    , megaparsec
-    , monad-logger
-    , mtl
-    , neat-interpolation
-    , profunctors
+    , pandoc
+    , pandoc-types
     , relude
-    , shower
-    , tagged
     , text
-    , time
-    , unliftio
     , with-utf8
 
   mixins:
@@ -54,16 +40,8 @@ executable org-zk
     -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns
 
   default-extensions:
-    FlexibleContexts
-    FlexibleInstances
-    KindSignatures
     LambdaCase
-    MultiParamTypeClasses
-    MultiWayIf
     OverloadedStrings
-    ScopedTypeVariables
-    TupleSections
-    ViewPatterns
 
   main-is:            Main.hs
   hs-source-dirs:     src
diff --git a/src/Main.hs b/src/Main.hs
index 1490acd..91fa612 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,10 +1,58 @@
-{-# LANGUAGE TypeApplications #-}
-
 module Main where
 
 import Main.Utf8 (withUtf8)
 
+import Text.Pandoc.Readers (readOrg)
+import Text.Pandoc.Walk (walkM)
+import Text.Pandoc.Definition (Block(..), Inline(..))
+import Text.Pandoc.Shared (stringify)
+import Data.Default (def)
+import Text.Pandoc.Class (runIOorExplode)
+import qualified Relude.Extra.Map as Map
+import qualified Data.Text as T
+import Data.Char (isAlphaNum)
+
+data HeaderState = HeaderState { headerStateMap :: Map Text (Text, [Text])
+                               , headerStateCurrent :: Text
+                               }
+
+isLink :: Inline -> Bool
+isLink Link{} = True
+isLink _ = False
+
+parseIds :: Text -> Text
+parseIds t
+  | T.null t = ""
+  | T.head t == '#' && T.all isAlphaNum (T.tail t) = T.tail t
+  | otherwise = ""
+
+getHeaders :: Block -> State HeaderState Block
+getHeaders h@(Header _ (a, _, _) t) = do
+  s <- get
+  let m' = Map.insert (stringify t) (a, []) (headerStateMap s)
+  put (HeaderState m' (stringify t))
+  return h
+getHeaders p@(Para i) = do
+  let f = filter isLink i
+  s <- get
+  let m' = Map.insertWith (\(_, x) (w, y) -> (w, x <> y))
+             (headerStateCurrent s)
+             ("", filter (not . T.null) (parseIds . stringify <$> f))
+             (headerStateMap s)
+  put (HeaderState m' (headerStateCurrent s))
+  return p
+getHeaders a = return a
+
+toDot :: (Text, [Text]) -> Text
+toDot (t, []) = "\"" <> t <> "\"" <> ";\n"
+toDot (t, l) = foldMap (\l' -> "\"" <> t <> "\"" <> " -> " <> "\"" <> l' <> "\"" <> ";\n") l
+
 main :: IO ()
-main = do
-  withUtf8 $ do
-    putStrLn . concat $ permutations "Hello World!"
+main = withUtf8 $ do
+  f <- readFileText "random.org"
+  x <- runIOorExplode (readOrg def ("#+options: H:15\n" <> f))
+  let (_, s) = runState (walkM getHeaders x) (HeaderState mempty "toplevel")
+  putTextLn "digraph G {\n"
+  putTextLn $ fold (toDot <$> toList (headerStateMap s))
+  putTextLn "}\n"
+  return ()