{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Swarm.DocGen (
  generateDocs,
  GenerateDocs (..),
  EditorType (..),
  SheetType (..),

  -- ** Formatted keyword lists
  keywordsCommands,
  keywordsDirections,
  operatorNames,
  builtinFunctionList,
  editorList,

  -- ** Wiki pages
  PageAddress (..),
  commandsPage,
  capabilityPage,
  noPageAddresses,
) where

import Control.Arrow (left)
import Control.Lens (view, (^.))
import Control.Lens.Combinators (to)
import Control.Monad (zipWithM, zipWithM_, (<=<))
import Control.Monad.Except (ExceptT, liftIO, runExceptT)
import Data.Bifunctor (Bifunctor (bimap))
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (find, toList)
import Data.List (transpose)
import Data.Map.Lazy (Map)
import Data.Map.Lazy qualified as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text, unpack)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Tuple (swap)
import Data.Yaml (decodeFileEither)
import Data.Yaml.Aeson (prettyPrintParseException)
import Swarm.Game.Display (displayChar)
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
import Swarm.Game.Entity qualified as E
import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight)
import Swarm.Game.Robot (equippedDevices, instantiateRobot, robotInventory)
import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
import Swarm.Game.WorldGen (testWorld2Entites)
import Swarm.Language.Capability (Capability)
import Swarm.Language.Capability qualified as Capability
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Syntax (Const (..))
import Swarm.Language.Syntax qualified as Syntax
import Swarm.Language.Typecheck (inferConst)
import Swarm.Util (getDataFileNameSafe, isRightOr, listEnums, quote)
import Text.Dot (Dot, NodeId, (.->.))
import Text.Dot qualified as Dot
import Witch (from)

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

data GenerateDocs where
  -- | Entity dependencies by recipes.
  RecipeGraph :: GenerateDocs
  -- | Keyword lists for editors.
  EditorKeywords :: Maybe EditorType -> GenerateDocs
  CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs
  deriving (GenerateDocs -> GenerateDocs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenerateDocs -> GenerateDocs -> Bool
$c/= :: GenerateDocs -> GenerateDocs -> Bool
== :: GenerateDocs -> GenerateDocs -> Bool
$c== :: GenerateDocs -> GenerateDocs -> Bool
Eq, Int -> GenerateDocs -> ShowS
[GenerateDocs] -> ShowS
GenerateDocs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenerateDocs] -> ShowS
$cshowList :: [GenerateDocs] -> ShowS
show :: GenerateDocs -> String
$cshow :: GenerateDocs -> String
showsPrec :: Int -> GenerateDocs -> ShowS
$cshowsPrec :: Int -> GenerateDocs -> ShowS
Show)

data EditorType = Emacs | VSCode
  deriving (EditorType -> EditorType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EditorType -> EditorType -> Bool
$c/= :: EditorType -> EditorType -> Bool
== :: EditorType -> EditorType -> Bool
$c== :: EditorType -> EditorType -> Bool
Eq, Int -> EditorType -> ShowS
[EditorType] -> ShowS
EditorType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EditorType] -> ShowS
$cshowList :: [EditorType] -> ShowS
show :: EditorType -> String
$cshow :: EditorType -> String
showsPrec :: Int -> EditorType -> ShowS
$cshowsPrec :: Int -> EditorType -> ShowS
Show, Int -> EditorType
EditorType -> Int
EditorType -> [EditorType]
EditorType -> EditorType
EditorType -> EditorType -> [EditorType]
EditorType -> EditorType -> EditorType -> [EditorType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: EditorType -> EditorType -> EditorType -> [EditorType]
$cenumFromThenTo :: EditorType -> EditorType -> EditorType -> [EditorType]
enumFromTo :: EditorType -> EditorType -> [EditorType]
$cenumFromTo :: EditorType -> EditorType -> [EditorType]
enumFromThen :: EditorType -> EditorType -> [EditorType]
$cenumFromThen :: EditorType -> EditorType -> [EditorType]
enumFrom :: EditorType -> [EditorType]
$cenumFrom :: EditorType -> [EditorType]
fromEnum :: EditorType -> Int
$cfromEnum :: EditorType -> Int
toEnum :: Int -> EditorType
$ctoEnum :: Int -> EditorType
pred :: EditorType -> EditorType
$cpred :: EditorType -> EditorType
succ :: EditorType -> EditorType
$csucc :: EditorType -> EditorType
Enum, EditorType
forall a. a -> a -> Bounded a
maxBound :: EditorType
$cmaxBound :: EditorType
minBound :: EditorType
$cminBound :: EditorType
Bounded)

