{-# LANGUAGE OverloadedStrings #-}

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

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

  -- ** Wiki pages
  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

-- ============================================================================
-- 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 :: 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"

-- ----------------------------------------------------------------------------
-- 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
"|"
 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

-- | 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

-- ---------
-- 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 (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)

-- ----------------------------------------------------------------------------
-- 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 entites
  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
  -- --------------------------------------------------------------------------
  -- 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, entites 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 entites
  (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 entites 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 entites 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 entites 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 entites in sets depending on how soon it is possible to obtain them.
--
-- So:
--  * Level 0 - starting entites (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 entites
-- required for recipe is subset of the entites 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 entites.
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

-- | Ignore utility entites that are just used for tutorials and challenges.
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"
    ]

-- ----------------------------------------------------------------------------
-- 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