From a098317df3065f592b5da5e90df5025d7cec18bc Mon Sep 17 00:00:00 2001 From: "Niels G. W. Serup" Date: Mon, 23 Sep 2024 21:14:18 +0200 Subject: [PATCH] Kind of make it work with pre-compilation But very messy now. --- byg/byg.cabal | 4 + byg/src/ComputationM.hs | 80 ++++++----------- byg/src/Dependency.hs | 112 ++++++++++++++++++++++++ byg/src/FunctionImplementations/IO.hs | 47 +++++----- byg/src/FunctionImplementations/Pure.hs | 20 +++-- byg/src/Functions.hs | 9 ++ byg/src/Generator.hs | 24 +++++ byg/src/Main.hs | 25 ++---- byg/src/Sources.hs | 16 ++-- byg/src/Types.hs | 52 +++++++++-- 10 files changed, 275 insertions(+), 114 deletions(-) create mode 100644 byg/src/Dependency.hs create mode 100644 byg/src/Generator.hs diff --git a/byg/byg.cabal b/byg/byg.cabal index 44453ab..dcee009 100644 --- 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 diff --git a/byg/src/ComputationM.hs b/byg/src/ComputationM.hs index 6eaaa4a..55a97fb 100644 --- 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) diff --git a/byg/src/Dependency.hs b/byg/src/Dependency.hs new file mode 100644 index 0000000..199cd72 --- /dev/null +++ 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) diff --git a/byg/src/FunctionImplementations/IO.hs b/byg/src/FunctionImplementations/IO.hs index 1824a98..7fd1467 100644 --- 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 diff --git a/byg/src/FunctionImplementations/Pure.hs b/byg/src/FunctionImplementations/Pure.hs index cec8d57..d06db90 100644 --- 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 diff --git a/byg/src/Functions.hs b/byg/src/Functions.hs index 8fb6d41..55ef75e 100644 --- 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 diff --git a/byg/src/Generator.hs b/byg/src/Generator.hs new file mode 100644 index 0000000..ab4579e --- /dev/null +++ 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 + diff --git a/byg/src/Main.hs b/byg/src/Main.hs index 8614077..5a87e75 100644 --- 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 diff --git a/byg/src/Sources.hs b/byg/src/Sources.hs index a38c13f..ca4446f 100644 --- 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 diff --git a/byg/src/Types.hs b/byg/src/Types.hs index cdd791b..88a6875 100644 --- 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