Kind of make it work with pre-compilation

But very messy now.

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

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
-
+import Language.Haskell.TH.Syntax
-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
 
 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 :: (Show a, Show b, Lift a, Lift b) => Dependency a b -> ComputationM' ()
-tellDep dep = tell [DependencyUntyped dep (show dep)] -- Call show for later debugging purposes
+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 :: (Show a, Lift a) => a -> ComputationM a
-inject x = genDependency (Dependency NoToken (Inject x))
+-- 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)

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)

byg/src/FunctionImplementations/IO.hs

@@ -1,30 +1,37 @@
 module FunctionImplementations.IO
-  ( ListDirectory(..)
+  ( -- ListDirectory(..)
-  , ReadTemplate(..)
+  -- , ReadTemplate(..)
-  , ConvertImage(..)
+  -- , ConvertImage(..)
-  , SaveFile(..)
+  -- , SaveFile(..)
-  , RunPandoc(..)
+  -- , RunPandoc(..)
   ) where
 
 import Sources()
 import Types
 
-data ListDirectory = ListDirectory deriving (Show)
+import Language.Haskell.TH.Syntax
-instance IsFunctionIO ListDirectory FilePath [FilePath] where
-  runFIO ListDirectory _path = undefined
 
-data ReadTemplate = ReadTemplate deriving (Show)
+-- data ListDirectory = ListDirectory deriving (Show, Lift)
-instance IsFunctionIO ReadTemplate FilePath Template where
+-- instance IsFunctionIOId ListDirectory
-  runFIO ReadTemplate _path = undefined
+-- instance IsFunctionIO ListDirectory FilePath [FilePath] where
+--   runFIO ListDirectory _path = undefined
 
-data ConvertImage = ConvertImage deriving (Show)
+-- data ReadTemplate = ReadTemplate deriving (Show, Lift)
-instance IsFunctionIO ConvertImage ((FilePath, FilePath), ImageConversionSettings) () where
+-- instance IsFunctionIOId ReadTemplate
-  runFIO ConvertImage ((_, _), ResizeToWidth _)  = undefined
+-- instance IsFunctionIO ReadTemplate FilePath Template where
+--   runFIO ReadTemplate _path = undefined
 
-data SaveFile = SaveFile deriving (Show)
+-- data ConvertImage = ConvertImage deriving (Show, Lift)
-instance IsFunctionIO SaveFile (String, FilePath) () where
+-- instance IsFunctionIOId ConvertImage
-  runFIO SaveFile _source = undefined
+-- instance IsFunctionIO ConvertImage ((FilePath, FilePath), ImageConversionSettings) () where
+--   runFIO ConvertImage ((_, _), ResizeToWidth _)  = undefined
 
-data RunPandoc = RunPandoc deriving (Show)
+-- data SaveFile = SaveFile deriving (Show, Lift)
-instance IsFunctionIO RunPandoc String String where
+-- instance IsFunctionIOId SaveFile
-  runFIO RunPandoc _source = undefined
+-- 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

byg/src/FunctionImplementations/Pure.hs

@@ -1,15 +1,19 @@
 module FunctionImplementations.Pure
-  ( IsImageFilename(..)
+  ( -- IsImageFilename(..)
-  , ConvertedImageFilename(..)
+  -- , ConvertedImageFilename(..)
   ) where
 
 import Sources()
 import Types
 
-data IsImageFilename = IsImageFilename deriving (Show)
+import Language.Haskell.TH.Syntax
-instance IsFunction IsImageFilename FilePath Bool where
-  runF IsImageFilename _path = undefined
 
-data ConvertedImageFilename = ConvertedImageFilename deriving (Show)
+-- data IsImageFilename = IsImageFilename deriving (Show, Lift)
-instance IsFunction ConvertedImageFilename FilePath FilePath where
+-- instance IsFunctionId IsImageFilename
-  runF ConvertedImageFilename _path = undefined
+-- 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

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

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
+

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 ()
+import Language.Haskell.TH.Syntax
-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
 
-test :: ComputationM ()
+dependencies :: [DependencyUntyped]
-test = do
+dependencies = $(lift (evalComputationM generate))
-  templateFilename <- inject "template.html"
-  template <- readTemplate templateFilename
-  dir <- inject "retter"
-  dirContents <- listDirectory dir
-  mapComputationM_ (handleRecipeDir template) dirContents
 
 main :: IO ()
-main = mapM_ print $ evalComputationM test
+main = mapM_ print dependencies

byg/src/Sources.hs

@@ -5,14 +5,14 @@ module Sources where
 
 import Types
 
-data Source a where
+-- data Source a where
-  Data :: a -> Source a
+--   Data :: a -> Source a
 
-instance SourceState FilePath where
+-- instance SourceState FilePath where
-  stateOfSource = undefined
+--   stateOfSource = undefined
 
-instance SourceState ((FilePath, FilePath), ImageConversionSettings) where
+-- instance SourceState ((FilePath, FilePath), ImageConversionSettings) where
-  stateOfSource = undefined
+--   stateOfSource = undefined
 
-instance SourceState (String, FilePath) where
+-- instance SourceState (String, FilePath) where
-  stateOfSource = undefined
+--   stateOfSource = undefined

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
+-- class (Show f, Lift f) => IsFunctionId f
-  runF :: f -> a -> b
 
-class (SourceState a, Show f) => IsFunctionIO f a b | f -> a b where
+-- class (IsFunctionId f, SourceState a) => IsFunction f a b | f -> a b where
-  runFIO :: f -> a -> IO b
+--   runF :: f -> a -> b
 
-class SourceState a where
+-- class (Show f, Lift f) => IsFunctionIOId f
-  stateOfSource :: a -> IO ByteString
+-- 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