data SheetType = Entities | Commands | Capabilities | Recipes
  deriving (SheetType -> SheetType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SheetType -> SheetType -> Bool
$c/= :: SheetType -> SheetType -> Bool
== :: SheetType -> SheetType -> Bool
$c== :: SheetType -> SheetType -> Bool
Eq, Int -> SheetType -> ShowS
[SheetType] -> ShowS
SheetType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SheetType] -> ShowS
$cshowList :: [SheetType] -> ShowS
show :: SheetType -> String
$cshow :: SheetType -> String
showsPrec :: Int -> SheetType -> ShowS
$cshowsPrec :: Int -> SheetType -> ShowS
Show, Int -> SheetType
SheetType -> Int
SheetType -> [SheetType]
SheetType -> SheetType
SheetType -> SheetType -> [SheetType]
SheetType -> SheetType -> SheetType -> [SheetType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SheetType -> SheetType -> SheetType -> [SheetType]
$cenumFromThenTo :: SheetType -> SheetType -> SheetType -> [SheetType]
enumFromTo :: SheetType -> SheetType -> [SheetType]
$cenumFromTo :: SheetType -> SheetType -> [SheetType]
enumFromThen :: SheetType -> SheetType -> [SheetType]
$cenumFromThen :: SheetType -> SheetType -> [SheetType]
enumFrom :: SheetType -> [SheetType]
$cenumFrom :: SheetType -> [SheetType]
fromEnum :: SheetType -> Int
$cfromEnum :: SheetType -> Int
toEnum :: Int -> SheetType
$ctoEnum :: Int -> SheetType
pred :: SheetType -> SheetType
$cpred :: SheetType -> SheetType
succ :: SheetType -> SheetType
$csucc :: SheetType -> SheetType
Enum, SheetType
forall a. a -> a -> Bounded a
maxBound :: SheetType
$cmaxBound :: SheetType
minBound :: SheetType
$cminBound :: SheetType
Bounded)

data PageAddress = PageAddress
  { PageAddress -> Text
entityAddress :: Text
  , PageAddress -> Text
commandsAddress :: Text
  , PageAddress -> Text
capabilityAddress :: Text
  , PageAddress -> Text
recipesAddress :: Text
  }
  deriving (PageAddress -> PageAddress -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PageAddress -> PageAddress -> Bool
$c/= :: PageAddress -> PageAddress -> Bool
== :: PageAddress -> PageAddress -> Bool
$c== :: PageAddress -> PageAddress -> Bool
Eq, Int -> PageAddress -> ShowS
[PageAddress] -> ShowS
PageAddress -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PageAddress] -> ShowS
$cshowList :: [PageAddress] -> ShowS
show :: PageAddress -> String
$cshow :: PageAddress -> String
showsPrec :: Int -> PageAddress -> ShowS
$cshowsPrec :: Int -> PageAddress -> ShowS
Show)

noPageAddresses :: PageAddress
noPageAddresses :: PageAddress
noPageAddresses = Text -> Text -> Text -> Text -> PageAddress
PageAddress Text
"" Text
"" Text
"" Text
""

generateDocs :: GenerateDocs -> IO ()
generateDocs :: GenerateDocs -> IO ()
generateDocs = \case
  GenerateDocs
RecipeGraph -> IO String
generateRecipe forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn
  EditorKeywords Maybe EditorType
e ->
    case Maybe EditorType
e of
      Just EditorType
et -> EditorType -> IO ()
generateEditorKeywords EditorType
et
      Maybe EditorType
Nothing -> do
        String -> IO ()
putStrLn String
"All editor completions:"
        let editorGen :: EditorType -> IO ()
editorGen EditorType
et = do
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
40 Char
'-'
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"-- " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show EditorType
et
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
40 Char
'-'
              EditorType -> IO ()
generateEditorKeywords EditorType
et
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EditorType -> IO ()
editorGen forall e. (Enum e, Bounded e) => [e]
listEnums
  CheatSheet PageAddress
address Maybe SheetType
s -> case Maybe SheetType
s of
    Maybe SheetType
Nothing -> forall a. HasCallStack => String -> a
error String
"Not implemented for all Wikis"
    Just SheetType
st -> case SheetType
st of
      SheetType
Commands -> Text -> IO ()
T.putStrLn Text
commandsPage
      SheetType
Capabilities -> forall a. ExceptT Text IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
        EntityMap
entities <- forall (m :: * -> *). MonadIO m => m (Either Text EntityMap)
loadEntities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
"load entities"
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ PageAddress -> EntityMap -> Text
capabilityPage PageAddress
address EntityMap
entities
      SheetType
Entities -> forall a. ExceptT Text IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
        let loadEntityList :: String -> IO (Either c a)
loadEntityList String
fp = forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (forall source target. From source target => source -> target
from forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> String
prettyPrintParseException) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
fp
        let f :: String
f = String
"entities.yaml"
        Just String
fileName <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
getDataFileNameSafe String
f
        [Entity]
entities <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall {c} {a}.
(From String c, FromJSON a) =>
String -> IO (Either c a)
loadEntityList String
fileName) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
"load entities"
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ PageAddress -> [Entity] -> Text
entitiesPage PageAddress
address [Entity]
entities
      SheetType
Recipes -> forall a. ExceptT Text IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
        EntityMap
entities <- forall (m :: * -> *). MonadIO m => m (Either Text EntityMap)
loadEntities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
"load entities"
        [Recipe Entity]
recipes <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
EntityMap -> m (Either Text [Recipe Entity])
loadRecipes EntityMap
entities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
"load recipes"
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ PageAddress -> [Recipe Entity] -> Text
recipePage PageAddress
address [Recipe Entity]
recipes

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

