Gen.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Auto-generation of various forms of documentation.
module Swarm.Doc.Gen (
  -- ** Main document generation function + types
  generateDocs,
  GenerateDocs (..),
  SheetType (..),

  -- ** Wiki pages
  PageAddress (..),

  -- ** Recipe graph drawing
  EdgeFilter (..),
) where

import Control.Lens (view, (^.))
import Control.Monad (zipWithM, zipWithM_)
import Data.Aeson.Text (encodeToLazyText)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.List qualified as List
import Data.List.Extra (enumerate)
import Data.Map.Lazy qualified as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy.IO qualified as TL
import Swarm.Doc.Command (getCatalog)
import Swarm.Doc.Keyword
import Swarm.Doc.Pedagogy
import Swarm.Doc.Wiki.Cheatsheet
import Swarm.Game.Entity (Entity, entityName, entityYields)
import Swarm.Game.Recipe (recipeCatalysts, recipeInputs, recipeOutputs)
import Swarm.Game.Recipe.Graph qualified as RG
import Swarm.Language.Key (specialKeyNames)
import Swarm.Util (both)
import Text.Dot (Dot, NodeId, (.->.))
import Text.Dot qualified as Dot

-- ============================================================================
-- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR
-- ============================================================================
--
-- These are the exported functions used by the executable.
--
-- ----------------------------------------------------------------------------

-- | An enumeration of the kinds of documentation we can generate.
data GenerateDocs where
  -- | Entity dependencies by recipes.
  RecipeGraph :: EdgeFilter -> GenerateDocs
  -- | Keyword lists for editors.
  EditorKeywords :: Maybe EditorType -> GenerateDocs
  -- | List of special key names recognized by 'Swarm.Language.Syntax.Key' command
  SpecialKeyNames :: GenerateDocs
  -- | Cheat sheets for inclusion on the Swarm wiki.
  CheatSheet :: PageAddress -> SheetType -> GenerateDocs
  -- | JSON representation of commands metadata matrix
  CommandsData :: GenerateDocs
  -- | List command introductions by tutorial
  TutorialCoverage :: GenerateDocs
  deriving (Eq, Show)

-- | Generate the requested kind of documentation to stdout.
generateDocs :: GenerateDocs -> IO ()
generateDocs = \case
  RecipeGraph ef -> generateRecipe ef >>= putStrLn
  EditorKeywords e ->
    case e of
      Just et -> generateEditorKeywords et
      Nothing -> do
        putStrLn "All editor completions:"
        let editorGen et = do
              putStrLn $ replicate 40 '-'
              putStrLn $ "-- " <> show et
              putStrLn $ replicate 40 '-'
              generateEditorKeywords et
        mapM_ editorGen enumerate
  SpecialKeyNames -> generateSpecialKeyNames
  CheatSheet address s -> makeWikiPage address s
  CommandsData -> TL.putStrLn $ encodeToLazyText getCatalog
  TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack

-- ----------------------------------------------------------------------------
-- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED
-- ----------------------------------------------------------------------------

-- | Generate a list of keywords in the format expected by one of the
--   supported editors.
generateEditorKeywords :: EditorType -> IO ()
generateEditorKeywords = \case
  Emacs -> do
    putStrLn "(defvar swarm-mode-builtins '("
    T.putStr $ builtinFunctionList Emacs <> "))"
    putStrLn "\n(defvar swarm-mode-commands '("
    T.putStr $ keywordsCommands Emacs
    T.putStr $ keywordsDirections Emacs <> "))"
    putStrLn "\n (defvar swarm-mode-operators '("
    T.putStr $ operatorNames Emacs <> "))"
  VSCode -> do
    putStrLn "Functions and commands:"
    T.putStrLn $ builtinFunctionList VSCode <> "|" <> keywordsCommands VSCode
    putStrLn "\nDirections:"
    T.putStrLn $ keywordsDirections VSCode
    putStrLn "\nOperators:"
    T.putStrLn $ operatorNames VSCode
  Vim -> do
    putStrLn "syn keyword Builtins "
    T.putStr $ builtinFunctionList Vim
    putStrLn "\nsyn keyword Command "
    T.putStr $ keywordsCommands Vim
    putStrLn "\nsyn keyword Direction "
    T.putStr $ keywordsDirections Vim
    putStrLn "\nsyn match Operators "
    T.putStr $ "[" <> operatorNames Vim <> "]"

-- ----------------------------------------------------------------------------
-- GENERATE SPECIAL KEY NAMES
-- ----------------------------------------------------------------------------

generateSpecialKeyNames :: IO ()
generateSpecialKeyNames =
  T.putStr . T.unlines . Set.toList $ specialKeyNames

-- ----------------------------------------------------------------------------
-- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES
-- ----------------------------------------------------------------------------

generateRecipe :: EdgeFilter -> IO String
generateRecipe ef = do
  graphData <- RG.classicScenarioRecipeGraph
  return . Dot.showDot $ recipesToDot graphData ef

data EdgeFilter = NoFilter | FilterForward | FilterNext
  deriving (Eq, Show)

filterEdge :: EdgeFilter -> Int -> Int -> Bool
filterEdge ef i o = case ef of
  NoFilter -> True
  FilterForward -> i <= o
  FilterNext -> i + 1 == o

