From 1da32745a257ce0e28e21bcdc93f648a10b790b2 Mon Sep 17 00:00:00 2001
From: "Niels G. W. Serup" <ngws@metanohi.name>
Date: Mon, 14 Oct 2024 22:48:58 +0200
Subject: [PATCH] Rewrite pandoc functions to be inline

---
 byg/src/DependencyGenerator.hs |  8 +++-
 byg/src/DependencyRunner.hs    | 72 ++++++++++++++++++++++------------
 byg/src/Functions/Pandoc.hs    | 34 +++++-----------
 byg/src/Types/Dependency.hs    |  2 +-
 byg/src/Types/Token.hs         |  6 +--
 5 files changed, 64 insertions(+), 58 deletions(-)

diff --git a/byg/src/DependencyGenerator.hs b/byg/src/DependencyGenerator.hs
index d80d1f1..ccbff84 100644
--- a/byg/src/DependencyGenerator.hs
+++ b/byg/src/DependencyGenerator.hs
@@ -7,6 +7,7 @@ module DependencyGenerator
   , toTupleToken
   , evalDepGenM
   , inject
+  , onToken
   , runFunction
   , runFunctionIO
   , runFunctionIO_
@@ -27,7 +28,7 @@ module DependencyGenerator
 
 import Types.Token (Token(..))
 import Types.Functions (IsFunction(), IsFunctionIO(..))
-import Types.Dependency (Action(..), Dependency, makeDependency)
+import Types.Dependency (Action(..), F(..), Dependency, makeDependency)
 
 import Type.Reflection (Typeable, TypeRep, typeRep)
 import Control.Monad.State (MonadState, State, runState, put, get)
@@ -68,6 +69,11 @@ genDependency f = genDependencyM (pure . f)
 inject :: (Show a, Typeable a) => a -> DepGenM (Token a)
 inject x = genDependency (makeDependency NoToken (Inject x))
 
+onToken :: (TokenableTo a t, Show a, Typeable a, Show b, Typeable b) => (a -> b) -> t -> DepGenM (Token b)
+onToken f input = do
+  input' <- toToken input
+  genDependency (makeDependency input' (InlineFunction (F f)))
+
 runFunction :: IsFunction f a b => f -> Token a -> DepGenM (Token b)
 runFunction f input = genDependency (makeDependency input (Function f))
 
diff --git a/byg/src/DependencyRunner.hs b/byg/src/DependencyRunner.hs
index 6de640d..4ac2b6d 100644
--- a/byg/src/DependencyRunner.hs
+++ b/byg/src/DependencyRunner.hs
@@ -10,6 +10,7 @@ import Types.Value
 import Types.Token
 import Types.Dependency
 
+import Type.Reflection (Typeable)
 import Data.Map (Map)
 import qualified Data.Map as M
 import Control.Monad (void, forM)
@@ -49,24 +50,38 @@ runDep (Dependency _ a action _ b) =
             putStrLn "----------"
           pure result
 
+getTokenValueByIndex :: Int -> DepRunM Value
+getTokenValueByIndex i = do
+  m <- get
+  evaluate (m M.! i)
+
+getTokenValueRaw :: Token a -> DepRunM a
+getTokenValueRaw token = case token of
+  Token i ->
+    fromValue <$> getTokenValueByIndex i
+  TupleToken a b -> do
+    (,) <$> getTokenValueRaw a <*> getTokenValueRaw b
+  ZipToken a b -> do
+    zip <$> getTokenValueRaw a <*> getTokenValueRaw b
+  ListToken ts -> do
+    mapM getTokenValueRaw ts
+  NoToken ->
+    pure ()
+
 getTokenValue :: Token a -> DepRunM Value
 getTokenValue token = case token of
-  Token i -> do
-    m <- get
-    evaluate (m M.! i)
-  TupleToken a b -> do
-    va <- getTokenValue a
-    vb <- getTokenValue b
-    pure $ toValueRep (tokenTypeRep token) (fromValue va, fromValue vb)
-  ZipToken a b -> do
-    va <- getTokenValue a
-    vb <- getTokenValue b
-    pure $ toValueRep (tokenTypeRep token) $ zip (fromValue va) (fromValue vb)
-  ListToken ts -> do
-    vs <- mapM getTokenValue ts
-    pure $ toValueRep (tokenTypeRep token) (map fromValue vs)
+  Token i ->
+    getTokenValueByIndex i
+  TupleToken _ _ ->
+    fromRaw token
+  ZipToken _ _ ->
+    fromRaw token
+  ListToken _ ->
+    fromRaw token
   NoToken ->
-    pure $ toValue ()
+    fromRaw token
+  where fromRaw :: (Typeable a, Show a) => Token a -> DepRunM Value
+        fromRaw = fmap toValue . getTokenValueRaw
 
 putTokenValue :: Token a -> ValueExistence -> DepRunM ()
 putTokenValue t e = case t of
@@ -77,29 +92,34 @@ putTokenValue t e = case t of
   _ ->
     error "unexpected"
 
-runAction :: Action a b -> Value -> DepRunM Value
+runAction :: forall a b. Action a b -> Value -> DepRunM Value
 runAction action input = case action of
   Function f ->
-    pure $ toValue $ evalFunction f $ fromValue input
+    calc (evalFunction f)
   InlineFunction (F f) ->
-    pure $ toValue $ f $ fromValue input
+    calc f
   FunctionIO f ->
-    liftIO (toValue <$> evalFunctionIO f (fromValue input))
+    calcM (liftIO . evalFunctionIO f)
   Inject x ->
     pure $ toValue x
   FilterComp ->
-    let (vs, mask) = fromValue input
-    in pure $ toValueRep (actionTargetType action) $ map fst $ filter snd $ zip vs mask
+    calc (\(vs, mask) -> map fst $ filter snd $ zip vs mask)
   UntupleFst ->
-    pure $ toValue $ fst $ fromValueRep (actionSourceType action) input
+    calc fst
   UntupleSnd ->
-    pure $ toValue $ snd $ fromValueRep (actionSourceType action) input
+    calc snd
   UnzipFst ->
-    pure $ toValue $ map fst $ fromValueRep (actionSourceType action) input
+    calc (map fst)
   UnzipSnd ->
-    pure $ toValue $ map snd $ fromValueRep (actionSourceType action) input
+    calc (map snd)
   MapComp subDeps innerInput innerOutput ->
-    (toValueRep (actionTargetType action) <$>) $ forM (fromValueRep (actionSourceType action) input) $ \x -> do
+    (toValueRep (actionTargetType action) <$>)
+    $ forM (fromValueRep (actionSourceType action) input) $ \x -> do
       putTokenValue innerInput $ Evaluated $ toValue x
       runDeps subDeps
       fromValue <$> getTokenValue innerOutput
+  where calcM :: (Typeable a, Typeable b, Show b) => (a -> DepRunM b) -> DepRunM Value
+        calcM f = toValue <$> (f $ fromValueRep (actionSourceType action) input)
+
+        calc :: (Typeable a, Typeable b, Show b) => (a -> b) -> DepRunM Value
+        calc f = calcM (pure . f)
diff --git a/byg/src/Functions/Pandoc.hs b/byg/src/Functions/Pandoc.hs
index 0d121d3..f2bd9bf 100644
--- a/byg/src/Functions/Pandoc.hs
+++ b/byg/src/Functions/Pandoc.hs
@@ -4,8 +4,8 @@ module Functions.Pandoc
   , extractTitle
   ) where
 
