From f348bd1e826a76575a739d53a49b2e7e8090853c Mon Sep 17 00:00:00 2001 From: "Niels G. W. Serup" Date: Thu, 10 Oct 2024 23:53:54 +0200 Subject: [PATCH] Change Value type to just be Dynamic Restructure into more modules. --- byg/byg.cabal | 14 +- byg/src/DependencyGenerator.hs | 5 +- byg/src/DependencyRunner.hs | 65 +++----- byg/src/Function.hs | 139 ------------------ byg/src/FunctionIO.hs | 105 ------------- byg/src/Functions.hs | 15 ++ byg/src/Functions/General.hs | 18 +++ byg/src/Functions/Image.hs | 58 ++++++++ byg/src/Functions/Pandoc.hs | 24 +++ byg/src/Functions/Paths.hs | 90 ++++++++++++ byg/src/Functions/Template.hs | 33 +++++ byg/src/Functions/Text.hs | 69 +++++++++ byg/src/SiteGenerator.hs | 17 +-- byg/src/Types.hs | 8 +- byg/src/Types/Dependency.hs | 3 +- byg/src/Types/Function.hs | 9 -- byg/src/Types/{FunctionIO.hs => Functions.hs} | 8 +- byg/src/Types/Value.hs | 128 ++++------------ byg/src/Types/Values.hs | 37 ----- 19 files changed, 378 insertions(+), 467 deletions(-) delete mode 100644 byg/src/Function.hs delete mode 100644 byg/src/FunctionIO.hs create mode 100644 byg/src/Functions.hs create mode 100644 byg/src/Functions/General.hs create mode 100644 byg/src/Functions/Image.hs create mode 100644 byg/src/Functions/Pandoc.hs create mode 100644 byg/src/Functions/Paths.hs create mode 100644 byg/src/Functions/Template.hs create mode 100644 byg/src/Functions/Text.hs delete mode 100644 byg/src/Types/Function.hs rename byg/src/Types/{FunctionIO.hs => Functions.hs} (58%) delete mode 100644 byg/src/Types/Values.hs diff --git a/byg/byg.cabal b/byg/byg.cabal index f044e5e..d82ef79 100644 --- a/byg/byg.cabal +++ b/byg/byg.cabal @@ -21,15 +21,18 @@ library hs-source-dirs: src exposed-modules: Types.Token - Types.Values Types.Value - Types.Function - Types.FunctionIO + Types.Functions Types.Dependency Types DependencyGenerator - Function - FunctionIO + Functions.General + Functions.Image + Functions.Pandoc + Functions.Paths + Functions.Template + Functions.Text + Functions DependencyRunner SiteGenerator Precomputer @@ -50,5 +53,4 @@ executable byg main-is: src/Main.hs build-depends: base >=4.14 && <4.20 - , text , byg diff --git a/byg/src/DependencyGenerator.hs b/byg/src/DependencyGenerator.hs index 79f3926..16f42b5 100644 --- a/byg/src/DependencyGenerator.hs +++ b/byg/src/DependencyGenerator.hs @@ -25,12 +25,9 @@ module DependencyGenerator , unzipDepGenM ) where -import Prelude hiding (String, FilePath) - import Types.Token (Token(..)) import Types.Value (Valuable(..)) -import Types.FunctionIO (IsFunctionIO(..)) -import Types.Function (IsFunction(..)) +import Types.Functions (IsFunction(), IsFunctionIO(..)) import Types.Dependency (Action(..), Dependency, makeDependency, makeUToken) import Control.Monad.State (MonadState, State, runState, put, get) diff --git a/byg/src/DependencyRunner.hs b/byg/src/DependencyRunner.hs index 4b223e7..1d36ea7 100644 --- a/byg/src/DependencyRunner.hs +++ b/byg/src/DependencyRunner.hs @@ -4,12 +4,12 @@ module DependencyRunner , runDepRunMIO ) where -import Types (Value(..), Valuable(..), evalFunction, evalFunctionIO) +import Types (Value(..), fromValue, toValue, evalFunction, evalFunctionIO) import Types.Dependency import Data.Map (Map) import qualified Data.Map as M -import Control.Monad (void) +import Control.Monad (void, forM) import Control.Monad.State (MonadState, MonadIO, StateT, evalStateT, get, modify, liftIO) data ValueExistence = Evaluated Value @@ -46,6 +46,12 @@ runDep (Dependency a action b) = putStrLn "----------" pure result +foo' :: [Value] -> [Value] -> [(Value, Value)] +foo' = zip + +foo :: Value -> Value -> Value +foo va vb = toValue $ foo' (fromValue va) (fromValue vb) + getTokenValue :: UToken -> DepRunM Value getTokenValue = \case UToken i -> do @@ -54,20 +60,16 @@ getTokenValue = \case UTupleToken a b -> do va <- getTokenValue a vb <- getTokenValue b - pure $ Tuple (va, vb) + pure $ toValue (va, vb) UZipToken a b -> do va <- getTokenValue a vb <- getTokenValue b - case (va, vb) of - (List as, List bs) -> - pure $ List $ zipWith (curry Tuple) as bs - _ -> - error "unexpected" + pure $ foo va vb UListToken ts -> do vs <- mapM getTokenValue ts - pure $ List vs + pure $ toValue vs UNoToken -> - pure Empty + pure $ toValue () putTokenValue :: UToken -> ValueExistence -> DepRunM () putTokenValue t e = case t of @@ -87,41 +89,18 @@ runAction action input = case action of Inject v -> pure v FilterComp -> - case input of - Tuple (List vs, List mask) -> - pure $ List $ map fst $ filter (fromValue . snd) $ zip vs mask - _ -> - error "unexpected" + let (vs, mask) = fromValue input :: ([Value], [Value]) + in pure $ toValue $ map fst $ filter (fromValue . snd) $ zip vs mask UntupleFst -> - case input of - Tuple (v, _) -> - pure v - _ -> - error "unexpected" + pure $ fst (fromValue input :: (Value, Value)) UntupleSnd -> - case input of - Tuple (_, v) -> - pure v - _ -> - error "unexpected" + pure $ snd (fromValue input :: (Value, Value)) UnzipFst -> - case input of - List vs -> - List <$> mapM (runAction UntupleFst) vs - _ -> - error "unexpected" + toValue <$> mapM (runAction UntupleFst) (fromValue input :: [Value]) UnzipSnd -> - case input of - List vs -> - List <$> mapM (runAction UntupleSnd) vs - _ -> - error "unexpected" + toValue <$> mapM (runAction UntupleSnd) (fromValue input :: [Value]) MapComp subDeps innerInput innerOutput -> - case input of - List vs -> - (List <$>) $ flip mapM vs $ \v -> do - putTokenValue innerInput $ Evaluated v - runDeps subDeps - getTokenValue innerOutput - _ -> - error "unexpected" + (toValue <$>) $ forM (fromValue input :: [Value]) $ \v -> do + putTokenValue innerInput $ Evaluated v + runDeps subDeps + getTokenValue innerOutput diff --git a/byg/src/Function.hs b/byg/src/Function.hs deleted file mode 100644 index 04d3cb3..0000000 --- a/byg/src/Function.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Function - ( concatStrings - , concatTexts - , joinPaths - , fileComponents - , lowerString - , elemOf - , makeTemplate - , applyTemplate - , toText - , convertImage - , runPandoc - ) where - -import Prelude hiding (String, FilePath) - -import Types.Values -import Types.Value (Valuable) -import Types.Function -import Types.Token (Token(..)) -import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction) - -import Type.Reflection (Typeable, TypeRep, typeRep) -import qualified Codec.Picture as CP -import qualified Codec.Picture.STBIR as CPS -import Data.Char (toLower) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Text.Pandoc as P -import qualified Text.Blaze.Html.Renderer.Text as B - - -data ConcatStrings = ConcatStrings deriving Show -instance IsFunction ConcatStrings [String] String where - evalFunction ConcatStrings = StringWrapper . concatMap unStringWrapper - -concatStrings :: TokenableTo [String] a => a -> DepGenM (Token String) -concatStrings a = runFunction ConcatStrings =<< toToken a - - -data ConcatTexts = ConcatTexts deriving Show -instance IsFunction ConcatTexts [Text] Text where - evalFunction ConcatTexts = T.concat - -concatTexts :: TokenableTo [Text] a => a -> DepGenM (Token Text) -concatTexts a = runFunction ConcatTexts =<< toToken a - - -data JoinPaths = JoinPaths deriving Show -instance IsFunction JoinPaths (FilePath, FilePath) FilePath where - evalFunction JoinPaths (StringWrapper s0, StringWrapper s1) = StringWrapper (s0 ++ "/" ++ s1) - -joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM (Token FilePath) -joinPaths a b = runFunction JoinPaths =<< TupleToken <$> toToken a <*> toToken b - - -data FileComponents = FileComponents deriving Show -instance IsFunction FileComponents FilePath (String, String) where - evalFunction FileComponents (StringWrapper s) = - let (lastRev, firstRev) = span (/= '.') $ reverse s - (base, ext) = case firstRev of - _ : firstRev' -> (reverse firstRev', reverse lastRev) - [] -> (reverse lastRev, "") - in (StringWrapper base, StringWrapper ext) - -fileComponents :: TokenableTo FilePath a => a -> DepGenM (Token (String, String)) -fileComponents a = runFunction FileComponents =<< toToken a - - -data LowerString = LowerString deriving Show -instance IsFunction LowerString String String where - evalFunction LowerString (StringWrapper s) = StringWrapper (map toLower s) - -lowerString :: TokenableTo String a => a -> DepGenM (Token String) -lowerString a = runFunction LowerString =<< toToken a - - -data ElemOf a where ElemOf :: TypeRep a -> ElemOf a -deriving instance Show (ElemOf a) -instance (Show a, Valuable a, Eq a) => IsFunction (ElemOf a) (a, [a]) Bool where - evalFunction (ElemOf _) (y, ys) = y `elem` ys - -elemOf :: forall t a b. (Show t, Valuable t, Eq t, TokenableTo t a, TokenableTo [t] b, Typeable t) => a -> b -> DepGenM (Token Bool) -elemOf a b = runFunction (ElemOf (typeRep :: TypeRep t)) =<< toTupleToken a b - - -data MakeTemplate = MakeTemplate deriving Show -instance IsFunction MakeTemplate (Text, Text) Template where - evalFunction MakeTemplate (t, c) = - let (beforeContent, after) = T.breakOn c t - afterContent = T.drop (T.length c) after - in TemplateParts beforeContent afterContent - -makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM (Token Template) -makeTemplate a b = runFunction MakeTemplate =<< toTupleToken a b - - -data ApplyTemplate = ApplyTemplate deriving Show -instance IsFunction ApplyTemplate (Template, Text) Text where - evalFunction ApplyTemplate (TemplateParts beforeContent afterContent, t) = - T.concat [beforeContent, t, afterContent] - -applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM (Token Text) -applyTemplate a b = runFunction ApplyTemplate =<< toTupleToken a b - - -data ToText = ToText deriving Show -instance IsFunction ToText String Text where - evalFunction ToText (StringWrapper s) = T.pack s - -toText :: TokenableTo String a => a -> DepGenM (Token Text) -toText a = runFunction ToText =<< toToken a - - -data ConvertImage = ConvertImage deriving Show -instance IsFunction ConvertImage (Image, ImageConversionSettings) Image where - evalFunction ConvertImage (ImageWrapper image, ResizeToWidth widthResized) = - let sizeFactor :: Double - sizeFactor = fromIntegral (CP.imageWidth image) / fromIntegral widthResized - heightResized = round (fromIntegral (CP.imageHeight image) / sizeFactor) - in ImageWrapper $ CPS.resize CPS.defaultOptions widthResized heightResized image - -convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM (Token Image) -convertImage a b = runFunction ConvertImage =<< toTupleToken a b - - -data RunPandoc = RunPandoc deriving Show -instance IsFunction RunPandoc Text Text where - evalFunction RunPandoc contents = - let settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] } - m = P.writeHtml5 P.def =<< P.readMarkdown settings contents - in case P.runPure m of - Left e -> error ("unexpected pandoc error: " ++ show e) - Right html -> TL.toStrict $ B.renderHtml html - -runPandoc :: TokenableTo Text a => a -> DepGenM (Token Text) -runPandoc a = runFunction RunPandoc =<< toToken a diff --git a/byg/src/FunctionIO.hs b/byg/src/FunctionIO.hs deleted file mode 100644 index 28bb4df..0000000 --- a/byg/src/FunctionIO.hs +++ /dev/null @@ -1,105 +0,0 @@ -module FunctionIO - ( listDirectory - , isDirectory - , readTextFile - , openImage - , saveImage - , saveTextFile - , copyFile - , makeDir - ) where - -import Prelude hiding (String, FilePath) - -import Types.Values -import Types.FunctionIO -import Types.Token (Token(..)) -import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunctionIO, runFunctionIO_) - -import Data.Text (Text) -import qualified Data.Text.IO as T -import qualified Codec.Picture as CP -import qualified System.Directory as SD - - -data ListDirectory = ListDirectory deriving Show -instance IsFunctionIO ListDirectory FilePath [FilePath] where - evalFunctionIO ListDirectory (StringWrapper s) = - map StringWrapper <$> SD.listDirectory s - functionIOTouchesFilesystem ListDirectory = False - -listDirectory :: TokenableTo FilePath a => a -> DepGenM (Token [FilePath]) -listDirectory a = runFunctionIO ListDirectory =<< toToken a - - -data IsDirectory = IsDirectory deriving Show -instance IsFunctionIO IsDirectory FilePath Bool where - evalFunctionIO IsDirectory (StringWrapper s) = - SD.doesDirectoryExist s - functionIOTouchesFilesystem IsDirectory = False - -isDirectory :: TokenableTo FilePath a => a -> DepGenM (Token Bool) -isDirectory a = runFunctionIO IsDirectory =<< toToken a - - -data ReadTextFile = ReadTextFile deriving Show -instance IsFunctionIO ReadTextFile FilePath Text where - evalFunctionIO ReadTextFile (StringWrapper s) = - T.readFile s - functionIOTouchesFilesystem ReadTextFile = False - -readTextFile :: TokenableTo FilePath a => a -> DepGenM (Token Text) -readTextFile a = runFunctionIO ReadTextFile =<< toToken a - - -data OpenImage = OpenImage deriving Show -instance IsFunctionIO OpenImage FilePath Image where - evalFunctionIO OpenImage (StringWrapper s) = do - imageOrig <- CP.readImage s - case imageOrig of - Left e -> error ("unexpected error: " ++ e) - Right image -> pure $ ImageWrapper $ CP.convertRGB8 image - functionIOTouchesFilesystem OpenImage = False - -openImage :: TokenableTo FilePath a => a -> DepGenM (Token Image) -openImage a = runFunctionIO OpenImage =<< toToken a - - -data SaveImage = SaveImage deriving Show -instance IsFunctionIO SaveImage (Image, FilePath) () where - evalFunctionIO SaveImage (ImageWrapper image, StringWrapper s) = - CP.saveJpgImage 90 s $ CP.ImageRGB8 image - functionIOTouchesFilesystem SaveImage = True - -saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM () -saveImage a b = runFunctionIO_ SaveImage =<< toTupleToken a b - - -data SaveTextFile = SaveTextFile deriving Show -instance IsFunctionIO SaveTextFile (Text, FilePath) () where - evalFunctionIO SaveTextFile (t, StringWrapper s) = - T.writeFile s t - functionIOTouchesFilesystem SaveTextFile = True - -saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM () -saveTextFile a b = runFunctionIO_ SaveTextFile =<< toTupleToken a b - - -data CopyFile = CopyFile deriving Show -instance IsFunctionIO CopyFile (FilePath, FilePath) () where - evalFunctionIO CopyFile (StringWrapper source, StringWrapper target) = - SD.copyFile source target - functionIOTouchesFilesystem CopyFile = True - -copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM () -copyFile a b = runFunctionIO_ CopyFile =<< toTupleToken a b - - -data MakeDir = MakeDir deriving Show -instance IsFunctionIO MakeDir FilePath () where - evalFunctionIO MakeDir (StringWrapper s) = - SD.createDirectory s - functionIOTouchesFilesystem MakeDir = True - -makeDir :: TokenableTo FilePath a => a -> DepGenM () -makeDir a = runFunctionIO_ MakeDir =<< toToken a diff --git a/byg/src/Functions.hs b/byg/src/Functions.hs new file mode 100644 index 0000000..94ef3da --- /dev/null +++ b/byg/src/Functions.hs @@ -0,0 +1,15 @@ +module Functions + ( module Functions.General + , module Functions.Image + , module Functions.Pandoc + , module Functions.Paths + , module Functions.Template + , module Functions.Text + ) where + +import Functions.General +import Functions.Image +import Functions.Pandoc +import Functions.Paths +import Functions.Template +import Functions.Text diff --git a/byg/src/Functions/General.hs b/byg/src/Functions/General.hs new file mode 100644 index 0000000..f6ab01c --- /dev/null +++ b/byg/src/Functions/General.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GADTs #-} +module Functions.General + ( elemOf + ) where + +import Types (Valuable, IsFunction(..), Token) +import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction) + +import Type.Reflection (Typeable, TypeRep, typeRep) + + +data ElemOf a where ElemOf :: TypeRep a -> ElemOf a +deriving instance Show (ElemOf a) +instance (Show a, Valuable a, Eq a) => IsFunction (ElemOf a) (a, [a]) Bool where + evalFunction (ElemOf _) (y, ys) = y `elem` ys + +elemOf :: forall t a b. (Show t, Valuable t, Eq t, TokenableTo t a, TokenableTo [t] b, Typeable t) => a -> b -> DepGenM (Token Bool) +elemOf a b = runFunction (ElemOf (typeRep :: TypeRep t)) =<< toTupleToken a b diff --git a/byg/src/Functions/Image.hs b/byg/src/Functions/Image.hs new file mode 100644 index 0000000..57d058b --- /dev/null +++ b/byg/src/Functions/Image.hs @@ -0,0 +1,58 @@ +module Functions.Image + ( Image(..) + , ImageConversionSettings(..) + , openImage + , saveImage + , convertImage + ) where + +import Types (IsFunction(..), IsFunctionIO(..), Token) +import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, + runFunction, runFunctionIO, runFunctionIO_) + +import qualified Codec.Picture as CP +import qualified Codec.Picture.STBIR as CPS + + +newtype Image = ImageWrapper (CP.Image CP.PixelRGB8) + deriving (Eq) + +instance Show Image where + show = const "" + +data ImageConversionSettings = ResizeToWidth Int + deriving (Eq, Show) + +data OpenImage = OpenImage deriving Show +instance IsFunctionIO OpenImage FilePath Image where + evalFunctionIO OpenImage s = do + imageOrig <- CP.readImage s + case imageOrig of + Left e -> error ("unexpected error: " ++ e) + Right image -> pure $ ImageWrapper $ CP.convertRGB8 image + functionIOTouchesFilesystem OpenImage = False + +openImage :: TokenableTo FilePath a => a -> DepGenM (Token Image) +openImage a = runFunctionIO OpenImage =<< toToken a + + +data SaveImage = SaveImage deriving Show +instance IsFunctionIO SaveImage (Image, FilePath) () where + evalFunctionIO SaveImage (ImageWrapper image, s) = + CP.saveJpgImage 90 s $ CP.ImageRGB8 image + functionIOTouchesFilesystem SaveImage = True + +saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM () +saveImage a b = runFunctionIO_ SaveImage =<< toTupleToken a b + + +data ConvertImage = ConvertImage deriving Show +instance IsFunction ConvertImage (Image, ImageConversionSettings) Image where + evalFunction ConvertImage (ImageWrapper image, ResizeToWidth widthResized) = + let sizeFactor :: Double + sizeFactor = fromIntegral (CP.imageWidth image) / fromIntegral widthResized + heightResized = round (fromIntegral (CP.imageHeight image) / sizeFactor) + in ImageWrapper $ CPS.resize CPS.defaultOptions widthResized heightResized image + +convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM (Token Image) +convertImage a b = runFunction ConvertImage =<< toTupleToken a b diff --git a/byg/src/Functions/Pandoc.hs b/byg/src/Functions/Pandoc.hs new file mode 100644 index 0000000..ce70da5 --- /dev/null +++ b/byg/src/Functions/Pandoc.hs @@ -0,0 +1,24 @@ +module Functions.Pandoc + ( runPandoc + ) where + +import Types (IsFunction(..), Token) +import DependencyGenerator (DepGenM, TokenableTo(..), runFunction) + +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import qualified Text.Pandoc as P +import qualified Text.Blaze.Html.Renderer.Text as B + + +data RunPandoc = RunPandoc deriving Show +instance IsFunction RunPandoc Text Text where + evalFunction RunPandoc contents = + let settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] } + m = P.writeHtml5 P.def =<< P.readMarkdown settings contents + in case P.runPure m of + Left e -> error ("unexpected pandoc error: " ++ show e) + Right html -> TL.toStrict $ B.renderHtml html + +runPandoc :: TokenableTo Text a => a -> DepGenM (Token Text) +runPandoc a = runFunction RunPandoc =<< toToken a diff --git a/byg/src/Functions/Paths.hs b/byg/src/Functions/Paths.hs new file mode 100644 index 0000000..708ee0e --- /dev/null +++ b/byg/src/Functions/Paths.hs @@ -0,0 +1,90 @@ +module Functions.Paths + ( joinPaths + , fileComponents + , hasExtension + , listDirectory + , isDirectory + , makeDir + , copyFile + , copyTo + ) where + +import Functions.Text (lowerString) +import Functions.General (elemOf) +import Types (IsFunction(..), IsFunctionIO(..), Token(..)) +import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction, + runFunctionIO, runFunctionIO_, untupleSndDepGenM) + +import qualified System.Directory as SD + + +data JoinPaths = JoinPaths deriving Show +instance IsFunction JoinPaths (FilePath, FilePath) FilePath where + evalFunction JoinPaths (s0, s1) = s0 ++ "/" ++ s1 + +joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM (Token FilePath) +joinPaths a b = runFunction JoinPaths =<< TupleToken <$> toToken a <*> toToken b + + +data FileComponents = FileComponents deriving Show +instance IsFunction FileComponents FilePath (String, String) where + evalFunction FileComponents s = + let (lastRev, firstRev) = span (/= '.') $ reverse s + (base, ext) = case firstRev of + _ : firstRev' -> (reverse firstRev', reverse lastRev) + [] -> (reverse lastRev, "") + in (base, ext) + +fileComponents :: TokenableTo FilePath a => a -> DepGenM (Token (String, String)) +fileComponents a = runFunction FileComponents =<< toToken a + +hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM (Token Bool) +hasExtension exts filename = do + ext <- lowerString =<< untupleSndDepGenM =<< fileComponents filename + ext `elemOf` exts + + +data ListDirectory = ListDirectory deriving Show +instance IsFunctionIO ListDirectory FilePath [FilePath] where + evalFunctionIO ListDirectory s = + SD.listDirectory s + functionIOTouchesFilesystem ListDirectory = False + +listDirectory :: TokenableTo FilePath a => a -> DepGenM (Token [FilePath]) +listDirectory a = runFunctionIO ListDirectory =<< toToken a + + +data IsDirectory = IsDirectory deriving Show +instance IsFunctionIO IsDirectory FilePath Bool where + evalFunctionIO IsDirectory s = + SD.doesDirectoryExist s + functionIOTouchesFilesystem IsDirectory = False + +isDirectory :: TokenableTo FilePath a => a -> DepGenM (Token Bool) +isDirectory a = runFunctionIO IsDirectory =<< toToken a + + +data MakeDir = MakeDir deriving Show +instance IsFunctionIO MakeDir FilePath () where + evalFunctionIO MakeDir s = + SD.createDirectory s + functionIOTouchesFilesystem MakeDir = True + +makeDir :: TokenableTo FilePath a => a -> DepGenM () +makeDir a = runFunctionIO_ MakeDir =<< toToken a + + +data CopyFile = CopyFile deriving Show +instance IsFunctionIO CopyFile (FilePath, FilePath) () where + evalFunctionIO CopyFile (source, target) = + SD.copyFile source target + functionIOTouchesFilesystem CopyFile = True + +copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM () +copyFile a b = runFunctionIO_ CopyFile =<< toTupleToken a b + +copyTo :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM () +copyTo path targetDir = do + pathToken <- toToken path + copyFile pathToken =<< joinPaths targetDir pathToken + diff --git a/byg/src/Functions/Template.hs b/byg/src/Functions/Template.hs new file mode 100644 index 0000000..cb58cf4 --- /dev/null +++ b/byg/src/Functions/Template.hs @@ -0,0 +1,33 @@ +module Functions.Template + ( Template(..) + , makeTemplate + , applyTemplate + ) where + +import Types (IsFunction(..), Token) +import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction) + +import Data.Text (Text) +import qualified Data.Text as T + +data Template = TemplateParts Text Text + deriving (Eq, Show) + +data MakeTemplate = MakeTemplate deriving Show +instance IsFunction MakeTemplate (Text, Text) Template where + evalFunction MakeTemplate (t, c) = + let (beforeContent, after) = T.breakOn c t + afterContent = T.drop (T.length c) after + in TemplateParts beforeContent afterContent + +makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM (Token Template) +makeTemplate a b = runFunction MakeTemplate =<< toTupleToken a b + + +data ApplyTemplate = ApplyTemplate deriving Show +instance IsFunction ApplyTemplate (Template, Text) Text where + evalFunction ApplyTemplate (TemplateParts beforeContent afterContent, t) = + T.concat [beforeContent, t, afterContent] + +applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM (Token Text) +applyTemplate a b = runFunction ApplyTemplate =<< toTupleToken a b diff --git a/byg/src/Functions/Text.hs b/byg/src/Functions/Text.hs new file mode 100644 index 0000000..e848eb8 --- /dev/null +++ b/byg/src/Functions/Text.hs @@ -0,0 +1,69 @@ +module Functions.Text + ( concatStrings + , concatTexts + , lowerString + , toText + , readTextFile + , saveTextFile + ) where + +import Types (IsFunction(..), IsFunctionIO(..), Token) +import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, + runFunction, runFunctionIO, runFunctionIO_) + +import Data.Char (toLower) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T + + +data ConcatStrings = ConcatStrings deriving Show +instance IsFunction ConcatStrings [String] String where + evalFunction ConcatStrings = concat + +concatStrings :: TokenableTo [String] a => a -> DepGenM (Token String) +concatStrings a = runFunction ConcatStrings =<< toToken a + + +data ConcatTexts = ConcatTexts deriving Show +instance IsFunction ConcatTexts [Text] Text where + evalFunction ConcatTexts = T.concat + +concatTexts :: TokenableTo [Text] a => a -> DepGenM (Token Text) +concatTexts a = runFunction ConcatTexts =<< toToken a + + +data LowerString = LowerString deriving Show +instance IsFunction LowerString String String where + evalFunction LowerString s = map toLower s + +lowerString :: TokenableTo String a => a -> DepGenM (Token String) +lowerString a = runFunction LowerString =<< toToken a + + +data ToText = ToText deriving Show +instance IsFunction ToText String Text where + evalFunction ToText s = T.pack s + +toText :: TokenableTo String a => a -> DepGenM (Token Text) +toText a = runFunction ToText =<< toToken a + + +data ReadTextFile = ReadTextFile deriving Show +instance IsFunctionIO ReadTextFile FilePath Text where + evalFunctionIO ReadTextFile s = + T.readFile s + functionIOTouchesFilesystem ReadTextFile = False + +readTextFile :: TokenableTo FilePath a => a -> DepGenM (Token Text) +readTextFile a = runFunctionIO ReadTextFile =<< toToken a + + +data SaveTextFile = SaveTextFile deriving Show +instance IsFunctionIO SaveTextFile (Text, FilePath) () where + evalFunctionIO SaveTextFile (t, s) = + T.writeFile s t + functionIOTouchesFilesystem SaveTextFile = True + +saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM () +saveTextFile a b = runFunctionIO_ SaveTextFile =<< toTupleToken a b diff --git a/byg/src/SiteGenerator.hs b/byg/src/SiteGenerator.hs index 7fda704..92f7959 100644 --- a/byg/src/SiteGenerator.hs +++ b/byg/src/SiteGenerator.hs @@ -1,24 +1,11 @@ module SiteGenerator (generateSite) where -import Prelude hiding (String, FilePath) - -import Types +import Types (Token) import DependencyGenerator -import Function -import FunctionIO +import Functions import Control.Monad (forM_) -copyTo :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM () -copyTo path targetDir = do - pathToken <- toToken path - copyFile pathToken =<< joinPaths targetDir pathToken - -hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM (Token Bool) -hasExtension exts filename = do - ext <- lowerString =<< untupleSndDepGenM =<< fileComponents filename - ext `elemOf` exts - handleRecipeDir :: Token FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM () handleRecipeDir outputDir htmlTemplate indexName dir = do recipeDirOut <- joinPaths outputDir dir diff --git a/byg/src/Types.hs b/byg/src/Types.hs index 645c6d8..fdac6c4 100644 --- a/byg/src/Types.hs +++ b/byg/src/Types.hs @@ -1,15 +1,11 @@ module Types ( module Types.Token - , module Types.Values , module Types.Value - , module Types.Function - , module Types.FunctionIO + , module Types.Functions , Dependency ) where import Types.Token -import Types.Values import Types.Value -import Types.Function -import Types.FunctionIO +import Types.Functions import Types.Dependency (Dependency) diff --git a/byg/src/Types/Dependency.hs b/byg/src/Types/Dependency.hs index b9ad474..48ed13d 100644 --- a/byg/src/Types/Dependency.hs +++ b/byg/src/Types/Dependency.hs @@ -11,8 +11,7 @@ module Types.Dependency import Types.Token (Token(..)) import Types.Value (Value) -import Types.Function (IsFunction()) -import Types.FunctionIO (IsFunctionIO(..)) +import Types.Functions (IsFunction(), IsFunctionIO(..)) import Text.Printf (printf) import Data.Text (Text) diff --git a/byg/src/Types/Function.hs b/byg/src/Types/Function.hs deleted file mode 100644 index ca41d0c..0000000 --- a/byg/src/Types/Function.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -module Types.Function - ( IsFunction(..) - ) where - -import Types.Value (Valuable) - -class (Show f, Valuable a, Valuable b) => IsFunction f a b | f -> a b where - evalFunction :: f -> a -> b diff --git a/byg/src/Types/FunctionIO.hs b/byg/src/Types/Functions.hs similarity index 58% rename from byg/src/Types/FunctionIO.hs rename to byg/src/Types/Functions.hs index 9ba90be..0c903e4 100644 --- a/byg/src/Types/FunctionIO.hs +++ b/byg/src/Types/Functions.hs @@ -1,10 +1,14 @@ {-# LANGUAGE FunctionalDependencies #-} -module Types.FunctionIO - ( IsFunctionIO(..) +module Types.Functions + ( IsFunction(..) + , IsFunctionIO(..) ) where import Types.Value (Valuable) +class (Show f, Valuable a, Valuable b) => IsFunction f a b | f -> a b where + evalFunction :: f -> a -> b + class (Show f, Valuable a, Valuable b) => IsFunctionIO f a b | f -> a b where evalFunctionIO :: f -> a -> IO b functionIOTouchesFilesystem :: f -> Bool diff --git a/byg/src/Types/Value.hs b/byg/src/Types/Value.hs index bfa1269..3412f07 100644 --- a/byg/src/Types/Value.hs +++ b/byg/src/Types/Value.hs @@ -1,117 +1,47 @@ {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} module Types.Value ( Value(..) , Valuable(..) - , WitnessFor(..) ) where -import Prelude hiding (String) +import Data.Dynamic -import Types.Values +data Value = Value { valueDynamic :: Dynamic + , valueShow :: String + } -import Data.Text (Text) +instance Show Value where + show = valueShow --- Note: We use a wrapper for the String type in order to be able to define the --- general Valuable [a] instance further down. Otherwise it would conflict with --- our Valuable String instance, since the non-wrapped String type is just an --- alias for [Char]. -data Value = String String - | Text Text - | Bool Bool - | Image Image - | ImageConversionSettings ImageConversionSettings - | Template Template - | Empty - | Tuple (Value, Value) - | List [Value] - deriving (Show) - -class Valuable a where +class Typeable a => Valuable a where toValue :: a -> Value fromValue :: Value -> a -instance Valuable String where - toValue = String - fromValue = \case - String a -> a - _ -> error "unexpected" +toValueOnce :: (Typeable a, Show a) => a -> Value +toValueOnce x = Value { valueDynamic = toDyn x + , valueShow = show x + } -instance Valuable Text where - toValue = Text - fromValue = \case - Text a -> a - _ -> error "unexpected" +fromValueOnce :: Typeable a => Value -> a +fromValueOnce = flip fromDyn (error "unexpected") . valueDynamic -instance Valuable Bool where - toValue = Bool - fromValue = \case - Bool a -> a - _ -> error "unexpected" +instance Valuable Value where + toValue = id + fromValue = id -instance Valuable Image where - toValue = Image - fromValue = \case - Image a -> a - _ -> error "unexpected" +instance {-# OVERLAPPABLE #-} Valuable String where + toValue = toValueOnce + fromValue = fromValueOnce -instance Valuable ImageConversionSettings where - toValue = ImageConversionSettings - fromValue = \case - ImageConversionSettings a -> a - _ -> error "unexpected" +instance {-# OVERLAPPABLE #-} Valuable a => Valuable [a] where + toValue = toValueOnce . map toValue + fromValue = map fromValue . fromValueOnce -instance Valuable Template where - toValue = Template - fromValue = \case - Template a -> a - _ -> error "unexpected" +instance {-# OVERLAPPABLE #-} (Valuable a, Valuable b) => Valuable (a, b) where + toValue (a, b) = toValueOnce (toValue a, toValue b) + fromValue v = let (va, vb) = fromValueOnce v + in (fromValue va, fromValue vb) -instance Valuable () where - toValue () = Empty - fromValue = \case - Empty -> () - _ -> error "unexpected" - -instance (Valuable a, Valuable b) => Valuable (a, b) where - toValue (a, b) = Tuple (toValue a, toValue b) - fromValue = \case - Tuple (va, vb) -> (fromValue va, fromValue vb) - _ -> error "unexpected" - -instance Valuable a => Valuable [a] where - toValue = List . map toValue - fromValue = \case - List a -> map fromValue a - _ -> error "unexpected" - - -class Show w => WitnessFor w t | w -> t, t -> w where - witnessValue :: w - -data StringType = StringType deriving Show -instance WitnessFor StringType String where witnessValue = StringType - -data TextType = TextType deriving Show -instance WitnessFor TextType Text where witnessValue = TextType - -data BoolType = BoolType deriving Show -instance WitnessFor BoolType Bool where witnessValue = BoolType - -data ImageType = ImageType deriving Show -instance WitnessFor ImageType Image where witnessValue = ImageType - -data ImageConversionSettingsType = ImageConversionSettingsType deriving Show -instance WitnessFor ImageConversionSettingsType ImageConversionSettings where witnessValue = ImageConversionSettingsType - -data TemplateType = TemplateType deriving Show -instance WitnessFor TemplateType Template where witnessValue = TemplateType - -data EmptyType = EmptyType deriving Show -instance WitnessFor EmptyType () where witnessValue = EmptyType - -data TupleType ta tb = TupleType ta tb deriving Show -instance (WitnessFor ta a, WitnessFor tb b) => WitnessFor (TupleType ta tb) (a, b) where witnessValue = TupleType witnessValue witnessValue - -data ListType t = ListType t deriving Show -instance WitnessFor t a => WitnessFor (ListType t) [a] where witnessValue = ListType witnessValue +instance {-# OVERLAPPABLE #-} (Typeable a, Show a) => Valuable a where + toValue = toValueOnce + fromValue = fromValueOnce diff --git a/byg/src/Types/Values.hs b/byg/src/Types/Values.hs deleted file mode 100644 index e52e3bb..0000000 --- a/byg/src/Types/Values.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Types.Values - ( String(..) - , FilePath - , Image(..) - , ImageConversionSettings(..) - , Template(..) - ) where - -import Prelude hiding (String, FilePath) -import qualified Prelude - -import Data.String (IsString(..)) -import Data.Text (Text) -import qualified Codec.Picture as CP - -newtype String = StringWrapper { unStringWrapper :: Prelude.String } - deriving (Eq) - -instance Show String where - show (StringWrapper s) = show s - -type FilePath = String - -instance IsString String where - fromString = StringWrapper - -newtype Image = ImageWrapper (CP.Image CP.PixelRGB8) - deriving (Eq) - -instance Show Image where - show = const "Image" - -data ImageConversionSettings = ResizeToWidth Int - deriving (Eq, Show) - -data Template = TemplateParts Text Text - deriving (Eq, Show)