Split ConvertImage into three steps

byg/src/DependencyGenerator.hs

@@ -33,10 +33,13 @@ module DependencyGenerator
   , makeTemplate
   , applyTemplate
   , toText
+  , convertImage
+
   , listDirectory
   , isDirectory
   , readTextFile
-  , convertImage
+  , openImage
+  , saveImage
   , saveTextFile
   , copyFile
   , copyFile'
@@ -236,6 +239,9 @@ applyTemplate a b = runFunction ApplyTemplate =<< toTupleToken a b
 toText :: TokenableTo String a => a -> DepGenM' Text
 toText a = runFunction ToText =<< toToken a
 
+convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM' Image
+convertImage a b = runFunction ConvertImage =<< toTupleToken a b
+
 listDirectory :: TokenableTo FilePath a => a -> DepGenM' [FilePath]
 listDirectory a = runFunctionIO ListDirectory =<< toToken a
 
@@ -245,8 +251,11 @@ isDirectory a = runFunctionIO IsDirectory =<< toToken a
 readTextFile :: TokenableTo FilePath a => a -> DepGenM' Text
 readTextFile a = runFunctionIO ReadTextFile =<< toToken a
 
-convertImage :: (TokenableTo FilePath a, TokenableTo FilePath b, TokenableTo ImageConversionSettings c) => a -> b -> c -> DepGenM ()
+openImage :: TokenableTo FilePath a => a -> DepGenM' Image
-convertImage a b c = runFunctionIO' ConvertImage =<< toTupleToken (toTupleToken a b) c
+openImage a = runFunctionIO OpenImage =<< toToken a
+
+saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM ()
+saveImage a b = runFunctionIO' SaveImage =<< toTupleToken a b
 
 saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
 saveTextFile a b = runFunctionIO' SaveTextFile =<< toTupleToken a b

byg/src/Evaluation/Function.hs

@@ -5,8 +5,11 @@ module Evaluation.Function
 import Prelude hiding (String, FilePath)
 import qualified Prelude
 
-import Types (Function(..), Value(..), String(..), Template(..), fromValue)
+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
 
@@ -17,9 +20,6 @@ fileComponents s =
        _ : firstRev' -> (reverse firstRev', reverse lastRev)
        [] -> (reverse lastRev, "")
 
-makeString :: Prelude.String -> Value
-makeString = String . StringWrapper
-
 unStringWrapper :: Value -> Prelude.String
 unStringWrapper = \case
   String (StringWrapper s) -> s
@@ -63,5 +63,12 @@ evalFunction f x = case (f, x) of
   (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
+
   _ ->
     error "unexpected combination of function and argument type"

byg/src/Evaluation/FunctionIO.hs

@@ -5,14 +5,13 @@ module Evaluation.FunctionIO
 import Prelude hiding (String, FilePath)
 
 import Types.Values
-import Types (FunctionIO(..), Value(..), toValue)
+import Types (FunctionIO(..), Value(..), toValue, makeImage)
 
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.IO as T
 import qualified Text.Pandoc as P
 import qualified Text.Blaze.Html.Renderer.Text as B
 import qualified Codec.Picture as CP
-import qualified Codec.Picture.STBIR as CPS
 import System.Directory (listDirectory, doesDirectoryExist, createDirectory, copyFile)
 
 evalFunctionIO :: FunctionIO -> Value -> IO Value
@@ -26,17 +25,14 @@ evalFunctionIO f x = case (f, x) of
   (ReadTextFile, String (StringWrapper s)) ->
     Text <$> T.readFile s
 
-  (ConvertImage, Tuple (Tuple (String (StringWrapper source), String (StringWrapper target)),
+  (OpenImage, String (StringWrapper s)) -> do
-                        ImageConversionSettings (ResizeToWidth widthResized))) -> do
+    imageOrig <- CP.readImage s
-    imageOrig <- CP.readImage source
+    case imageOrig of
-    let imageOrig' = case imageOrig of
+      Left e -> error ("unexpected error: " ++ e)
-                       Left s -> error ("unexpected error: " ++ s)
+      Right image -> pure $ makeImage $ CP.convertRGB8 image
-                       Right image -> CP.convertRGB8 image
+
-        sizeFactor :: Double
+  (SaveImage, Tuple (Image (ImageWrapper image), String (StringWrapper s))) -> do
-        sizeFactor = fromIntegral (CP.imageWidth imageOrig') / fromIntegral widthResized
+    CP.saveJpgImage 90 s $ CP.ImageRGB8 image
-        heightResized = round (fromIntegral (CP.imageHeight imageOrig') / sizeFactor)
-        imageResized = CPS.resize CPS.defaultOptions widthResized heightResized imageOrig'
-    CP.saveJpgImage 90 target $ CP.ImageRGB8 imageResized
     pure Empty
 
   (SaveTextFile, Tuple (Text t, String (StringWrapper s))) -> do

byg/src/SiteGenerator.hs

@@ -18,7 +18,8 @@ handleRecipeDir outputDir htmlTemplate indexName dir = do
     path `copyTo` outputDir
     (base, ext) <- untupleDepGenM $ fileComponents name
     thumbnailName <- concatStrings [ pure base, inject "-thumbnail.", pure ext ]
-    convertImage path (joinPaths recipeDirOut thumbnailName) (inject (ResizeToWidth 800))
+    imageResized <- convertImage (openImage path) (inject (ResizeToWidth 800))
+    saveImage imageResized (joinPaths recipeDirOut thumbnailName)
     concatTexts [ inject "<p class=\"image\"><a href=\""
                 , toText name
                 , inject "\"><img src=\""

byg/src/Types/Function.hs

@@ -15,5 +15,6 @@ data Function = AppendStrings
               | MakeTemplate
               | ApplyTemplate
               | ToText
+              | ConvertImage
   deriving (Show, Lift)
 

byg/src/Types/FunctionIO.hs

@@ -7,7 +7,8 @@ import Language.Haskell.TH.Syntax (Lift)
 data FunctionIO = ListDirectory
                 | IsDirectory
                 | ReadTextFile
-                | ConvertImage
+                | OpenImage
+                | SaveImage
                 | SaveTextFile
                 | CopyFile
                 | MakeDir

byg/src/Types/Value.hs

@@ -1,22 +1,31 @@
 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
 -- 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].
+--
+-- Also note that the Image type does not actually implement Lift, so you
+-- shouldn't use it with Inject.  The better approach would be to split the
+-- Value type into a compile-time version and a runtime version.
 data Value = String String
            | Text Text
            | Bool Bool
+           | Image Image
            | ImageConversionSettings ImageConversionSettings
            | Template Template
            | Empty
@@ -24,6 +33,12 @@ 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

byg/src/Types/Values.hs

@@ -1,6 +1,7 @@
 module Types.Values
   ( String(..)
   , FilePath
+  , Image(..)
   , ImageConversionSettings(..)
   , Template(..)
   ) where
@@ -10,7 +11,8 @@ import qualified Prelude
 
 import Data.String (IsString(..))
 import Data.Text (Text)
-import Language.Haskell.TH.Syntax (Lift)
+import qualified Codec.Picture as CP
+import Language.Haskell.TH.Syntax (Lift(..))
 
 newtype String = StringWrapper Prelude.String
   deriving (Eq, Show, Lift)
@@ -20,6 +22,15 @@ 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"
+
+instance Lift Image where
+  liftTyped _ = error "cannot lift images"
+
 data ImageConversionSettings = ResizeToWidth Int
   deriving (Eq, Show, Lift)