Clean up and move things around

This commit is contained in:
Niels G. W. Serup 2024-09-23 22:11:54 +02:00
parent a098317df3
commit e7e767c007
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
19 changed files with 286 additions and 393 deletions

View File

@ -17,14 +17,17 @@ library
import: common import: common
hs-source-dirs: src hs-source-dirs: src
exposed-modules: exposed-modules:
Types.Token
Types.Values
Types.Value
Types.Function
Types.FunctionIO
Types Types
Sources
FunctionImplementations.Pure
FunctionImplementations.IO
Dependency Dependency
ComputationM DependencyGenerator
Functions Evaluation.Function
Generator Evaluation.FunctionIO
SiteGenerator
build-depends: build-depends:
base base
, mtl , mtl

View File

@ -1,95 +0,0 @@
module ComputationM
( ComputationM
, evalComputationM
, inject
-- , inject'
, mapComputationM
, mapComputationM_
, filterComputationM
, runFunction
, runFunctionIO
) where
import Types
import Dependency
import Control.Monad.State
import Control.Monad.Writer
import Language.Haskell.TH.Syntax
newtype ComputationM' a = ComputationM { unComputationM :: WriterT [DependencyUntyped] (State Int) a }
deriving (Functor, Applicative, Monad, MonadState Int, MonadWriter [DependencyUntyped])
type ComputationM a = ComputationM' (Token a)
evalComputationM' :: Int -> ComputationM () -> ([DependencyUntyped], Int)
evalComputationM' top m = runState (execWriterT (unComputationM m)) top
evalComputationM :: ComputationM () -> [DependencyUntyped]
evalComputationM m = fst (evalComputationM' 0 m)
tellDep :: (Show a, Show b, Lift a, Lift b) => Dependency a b -> ComputationM' ()
tellDep dep = tell [makeUntyped dep]
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
target = Token top'
put top'
result <- f target
tellDep result
pure target
genDependency :: (Show u, Show a, Lift u, Lift a) => (Token a -> Dependency u a) -> ComputationM a
genDependency f = genDependency' (pure . f)
-- inject :: (Show a, Lift a) => a -> ComputationM a
-- inject x = genDependency (Dependency NoToken (Inject x))
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, Lift a) => Token a -> Token [a] -> ComputationM ()
setListElem a outer = do
tellDep (Dependency a SetListElem outer)
pure NoToken
-- 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, Lift a, Lift b) => FunctionIO -> Token a -> ComputationM b
runFunctionIO f input = genDependency (Dependency input (FunctionIO f))
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
inp <- getListElem input
outp <- f inp
setListElem outp target
put top'
pure (Dependency input (MapComp res) target)
mapComputationM_ :: (Show a, Lift a) => (Token a -> ComputationM ()) -> Token [a] -> ComputationM ()
mapComputationM_ f input = do
_ <- mapComputationM f input
pure NoToken
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)

View File

@ -1,112 +1,42 @@
{-# LANGUAGE GADTs #-}
module Dependency module Dependency
( TypedRun(..) ( Action(..)
, UToken(..)
, Dependency(..) , Dependency(..)
, Token(..) , makeDependency
, DependencyUntyped
, makeUntyped
, tupleTokens
, zipTokens
) where ) where
import Types import Types.Token (Token(..))
import Types.Value (Value)
import Types.Function (Function)
import Types.FunctionIO (FunctionIO)
-- import Unsafe.Coerce (unsafeCoerce) import Language.Haskell.TH.Syntax (Lift)
import Language.Haskell.TH.Syntax
-- data TypedRun a b where data Action = Function Function
-- 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 | FunctionIO FunctionIO
| Inject Value | Inject Value
| MapComp [Dependency]
| FilterComp
| GetListElem | GetListElem
| SetListElem | SetListElem
| MapComp [DependencyUntyped]
| FilterComp
deriving (Show, Lift) deriving (Show, Lift)
data Token a where data UToken = UToken Int
Token :: Int -> Token a | UTupleToken UToken UToken
TupleToken :: Token a -> Token b -> Token (a, b) | UZipToken UToken UToken
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 | UNoToken
deriving (Show, Lift) deriving (Show, Lift)
makeUntypedToken :: Token a -> TokenUntyped data Dependency = Dependency UToken Action UToken
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) deriving (Show, Lift)
-- instance Show DependencyUntyped-- where makeDependency :: (Show a, Show b, Lift a, Lift b) => Token a -> Action -> Token b -> Dependency
-- -- show (DependencyUntyped _ _ _ s) = s makeDependency a action b = Dependency (makeUToken a) action (makeUToken b)
-- instance Lift DependencyUntyped makeUToken :: Token a -> UToken
makeUToken = \case
Token i -> UToken i
TupleToken a b -> UTupleToken (makeUToken a) (makeUToken b)
ZipToken a b -> UZipToken (makeUToken a) (makeUToken b)
NoToken -> UNoToken
makeUntyped :: (Show a, Show b, Lift a, Lift b) => Dependency a b -> DependencyUntyped
makeUntyped (Dependency ta tr tb) =
DependencyUntyped (makeUntypedToken ta) tr (makeUntypedToken tb)

