{-# LANGUAGE OverloadedStrings #-}
module Swarm.DocGen (
generateDocs,
GenerateDocs (..),
EditorType (..),
SheetType (..),
keywordsCommands,
keywordsDirections,
operatorNames,
builtinFunctionList,
editorList,
commandsPage,
) where
import Control.Lens (view, (^.))
import Control.Monad (zipWithM, zipWithM_, (<=<))
import Control.Monad.Except (ExceptT, runExceptT)
import Data.Bifunctor (Bifunctor (bimap))
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.List (transpose)
import Data.Map.Lazy (Map)
import Data.Map.Lazy qualified as Map
import Data.Maybe (fromMaybe)
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 Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName, loadEntities)
import Swarm.Game.Entity qualified as E
import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements)
import Swarm.Game.Robot (installedDevices, instantiateRobot, robotInventory)
import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
import Swarm.Game.WorldGen (testWorld2Entites)
import Swarm.Language.Capability (capabilityName, constCaps)
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 (isRightOr)
import Text.Dot (Dot, NodeId, (.->.))
import Text.Dot qualified as Dot
data GenerateDocs where
RecipeGraph :: GenerateDocs
EditorKeywords :: Maybe EditorType -> GenerateDocs
CheatSheet :: 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)
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 a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
CheatSheet Maybe SheetType
s -> case Maybe SheetType
s of
Maybe SheetType
Nothing -> forall a. HasCallStack => String -> a
error String
"Not implemented"
Just SheetType
st -> case SheetType
st of
SheetType
Commands -> Text -> IO ()
T.putStrLn Text
commandsPage
SheetType
_ -> forall a. HasCallStack => String -> a
error String
"Not implemented"
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
"|"
where
quote :: Text -> Text
quote = Char -> Text -> Text
T.cons Char
'"' 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
'"'
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
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
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)
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
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 (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show 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
capabilityName forall a b. (a -> b) -> a -> b
$ Const -> Maybe 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
]
where
addLink :: Text -> Text -> Text
addLink Text
l Text
t = [Text] -> Text
T.concat [Text
"[", Text
t, Text
"](", Text
l, Text
")"]
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
capabilityName) forall a b. (a -> b) -> a -> b
$ Const -> Maybe 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)
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"
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
ignoredEntites) [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
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
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])
(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
(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
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)
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")
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
(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)
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)
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)
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 -> [(Int, 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
installedDevices 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 -> [(Int, 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
ignoredEntites :: Set Text
ignoredEntites :: Set Text
ignoredEntites =
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"
]
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")]
hiddenNode :: Dot NodeId
hiddenNode :: Dot NodeId
hiddenNode = [(String, String)] -> Dot NodeId
Dot.node [(String
"style", String
"invis")]
(.~>.) :: 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")]
(---<>) :: 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")]
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