Kind of make it work with pre-compilation

But very messy now.
2024-09-23 21:14:18 +02:00
--- a/byg/byg.cabal
+++ b/byg/byg.cabal
@@ -21,16 +21,20 @@ library
        Sources
        FunctionImplementations.Pure
        FunctionImplementations.IO
+        Dependency
        ComputationM
        Functions
+        Generator
    build-depends:
        base
      , mtl
      , bytestring
+      , template-haskell

 executable byg
    import: common
    main-is: src/Main.hs
    build-depends:
        base
+      , template-haskell
      , byg
--- a/byg/src/ComputationM.hs
+++ b/byg/src/ComputationM.hs
@@ -1,11 +1,8 @@
-{-# LANGUAGE GADTs #-}
 module ComputationM
  ( ComputationM
-  , Token
-  , tupleTokens
-  , zipTokens
  , evalComputationM
  , inject
+  -- , inject'
  , mapComputationM
  , mapComputationM_
  , filterComputationM
@@ -14,43 +11,11 @@ module ComputationM
  ) where

 import Types
+import Dependency

 import Control.Monad.State
 import Control.Monad.Writer
-
-data TypedRun a b where
-  Function :: IsFunction f a b => f -> TypedRun a b
-  FunctionIO :: IsFunctionIO f a b => f -> TypedRun a b
-  Inject :: b -> TypedRun () b
-  GetListElem :: TypedRun [b] b
-  SetListElem :: TypedRun a [a]
-  MapComp :: [DependencyUntyped] -> TypedRun [a] [b]
-  FilterComp :: TypedRun ([a], [Bool]) [a]
-
-deriving instance (Show a, Show b) => Show (TypedRun a b)
-
-data Token a where
-  Token :: Int -> Token a
-  TupleToken :: Token a -> Token b -> Token (a, b)
-  ZipToken :: Token [a] -> Token [b] -> Token [(a, b)]
-  NoToken :: Token ()
-
-deriving instance Show (Token a)
-
-tupleTokens :: (Show a, Show b) => Token a -> Token b -> Token (a, b)
-tupleTokens = TupleToken
-
-zipTokens :: (Show a, Show b) => Token [a] -> Token [b] -> Token [(a, b)]
-zipTokens = ZipToken
-
-data Dependency a b = Dependency (Token a) (TypedRun a b) (Token b)
-  deriving (Show)
-
-data DependencyUntyped where
-  DependencyUntyped :: Dependency a b -> String -> DependencyUntyped
-
-instance Show DependencyUntyped where
-  show (DependencyUntyped _ s) = s
+import Language.Haskell.TH.Syntax

 newtype ComputationM' a = ComputationM { unComputationM :: WriterT [DependencyUntyped] (State Int) a }
  deriving (Functor, Applicative, Monad, MonadState Int, MonadWriter [DependencyUntyped])
@@ -63,10 +28,10 @@ evalComputationM' top m = runState (execWriterT (unComputationM m)) top
 evalComputationM :: ComputationM () -> [DependencyUntyped]
 evalComputationM m = fst (evalComputationM' 0 m)

-tellDep :: (Show a, Show b) => Dependency a b -> ComputationM' ()
-tellDep dep = tell [DependencyUntyped dep (show dep)] -- Call show for later debugging purposes
+tellDep :: (Show a, Show b, Lift a, Lift b) => Dependency a b -> ComputationM' ()
+tellDep dep = tell [makeUntyped dep]

-genDependency' :: (Show u, Show a) => (Token a -> ComputationM' (Dependency u a)) -> ComputationM a
+genDependency' :: (Show u, Show a, Lift u, Lift a) => (Token a -> ComputationM' (Dependency u a)) -> ComputationM a
 genDependency' f = do
  top <- get
  let top' = top + 1
@@ -76,27 +41,40 @@ genDependency' f = do
  tellDep result
  pure target

-genDependency :: (Show u, Show a) => (Token a -> Dependency u a) -> ComputationM a
+genDependency :: (Show u, Show a, Lift u, Lift a) => (Token a -> Dependency u a) -> ComputationM a
 genDependency f = genDependency' (pure . f)

-inject :: Show a => a -> ComputationM a
-inject x = genDependency (Dependency NoToken (Inject x))
+-- inject :: (Show a, Lift a) => a -> ComputationM a
+-- inject x = genDependency (Dependency NoToken (Inject x))