View File

@ -0,0 +1,115 @@
module DependencyGenerator
( DepGenM
, evalDepGenM
, inject
, runFunction
, runFunctionIO
, mapDepGenM
, mapDepGenM_
, filterDepGenM
, isImageFilename
, convertedImageFilename
, listDirectory
, readTemplate
, convertImage
, saveFile
, runPandoc
) where
import Types.Token (Token(..))
import Types.Values
import Types.Value (Valuable(..))
import Types.Function (Function(..))
import Types.FunctionIO (FunctionIO(..))
import Dependency (Action(..), Dependency, makeDependency)
import Control.Monad.State (MonadState, State, runState, put, get)
import Control.Monad.Writer (MonadWriter, WriterT, execWriterT, tell)
import Language.Haskell.TH.Syntax (Lift)
newtype DepGenM' a = DepGenM { unDepGenM :: WriterT [Dependency] (State Int) a }
deriving (Functor, Applicative, Monad, MonadState Int, MonadWriter [Dependency])
type DepGenM a = DepGenM' (Token a)
evalDepGenM' :: Int -> DepGenM () -> ([Dependency], Int)
evalDepGenM' top m = runState (execWriterT (unDepGenM m)) top
evalDepGenM :: DepGenM () -> [Dependency]
evalDepGenM m = fst (evalDepGenM' 0 m)
tellDep :: Dependency -> DepGenM' ()
tellDep dep = tell [dep]
genDependencyM :: (Show a, Lift a) => (Token a -> DepGenM' Dependency) -> DepGenM a
genDependencyM f = do
top <- get
let top' = top + 1
target = Token top'
put top'
result <- f target
tellDep result
pure target
genDependency :: (Show a, Lift a) => (Token a -> Dependency) -> DepGenM a
genDependency f = genDependencyM (pure . f)
inject :: (Show a, Lift a, Valuable a) => a -> DepGenM a
inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
getListElem :: (Show a, Lift a) => Token [a] -> DepGenM a
getListElem outer = genDependency (makeDependency outer GetListElem)
setListElem :: (Show a, Lift a) => Token a -> Token [a] -> DepGenM ()
setListElem a outer = do
tellDep (makeDependency a SetListElem outer)
pure NoToken
runFunction :: (Show a, Show b, Lift a, Lift b) => Function -> Token a -> DepGenM b
runFunction f input = genDependency (makeDependency input (Function f))
runFunctionIO :: (Show a, Show b, Lift a, Lift b) => FunctionIO -> Token a -> DepGenM b
runFunctionIO f input = genDependency (makeDependency input (FunctionIO f))
mapDepGenM :: (Show a, Show b, Lift a, Lift b) => (Token a -> DepGenM b) -> Token [a] -> DepGenM [b]
mapDepGenM f input = genDependencyM $ \target -> do
top <- get
let (res, top') = evalDepGenM' top $ do
inp <- getListElem input
outp <- f inp
setListElem outp target
put top'
pure (makeDependency input (MapComp res) target)
mapDepGenM_ :: (Show a, Lift a) => (Token a -> DepGenM ()) -> Token [a] -> DepGenM ()
mapDepGenM_ f input = do
_ <- mapDepGenM f input
pure NoToken
filterDepGenM :: (Show a, Lift a) => (Token a -> DepGenM Bool) -> Token [a] -> DepGenM [a]
filterDepGenM f input = do
conds <- mapDepGenM f input
genDependency (makeDependency (TupleToken input conds) FilterComp)
isImageFilename :: Token FilePath -> DepGenM Bool
isImageFilename = runFunction IsImageFilename
convertedImageFilename :: Token FilePath -> DepGenM FilePath
convertedImageFilename = runFunction ConvertedImageFilename
listDirectory :: Token FilePath -> DepGenM [FilePath]
listDirectory = runFunctionIO ListDirectory
readTemplate :: Token FilePath -> DepGenM Template
readTemplate = runFunctionIO ReadTemplate
convertImage :: Token ((FilePath, FilePath), ImageConversionSettings) -> DepGenM ()
convertImage = runFunctionIO ConvertImage
saveFile :: Token (String, FilePath) -> DepGenM ()
saveFile = runFunctionIO SaveFile
runPandoc :: Token String -> DepGenM String
runPandoc = runFunctionIO RunPandoc

View File

@ -0,0 +1,8 @@
module Evaluation.Function
( evalFunction
) where
import Types (Function(..))
evalFunction :: Function -> a -> b
evalFunction = undefined

View File

@ -0,0 +1,8 @@
module Evaluation.FunctionIO
( evalFunctionIO
) where
import Types (FunctionIO(..))
evalFunctionIO :: FunctionIO -> a -> b
evalFunctionIO = undefined

View File

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

View File

@ -1,19 +0,0 @@
module FunctionImplementations.Pure
( -- IsImageFilename(..)
-- , ConvertedImageFilename(..)
) where
import Sources()
import Types
import Language.Haskell.TH.Syntax
-- 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

View File

@ -1,32 +0,0 @@
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Functions
( isImageFilename
, convertedImageFilename
, listDirectory
, readTemplate
, convertImage
, saveFile
, runPandoc
) where
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

View File

@ -1,24 +0,0 @@
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

View File

@ -1,14 +1,14 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Main where module Main where
import Dependency import Types (Dependency)
import ComputationM import DependencyGenerator (evalDepGenM)
import Generator import SiteGenerator (generateSite)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax (lift)
dependencies :: [DependencyUntyped] dependencies :: [Dependency]
dependencies = $(lift (evalComputationM generate)) dependencies = $(lift (evalDepGenM generateSite))
main :: IO () main :: IO ()
main = mapM_ print dependencies main = mapM_ print dependencies

22
byg/src/SiteGenerator.hs Normal file
View File

@ -0,0 +1,22 @@
module SiteGenerator (generateSite) where
import Types
import DependencyGenerator
handleRecipeDir :: Token Template -> Token FilePath -> DepGenM ()
handleRecipeDir _template dir = do
dirContents <- listDirectory dir
imageFilenames <- filterDepGenM isImageFilename dirContents
convertedImageFilenames <- mapDepGenM convertedImageFilename imageFilenames
flip mapDepGenM_ (ZipToken imageFilenames convertedImageFilenames) $ \files -> do
settings <- inject $ ResizeToWidth 800
convertImage $ TupleToken files settings
generateSite :: DepGenM ()
generateSite = do
templateFilename <- inject "template.html"
template <- readTemplate templateFilename
dir <- inject "retter"
dirContents <- listDirectory dir
mapDepGenM_ (handleRecipeDir template) dirContents

View File

@ -1,18 +0,0 @@
{-# OPTIONS_GHC -Wno-orphans #-}
module Sources where
-- TODO: Figure out if any of this is useful.
import Types
-- data Source a where
-- Data :: a -> Source a
-- instance SourceState FilePath where
-- stateOfSource = undefined
-- instance SourceState ((FilePath, FilePath), ImageConversionSettings) where
-- stateOfSource = undefined
-- instance SourceState (String, FilePath) where
-- stateOfSource = undefined

View File

@ -1,58 +1,15 @@
{-# LANGUAGE FunctionalDependencies #-} module Types
module Types where ( module Types.Token
, module Types.Values
, module Types.Value
, module Types.Function
, module Types.FunctionIO
, Dependency
) where
import Data.ByteString (ByteString) import Types.Token
import Language.Haskell.TH.Syntax import Types.Values
import Types.Value
data ImageConversionSettings = ResizeToWidth Int import Types.Function
deriving (Show, Lift) import Types.FunctionIO
import Dependency
data TemplatePart = Literal String
| KeyValue String
deriving (Show, Lift)
data Template = Template [TemplatePart]
deriving (Show, Lift)
-- class (Show f, Lift f) => IsFunctionId f
-- class (IsFunctionId f, SourceState a) => IsFunction f a b | f -> a b where
-- runF :: f -> a -> b
-- 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

10
byg/src/Types/Function.hs Normal file
View File

@ -0,0 +1,10 @@
module Types.Function
( Function(..)
) where
import Language.Haskell.TH.Syntax (Lift)
data Function = IsImageFilename
| ConvertedImageFilename
deriving (Show, Lift)

View File

@ -0,0 +1,12 @@
module Types.FunctionIO
( FunctionIO(..)
) where
import Language.Haskell.TH.Syntax (Lift)
data FunctionIO = ListDirectory
| ReadTemplate
| ConvertImage
| SaveFile
| RunPandoc
deriving (Show, Lift)

15
byg/src/Types/Token.hs Normal file
View File

@ -0,0 +1,15 @@
{-# LANGUAGE GADTs #-}
module Types.Token
( Token(..)
) where
import Language.Haskell.TH.Syntax (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)

21
byg/src/Types/Value.hs Normal file
View File

@ -0,0 +1,21 @@
module Types.Value
( Value(..)
, Valuable(..)
) where
import Types.Values
import Language.Haskell.TH.Syntax (Lift)
data Value = String String
| ImageConversionSettings ImageConversionSettings
deriving (Show, Lift)
class Valuable a where
toValue :: a -> Value
instance Valuable String where
toValue = String
instance Valuable ImageConversionSettings where
toValue = ImageConversionSettings

17
byg/src/Types/Values.hs Normal file
View File

@ -0,0 +1,17 @@
module Types.Values
( ImageConversionSettings(..)
, TemplatePart(..)
, Template(..)
) where
import Language.Haskell.TH.Syntax (Lift)
data ImageConversionSettings = ResizeToWidth Int
deriving (Show, Lift)
data TemplatePart = Literal String
| KeyValue String
deriving (Show, Lift)
data Template = Template [TemplatePart]
deriving (Show, Lift)