Also copy fonts

Do some ugly shenanigans to make this work.

byg/src/DependencyGenerator.hs

@@ -4,6 +4,7 @@ module DependencyGenerator
   ( DepGenM
   , DepGenM'
   , evalDepGenM
+  , TokenableTo(..)
   , inject
   , runFunction
   , runFunctionIO
@@ -24,7 +25,8 @@ module DependencyGenerator
   , concatTexts
   , joinPaths
   , fileComponents
-  , hasImageExtension
+  , lowerString
+  , elemOf
   , applyTemplate
   , toText
   , listDirectory
@@ -38,6 +40,8 @@ module DependencyGenerator
   , runPandoc
   ) where
 
+import Prelude hiding (String, FilePath)
+
 import Types.Token (Token(..))
 import Types.Values
 import Types.Value (Valuable(..))
@@ -200,8 +204,14 @@ joinPaths a b = do
 fileComponents :: TokenableTo FilePath a => a -> DepGenM' (String, String)
 fileComponents a = runFunction FileComponents =<< toToken a
 
-hasImageExtension :: TokenableTo FilePath a => a -> DepGenM' Bool
+lowerString :: TokenableTo String a => a -> DepGenM' String
-hasImageExtension a = runFunction HasImageExtension =<< toToken a
+lowerString a = runFunction LowerString =<< toToken a
+
+elemOf :: (TokenableTo String a, TokenableTo [String] b) => a -> b -> DepGenM' Bool
+elemOf a b = do
+  a' <- toToken a
+  b' <- toToken b
+  runFunction ElemOf $ TupleToken (a', b')
 
 applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM' Text
 applyTemplate a b = do

byg/src/Evaluation/Function.hs

@@ -2,28 +2,36 @@ module Evaluation.Function
   ( evalFunction
   ) where
 
-import Types (Function(..), Value(..), Template(..), fromValue)
+import Prelude hiding (String, FilePath)
+import qualified Prelude
+
+import Types (Function(..), Value(..), String(..), Template(..), fromValue)
 
 import Data.Char (toLower)
 import qualified Data.Text as T
 
-fileComponents :: String -> (String, String)
+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, "")
 
-isImageExtension :: String -> Bool
+makeString :: Prelude.String -> Value
-isImageExtension = (`elem` ["jpg"]) . map toLower
+makeString = String . StringWrapper
+
+unStringWrapper :: Value -> Prelude.String
+unStringWrapper = \case
+  String (StringWrapper s) -> s
+  _ -> error "unexpected"
 
 evalFunction :: Function -> Value -> Value
 evalFunction f x = case (f, x) of
-  (AppendStrings, Tuple (String s0, String s1)) ->
+  (AppendStrings, Tuple (String (StringWrapper s0), String (StringWrapper s1))) ->
-    String (s0 ++ s1)
+    makeString (s0 ++ s1)
 
   (ConcatStrings, List vs) ->
-    String $ concatMap fromValue vs
+    makeString $ concatMap unStringWrapper vs
 
   (AppendTexts, Tuple (Text t0, Text t1)) ->
     Text $ T.append t0 t1
@@ -31,21 +39,23 @@ evalFunction f x = case (f, x) of
   (ConcatTexts, List vs) ->
     Text $ T.concat $ map fromValue vs
 
-  (JoinPaths, Tuple (String s0, String s1)) ->
+  (JoinPaths, Tuple (String (StringWrapper s0), String (StringWrapper s1))) ->
-    String (s0 ++ "/" ++ s1)
+    makeString (s0 ++ "/" ++ s1)
 
-  (FileComponents, String s) ->
+  (FileComponents, String (StringWrapper s)) ->
     let (base, ext) = fileComponents s
-    in Tuple (String base, String ext)
+    in Tuple (makeString base, makeString ext)
 
