diff --git a/byg/byg.cabal b/byg/byg.cabal index ca7b8e0..badc75a 100644 --- a/byg/byg.cabal +++ b/byg/byg.cabal @@ -28,8 +28,8 @@ library Types.Dependency Types DependencyGenerator + Function FunctionIO - Evaluation.Function DependencyRunner SiteGenerator Precomputer diff --git a/byg/src/DependencyGenerator.hs b/byg/src/DependencyGenerator.hs index cfb0fc6..79f3926 100644 --- a/byg/src/DependencyGenerator.hs +++ b/byg/src/DependencyGenerator.hs @@ -23,34 +23,18 @@ module DependencyGenerator , unzipFstDepGenM , unzipSndDepGenM , unzipDepGenM - - , concatStrings - , concatTexts - , joinPaths - , fileComponents - , lowerString - , elemOf - , makeTemplate - , applyTemplate - , toText - , convertImage - , runPandoc - - , hasExtension ) where import Prelude hiding (String, FilePath) import Types.Token (Token(..)) -import Types.Values import Types.Value (Valuable(..)) import Types.FunctionIO (IsFunctionIO(..)) -import Types.Function (Function(..)) +import Types.Function (IsFunction(..)) import Types.Dependency (Action(..), Dependency, makeDependency, makeUToken) import Control.Monad.State (MonadState, State, runState, put, get) import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell) -import Data.Text (Text) newtype DepGenM a = DepGenM { unDepGenM :: WriterT [Dependency] (State Int) a } deriving (Functor, Applicative, Monad, MonadState Int, MonadWriter [Dependency]) @@ -87,7 +71,7 @@ genDependency f = genDependencyM (pure . f) inject :: Valuable a => a -> DepGenM (Token a) inject x = genDependency (makeDependency NoToken (Inject (toValue x))) -runFunction :: Function -> Token a -> DepGenM (Token b) +runFunction :: IsFunction f a b => f -> Token a -> DepGenM (Token b) runFunction f input = genDependency (makeDependency input (Function f)) runFunctionIO :: IsFunctionIO f a b => f -> Token a -> DepGenM (Token b) @@ -194,41 +178,3 @@ unzipDepGenM t = do a <- unzipFstDepGenM t' b <- unzipSndDepGenM t' pure (a, b) - -concatStrings :: TokenableTo [String] a => a -> DepGenM (Token String) -concatStrings a = runFunction ConcatStrings =<< toToken a - -concatTexts :: TokenableTo [Text] a => a -> DepGenM (Token Text) -concatTexts a = runFunction ConcatTexts =<< toToken a - -joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM (Token FilePath) -joinPaths a b = runFunction JoinPaths =<< TupleToken <$> toToken a <*> toToken b - -fileComponents :: TokenableTo FilePath a => a -> DepGenM (Token (String, String)) -fileComponents a = runFunction FileComponents =<< toToken a - -lowerString :: TokenableTo String a => a -> DepGenM (Token String) -lowerString a = runFunction LowerString =<< toToken a - -elemOf :: (TokenableTo String a, TokenableTo [String] b) => a -> b -> DepGenM (Token Bool) -elemOf a b = runFunction ElemOf =<< toTupleToken a b - -makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM (Token Template) -makeTemplate a b = runFunction MakeTemplate =<< toTupleToken a b - -applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM (Token Text) -applyTemplate a b = runFunction ApplyTemplate =<< toTupleToken a b - -toText :: TokenableTo String a => a -> DepGenM (Token Text) -toText a = runFunction ToText =<< toToken a - -convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM (Token Image) -convertImage a b = runFunction ConvertImage =<< toTupleToken a b - -runPandoc :: TokenableTo Text a => a -> DepGenM (Token Text) -runPandoc a = runFunction RunPandoc =<< 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 diff --git a/byg/src/DependencyRunner.hs b/byg/src/DependencyRunner.hs index 60f5934..4b223e7 100644 --- a/byg/src/DependencyRunner.hs +++ b/byg/src/DependencyRunner.hs @@ -4,9 +4,8 @@ module DependencyRunner , runDepRunMIO ) where -import Types (Value(..), Valuable(..), evalFunctionIO) +import Types (Value(..), Valuable(..), evalFunction, evalFunctionIO) import Types.Dependency -import Evaluation.Function import Data.Map (Map) import qualified Data.Map as M @@ -82,7 +81,7 @@ putTokenValue t e = case t of runAction :: Action -> Value -> DepRunM Value runAction action input = case action of Function f -> - pure $ evalFunction f input + pure $ toValue $ evalFunction f $ fromValue input FunctionIO f -> liftIO (toValue <$> evalFunctionIO f (fromValue input)) Inject v -> diff --git a/byg/src/Evaluation/Function.hs b/byg/src/Evaluation/Function.hs deleted file mode 100644 index 4bdce7d..0000000 --- a/byg/src/Evaluation/Function.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Evaluation.Function - ( evalFunction - ) where - -import Prelude hiding (String, FilePath) -import qualified Prelude - -import Types.Values -import Types (Function(..), Value(..), fromValue, makeString, makeImage) - -import qualified Codec.Picture as CP -import qualified Codec.Picture.STBIR as CPS -import Data.Char (toLower) -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 - -fileComponents :: Prelude.String -> (Prelude.String, Prelude.String) -fileComponents s = - let (lastRev, firstRev) = span (/= '.') $ reverse s - in case firstRev of - _ : firstRev' -> (reverse firstRev', reverse lastRev) - [] -> (reverse lastRev, "") - -unStringWrapper :: Value -> Prelude.String -unStringWrapper = \case - String (StringWrapper s) -> s - _ -> error "unexpected" - -evalFunction :: Function -> Value -> Value -evalFunction f x = case (f, x) of - (ConcatStrings, List vs) -> - makeString $ concatMap unStringWrapper vs - - (ConcatTexts, List vs) -> - Text $ T.concat $ map fromValue vs - - (JoinPaths, Tuple (String (StringWrapper s0), String (StringWrapper s1))) -> - makeString (s0 ++ "/" ++ s1) - - (FileComponents, String (StringWrapper s)) -> - let (base, ext) = fileComponents s - in Tuple (makeString base, makeString ext) - - (LowerString, String (StringWrapper s)) -> - makeString $ map toLower s - - (ElemOf, Tuple (y, List ys)) -> - Bool (y `elem` ys) - - (MakeTemplate, Tuple (Text t, Text c)) -> - let (beforeContent, after) = T.breakOn c t - afterContent = T.drop (T.length c) after - in Template $ TemplateParts beforeContent afterContent - - (ApplyTemplate, Tuple (Template (TemplateParts beforeContent afterContent), Text t)) -> - Text $ T.concat [beforeContent, t, afterContent] - - (ToText, String (StringWrapper s)) -> - Text $ T.pack s - - (ConvertImage, Tuple (Image (ImageWrapper image), - ImageConversionSettings (ResizeToWidth widthResized))) -> - let sizeFactor :: Double - sizeFactor = fromIntegral (CP.imageWidth image) / fromIntegral widthResized - heightResized = round (fromIntegral (CP.imageHeight image) / sizeFactor) - in makeImage $ CPS.resize CPS.defaultOptions widthResized heightResized image - - (RunPandoc, Text 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 -> Text $ TL.toStrict $ B.renderHtml html - - _ -> - error "unexpected combination of function and argument type" diff --git a/byg/src/Function.hs b/byg/src/Function.hs new file mode 100644 index 0000000..bd22d26 --- /dev/null +++ b/byg/src/Function.hs @@ -0,0 +1,136 @@ +module Function + ( concatStrings + , concatTexts + , joinPaths + , fileComponents + , lowerString + , elemOf + , makeTemplate + , applyTemplate + , toText + , convertImage + , runPandoc + ) where + +import Prelude hiding (String, FilePath) + +import Types.Values +import Types.Function +import Types.Token (Token(..)) +import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction) + +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 +import Language.Haskell.TH.Syntax (Lift) + + +data ConcatStrings = ConcatStrings deriving (Show, Lift) +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, Lift) +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, Lift) +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, Lift) +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, Lift) +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 = ElemOf deriving (Show, Lift) +instance IsFunction ElemOf (String, [String]) Bool where + evalFunction ElemOf (y, ys) = y `elem` ys + +elemOf :: (TokenableTo String a, TokenableTo [String] b) => a -> b -> DepGenM (Token Bool) +elemOf a b = runFunction ElemOf =<< toTupleToken a b + + +data MakeTemplate = MakeTemplate deriving (Show, Lift) +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, Lift) +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, Lift) +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, Lift) +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, Lift) +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 index cca4300..5c3ebe9 100644 --- a/byg/src/FunctionIO.hs +++ b/byg/src/FunctionIO.hs @@ -11,8 +11,8 @@ module FunctionIO import Prelude hiding (String, FilePath) -import Types.FunctionIO import Types.Values +import Types.FunctionIO import Types.Token (Token(..)) import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunctionIO, runFunctionIO_) diff --git a/byg/src/SiteGenerator.hs b/byg/src/SiteGenerator.hs index 837b3b1..7fda704 100644 --- a/byg/src/SiteGenerator.hs +++ b/byg/src/SiteGenerator.hs @@ -4,6 +4,7 @@ import Prelude hiding (String, FilePath) import Types import DependencyGenerator +import Function import FunctionIO import Control.Monad (forM_) @@ -13,6 +14,11 @@ 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/Dependency.hs b/byg/src/Types/Dependency.hs index c763181..c4b293e 100644 --- a/byg/src/Types/Dependency.hs +++ b/byg/src/Types/Dependency.hs @@ -11,7 +11,7 @@ module Types.Dependency import Types.Token (Token(..)) import Types.Value (Value) -import Types.Function (Function) +import Types.Function (IsFunction()) import Types.FunctionIO (IsFunctionIO(..)) import Text.Printf (printf) @@ -20,7 +20,7 @@ import qualified Data.Text as T import Language.Haskell.TH.Syntax (Lift) data Action where - Function :: Function -> Action + Function :: IsFunction f a b => f -> Action FunctionIO :: IsFunctionIO f a b => f -> Action Inject :: Value -> Action FilterComp :: Action diff --git a/byg/src/Types/Function.hs b/byg/src/Types/Function.hs index 803cd83..4abd4f6 100644 --- a/byg/src/Types/Function.hs +++ b/byg/src/Types/Function.hs @@ -1,19 +1,11 @@ +{-# LANGUAGE FunctionalDependencies #-} module Types.Function - ( Function(..) + ( IsFunction(..) ) where +import Types.Value (Valuable) + import Language.Haskell.TH.Syntax (Lift) -data Function = ConcatStrings - | ConcatTexts - | JoinPaths - | FileComponents - | LowerString - | ElemOf - | MakeTemplate - | ApplyTemplate - | ToText - | ConvertImage - | RunPandoc - deriving (Show, Lift) - +class (Show f, Lift f, Valuable a, Valuable b) => IsFunction f a b | f -> a b where + evalFunction :: f -> a -> b diff --git a/byg/src/Types/Value.hs b/byg/src/Types/Value.hs index 545c15a..a08d070 100644 --- a/byg/src/Types/Value.hs +++ b/byg/src/Types/Value.hs @@ -1,17 +1,13 @@ module Types.Value ( Value(..) , Valuable(..) - , makeString - , makeImage ) where import Prelude hiding (String) -import qualified Prelude import Types.Values import Data.Text (Text) -import qualified Codec.Picture as CP import Language.Haskell.TH.Syntax (Lift) -- Note: We use a wrapper for the String type in order to be able to define the @@ -33,12 +29,6 @@ data Value = String String | List [Value] deriving (Eq, Show, Lift) -makeString :: Prelude.String -> Value -makeString = String . StringWrapper - -makeImage :: CP.Image CP.PixelRGB8 -> Value -makeImage = Image . ImageWrapper - class Valuable a where toValue :: a -> Value fromValue :: Value -> a diff --git a/byg/src/Types/Values.hs b/byg/src/Types/Values.hs index b2a29f3..00c2214 100644 --- a/byg/src/Types/Values.hs +++ b/byg/src/Types/Values.hs @@ -14,7 +14,7 @@ import Data.Text (Text) import qualified Codec.Picture as CP import Language.Haskell.TH.Syntax (Lift(..)) -newtype String = StringWrapper Prelude.String +newtype String = StringWrapper { unStringWrapper :: Prelude.String } deriving (Eq, Lift) instance Show String where