generateEditorKeywords :: EditorType -> IO ()
generateEditorKeywords :: EditorType -> IO ()
generateEditorKeywords = \case
  EditorType
Emacs -> do
    String -> IO ()
putStrLn String
"(x-builtins '("
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
Emacs
    String -> IO ()
putStrLn String
"))\n(x-commands '("
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsCommands EditorType
Emacs
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
Emacs
    String -> IO ()
putStrLn String
"))"
  EditorType
VSCode -> do
    String -> IO ()
putStrLn String
"Functions and commands:"
    Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
VSCode forall a. Semigroup a => a -> a -> a
<> Text
"|" forall a. Semigroup a => a -> a -> a
<> EditorType -> Text
keywordsCommands EditorType
VSCode
    String -> IO ()
putStrLn String
"\nDirections:"
    Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
VSCode
    String -> IO ()
putStrLn String
"\nOperators:"
    Text -> IO ()
T.putStrLn Text
operatorNames

commands :: [Const]
commands :: [Const]
commands = forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
Syntax.isCmd [Const]
Syntax.allConst

operators :: [Const]
operators :: [Const]
operators = forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
Syntax.isOperator [Const]
Syntax.allConst

builtinFunctions :: [Const]
builtinFunctions :: [Const]
builtinFunctions = forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
Syntax.isBuiltinFunction [Const]
Syntax.allConst

builtinFunctionList :: EditorType -> Text
builtinFunctionList :: EditorType -> Text
builtinFunctionList EditorType
e = EditorType -> [Text] -> Text
editorList EditorType
e forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Const -> Text
constSyntax [Const]
builtinFunctions

editorList :: EditorType -> [Text] -> Text
editorList :: EditorType -> [Text] -> Text
editorList = \case
  EditorType
Emacs -> [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
quote)
  EditorType
VSCode -> Text -> [Text] -> Text
T.intercalate Text
"|"

constSyntax :: Const -> Text
constSyntax :: Const -> Text
constSyntax = ConstInfo -> Text
Syntax.syntax forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> ConstInfo
Syntax.constInfo

-- | Get formatted list of basic functions/commands.
keywordsCommands :: EditorType -> Text
keywordsCommands :: EditorType -> Text
keywordsCommands EditorType
e = EditorType -> [Text] -> Text
editorList EditorType
e forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Const -> Text
constSyntax [Const]
commands

-- | Get formatted list of directions.
keywordsDirections :: EditorType -> Text
keywordsDirections :: EditorType -> Text
keywordsDirections EditorType
e = EditorType -> [Text] -> Text
editorList EditorType
e forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (DirInfo -> Text
Syntax.dirSyntax forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> DirInfo
Syntax.dirInfo) [Direction]
Syntax.allDirs

operatorNames :: Text
operatorNames :: Text
operatorNames = Text -> [Text] -> Text
T.intercalate Text
"|" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
escape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> Text
constSyntax) [Const]
operators
 where
  special :: String
  special :: String
special = String
"*+$[]|^"
  slashNotComment :: Char -> Text
slashNotComment = \case
    Char
'/' -> Text
"/(?![/|*])"
    Char
c -> Char -> Text
T.singleton Char
c
  escape :: Text -> Text
escape = (Char -> Text) -> Text -> Text
T.concatMap (\Char
c -> if Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
special then Text -> Char -> Text
T.snoc Text
"\\\\" Char
c else Char -> Text
slashNotComment Char
c)

-- ----------------------------------------------------------------------------
-- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE
-- ----------------------------------------------------------------------------

wrap :: Char -> Text -> Text
wrap :: Char -> Text -> Text
wrap Char
c = Char -> Text -> Text
T.cons Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
T.snoc Char
c

codeQuote :: Text -> Text
codeQuote :: Text -> Text
codeQuote = Char -> Text -> Text
wrap Char
'`'

escapeTable :: Text -> Text
escapeTable :: Text -> Text
escapeTable = (Char -> Text) -> Text -> Text
T.concatMap (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
'|' then Text -> Char -> Text
T.snoc Text
"\\" Char
c else Char -> Text
T.singleton Char
c)

separatingLine :: [Int] -> Text
separatingLine :: [Int] -> Text
separatingLine [Int]
ws = Char -> Text -> Text
T.cons Char
'|' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
T.snoc Char
'|' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Text -> Text
T.replicate Text
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
2 forall a. Num a => a -> a -> a
+)) [Int]
ws

listToRow :: [Int] -> [Text] -> Text
listToRow :: [Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
xs = Char -> Text -> Text
wrap Char
'|' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"|" forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Text -> Text
format [Int]
mw [Text]
xs
 where
  format :: Int -> Text -> Text
format Int
w Text
x = Char -> Text -> Text
wrap Char
' ' Text
x forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
w forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
x) Text
" "

maxWidths :: [[Text]] -> [Int]
maxWidths :: [[Text]] -> [Int]
maxWidths = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
T.length) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [[a]] -> [[a]]
transpose

addLink :: Text -> Text -> Text
addLink :: Text -> Text -> Text
addLink Text
l Text
t = [Text] -> Text
T.concat [Text
"[", Text
t, Text
"](", Text
l, Text
")"]