-getListElem :: Show a => Token [a] -> ComputationM a
+inject :: (Show a, Lift a, Valuable a) => a -> ComputationM a
+inject x = genDependency (Dependency NoToken (Inject (toValue x)))
+
+-- inject' :: ImageConversionSettings -> ComputationM ImageConversionSettings
+-- -- inject' x = genDependency (Dependency NoToken (InjectImageConversionSettings x))
+-- inject' x = genDependency (Dependency NoToken (Inject WImageConversionSettings x))
+
+getListElem :: (Show a, Lift a) => Token [a] -> ComputationM a
 getListElem outer = genDependency (Dependency outer GetListElem)

-setListElem :: Show a => Token a -> Token [a] -> ComputationM ()
+setListElem :: (Show a, Lift a) => Token a -> Token [a] -> ComputationM ()
 setListElem a outer = do
  tellDep (Dependency a SetListElem outer)
  pure NoToken

-runFunction :: (Show a, Show b, IsFunction f a b) => f -> Token a -> ComputationM b
+-- runFunction :: (Show a, Show b, Lift a, Lift b, IsFunction f a b) => f -> Token a -> ComputationM b
+-- runFunction f input = genDependency (Dependency input (Function f))
+
+-- runFunctionIO :: (Show a, Show b, Lift a, Lift b, IsFunctionIO f a b) => f -> Token a -> ComputationM b
+-- runFunctionIO f input = genDependency (Dependency input (FunctionIO f))
+
+runFunction :: (Show a, Show b, Lift a, Lift b) => Function -> Token a -> ComputationM b
 runFunction f input = genDependency (Dependency input (Function f))

-runFunctionIO :: (Show a, Show b, IsFunctionIO f a b) => f -> Token a -> ComputationM b
+runFunctionIO :: (Show a, Show b, Lift a, Lift b) => FunctionIO -> Token a -> ComputationM b
 runFunctionIO f input = genDependency (Dependency input (FunctionIO f))

