137 lines
5.1 KiB
Haskell
137 lines
5.1 KiB
Haskell
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
|