tshow :: Show a => a -> Text
tshow :: forall a. Show a => a -> Text
tshow = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- ---------
-- COMMANDS
-- ---------

commandHeader :: [Text]
commandHeader :: [Text]
commandHeader = [Text
"Syntax", Text
"Type", Text
"Capability", Text
"Description"]

commandToList :: Const -> [Text]
commandToList :: Const -> [Text]
commandToList Const
c =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Text -> Text -> Text
addLink (Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Const
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
codeQuote forall a b. (a -> b) -> a -> b
$ Const -> Text
constSyntax Const
c
    , Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyText forall a b. (a -> b) -> a -> b
$ Const -> Polytype
inferConst Const
c
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Capability -> Text
Capability.capabilityName forall a b. (a -> b) -> a -> b
$ Const -> Maybe Capability
Capability.constCaps Const
c
    , ConstDoc -> Text
Syntax.briefDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> ConstDoc
Syntax.constDoc forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
Syntax.constInfo Const
c
    ]

constTable :: [Const] -> Text
constTable :: [Const] -> Text
constTable [Const]
cs = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
commandRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
commandHeader forall a. a -> [a] -> [a]
: [[Text]]
commandRows)
  commandRows :: [[Text]]
commandRows = forall a b. (a -> b) -> [a] -> [b]
map Const -> [Text]
commandToList [Const]
cs
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
commandHeader, [Int] -> Text
separatingLine [Int]
mw]

commandToSection :: Const -> Text
commandToSection :: Const -> Text
commandToSection Const
c =
  [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    [ Text
"## " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Const
c)
    , Text
""
    , Text
"- syntax: " forall a. Semigroup a => a -> a -> a
<> Text -> Text
codeQuote (Const -> Text
constSyntax Const
c)
    , Text
"- type: " forall a. Semigroup a => a -> a -> a
<> (Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyText forall a b. (a -> b) -> a -> b
$ Const -> Polytype
inferConst Const
c)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"- required capabilities: " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Capability -> Text
Capability.capabilityName) forall a b. (a -> b) -> a -> b
$ Const -> Maybe Capability
Capability.constCaps Const
c
    , Text
""
    , ConstDoc -> Text
Syntax.briefDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> ConstDoc
Syntax.constDoc forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
Syntax.constInfo Const
c
    ]
      forall a. Semigroup a => a -> a -> a
<> let l :: Text
l = ConstDoc -> Text
Syntax.longDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> ConstDoc
Syntax.constDoc forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
Syntax.constInfo Const
c
          in if Text -> Bool
T.null Text
l then [] else [Text
"", Text
l]

commandsPage :: Text
commandsPage :: Text
commandsPage =
  Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$
    [ Text
"# Commands"
    , [Const] -> Text
constTable [Const]
commands
    , Text
"# Builtin functions"
    , Text
"These functions are evaluated immediately once they have enough arguments."
    , [Const] -> Text
constTable [Const]
builtinFunctions
    , Text
"# Operators"
    , [Const] -> Text
constTable [Const]
operators
    , Text
"# Detailed descriptions"
    ]
      forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Const -> Text
commandToSection ([Const]
commands forall a. Semigroup a => a -> a -> a
<> [Const]
builtinFunctions forall a. Semigroup a => a -> a -> a
<> [Const]
operators)

-- -------------
-- CAPABILITIES
-- -------------

capabilityHeader :: [Text]
capabilityHeader :: [Text]
capabilityHeader = [Text
"Name", Text
"Commands", Text
"Entities"]

capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text]
capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text]
capabilityRow PageAddress {Text
recipesAddress :: Text
capabilityAddress :: Text
commandsAddress :: Text
entityAddress :: Text
recipesAddress :: PageAddress -> Text
capabilityAddress :: PageAddress -> Text
commandsAddress :: PageAddress -> Text
entityAddress :: PageAddress -> Text
..} EntityMap
em Capability
cap =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Capability -> Text
Capability.capabilityName Capability
cap
    , Text -> [Text] -> Text
T.intercalate Text
", " (Const -> Text
linkCommand forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Const]
cs)
    , Text -> [Text] -> Text
T.intercalate Text
", " (Text -> Text
linkEntity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entity]
es)
    ]
 where
  linkEntity :: Text -> Text
linkEntity Text
t =
    if Text -> Bool
T.null Text
entityAddress
      then Text
t
      else Text -> Text -> Text
addLink (Text
entityAddress forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" Text
t) Text
t
  linkCommand :: Const -> Text
linkCommand Const
c =
    ( if Text -> Bool
T.null Text
commandsAddress
        then forall a. a -> a
id
        else Text -> Text -> Text
addLink (Text
commandsAddress forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Const
c)
    )
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
codeQuote
      forall a b. (a -> b) -> a -> b
$ Const -> Text
constSyntax Const
c

  cs :: [Const]
cs = [Const
c | Const
c <- [Const]
Syntax.allConst, let mcap :: Maybe Capability
mcap = Const -> Maybe Capability
Capability.constCaps Const
c, forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
== Capability
cap) Maybe Capability
mcap]
  es :: [Entity]
es = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ EntityMap -> Map Capability [Entity]
E.entitiesByCap EntityMap
em forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Capability
cap

capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text
capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text
capabilityTable PageAddress
a EntityMap
em [Capability]
cs = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
capabilityRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
capabilityHeader forall a. a -> [a] -> [a]
: [[Text]]
capabilityRows)
  capabilityRows :: [[Text]]
capabilityRows = forall a b. (a -> b) -> [a] -> [b]
map (PageAddress -> EntityMap -> Capability -> [Text]
capabilityRow PageAddress
a EntityMap
em) [Capability]
cs
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
capabilityHeader, [Int] -> Text
separatingLine [Int]
mw]

capabilityPage :: PageAddress -> EntityMap -> Text
capabilityPage :: PageAddress -> EntityMap -> Text
capabilityPage PageAddress
a EntityMap
em = PageAddress -> EntityMap -> [Capability] -> Text
capabilityTable PageAddress
a EntityMap
em forall e. (Enum e, Bounded e) => [e]
listEnums

-- ---------
-- Entities
-- ---------

entityHeader :: [Text]
entityHeader :: [Text]
entityHeader = [Text
"?", Text
"Name", Text
"Capabilities", Text
"Properties*", Text
"Portable"]

entityToList :: Entity -> [Text]
entityToList :: Entity -> [Text]
entityToList Entity
e =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Display
entityDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Display -> Char
displayChar
    , Text -> Text -> Text
addLink (Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
linkID) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName Entity
e
    , Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ Capability -> Text
Capability.capabilityName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set Capability)
E.entityCapabilities Entity
e)
    , Text -> [Text] -> Text
T.intercalate Text
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
tshow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= EntityProperty
E.Portable) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set EntityProperty
props
    , if EntityProperty
E.Portable forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set EntityProperty
props
        then Text
":heavy_check_mark:"
        else Text
":negative_squared_cross_mark:"
    ]
 where
  props :: Set EntityProperty
props = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set EntityProperty)
E.entityProperties Entity
e
  linkID :: Text
linkID = Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName Entity
e

entityTable :: [Entity] -> Text
entityTable :: [Entity] -> Text
entityTable [Entity]
es = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
entityRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
entityHeader forall a. a -> [a] -> [a]
: [[Text]]
entityRows)
  entityRows :: [[Text]]
entityRows = forall a b. (a -> b) -> [a] -> [b]
map Entity -> [Text]
entityToList [Entity]
es
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
entityHeader, [Int] -> Text
separatingLine [Int]
mw]

entityToSection :: Entity -> Text
entityToSection :: Entity -> Text
entityToSection Entity
e =
  [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    [ Text
"## " forall a. Semigroup a => a -> a -> a
<> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
E.entityName Entity
e
    , Text
""
    , Text
" - Char: " forall a. Semigroup a => a -> a -> a
<> (Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Display
entityDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Display -> Char
displayChar)
    ]
      forall a. Semigroup a => a -> a -> a
<> [Text
" - Properties: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set EntityProperty
props) | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set EntityProperty
props]
      forall a. Semigroup a => a -> a -> a
<> [Text
" - Capabilities: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (Capability -> Text
Capability.capabilityName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Capability]
caps) | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Capability]
caps]
      forall a. Semigroup a => a -> a -> a
<> [Text
"\n"]
      forall a. Semigroup a => a -> a -> a
<> [Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity [Text]
E.entityDescription Entity
e]
 where
  props :: Set EntityProperty
props = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set EntityProperty)
E.entityProperties Entity
e
  caps :: [Capability]
caps = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set Capability)
E.entityCapabilities Entity
e

entitiesPage :: PageAddress -> [Entity] -> Text
entitiesPage :: PageAddress -> [Entity] -> Text
entitiesPage PageAddress
_a [Entity]
es =
  Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$
    [ Text
"# Entities"
    , Text
"This is a quick-overview table of entities - click the name for detailed description."
    , Text
"*) As a note, most entities have the Portable property, so we show it in a separate column."
    , [Entity] -> Text
entityTable [Entity]
es
    ]
      forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Entity -> Text
entityToSection [Entity]
es

-- -------------
-- RECIPES
-- -------------

recipeHeader :: [Text]
recipeHeader :: [Text]
recipeHeader = [Text
"In", Text
"Out", Text
"Required", Text
"Time", Text
"Weight"]

recipeRow :: PageAddress -> Recipe Entity -> [Text]
recipeRow :: PageAddress -> Recipe Entity -> [Text]
recipeRow PageAddress {Text
recipesAddress :: Text
capabilityAddress :: Text
commandsAddress :: Text
entityAddress :: Text
recipesAddress :: PageAddress -> Text
capabilityAddress :: PageAddress -> Text
commandsAddress :: PageAddress -> Text
entityAddress :: PageAddress -> Text
..} Recipe Entity
r =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Entity) -> Text
formatCE forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs Recipe Entity
r)
    , Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Entity) -> Text
formatCE forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs Recipe Entity
r)
    , Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Entity) -> Text
formatCE forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeRequirements Recipe Entity
r)
    , forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) Integer
recipeTime Recipe Entity
r
    , forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) Integer