-mapComputationM :: (Show a, Show b) => (Token a -> ComputationM b) -> Token [a] -> ComputationM [b]
+mapComputationM :: (Show a, Show b, Lift a, Lift b) => (Token a -> ComputationM b) -> Token [a] -> ComputationM [b]
 mapComputationM f input = genDependency' $ \target -> do
  top <- get
  let (res, top') = evalComputationM' top $ do
@@ -106,12 +84,12 @@ mapComputationM f input = genDependency' $ \target -> do
  put top'
  pure (Dependency input (MapComp res) target)

-mapComputationM_ :: Show a => (Token a -> ComputationM ()) -> Token [a] -> ComputationM ()
+mapComputationM_ :: (Show a, Lift a) => (Token a -> ComputationM ()) -> Token [a] -> ComputationM ()
 mapComputationM_ f input = do
  _ <- mapComputationM f input
  pure NoToken

-filterComputationM :: Show a => (Token a -> ComputationM Bool) -> Token [a] -> ComputationM [a]
+filterComputationM :: (Show a, Lift a) => (Token a -> ComputationM Bool) -> Token [a] -> ComputationM [a]
 filterComputationM f input = do
  conds <- mapComputationM f input
  genDependency (Dependency (TupleToken input conds) FilterComp)
--- a/byg/src/Dependency.hs
+++ b/byg/src/Dependency.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE GADTs #-}
+module Dependency
+  ( TypedRun(..)
+  , Dependency(..)
+  , Token(..)
+  , DependencyUntyped
+  , makeUntyped
+  , tupleTokens
+  , zipTokens
+  ) where
+
+import Types
+
+-- import Unsafe.Coerce (unsafeCoerce)
+import Language.Haskell.TH.Syntax
+
+-- data TypedRun a b where
+--   Function :: IsFunctionId f => f -> TypedRun a b
+--   FunctionIO :: IsFunctionIOId f => f -> TypedRun a b
+--   Function :: IsFunction f a b => f -> TypedRun a b
+--   FunctionIO :: IsFunctionIO f a b => f -> TypedRun a b
+--   Inject :: Lift b => b -> TypedRun () b
+--   GetListElem :: TypedRun [b] b
+--   SetListElem :: TypedRun a [a]
+--   MapComp :: [DependencyUntyped] -> TypedRun [a] [b]
+--   FilterComp :: TypedRun ([a], [Bool]) [a]
+
+-- deriving instance (Show a, Show b) => Show (TypedRun a b)
+-- deriving instance (Lift a, Lift b) => Lift (TypedRun a b)
+
+-- data TypedRun where
+--   -- Function :: IsFunctionId f => f -> TypedRun
+--   -- FunctionIO :: IsFunctionIOId f => f -> TypedRun
+--   Function :: Function -> TypedRun
+--   FunctionIO :: FunctionIO -> TypedRun
+--   -- Inject :: (Show b, Lift b) => b -> TypedRun
+--   -- InjectString :: String -> TypedRun
+--   -- InjectImageConversionSettings :: ImageConversionSettings -> TypedRun
+--   -- Inject :: (Show a, Lift a, Witness w a) => w -> a -> TypedRun
+--   Inject :: Value -> TypedRun
+--   GetListElem :: TypedRun
+--   SetListElem :: TypedRun
+--   MapComp :: [DependencyUntyped] -> TypedRun
+--   FilterComp :: TypedRun
+
+-- deriving instance Show TypedRun
+-- deriving instance Lift TypedRun
+
+data TypedRun = Function Function
+              | FunctionIO FunctionIO
+              | Inject Value
+              | GetListElem
+              | SetListElem
+              | MapComp [DependencyUntyped]
+              | FilterComp
+  deriving (Show, Lift)
+
+data Token a where
+  Token :: Int -> Token a
+  TupleToken :: Token a -> Token b -> Token (a, b)
+  ZipToken :: Token [a] -> Token [b] -> Token [(a, b)]
+  NoToken :: Token ()
+
+deriving instance Show (Token a)
+deriving instance Lift (Token a)
+
+tupleTokens :: (Show a, Show b) => Token a -> Token b -> Token (a, b)
+tupleTokens = TupleToken
+
+zipTokens :: (Show a, Show b) => Token [a] -> Token [b] -> Token [(a, b)]
+zipTokens = ZipToken
+
+-- data Dependency a b = Dependency (Token a) (TypedRun a b) (Token b)
+--   deriving (Show)
+
+data Dependency a b = Dependency (Token a) TypedRun (Token b)
+  deriving (Show)
+
+deriving instance (Lift a, Lift b) => Lift (Dependency a b)
+
+-- type DependencyUntyped = Dependency () ()
+
+-- makeUntyped :: (Show a, Show b, Lift a, Lift b) => Dependency a b -> DependencyUntyped
+-- makeUntyped dep = unsafeCoerce dep
+
+data TokenUntyped = UToken Int
+                  | UTupleToken TokenUntyped TokenUntyped
+                  | UZipToken TokenUntyped TokenUntyped
+                  | UNoToken
+  deriving (Show, Lift)
+
+makeUntypedToken :: Token a -> TokenUntyped
+makeUntypedToken = \case
+  Token i -> UToken i
+  TupleToken a b -> UTupleToken (makeUntypedToken a) (makeUntypedToken b)
+  ZipToken a b -> UZipToken (makeUntypedToken a) (makeUntypedToken b)
+  NoToken -> UNoToken
+
+-- data DependencyUntyped where
+--   DependencyUntyped :: TokenUntyped -> TypedRun -> TokenUntyped -> String -> DependencyUntyped
+
+data DependencyUntyped = DependencyUntyped TokenUntyped TypedRun TokenUntyped
+  deriving (Show, Lift)
+
+-- instance Show DependencyUntyped--  where
+--   -- show (DependencyUntyped _ _ _ s) = s
+
+-- instance Lift DependencyUntyped
+
+makeUntyped :: (Show a, Show b, Lift a, Lift b) => Dependency a b -> DependencyUntyped
+makeUntyped (Dependency ta tr tb) =
+  DependencyUntyped (makeUntypedToken ta) tr (makeUntypedToken tb)
--- a/byg/src/FunctionImplementations/IO.hs
+++ b/byg/src/FunctionImplementations/IO.hs
@@ -1,30 +1,37 @@
 module FunctionImplementations.IO
-  ( ListDirectory(..)
-  , ReadTemplate(..)
-  , ConvertImage(..)
-  , SaveFile(..)
-  , RunPandoc(..)
+  ( -- ListDirectory(..)
+  -- , ReadTemplate(..)
+  -- , ConvertImage(..)
+  -- , SaveFile(..)
+  -- , RunPandoc(..)
  ) where

 import Sources()
 import Types

-data ListDirectory = ListDirectory deriving (Show)
-instance IsFunctionIO ListDirectory FilePath [FilePath] where
-  runFIO ListDirectory _path = undefined
+import Language.Haskell.TH.Syntax

-data ReadTemplate = ReadTemplate deriving (Show)
-instance IsFunctionIO ReadTemplate FilePath Template where
-  runFIO ReadTemplate _path = undefined
+-- data ListDirectory = ListDirectory deriving (Show, Lift)
+-- instance IsFunctionIOId ListDirectory
+-- instance IsFunctionIO ListDirectory FilePath [FilePath] where
+--   runFIO ListDirectory _path = undefined

-data ConvertImage = ConvertImage deriving (Show)
-instance IsFunctionIO ConvertImage ((FilePath, FilePath), ImageConversionSettings) () where
-  runFIO ConvertImage ((_, _), ResizeToWidth _)  = undefined
+-- data ReadTemplate = ReadTemplate deriving (Show, Lift)
+-- instance IsFunctionIOId ReadTemplate
+-- instance IsFunctionIO ReadTemplate FilePath Template where
+--   runFIO ReadTemplate _path = undefined

-data SaveFile = SaveFile deriving (Show)
-instance IsFunctionIO SaveFile (String, FilePath) () where
-  runFIO SaveFile _source = undefined
+-- data ConvertImage = ConvertImage deriving (Show, Lift)
+-- instance IsFunctionIOId ConvertImage
+-- instance IsFunctionIO ConvertImage ((FilePath, FilePath), ImageConversionSettings) () where
+--   runFIO ConvertImage ((_, _), ResizeToWidth _)  = undefined

-data RunPandoc = RunPandoc deriving (Show)
-instance IsFunctionIO RunPandoc String String where
-  runFIO RunPandoc _source = undefined
+-- data SaveFile = SaveFile deriving (Show, Lift)
+-- instance IsFunctionIOId SaveFile
+-- instance IsFunctionIO SaveFile (String, FilePath) () where
+--   runFIO SaveFile _source = undefined
+
+-- data RunPandoc = RunPandoc deriving (Show, Lift)
+-- instance IsFunctionIOId RunPandoc
+-- instance IsFunctionIO RunPandoc String String where
+--   runFIO RunPandoc _source = undefined
--- a/byg/src/FunctionImplementations/Pure.hs
+++ b/byg/src/FunctionImplementations/Pure.hs
@@ -1,15 +1,19 @@
 module FunctionImplementations.Pure
-  ( IsImageFilename(..)
-  , ConvertedImageFilename(..)
+  ( -- IsImageFilename(..)
+  -- , ConvertedImageFilename(..)
  ) where

 import Sources()
 import Types

-data IsImageFilename = IsImageFilename deriving (Show)
-instance IsFunction IsImageFilename FilePath Bool where
-  runF IsImageFilename _path = undefined
+import Language.Haskell.TH.Syntax

-data ConvertedImageFilename = ConvertedImageFilename deriving (Show)
-instance IsFunction ConvertedImageFilename FilePath FilePath where
-  runF ConvertedImageFilename _path = undefined
+-- data IsImageFilename = IsImageFilename deriving (Show, Lift)
+-- instance IsFunctionId IsImageFilename
+-- instance IsFunction IsImageFilename FilePath Bool where
+--   runF IsImageFilename _path = undefined
+
+-- data ConvertedImageFilename = ConvertedImageFilename deriving (Show, Lift)
+-- instance IsFunctionId ConvertedImageFilename
+-- instance IsFunction ConvertedImageFilename FilePath FilePath where
+--   runF ConvertedImageFilename _path = undefined
--- a/byg/src/Functions.hs
+++ b/byg/src/Functions.hs
@@ -12,12 +12,21 @@ module Functions
 import FunctionImplementations.Pure
 import FunctionImplementations.IO
 import ComputationM
+import Types
+import Dependency

+isImageFilename :: Token FilePath -> ComputationM Bool
 isImageFilename = runFunction IsImageFilename
+convertedImageFilename :: Token FilePath -> ComputationM FilePath
 convertedImageFilename = runFunction ConvertedImageFilename

+listDirectory :: Token FilePath -> ComputationM [FilePath]
 listDirectory = runFunctionIO ListDirectory
+readTemplate :: Token FilePath -> ComputationM Template
 readTemplate = runFunctionIO ReadTemplate
+convertImage :: Token ((FilePath, FilePath), ImageConversionSettings) -> ComputationM ()
 convertImage = runFunctionIO ConvertImage
+saveFile :: Token (String, FilePath) -> ComputationM ()
 saveFile = runFunctionIO SaveFile
+runPandoc :: Token String -> ComputationM String
 runPandoc = runFunctionIO RunPandoc
--- a/byg/src/Generator.hs
+++ b/byg/src/Generator.hs
@@ -0,0 +1,24 @@
+module Generator (generate) where
+
+import Types
+import Dependency
+import ComputationM
+import Functions
+
+handleRecipeDir :: Token Template -> Token FilePath -> ComputationM ()
+handleRecipeDir _template dir = do
+  dirContents <- listDirectory dir
+  imageFilenames <- filterComputationM isImageFilename dirContents
+  convertedImageFilenames <- mapComputationM convertedImageFilename imageFilenames
+  flip mapComputationM_ (zipTokens imageFilenames convertedImageFilenames) $ \files -> do
+    settings <- inject $ ResizeToWidth 800
+    convertImage $ tupleTokens files settings
+
+generate :: ComputationM ()
+generate = do
+  templateFilename <- inject "template.html"
+  template <- readTemplate templateFilename
+  dir <- inject "retter"
+  dirContents <- listDirectory dir
+  mapComputationM_ (handleRecipeDir template) dirContents
+
--- a/byg/src/Main.hs
+++ b/byg/src/Main.hs
@@ -1,25 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Main where

-import Types
+import Dependency
 import ComputationM
-import Functions
+import Generator

-handleRecipeDir :: Token Template -> Token FilePath -> ComputationM ()
-handleRecipeDir template dir = do
-  dirContents <- listDirectory dir
-  imageFilenames <- filterComputationM isImageFilename dirContents
-  convertedImageFilenames <- mapComputationM convertedImageFilename imageFilenames
-  flip mapComputationM_ (zipTokens imageFilenames convertedImageFilenames) $ \files -> do
-    settings <- inject $ ResizeToWidth 800
-    convertImage $ tupleTokens files settings
+import Language.Haskell.TH.Syntax

-test :: ComputationM ()
-test = do
-  templateFilename <- inject "template.html"
-  template <- readTemplate templateFilename
-  dir <- inject "retter"
-  dirContents <- listDirectory dir
-  mapComputationM_ (handleRecipeDir template) dirContents
+dependencies :: [DependencyUntyped]
+dependencies = $(lift (evalComputationM generate))

 main :: IO ()
-main = mapM_ print $ evalComputationM test
+main = mapM_ print dependencies
--- a/byg/src/Sources.hs
+++ b/byg/src/Sources.hs
@@ -5,14 +5,14 @@ module Sources where

 import Types

-data Source a where
-  Data :: a -> Source a
+-- data Source a where
+--   Data :: a -> Source a

-instance SourceState FilePath where
-  stateOfSource = undefined
+-- instance SourceState FilePath where
+--   stateOfSource = undefined

-instance SourceState ((FilePath, FilePath), ImageConversionSettings) where
-  stateOfSource = undefined
+-- instance SourceState ((FilePath, FilePath), ImageConversionSettings) where
+--   stateOfSource = undefined

-instance SourceState (String, FilePath) where
-  stateOfSource = undefined
+-- instance SourceState (String, FilePath) where
+--   stateOfSource = undefined
--- a/byg/src/Types.hs
+++ b/byg/src/Types.hs
@@ -2,23 +2,57 @@
 module Types where

 import Data.ByteString (ByteString)
+import Language.Haskell.TH.Syntax

 data ImageConversionSettings = ResizeToWidth Int
-  deriving (Show)
+  deriving (Show, Lift)

 data TemplatePart = Literal String
                  | KeyValue String
-  deriving (Show)
+  deriving (Show, Lift)

 data Template = Template [TemplatePart]
-  deriving (Show)
+  deriving (Show, Lift)

-class (SourceState a, Show f) => IsFunction f a b | f -> a b where
-  runF :: f -> a -> b
+-- class (Show f, Lift f) => IsFunctionId f

-class (SourceState a, Show f) => IsFunctionIO f a b | f -> a b where
-  runFIO :: f -> a -> IO b
+-- class (IsFunctionId f, SourceState a) => IsFunction f a b | f -> a b where
+--   runF :: f -> a -> b

-class SourceState a where
-  stateOfSource :: a -> IO ByteString
+-- class (Show f, Lift f) => IsFunctionIOId f
+-- class (IsFunctionIOId f, SourceState a) => IsFunctionIO f a b | f -> a b where
+--   runFIO :: f -> a -> IO b

+-- class SourceState a where
+--   stateOfSource :: a -> IO ByteString
+
+
+data Function = IsImageFilename
+              | ConvertedImageFilename
+  deriving (Show, Lift)
+
+data FunctionIO = ListDirectory
+                | ReadTemplate
+                | ConvertImage
+                | SaveFile
+                | RunPandoc
+  deriving (Show, Lift)
+
+
+-- class (Show w, Lift w) => Witness w a | w -> a where
+
+-- data WImageConversionSettings = WImageConversionSettings deriving (Show, Lift)
+-- instance Witness WImageConversionSettings ImageConversionSettings
+
+data Value = ImageConversionSettings ImageConversionSettings
+           | String String
+  deriving (Show, Lift)
+
+class Valuable a where
+  toValue :: a -> Value
+
+instance Valuable ImageConversionSettings where
+  toValue = ImageConversionSettings
+
+instance Valuable String where
+  toValue = String