-  (HasImageExtension, String s) ->
+  (LowerString, String (StringWrapper s)) ->
-    let (_, ext) = fileComponents s
+    makeString $ map toLower s
-    in Bool $ isImageExtension ext
+
+  (ElemOf, Tuple (y, List ys)) ->
+    Bool (y `elem` ys)
 
   (ApplyTemplate, Tuple (Template (TemplateParts beforeContent afterContent), Text t)) ->
     Text $ T.concat [beforeContent, t, afterContent]
 
-  (ToText, String s) ->
+  (ToText, String (StringWrapper s)) ->
     Text $ T.pack s
 
   _ ->

byg/src/Evaluation/FunctionIO.hs

@@ -2,6 +2,8 @@ module Evaluation.FunctionIO
   ( evalFunctionIO
   ) where
 
+import Prelude hiding (String, FilePath)
+
 import Types.Values
 import Types (FunctionIO(..), Value(..), toValue)
 
@@ -16,20 +18,20 @@ import System.Directory (listDirectory, doesDirectoryExist, createDirectory, cop
 
 evalFunctionIO :: FunctionIO -> Value -> IO Value
 evalFunctionIO f x = case (f, x) of
-  (ListDirectory, String s) ->
+  (ListDirectory, String (StringWrapper s)) ->
-    (List . map toValue) <$> listDirectory s
+    (List . map (toValue . StringWrapper)) <$> listDirectory s
 
-  (IsDirectory, String s) ->
+  (IsDirectory, String (StringWrapper s)) ->
     Bool <$> doesDirectoryExist s
 
-  (ReadTemplate, String s) -> do
+  (ReadTemplate, String (StringWrapper s)) -> do
     t <- T.readFile s
     let c = "CONTENT"
         (beforeContent, after) = T.breakOn c t
         afterContent = T.drop (T.length c) after
     pure $ Template $ TemplateParts beforeContent afterContent
 
-  (ConvertImage, Tuple (Tuple (String source, String target),
+  (ConvertImage, Tuple (Tuple (String (StringWrapper source), String (StringWrapper target)),
                         ImageConversionSettings (ResizeToWidth widthResized))) -> do
     imageOrig <- CP.readImage source
     let imageOrig' = case imageOrig of
@@ -42,19 +44,19 @@ evalFunctionIO f x = case (f, x) of
     CP.saveJpgImage 90 target $ CP.ImageRGB8 imageResized
     pure Empty
 
-  (SaveFile, Tuple (Text t, String s)) -> do
+  (SaveFile, Tuple (Text t, String (StringWrapper s))) -> do
     T.writeFile s t
     pure Empty
 
-  (CopyFile, Tuple (String source, String target)) -> do
+  (CopyFile, Tuple (String (StringWrapper source), String (StringWrapper target))) -> do
     copyFile source target
     pure Empty
 
-  (MakeDir, String s) -> do
+  (MakeDir, String (StringWrapper s)) -> do
     createDirectory s
     pure Empty
 
-  (RunPandoc, String s) -> do
+  (RunPandoc, String (StringWrapper s)) -> do
     contents <- T.readFile s
     html <- P.runIOorExplode (P.writeHtml5 P.def =<< P.readMarkdown (P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] }) contents)
     pure $ Text $ TL.toStrict $ B.renderHtml html

byg/src/SiteGenerator.hs

@@ -1,5 +1,7 @@
 module SiteGenerator (generateSite) where
 
+import Prelude hiding (String, FilePath)
+
 import Types
 import DependencyGenerator
 
@@ -25,13 +27,18 @@ makeImageHTML t = do
           (toText thumbnail)
           (inject "\"></a></p>"))))
 
+hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM' Bool
+hasExtension exts filename = do
+  ext <- lowerString $ untupleSndDepGenM $ fileComponents filename
+  ext `elemOf` exts
+
 handleRecipeDir :: Token FilePath -> Token FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM ()
 handleRecipeDir inputDir outputDir template indexName name = do
   dir <- joinPaths inputDir name
   recipeDirOut <- joinPaths outputDir name
   makeDir recipeDirOut
   dirContents <- listDirectory dir