recipeWeight Recipe Entity
r
    ]
 where
  formatCE :: (a, Entity) -> Text
formatCE (a
c, Entity
e) = [Text] -> Text
T.unwords [forall a. Show a => a -> Text
tshow a
c, Text -> Text
linkEntity forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName Entity
e]
  linkEntity :: Text -> Text
linkEntity Text
t =
    if Text -> Bool
T.null Text
entityAddress
      then Text
t
      else Text -> Text -> Text
addLink (Text
entityAddress forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" Text
t) Text
t

recipeTable :: PageAddress -> [Recipe Entity] -> Text
recipeTable :: PageAddress -> [Recipe Entity] -> Text
recipeTable PageAddress
a [Recipe Entity]
rs = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
recipeRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
recipeHeader forall a. a -> [a] -> [a]
: [[Text]]
recipeRows)
  recipeRows :: [[Text]]
recipeRows = forall a b. (a -> b) -> [a] -> [b]
map (PageAddress -> Recipe Entity -> [Text]
recipeRow PageAddress
a) [Recipe Entity]
rs
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
recipeHeader, [Int] -> Text
separatingLine [Int]
mw]

recipePage :: PageAddress -> [Recipe Entity] -> Text
recipePage :: PageAddress -> [Recipe Entity] -> Text
recipePage = PageAddress -> [Recipe Entity] -> Text
recipeTable

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

generateRecipe :: IO String
generateRecipe :: IO String
generateRecipe = forall a. ExceptT Text IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
  EntityMap
entities <- forall (m :: * -> *). MonadIO m => m (Either Text EntityMap)
loadEntities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
"load entities"
  [Recipe Entity]
recipes <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
EntityMap -> m (Either Text [Recipe Entity])
loadRecipes EntityMap
entities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
"load recipes"
  Scenario
classic <- ExceptT Text IO Scenario
classicScenario
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Dot a -> String
Dot.showDot forall a b. (a -> b) -> a -> b
$ Scenario -> EntityMap -> [Recipe Entity] -> Dot ()
recipesToDot Scenario
classic EntityMap
entities [Recipe Entity]
recipes

recipesToDot :: Scenario -> EntityMap -> [Recipe Entity] -> Dot ()
recipesToDot :: Scenario -> EntityMap -> [Recipe Entity] -> Dot ()
recipesToDot Scenario
classic EntityMap
emap [Recipe Entity]
recipes = do
  (String, String) -> Dot ()
Dot.attribute (String
"rankdir", String
"LR")
  (String, String) -> Dot ()
Dot.attribute (String
"ranksep", String
"2")
  NodeId
world <- String -> Dot NodeId
diamond String
"World"
  NodeId
base <- String -> Dot NodeId
diamond String
"Base"
  -- --------------------------------------------------------------------------
  -- add nodes with for all the known entities
  let enames' :: [Text]
enames' = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityMap -> Map Text Entity
entitiesByName forall a b. (a -> b) -> a -> b
$ EntityMap
emap
      enames :: [Text]
enames = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
ignoredEntities) [Text]
enames'
  Map Text NodeId
ebmap <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
enames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Dot NodeId
box forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) [Text]
enames
  -- --------------------------------------------------------------------------
  -- getters for the NodeId based on entity name or the whole entity
  let safeGetEntity :: Map Text a -> Text -> a
safeGetEntity Map Text a
m Text
e = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
e forall a. Semigroup a => a -> a -> a
<> String
" is not an entity!?") forall a b. (a -> b) -> a -> b
$ Map Text a
m forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
e
      getE :: Text -> NodeId
getE = forall {a}. Map Text a -> Text -> a
safeGetEntity Map Text NodeId
ebmap
      nid :: Entity -> NodeId
nid = Text -> NodeId
getE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName
  -- --------------------------------------------------------------------------
  -- Get the starting inventories, entities present in the world and compute
  -- how hard each entity is to get - see 'recipeLevels'.
  let devs :: Set Entity
devs = Scenario -> Set Entity
startingDevices Scenario
classic
      inv :: Map Entity Int
inv = Scenario -> Map Entity Int
startingInventory Scenario
classic
      worldEntites :: Set Entity
worldEntites = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall {a}. Map Text a -> Text -> a
safeGetEntity forall a b. (a -> b) -> a -> b
$ EntityMap -> Map Text Entity
entitiesByName EntityMap
emap) Set Text
testWorld2Entites
      levels :: [Set Entity]
levels = [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels [Recipe Entity]
recipes (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Entity
worldEntites, Set Entity
devs])
  -- --------------------------------------------------------------------------
  -- Base inventory
  (NodeId
_bc, ()) <- forall a. Dot a -> Dot (NodeId, a)
Dot.cluster forall a b. (a -> b) -> a -> b
$ do
    (String, String) -> Dot ()
Dot.attribute (String
"style", String
"filled")
    (String, String) -> Dot ()
Dot.attribute (String
"color", String
"lightgrey")
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId
base NodeId -> NodeId -> Dot ()
---<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> NodeId
nid) Set Entity
devs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId
base NodeId -> NodeId -> Dot ()
.->.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> NodeId
nid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Entity Int
inv
  -- --------------------------------------------------------------------------
  -- World entities
  (NodeId
_wc, ()) <- forall a. Dot a -> Dot (NodeId, a)
Dot.cluster forall a b. (a -> b) -> a -> b
$ do
    (String, String) -> Dot ()