-import Types (IsFunction(..), Token)
-import DependencyGenerator (DepGenM, TokenableTo(..), runFunction)
+import Types (Token)
+import DependencyGenerator (DepGenM, TokenableTo(..), onToken)
 
 import Data.Text (Text)
 import Text.Pandoc.Definition (Pandoc)
@@ -18,31 +18,15 @@ runPandoc m = case P.runPure m of
   Left e -> error ("unexpected pandoc error: " ++ show e)
   Right result -> result
 
-data ReadMarkdown = ReadMarkdown deriving Show
-instance IsFunction ReadMarkdown Text Pandoc where
-  evalFunction ReadMarkdown contents =
-    let settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] }
-    in runPandoc $ P.readMarkdown settings contents
-
 readMarkdown :: TokenableTo Text a => a -> DepGenM (Token Pandoc)
-readMarkdown a = runFunction ReadMarkdown =<< toToken a
-
-
-data WriteHtml = WriteHtml deriving Show
-instance IsFunction WriteHtml Pandoc Text where
-  evalFunction WriteHtml pandoc =
-    runPandoc
-    $ P.writeHtml5String P.def pandoc
+readMarkdown = onToken $ \contents ->
+  let settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] }
+  in runPandoc $ P.readMarkdown settings contents
 
 writeHtml :: TokenableTo Pandoc a => a -> DepGenM (Token Text)
-writeHtml a = runFunction WriteHtml =<< toToken a
-
-
-data ExtractTitle = ExtractTitle deriving Show
-instance IsFunction ExtractTitle Pandoc Text where
-  evalFunction ExtractTitle (PD.Pandoc _ blocks) = case blocks of
-    (PD.Header 1 _ inlines : _) -> PS.stringify inlines
-    _ -> error "unexpected"
+writeHtml = onToken $ \pandoc -> runPandoc $ P.writeHtml5String P.def pandoc
 
 extractTitle :: TokenableTo Pandoc a => a -> DepGenM (Token Text)
-extractTitle a = runFunction ExtractTitle =<< toToken a
+extractTitle = onToken $ \(PD.Pandoc _ blocks) -> case blocks of
+  (PD.Header 1 _ inlines : _) -> PS.stringify inlines
+  _ -> error "unexpected"
diff --git a/byg/src/Types/Dependency.hs b/byg/src/Types/Dependency.hs
index 9c9fe24..d8d5a1b 100644
--- a/byg/src/Types/Dependency.hs
+++ b/byg/src/Types/Dependency.hs
@@ -38,7 +38,7 @@ instance Show (F a b) where
   show = const "<function>"
 
 data Dependency where
-  Dependency :: (Typeable a, Show a) => TypeRep a -> Token a -> Action a b -> TypeRep b -> Token b -> Dependency
+  Dependency :: TypeRep a -> Token a -> Action a b -> TypeRep b -> Token b -> Dependency
 deriving instance Show Dependency
 
 makeDependency :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Action a b -> Token b -> Dependency
diff --git a/byg/src/Types/Token.hs b/byg/src/Types/Token.hs
index db3b3ab..31d8481 100644
--- a/byg/src/Types/Token.hs
+++ b/byg/src/Types/Token.hs
@@ -1,10 +1,9 @@
 {-# LANGUAGE GADTs #-}
 module Types.Token
   ( Token(..)
-  , tokenTypeRep
   ) where
 
-import Type.Reflection (Typeable, TypeRep, typeRep)
+import Type.Reflection (Typeable)
 
 data Token a where
   Token :: (Typeable a, Show a) => Int -> Token a
@@ -14,6 +13,3 @@ data Token a where
   NoToken :: Token ()
 
 deriving instance Show (Token a)
-
-tokenTypeRep :: Typeable a => Token a -> TypeRep a
-tokenTypeRep _ = typeRep