path: root/src/Main.hs

{-# LANGUAGE OverloadedRecordDot #-}

-- |
-- Module      : Main
-- Description : Command-line interface for org-zk
-- Copyright   : (c) 2023, Yann Herklotz
-- License     : GPL-3.0-only
-- Maintainer  : git [at] yannherklotz [dot] com
-- Stability   : experimental
-- Portability : POSIX
module Main where

-- import Data.Char (isAlphaNum, isLetter, isNumber)
-- import Data.Default (def)
-- import Data.List (nub)
-- import qualified Data.Text as T
-- import Data.Text.Read (decimal)
-- import Numeric (readInt, showIntAtBase)
-- import qualified Relude.Extra.Map as Map
-- import Text.Pandoc.Class (runIOorExplode)
-- import Text.Pandoc.Definition (Block (..), Inline (..), Pandoc(..), MetaValue(..), Meta(..))
-- import Text.Pandoc.Readers (readOrg)
-- import Text.Pandoc.Templates (compileTemplate, WithDefaultPartials(..), Template(..))
-- import Text.Pandoc.Writers (writeChunkedHTML, writeMarkdown)
-- import Text.Pandoc.Options (WriterOptions(..))
-- import Text.Pandoc.Chunks (splitIntoChunks, PathTemplate(..), ChunkedDoc(..), Chunk(..), toTOCTree, tocToList)
-- import Text.Pandoc.Shared (stringify)
-- import Text.Pandoc.Walk (walkM, walk)
-- import qualified Data.ByteString.Lazy as B
-- import System.Directory (createDirectoryIfMissing)

import Control.Exception (ioError)
import Control.Logging
import Data.Map.Strict (intersection)
import qualified Data.Text as T
import Data.Version (showVersion)
import Paths_org_zk (version)
import System.Console.GetOpt
import System.IO.Error (userError)
import Zettel

-- data HeaderState = HeaderState
--  { headerStateMap :: Map Text ((ZettelId, 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 = ""
--
-- addLinks :: [Inline] -> Block -> State HeaderState Block
-- addLinks il b = do
--  let f = filter isLink il
--  s <- get
--  let m' =
--        Map.insertWith
--          (\(_, y) (z, x) -> (z, x <> y))
--          (headerStateCurrent s)
--          ((mempty, mempty), filter (not . T.null) (parseIds . stringify <$> f))
--          (headerStateMap s)
--  put (HeaderState m' (headerStateCurrent s))
--  return b
--
-- getHeaders :: Block -> State HeaderState Block
-- getHeaders h@(Header _ (a, _, _) t) = do
--  s <- get
--  let m' = Map.insert a ((ZettelId a, stringify t), []) (headerStateMap s)
--  put (HeaderState m' a)
--  return h
-- getHeaders p@(Plain i) = addLinks i p
-- getHeaders p@(Para i) = addLinks i p
-- getHeaders p@(LineBlock i) = addLinks (concat i) p
-- getHeaders p = addLinks [] p
--
-- splitId :: ZettelId -> [Text]
-- splitId (ZettelId zid)
--  | T.null zid = []
--  | isNumber (T.head zid) = T.takeWhile isNumber zid : (splitId . ZettelId $ T.dropWhile isNumber zid)
--  | isLetter (T.head zid) = T.takeWhile isLetter zid : (splitId . ZettelId $ T.dropWhile isLetter zid)
--  | otherwise = []
--
-- combineId :: [Text] -> ZettelId
-- combineId = ZettelId . fold
--
-- intToDigit26 :: Int -> Char
-- intToDigit26 i
--  | i <= 25 && i >= 0 = toEnum $ fromEnum 'a' + i
--  | otherwise = error "Integer out of range."
--
-- digitToInt26 :: Char -> Int
-- digitToInt26 c = fromEnum c - fromEnum 'a'
--
-- fromBase :: Int -> String -> Maybe Int
-- fromBase base = fmap fst . viaNonEmpty head . readInt base ((< base) . digitToInt26) digitToInt26
--
-- toBase :: Int -> Int -> String
-- toBase base num = showIntAtBase base intToDigit26 num ""
--
-- opOnBase26 :: (Int -> Int) -> Text -> Maybe Text
-- opOnBase26 f t =
--  fromString . toBase 26 . f <$> fromBase 26 (toString t)
--
-- opOnIdPart :: (Int -> Int) -> Text -> Maybe Text
-- opOnIdPart f t
--  | T.null t = Nothing
--  | isNumber $ T.head t =
--      case decimal t of
--        Right (a, _) -> Just . show $ f a
--        _ -> Nothing
--  | isLetter $ T.head t = opOnBase26 f t
--  | otherwise = Nothing
--
-- defPredId :: ZettelId -> Maybe ZettelId
-- defPredId z =
--  case nonEmpty (splitId z) of
--    Just ne ->
--      if last ne == "a" || last ne == "1"
--        then Just (combineId (init ne))
--        else combineId . (init ne <>) . (: []) <$> opOnIdPart (subtract 1) (last ne)
--    Nothing -> Nothing
--
-- quoted :: Text -> Text
-- quoted t = "\"" <> t <> "\""
--
-- toDot :: [Text] -> (Text, [Text]) -> Text
-- toDot _ (t, l) = foldMap (\l' -> quoted l' <> " -> " <> quoted t <> ";\n") l
--
-- toDotNodes :: ZettelId -> Text
-- toDotNodes (ZettelId t)
--  | T.null t = ""
--  | isNumber $ T.head t = quoted t <> " [color=" <> T.singleton (T.head t) <> "];\n"
--  | otherwise = ""
--
-- addSelfLinks :: Map Text ((ZettelId, Text), [Text]) -> ZettelId -> Map Text ((ZettelId, Text), [Text])
-- addSelfLinks m z =
--  Map.insertWith (\((_, _), l') ((z', t), l) -> ((z', t), l ++ l')) (unZettelId z) ((mempty, mempty), [unZettelId z]) m
--
-- addSelfLinks2 :: ((ZettelId, b), [Text]) -> ((ZettelId, b), [Text])
-- addSelfLinks2 ((t, b), l) =
--  ((t, b), maybeToList (unZettelId <$> defPredId t) <> l)
--
-- decode :: ByteString -> Text
-- decode = decodeUtf8
--
-- normaliseHeadings :: Int -> Block -> Block
-- normaliseHeadings i (Header _ a b) = Header i a b
-- normaliseHeadings _ a = a
--
-- subtractHeadings :: Int -> Block -> Block
-- subtractHeadings i (Header current a b) = Header (current - i) a b
-- subtractHeadings _ a = a
--
-- removeHeadings :: Block -> Block
-- removeHeadings (Header _ _ _) = Plain []
-- removeHeadings a = a
--
-- mkLongPath :: ZettelId -> Text
-- mkLongPath i = fold . intersperse "/" $ splitId i
--
-- splitZettel :: Chunk -> Pandoc
-- splitZettel c =
--  walk removeHeadings
--    (Pandoc
--      (Meta
--        (fromList [("title", MetaInlines $ chunkHeading c)]))
--      (chunkContents c))
--
-- template :: Text
-- template = unlines ["+++",
--                    "title = \"$title$\"",
--                    "$if(date)$",
--                    "date = \"$date$\"",
--                    "$endif$",
--                    "+++",
--                    "",
--                    "$body$"]
--
-- main :: IO ()
-- main = do
--  let fl =
--        [ "/Users/ymherklotz/Dropbox/zk/verification.org",
--          "/Users/ymherklotz/Dropbox/zk/mathematics.org",
--          "/Users/ymherklotz/Dropbox/zk/hls.org",
--          "/Users/ymherklotz/Dropbox/zk/computing.org",
--          "/Users/ymherklotz/Dropbox/zk/hardware.org"
--        ]
--  fs <- mapM readFileBS fl
--  x <- mapM (runIOorExplode . readOrg def . decode) fs
--  let (_, s) = runState (forM x (walkM getHeaders)) (HeaderState mempty "toplevel")
--  let allZettel = second nub . addSelfLinks2 <$> headerStateMap s
--  writeFileText "out.dot" $
--    "digraph G {\noverlap=false;\nnode [colorscheme=pastel28,style=filled];\n"
--      <> foldMap (toDotNodes . fst . fst) allZettel
--      <> foldMap
--        ( toDot (foldMap snd allZettel)
--            . (\((ZettelId a, _), b) -> (a, b))
--        )
--        allZettel
--      <> "}\n"
--
--  let Just(firstDoc) = viaNonEmpty head x
----  print firstDoc
--  let res = splitIntoChunks "%i.md" False Nothing 15 firstDoc
--  Right templ <- runIOorExplode . runWithDefaultPartials $ compileTemplate "" template
--  forM_ (chunkedChunks res) $ \c -> do
--    print (chunkContents c)
--    let toc = case Map.lookup (chunkId c) allZettel of
--          Just toLinks ->
--            [BulletList (map (\x -> [Para [Link mempty [Str ("#" <> x)] ("/" <> x, mempty)]]) (snd toLinks))]
--          Nothing -> []
--    text <- runIOorExplode $ writeMarkdown (def { writerTemplate = Just templ }) (splitZettel c)
--    writeFileText ("test/content/" <> chunkPath c) text
--

data Options = Options
  { -- | Bibliography FILE (default: references.bib)
    optBibliography :: Maybe FilePath,
    -- | Bibliography FILE (default: bibliography.org)
    optOrgBibliography :: Maybe FilePath,
    -- | Csl FILE
    optCsl :: Maybe FilePath,
    -- | Index FILE (default: org-zettelkasten-index)
    optIndexFile :: Maybe FilePath,
    -- | Only process these indices
    optIndex :: [ZettelId],
    -- | output DIR
    optOutput :: Maybe FilePath,
    -- | Verbose output while processing files
    optVerbose :: Int,
    -- | Suppress all output
    optQuiet :: Bool,
    -- | Show current version
    optShowVersion :: Bool,
    -- | Show this help menu
    optShowHelp :: Bool
  }
  deriving (Show, Eq)

defaultOptions :: Options
defaultOptions =
  Options
    { optBibliography = Nothing,
      optOrgBibliography = Nothing,
      optCsl = Nothing,
      optIndexFile = Nothing,
      optIndex = [],
      optOutput = Nothing,
      optVerbose = 0,
      optQuiet = False,
      optShowVersion = False,
      optShowHelp = False
    }

parseIdList :: Text -> [ZettelId]
parseIdList = fmap ZettelId . T.splitOn ","

options :: [OptDescr (Options -> Options)]
options =
  [ Option
      ['b']
      ["bibliography"]
      (ReqArg (\f opts -> opts {optBibliography = Just f}) "FILE")
      "Bibliography FILE (default: references.bib)",
    Option
      ['c']
      ["csl"]
      (ReqArg (\f opts -> opts {optCsl = Just f}) "FILE")
      "Csl FILE",
    Option
      ['f']
      ["index-file"]
      (ReqArg (\f opts -> opts {optIndexFile = Just f}) "FILE")
      "Index FILE (default: org-zettelkasten-index)",
    Option
      ['h']
      ["help"]
      (NoArg (\opts -> opts {optShowHelp = True}))
      "Show this help menu",
    Option
      ['i']
      ["id"]
      ( ReqArg
          (\f opts -> opts {optIndex = opts.optIndex ++ parseIdList (T.pack f)})
          "ID"
      )
      "Only process these IDs",
    Option
      ['o']
      ["output"]
      (ReqArg (\f opts -> opts {optOutput = Just f}) "DIR")
      "output DIR",
    Option
      []
      ["org-bibliography"]
      (ReqArg (\f opts -> opts {optOrgBibliography = Just f}) "FILE")
      "Bibliography FILE (default: bibliography.org)",
    Option
      ['q']
      ["quiet"]
      (NoArg (\opts -> opts {optQuiet = True}))
      "Suppress all output",
    Option
      ['v']
      ["verbose"]
      (NoArg (\opts -> opts {optVerbose = optVerbose opts + 1}))
      "Verbose output while processing files",
    Option
      ['V', '?']
      ["version"]
      (NoArg (\opts -> opts {optShowVersion = True}))
      "Show current version"
  ]

versionStr :: String
versionStr = "org-zk " <> showVersion version <> " - (C) 2023 Yann Herklotz"

headerOpts :: String
headerOpts = versionStr <> "\n\nUsage: org-zk [OPTION...] [FILE...]\n\n[OPTION]"

compilerOpts :: [String] -> IO (Options, [String])
compilerOpts argv =
  case getOpt Permute options argv of
    (o, n, []) -> return (foldl' (flip id) defaultOptions o, n)
    (_, _, errs) -> ioError (userError (concat errs ++ usageInfo headerOpts options))

filterWithIds :: [ZettelId] -> ZettelGraph -> ZettelGraph
filterWithIds [] zg = zg
filterWithIds ids (ZettelGraph zidMap bibMap) =
  ZettelGraph (intersection zidMap zidMapFilter) (intersection bibMap bibMapFilter)
  where
    zidMapFilter = fromList $ map (\x -> (x, ())) ids
    bibMapFilter = fromList $ map (\(ZettelId t) -> (BibId t, ())) ids

main :: IO ()
main = withStderrLogging $ do
  (zkOpts, fl) <- getArgs >>= compilerOpts

  setLogLevel LevelWarn
  when (optVerbose zkOpts == 1) $ setLogLevel LevelInfo
  when (optVerbose zkOpts > 1) $ setLogLevel LevelDebug
  when (optQuiet zkOpts) $ setLogLevel LevelError

  debug $ "Options: " <> T.pack (show zkOpts)

  when (optShowHelp zkOpts) $ do
    putStrLn $ usageInfo headerOpts options
    exitSuccess

  when (optShowVersion zkOpts) $ do
    putStrLn versionStr
    exitSuccess

  graph <- parseZettelKasten (zip [1 ..] fl) (optOrgBibliography zkOpts)

  let pipeline = handleBibliography . wrapZettelGraph . linkAll . transcludeMdAll

  when (isNothing (optCsl zkOpts)) . warn $ "CSL file not set, using: ieee.csl"
  when (isNothing (optBibliography zkOpts)) . warn $ "Bibliography file not set, using: references.bib"

  renderZettelGraphFile
    (optVerbose zkOpts > 2)
    ( fromMaybe
        "ieee.csl"
        (optCsl zkOpts)
    )
    (optBibliography zkOpts)
    (fromMaybe "output" (optOutput zkOpts))
    (filterWithIds (optIndex zkOpts) $ pipeline graph)