Dot.attribute (String
"style", String
"filled")
    (String, String) -> Dot ()
Dot.attribute (String
"color", String
"forestgreen")
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(Dot..->.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId
world,)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NodeId
getE) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Text
testWorld2Entites)
  -- --------------------------------------------------------------------------
  let -- put a hidden node above and below entities and connect them by hidden edges
      wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
      wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
wrapBelowAbove Set Entity
ns = do
        NodeId
b <- Dot NodeId
hiddenNode
        NodeId
t <- Dot NodeId
hiddenNode
        let ns' :: [NodeId]
ns' = forall a b. (a -> b) -> [a] -> [b]
map Entity -> NodeId
nid forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Entity
ns
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeId
b NodeId -> NodeId -> Dot ()
.~>.) [NodeId]
ns'
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeId -> NodeId -> Dot ()
.~>. NodeId
t) [NodeId]
ns'
        forall (m :: * -> *) a. Monad m => a -> m a
return (NodeId
b, NodeId
t)
      -- put set of entities in nice
      subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)
      subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)
subLevel Int
i Set Entity
ns = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Dot a -> Dot (NodeId, a)
Dot.cluster forall a b. (a -> b) -> a -> b
$ do
        (String, String) -> Dot ()
Dot.attribute (String
"style", String
"filled")
        (String, String) -> Dot ()
Dot.attribute (String
"color", String
"khaki")
        (NodeId, NodeId)
bt <- Set Entity -> Dot (NodeId, NodeId)
wrapBelowAbove Set Entity
ns
        (String, String) -> Dot ()
Dot.attribute (String
"rank", String
"sink")
        -- the normal label for cluster would be cover by lines
        NodeId
_bigLabel <-
          [(String, String)] -> Dot NodeId
Dot.node
            [ (String
"shape", String
"plain")
            , (String
"label", String
"Bottom Label")
            , (String
"fontsize", String
"20pt")
            , (String
"label", String
"Level #" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i)
            ]
        forall (m :: * -> *) a. Monad m => a -> m a
return (NodeId, NodeId)
bt
  -- --------------------------------------------------------------------------
  -- order entities into clusters based on how "far" they are from
  -- what is available at the start - see 'recipeLevels'.
  (NodeId, NodeId)
bottom <- Set Entity -> Dot (NodeId, NodeId)
wrapBelowAbove Set Entity
worldEntites
  [(NodeId, NodeId)]
ls <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> Set Entity -> Dot (NodeId, NodeId)
subLevel [Int
1 ..] (forall a. [a] -> [a]
tail [Set Entity]
levels)
  let invisibleLine :: [NodeId] -> [NodeId] -> Dot ()
invisibleLine = forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ NodeId -> NodeId -> Dot ()
(.~>.)
  [NodeId]
tls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const Dot NodeId
hiddenNode) [Set Entity]
levels
  [NodeId]
bls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const Dot NodeId
hiddenNode) [Set Entity]
levels
  [NodeId] -> [NodeId] -> Dot ()
invisibleLine [NodeId]
tls [NodeId]
bls
  [NodeId] -> [NodeId] -> Dot ()
invisibleLine [NodeId]
bls (forall a. [a] -> [a]
tail [NodeId]
tls)
  let sameBelowAbove :: (NodeId, NodeId) -> (NodeId, NodeId) -> Dot ()
sameBelowAbove (NodeId
b1, NodeId
t1) (NodeId
b2, NodeId
t2) = [NodeId] -> Dot ()
Dot.same [NodeId
b1, NodeId
b2] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [NodeId] -> Dot ()
Dot.same [NodeId
t1, NodeId
t2]
  forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (NodeId, NodeId) -> (NodeId, NodeId) -> Dot ()
sameBelowAbove ((NodeId, NodeId)
bottom forall a. a -> [a] -> [a]
: [(NodeId, NodeId)]
ls) (forall a b. [a] -> [b] -> [(a, b)]
zip [NodeId]
bls [NodeId]
tls)
  -- --------------------------------------------------------------------------
  -- add node for the world and draw a line to each entity found in the wild
  -- finally draw recipes
  let recipeInOut :: Recipe b -> [(b, b)]
recipeInOut Recipe b
r = [(forall a b. (a, b) -> b
snd (Int, b)
i, forall a b. (a, b) -> b
snd (Int, b)
o) | (Int, b)
i <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs, (Int, b)
o <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs]
      recipeReqOut :: Recipe b -> [(b, b)]