-  areImageFilenames <- mapDepGenM hasImageExtension dirContents
+  areImageFilenames <- mapDepGenM (hasExtension $ inject ["jpg"]) dirContents
   imageFilenames <- filterDepGenM areImageFilenames dirContents
   imagePaths <- mapDepGenM (joinPaths dir) imageFilenames
   imagePathsOut <- mapDepGenM (joinPaths recipeDirOut) imageFilenames
@@ -74,3 +81,19 @@ generateSite = do
   forM_ ["mad-icon.png", "mad-logo.png"] $ \name -> do
     val <- inject name
     copyFile (joinPaths imgName val) (joinPaths imgPathOut val)
+  fontsDir <- inject "fonts"
+  fontsNames <- listDirectory fontsDir
+  fontsPaths <- mapDepGenM (joinPaths fontsDir) fontsNames
+  fontsPathsAreSubdirs <- mapDepGenM isDirectory fontsPaths
+  fontsPaths' <- filterDepGenM fontsPathsAreSubdirs fontsPaths
+  makeDir (joinPaths outputDir fontsDir)
+  mapDepGenM_ (handleFontDir outputDir) fontsPaths'
+
+handleFontDir :: Token FilePath -> Token FilePath -> DepGenM ()
+handleFontDir outputDir fontPath = do
+  makeDir (joinPaths outputDir fontPath)
+  files <- listDirectory fontPath
+  paths <- mapDepGenM (joinPaths fontPath) files
+  mask <- mapDepGenM (hasExtension $ inject ["woff2", "css"]) paths
+  paths' <- filterDepGenM mask paths
+  mapDepGenM_ (\p -> copyFile p (joinPaths outputDir p)) paths'

byg/src/Types/Function.hs

@@ -10,7 +10,8 @@ data Function = AppendStrings
               | ConcatTexts
               | JoinPaths
               | FileComponents
-              | HasImageExtension
+              | LowerString
+              | ElemOf
               | ApplyTemplate
               | ToText
   deriving (Show, Lift)

byg/src/Types/Value.hs

@@ -3,11 +3,17 @@ module Types.Value
   , Valuable(..)
   ) where
 
+import Prelude hiding (String)
+
 import Types.Values
 
 import Data.Text (Text)
 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].
 data Value = String String
            | Text Text
            | Bool Bool
@@ -16,7 +22,7 @@ data Value = String String
            | Empty
            | Tuple (Value, Value)
            | List [Value]
-  deriving (Show, Lift)
+  deriving (Eq, Show, Lift)
 
 class Valuable a where
   toValue :: a -> Value
@@ -45,3 +51,9 @@ instance Valuable ImageConversionSettings where
   fromValue = \case
     ImageConversionSettings a -> a
     _ -> error "unexpected"
+
+instance Valuable a => Valuable [a] where
+  toValue = List . map toValue
+  fromValue = \case
+    List a -> map fromValue a
+    _ -> error "unexpected"

byg/src/Types/Values.hs

@@ -1,13 +1,27 @@
 module Types.Values
-  ( ImageConversionSettings(..)
+  ( String(..)
+  , FilePath
+  , ImageConversionSettings(..)
   , Template(..)
   ) where
 
+import Prelude hiding (String, FilePath)
+import qualified Prelude
+
+import Data.String (IsString(..))
 import Data.Text (Text)
 import Language.Haskell.TH.Syntax (Lift)
 
+newtype String = StringWrapper Prelude.String
+  deriving (Eq, Show, Lift)
+
+type FilePath = String
+
+instance IsString String where
+  fromString = StringWrapper
+
 data ImageConversionSettings = ResizeToWidth Int
-  deriving (Show, Lift)
+  deriving (Eq, Show, Lift)
 
 data Template = TemplateParts Text Text
-  deriving (Show, Lift)
+  deriving (Eq, Show, Lift)