make lántas script color configurable with LANG_COLOR

Makefile

@@ -38,7 +38,7 @@ $(BUILDDIR)/%.html: $(PAGESDIR)/%.md $(TEMPLATE) $(LANGFILTER) $(LAANTAS_SCRIPT)
 	@echo "[pandoc] $<"
 	mkdir -p $(dir $@)
 	mkdir -p $(basename $@)
-	LAANTAS_SCRIPT="$(LAANTAS_SCRIPT)" \
+	LAANTAS_SCRIPT="$(LAANTAS_SCRIPT)" LANG_COLOR="hsl(340deg, 50%, 35%)" \
 	  DIRNAME="$(basename $@)" \
 	  FILENAME="$@" \
 	  pandoc -s --toc --template $(TEMPLATE) -o $@ $< \

langfilter/LaantasImage.hs

@@ -2,6 +2,7 @@ module LaantasImage
   (Image (..), splitImage, splitImage', makeImage)
 where
 
+import Lang
 import Text.Pandoc.Definition hiding (Image)
 import qualified Text.Pandoc.Definition as Pandoc
 import Data.Bifunctor
@@ -26,22 +27,22 @@ data Image =
     showText     :: Bool
   } deriving (Eq, Show)
 
-splitImage :: Text -> Maybe Image
+splitImage :: Vars => Text -> Maybe Image
 splitImage (Text.uncons -> Just (c, txt))
   | c == '!' = Just $ splitImage' txt
   | c == '#' = Just $ (splitImage' txt) {showText = False}
 splitImage _ = Nothing
 
-splitImage' :: Text -> Image
+splitImage' :: Vars => Text -> Image
 splitImage' txt₀ =
   case imageOpts txt₀ of
-    Just (txt, opts) -> defaultImage txt
+    Just (txt, opts) -> defaultImage txt ?defColor
       & withOpt opts "file"   (\f i -> i {file   = makeFile f})
       & withOpt opts "size"   (\s i -> i {size   = readt s})
       & withOpt opts "stroke" (\k i -> i {stroke = readt k})
       & withOpt opts "width"  (\w i -> i {width  = readt w})
       & withOpt opts "color"  (\c i -> i {color  = c})
-    Nothing -> defaultImage txt₀
+    Nothing -> defaultImage txt₀ ?defColor
   where readt x = read $ Text.unpack x
 
 withOpt :: Ord k => Map k v -> k -> (v -> a -> a) -> (a -> a)
@@ -50,8 +51,8 @@ withOpt m k f =
     Just v  -> f v
     Nothing -> id
 
-defaultImage :: Text -> Image
-defaultImage txt =
+defaultImage :: Text -> Text -> Image
+defaultImage txt color =
     Image {
       text = Text.filter notPunc txt,
       title = toTitle txt,
@@ -59,7 +60,7 @@ defaultImage txt =
       size = 20,
       stroke = 0.75,
       width = 600,
-      color = "hsl(340deg, 50%, 35%)",
+      color = color,
       showText = True
     }
 

langfilter/Lang.hs

@@ -4,16 +4,28 @@ import Text.Pandoc.Definition
 import Data.Char (toLower)
 import qualified Data.Text as Text
 import System.IO
+import Data.Text (Text)
 
 data Lang = Lántas deriving (Eq, Show)
 
-type Vars = (?lang :: Maybe Lang)
+type Vars = (?lang :: Maybe Lang, ?defColor :: Text)
+
+toText :: Maybe MetaValue -> IO (Maybe Text)
+toText (Just (MetaInlines [Str s])) = toText (Just (MetaString s)) -- ugh
+toText (Just (MetaString s)) = pure $ Just s
+toText Nothing = pure Nothing
+toText (Just ℓ) = do
+  hPutStrLn stderr $ "[WARN] expected a string, got: " <> show ℓ
+  pure Nothing
 
 toLang :: Maybe MetaValue -> IO (Maybe Lang)
-toLang (Just (MetaInlines [Str s])) = toLang (Just (MetaString s)) -- ugh
-toLang (Just (MetaString (Text.map toLower -> s)))
-  | s == "lántas" || s == "laantas" = pure $ Just Lántas
-toLang Nothing = pure Nothing
-toLang (Just ℓ) = do
-  hPutStrLn stderr $ "[WARN] unknown language: " <> show ℓ
+toLang m = do
+  mres <- fmap (Text.map toLower) <$> toText m
+  case mres of
+    Just res -> do
+      if res `elem` ["laantas", "lántas"] then
+        pure $ Just Lántas
+      else do
+        hPutStrLn stderr $ "[WARN] unknown language: " <> show res
         pure Nothing
+    Nothing -> pure Nothing

langfilter/Main.hs

@@ -9,17 +9,22 @@ import Text.Pandoc.Definition
 import Text.Pandoc.JSON
 import Text.Pandoc.Walk
 import Data.Maybe
+import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Text (Text)
 import qualified Data.Text as Text
 import Control.Applicative
 import Control.Monad
+import System.Environment
 
 
 main :: IO ()
 main = toJSONFilter filter where
   filter p@(Pandoc (Meta m) _) = do
-    lang' <- toLang $ Map.lookup "conlang" m
-    let ?lang = lang'
+    lang <- toLang $ Map.lookup "conlang" m
+    defColor <- getDefColor m
+    let ?lang = lang
+    let ?defColor = defColor
     fmap (walk makeEbnf .
           walk makeQuotes .
           walk (concatMap makeBlocks) .
@@ -27,6 +32,14 @@ main = toJSONFilter filter where
       walkM spans =<<
       walkM (fmap concat . traverse glosses) p
 
+getDefColor :: Map Text MetaValue -> IO Text
+getDefColor m = do
+  res <- toText $ Map.lookup "lang-color" m
+  case res of
+    Just col -> pure col
+    Nothing  -> do
+      env <- lookupEnv "LANG_COLOR"
+      pure $ maybe "black" Text.pack env
 
 pluck :: Eq a => a -> [a] -> Maybe [a]
 pluck _ []                 = Nothing