recipesToDot :: RG.RecipeGraph -> EdgeFilter -> Dot ()
recipesToDot graphData ef = do
  Dot.attribute ("rankdir", "LR")
  Dot.attribute ("ranksep", "2")
  world <- diamond "World"
  base <- diamond "Base"
  -- --------------------------------------------------------------------------
  -- add nodes for all the known entities
  let enames' = map (view entityName) . toList $ RG.allEntities graphData
      enames = filter (`Set.notMember` RG.ignoredEntities) enames'
  ebmap <- Map.fromList . zip enames <$> mapM (box . T.unpack) enames
  -- --------------------------------------------------------------------------
  -- getters for the NodeId based on entity name or the whole entity
  let safeGetEntity m e = fromMaybe (error $ show e <> " is not an entity!?") $ m Map.!? e
      -- The above call to `error` (1) should never happen, and (2)
      -- even if it does, it will only crash recipe cheatsheet
      -- generation, not the game itself.
      getE = safeGetEntity ebmap
      nid = getE . view entityName
  -- --------------------------------------------------------------------------
  -- Get the starting inventories, entities present in the world and compute
  -- how hard each entity is to get - see 'recipeLevels'.
  let devs = RG.startingDevices graphData
      inv = RG.startingInventory graphData
      worldEntities = RG.worldEntities graphData
      levels = RG.levels graphData
      recipes = RG.recipes graphData
  -- --------------------------------------------------------------------------
  -- Base inventory
  (_bc, ()) <- Dot.cluster $ do
    Dot.attribute ("style", "filled")
    Dot.attribute ("color", "lightgrey")
    mapM_ ((base ---<>) . nid) devs
    mapM_ ((base .->.) . nid) inv
  -- --------------------------------------------------------------------------
  -- World entities
  (_wc, ()) <- Dot.cluster $ do
    Dot.attribute ("style", "filled")
    Dot.attribute ("color", "forestgreen")
    mapM_ (uncurry (Dot..->.) . (world,) . nid) worldEntities
  -- --------------------------------------------------------------------------
  let -- put a hidden node above and below entities and connect them by hidden edges
      wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
      wrapBelowAbove ns = do
        b <- hiddenNode
        t <- hiddenNode
        let ns' = map nid $ toList ns
        mapM_ (b .~>.) ns'
        mapM_ (.~>. t) ns'
        return (b, t)
      -- put set of entities in nice
      subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)
      subLevel i ns = fmap snd . Dot.cluster $ do
        Dot.attribute ("style", "filled")
        Dot.attribute ("color", "khaki")
        bt <- wrapBelowAbove ns
        Dot.attribute ("rank", "sink")
        -- the normal label for cluster would be cover by lines
        _bigLabel <-
          Dot.node
            [ ("shape", "plain")
            , ("label", "Bottom Label")
            , ("fontsize", "20pt")
            , ("label", "Level #" <> show i)
            ]
        return bt
  -- --------------------------------------------------------------------------
  -- order entities into clusters based on how "far" they are from
  -- what is available at the start - see 'recipeLevels'.
  bottom <- wrapBelowAbove worldEntities
  ls <- zipWithM subLevel [1 ..] (drop 1 levels)
  let invisibleLine = zipWithM_ (.~>.)
  tls <- mapM (const hiddenNode) levels
  bls <- mapM (const hiddenNode) levels
  invisibleLine tls bls
  invisibleLine bls (drop 1 tls)
  let sameBelowAbove (b1, t1) (b2, t2) = Dot.same [b1, b2] >> Dot.same [t1, t2]
  zipWithM_ sameBelowAbove (bottom : ls) (zip bls tls)
  -- --------------------------------------------------------------------------
  -- add node for the world and draw a line to each entity found in the wild
  -- finally draw recipes
  let eFilter = filterEdge ef
      lvl e = fromMaybe (-1) $ List.findIndex (Set.member e) levels
      recipeInOut r = [(i, o) | (_, i) <- r ^. recipeInputs, (_, o) <- r ^. recipeOutputs, lvl i `eFilter` lvl o]
      recipeReqOut r = [(q, o) | (_, q) <- r ^. recipeCatalysts, (_, o) <- r ^. recipeOutputs, lvl q `eFilter` lvl o]
      recipesToPairs f rs = both nid <$> nubOrd (concatMap f rs)
  mapM_ (uncurry (.->.)) (recipesToPairs recipeInOut recipes)
  mapM_ (uncurry (---<>)) (recipesToPairs recipeReqOut recipes)
  -- --------------------------------------------------------------------------
  -- also draw an edge for each entity that "yields" another entity
  let yieldPairs = mapMaybe (\e -> (e ^. entityName,) <$> (e ^. entityYields)) . toList $ RG.allEntities graphData
  mapM_ (uncurry (.-<>.)) (both getE <$> yieldPairs)

-- ----------------------------------------------------------------------------
-- GRAPHVIZ HELPERS
-- ----------------------------------------------------------------------------

customNode :: [(String, String)] -> String -> Dot NodeId
customNode attrs label = Dot.node $ [("style", "filled"), ("label", label)] <> attrs

box, diamond :: String -> Dot NodeId
box = customNode [("shape", "box")]
diamond = customNode [("shape", "diamond")]

-- | Hidden node - used for layout.
hiddenNode :: Dot NodeId
hiddenNode = Dot.node [("style", "invis")]

-- | Edge for yielded entities.
(.-<>.) :: NodeId -> NodeId -> Dot ()
e1 .-<>. e2 = Dot.edge e1 e2 attrs
 where
  attrs = [("arrowhead", "diamond"), ("color", "purple")]

-- | Hidden edge - used for layout.
(.~>.) :: NodeId -> NodeId -> Dot ()
i .~>. j = Dot.edge i j [("style", "invis")]

-- | Edge for recipe requirements and outputs.
(---<>) :: NodeId -> NodeId -> Dot ()
e1 ---<> e2 = Dot.edge e1 e2 attrs
 where
  attrs = [("arrowhead", "diamond"), ("color", "blue")]