diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 85 |
1 files changed, 28 insertions, 57 deletions
diff --git a/src/Main.hs b/src/Main.hs index 04c234c..c09c4f9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,55 +1,19 @@ module Main where -import Data.Char (isAlphaNum, isLetter, isNumber, intToDigit, digitToInt) +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 Main.Utf8 (withUtf8) import qualified Relude.Extra.Map as Map import Text.Pandoc.Class (runIOorExplode) -import Text.Pandoc.Definition (Block (..), Inline (..), Pandoc (..)) +import Text.Pandoc.Definition (Block (..), Inline (..)) import Text.Pandoc.Readers (readOrg) -import Text.Pandoc.Writers (writeHtml5String, writeMarkdown) import Text.Pandoc.Shared (stringify) import Text.Pandoc.Walk (walkM) import Numeric (showIntAtBase, readInt) - -newtype ZettelId = ZettelId - { -- | The ZettelId is just Text, however, it should also be possible to convert - -- it to a list of the ID split up into it's parts. - unZettelId :: Text - } - deriving (Show, Eq, Ord) - -instance IsString ZettelId where - fromString = ZettelId . fromString - -instance ToString ZettelId where - toString = toString . unZettelId - -instance Semigroup ZettelId where - ZettelId a <> ZettelId b = ZettelId $ a <> b - -instance Monoid ZettelId where - mempty = ZettelId mempty - -data Zettel = Zettel - { -- | The ID that is assigned to the Zettel. - zettelId :: !ZettelId, - -- | The title of the Zettel, which should also be present in the body, however, - -- this is useful to gather metadata about the Zettel. - zettelTitle :: !Text, - -- | The text body of the Zettel, which is stored as a Pandoc document to make it - -- easy to export to other documents. - zettelBody :: Pandoc - } - deriving (Show, Eq) - -instance Semigroup Zettel where - Zettel a b c <> Zettel _ _ c' = Zettel a b $ c <> c' - -instance Monoid Zettel where - mempty = Zettel mempty mempty mempty +import Zettel data HeaderState = HeaderState { headerStateMap :: Map Text ((ZettelId, Text), [Text]), @@ -137,34 +101,41 @@ defPredId z = 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' -> "\"" <> l' <> "\"" <> " -> " <> "\"" <> t <> "\"" <> ";\n") l +toDot _ (t, l) = foldMap (\l' -> quoted l' <> " -> " <> quoted t <> ";\n") l -toDotNodes :: Text -> Text -toDotNodes t +toDotNodes :: ZettelId -> Text +toDotNodes (ZettelId t) | T.null t = "" - | isNumber $ T.head t = "\"" <> t <> "\"" <> " [color=" <> T.singleton (T.head t) <> "];\n" + | isNumber $ T.head t = quoted t <> " [color=" <> T.singleton (T.head t) <> "];\n" | otherwise = "" -addSelfLinks :: ZettelId -> Map Text ((ZettelId, Text), [Text]) -> Map Text ((ZettelId, Text), [Text]) -addSelfLinks z m = - Map.insertWith (\((_, _), l') ((z', t), l) -> ((z', t), l ++ l')) (unZettelId z) +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 :: (a, ((ZettelId, b), [Text])) -> (a, ((ZettelId, b), [Text])) -addSelfLinks2 (a, ((t, b), l)) = - (a, ((t, b), maybeToList (unZettelId <$> defPredId t) <> l)) +addSelfLinks2 :: ((ZettelId, b), [Text]) -> ((ZettelId, b), [Text]) +addSelfLinks2 ((t, b), l) = + ((t, b), maybeToList (unZettelId <$> defPredId t) <> l) main :: IO () main = withUtf8 $ do - let fl = ["/Users/yannherklotz/Dropbox/zk/verification.org", "/Users/yannherklotz/Dropbox/zk/mathematics.org", "/Users/yannherklotz/Dropbox/zk/hls.org", "/Users/yannherklotz/Dropbox/zk/computing.org", "/Users/yannherklotz/Dropbox/zk/hardware.org"] - fs <- sequence $ readFileText <$> fl - x <- sequence $ runIOorExplode . readOrg def <$> fs + let fl = ["/home/ymherklotz/Dropbox/zk/verification.org", + "/home/ymherklotz/Dropbox/zk/mathematics.org", + "/home/ymherklotz/Dropbox/zk/hls.org", + "/home/ymherklotz/Dropbox/zk/computing.org", + "/home/ymherklotz/Dropbox/zk/hardware.org"] + fs <- mapM readFileText fl + x <- mapM (runIOorExplode . readOrg def) fs let (_, s) = runState (forM x (walkM getHeaders)) (HeaderState mempty "toplevel") - let allZettel = map addSelfLinks $ Map.toPairs (headerStateMap s) + let allZettel = second nub . addSelfLinks2 <$> headerStateMap s writeFileText "out.dot" $ "digraph G {\nnode [colorscheme=pastel28,style=filled];\n" - <> fold (toDotNodes . fst <$> allZettel) - <> fold (toDot (foldMap (snd . snd) allZettel) - . (\(a, (_, b)) -> (a, b)) <$> allZettel) + <> foldMap (toDotNodes . fst . fst) allZettel + <> foldMap (toDot (foldMap snd allZettel) + . (\((ZettelId a, _), b) -> (a, b))) allZettel <> "}\n" -- forM_ allZettel (\(_, ((a, _), _)) -> do -- t <- runIOorExplode $ writeMarkdown def p |