recipeReqOut Recipe b
r = [(forall a b. (a, b) -> b
snd (Int, b)
q, forall a b. (a, b) -> b
snd (Int, b)
o) | (Int, b)
q <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeRequirements, (Int, b)
o <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs]
      recipesToPairs :: (a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs a -> [p Entity Entity]
f t a
rs = forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both Entity -> NodeId
nid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> [a]
nubOrd (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [p Entity Entity]
f t a
rs)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(.->.)) (forall {p :: * -> * -> *} {t :: * -> *} {a}.
(Bifunctor p, Ord (p Entity Entity), Foldable t) =>
(a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs forall {b}. Recipe b -> [(b, b)]
recipeInOut [Recipe Entity]
recipes)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(---<>)) (forall {p :: * -> * -> *} {t :: * -> *} {a}.
(Bifunctor p, Ord (p Entity Entity), Foldable t) =>
(a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs forall {b}. Recipe b -> [(b, b)]
recipeReqOut [Recipe Entity]
recipes)

-- ----------------------------------------------------------------------------
-- RECIPE LEVELS
-- ----------------------------------------------------------------------------

-- | Order entities in sets depending on how soon it is possible to obtain them.
--
-- So:
--  * Level 0 - starting entities (for example those obtainable in the world)
--  * Level N+1 - everything possible to make (or drill) from Level N
--
-- This is almost a BFS, but the requirement is that the set of entities
-- required for recipe is subset of the entities known in Level N.
--
-- If we ever depend on some graph library, this could be rewritten
-- as some BFS-like algorithm with added recipe nodes, but you would
-- need to enforce the condition that recipes need ALL incoming edges.
recipeLevels :: [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels :: [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels [Recipe Entity]
recipes Set Entity
start = [Set Entity]
levels
 where
  recipeParts :: Recipe e -> (IngredientList e, IngredientList e)
recipeParts Recipe e
r = ((Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs) forall a. Semigroup a => a -> a -> a
<> (Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeRequirements), Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs)
  m :: [(Set Entity, Set Entity)]
  m :: [(Set Entity, Set Entity)]
m = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both (forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e}. Recipe e -> (IngredientList e, IngredientList e)
recipeParts) [Recipe Entity]
recipes
  levels :: [Set Entity]
  levels :: [Set Entity]
levels = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [Set Entity] -> Set Entity -> [Set Entity]
go [Set Entity
start] Set Entity
start
   where
    isKnown :: Set a -> (Set a, b) -> Bool
isKnown Set a
known (Set a
i, b
_o) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Set a
i forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
known
    nextLevel :: Set Entity -> Set Entity
nextLevel Set Entity
known = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall {a} {b}. Ord a => Set a -> (Set a, b) -> Bool
isKnown Set Entity
known) [(Set Entity, Set Entity)]
m
    go :: [Set Entity] -> Set Entity -> [Set Entity]
go [Set Entity]
ls Set Entity
known =
      let n :: Set Entity
n = Set Entity -> Set Entity
nextLevel Set Entity
known forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Entity
known
       in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Entity
n
            then [Set Entity]
ls
            else [Set Entity] -> Set Entity -> [Set Entity]
go (Set Entity
n forall a. a -> [a] -> [a]
: [Set Entity]
ls) (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Entity
n Set Entity
known)

-- | Get classic scenario to figure out starting entities.
classicScenario :: ExceptT Text IO Scenario
classicScenario :: ExceptT Text IO Scenario
classicScenario = do
  EntityMap
entities <- forall (m :: * -> *). MonadIO m => m (Either Text EntityMap)
loadEntities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
"load entities"
  forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
String -> EntityMap -> m (Scenario, String)
loadScenario String
"data/scenarios/classic.yaml" EntityMap
entities

startingDevices :: Scenario -> Set Entity
startingDevices :: Scenario -> Set Entity
startingDevices = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> IngredientList Entity
E.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Robot Inventory
equippedDevices forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TRobot -> Robot
instantiateRobot Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Scenario [TRobot]
scenarioRobots

startingInventory :: Scenario -> Map Entity Int
startingInventory :: Scenario -> Map Entity Int
startingInventory = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> IngredientList Entity
E.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Robot Inventory
robotInventory forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TRobot -> Robot
instantiateRobot Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Scenario [TRobot]
scenarioRobots

-- | Ignore utility entities that are just used for tutorials and challenges.
ignoredEntities :: Set Text
ignoredEntities :: Set Text
ignoredEntities =
  forall a. Ord a => [a] -> Set a
Set.fromList
    [ Text
"upper left corner"
    , Text
"upper right corner"
    , Text
"lower left corner"
    , Text
"lower right corner"
    , Text
"horizontal wall"
    , Text
"vertical wall"
    ]

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

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

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

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

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

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

-- ----------------------------------------------------------------------------
-- UTILITY
-- ----------------------------------------------------------------------------

both :: Bifunctor p => (a -> d) -> p a a -> p d d
both :: forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both a -> d
f = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> d
f a -> d
f

guardRight :: Text -> Either Text a -> ExceptT Text IO a
guardRight :: forall a. Text -> Either Text a -> ExceptT Text IO a
guardRight Text
what Either Text a
i = Either Text a
i forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) b a.
Has (Throw e) sig m =>
Either b a -> (b -> e) -> m a
`isRightOr` (\Text
e -> Text
"Failed to " forall a. Semigroup a => a -> a -> a
<> Text
what forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
e)

simpleErrorHandle :: ExceptT Text IO a -> IO a
simpleErrorHandle :: forall a. ExceptT Text IO a -> IO a
simpleErrorHandle = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT