tests/Recipes.hs

   1 module Recipes where
   2
   3 import Control.Monad.Trans.Class qualified as MT
   4 import Control.Monad.Trans.State.Strict qualified as MT
   5 import Data.ByteString.Builder qualified as Builder
   6 import Data.List qualified as List
   7 import Data.Map.Strict qualified as Map
   8 import Data.Text qualified as Text
   9 import Data.Text.Short qualified as ShortText
  10 import Graph.DOT qualified as DOT
  11 import Text.Blaze
  12 import Text.Blaze.Renderer.Utf8 qualified as Blaze
  13 import Text.Blaze.XHtml1.FrameSet qualified as H
  14 import Text.Blaze.XHtml1.FrameSet.Attributes qualified as H
  15 import Worksheets.Utils.HTML qualified as HTML
  16 import Worksheets.Utils.Prelude
  17
  18 type Type = ShortText
  19 type Name = ShortText
  20 type Quantity = ShortText
  21 data Recipe = Recipe
  22   { recipeName :: Name
  23   , recipeFunctions :: [(Name, Function)]
  24   }
  25 data Term
  26   = TermDescr {termQuantity :: Quantity}
  27   | TermRef
  28       { termRefName :: Name
  29       , termRefPort :: Maybe Name
  30       , termRefQuantity :: Maybe Quantity
  31       }
  32
  33 termToShortText :: Term -> ShortText
  34 termToShortText = \case
  35   TermDescr s -> s
  36   TermRef{..} -> termRefName <> (termRefPort & maybe "" (\p -> ":" <> p))
  37
  38 instance IsString Term where
  39   fromString = TermDescr . ShortText.pack
  40 data Function = Function
  41   { functionInputs :: Map Name Term
  42   , functionSteps :: [ShortText]
  43   , functionOutputs :: Map Name Type
  44   }
  45
  46 data RecipeState = RecipeState
  47   { recipeStateStep :: Natural
  48   }
  49 recipeDOT :: Recipe -> Builder.Builder
  50 recipeDOT Recipe{..} = (`MT.evalState` RecipeState{recipeStateStep = 1}) $ DOT.runDOT $ do
  51   DOT.dotLine "digraph g"
  52   DOT.dotBlock do
  53     DOT.dotLine "size=\"8.267,11.7!\""
  54     DOT.dotLine "margin=0"
  55     DOT.dotLine "nodesep=10"
  56     DOT.dotLine "ranksep=10"
  57     DOT.dotLine "rankdir=TD"
  58     DOT.dotLine "//fontnames=\"DejaVu Sans Mono,\""
  59     DOT.dotLine "splines=true"
  60     DOT.dotLine "overlap=false"
  61     DOT.dotLine "stylesheet=\"recipe.css\""
  62     DOT.dotLine "ratio=\"fill\""
  63     DOT.dotLine "//graph [layout=\"dot\" fontname=\"helvetica\"];"
  64     DOT.dotLine "node [fontsize=400 shape=\"box\" style=\"plaintext\" fontname=\"Linux Libertine Capitals\"];"
  65     DOT.dotLine "edge [color=\"#aaaaaa\" fontcolor=blue penwidth=30 arrowhead=open arrowsize=20];"
  66     forM_ (recipeFunctions & ol1) \(functionNum :: Natural, (functionName, Recipes.Function{..})) -> do
  67       -- step <- MT.lift $ MT.lift $ MT.state \st ->
  68       --  ( recipeStateStep st
  69       --  , st{recipeStateStep = recipeStateStep st + fromIntegral (List.length functionSteps) }
  70       --  )
  71       DOT.dotNode
  72         (functionName & DOT.builderQuotedShortText)
  73         [ "label" := DOT.ValueHTML $ Blaze.renderMarkupBuilder $ do
  74             H.table
  75               ! H.border "0"
  76               ! H.cellspacing "0"
  77               ! H.cellpadding "0"
  78               ! H.valign "MIDDLE"
  79               ! H.customAttribute "cellborder" "0"
  80               ! H.customAttribute "rows" "*"
  81               -- ! H.customAttribute "columns" "*"
  82               $ do
  83                 H.tr do
  84                   H.td
  85                     ! H.colspan "4"
  86                     ! H.height "300"
  87                     ! H.bgcolor "grey80"
  88                     ! H.customAttribute "cellborder" "0"
  89                     $ do
  90                       H.b do
  91                         xhtml1_text functionNum
  92                           ! H.customAttribute "color" "blue"
  93                         xhtml1_text (". " :: ShortText)
  94                         xhtml1_text functionName
  95                           ! H.customAttribute "color" "black"
  96                 forM_ (functionInputs & Map.toList) \(inputName, inputValue) -> do
  97                   H.tr do
  98                     td_checkbox
  99                       ! H.align "left"
 100                       ! H.customAttribute "port" (inputName & ShortText.unpack & ("input-" <>) & toValue)
 101                     let td_quantity =
 102                           H.td
 103                             ! H.valign "MIDDLE"
 104                             ! H.align "right"
 105                             ! H.bgcolor "white"
 106                             ! H.width "0"
 107                             ! H.height "100"
 108                     -- ! H.customAttribute "fixedsize" "true"
 109                     td_quantity do
 110                       case inputValue of
 111                         TermDescr{termQuantity} | termQuantity /= "" -> do
 112                           -- !? ( case inputValue of
 113                           --        TermDescr{} -> (False, H.customAttribute "port" "")
 114                           --        TermRef{..} -> (True, termRefPort & maybe (H.customAttribute "port" "") (H.customAttribute "port" . toValue . ShortText.unpack))
 115                           --     -- " PORT="<>ShortText.unpack termRefPort
 116                           --     --(isJust termRefPort, H.customAttribute "port" (termRefPort & fromMaybe ""))
 117                           --    )
 118                           xhtml1_quantity termQuantity
 119                         TermRef{..} | termRefQuantity & isJust -> do
 120                           termRefQuantity & maybe "" \q -> do
 121                             xhtml1_quantity q
 122                         _ -> xhtml1_quantity "1×"
 123                     H.td
 124                       ! H.valign "MIDDLE"
 125                       ! H.align "left"
 126                       ! H.bgcolor "white"
 127                       ! H.width "0"
 128                       ! H.height "100"
 129                       ! H.colspan "1"
 130                       $ do
 131                         xhtml1_text inputName
 132                     H.td do
 133                       ""
 134                 forM_ (functionSteps & ol1) \(stepNum :: Natural, stepName) -> do
 135                   H.tr do
 136                     td_checkbox
 137                       ! H.align "left"
 138                     H.td
 139                       ! H.align "left"
 140                       ! H.valign "MIDDLE"
 141                       ! H.colspan "3"
 142                       ! H.bgcolor "lightyellow"
 143                       $ do
 144                         H.b do
 145                           xhtml1_text (" " :: ShortText)
 146                           xhtml1_text (functionNum & show & ShortText.pack)
 147                             ! H.customAttribute "color" "blue"
 148                           xhtml1_text ("." :: ShortText)
 149                           xhtml1_text (stepNum & show & ShortText.pack)
 150                           xhtml1_text (". " :: ShortText)
 151                         stepName
 152                           & ShortText.toText
 153                           & Text.lines
 154                           <&> xhtml1_text
 155                           & List.intersperse H.br
 156                           & mconcat
 157                         xhtml1_text @ShortText " "
 158                 forM_ (functionOutputs & Map.toList) \(outputName, outputValue) -> do
 159                   H.tr do
 160                     H.td
 161                       ! H.width "0"
 162                       $ do
 163                         ""
 164                     H.td
 165                       ! H.valign "MIDDLE"
 166                       ! H.align "right"
 167                       ! H.bgcolor "white"
 168                       ! H.width "0"
 169                       ! H.height "100"
 170                       $ do
 171                         xhtml1_quantity outputValue
 172                     H.td
 173                       ! H.valign "MIDDLE"
 174                       ! H.align "left"
 175                       ! H.bgcolor "white"
 176                       ! H.width "0"
 177                       ! H.height "100"
 178                       $ do
 179                         xhtml1_text outputName
 180                     td_checkbox
 181                       ! H.align "right"
 182                       ! H.customAttribute "port" (outputName & ShortText.unpack & ("output-" <>) & toValue)
 183         ]
 184     forM_ recipeFunctions \(functionName, Recipes.Function{..}) -> do
 185       forM_ (functionInputs & Map.toList) \(inputName, inputTerm) -> do
 186         case inputTerm of
 187           TermDescr{} -> return ()
 188           TermRef{..} ->
 189             DOT.dotEdges
 190               [ [ [termRefName & DOT.builderQuotedShortText]
 191                 , termRefPort & maybeToList <&> (("output-" <>) >>> DOT.builderQuotedShortText)
 192                 , ["e"]
 193                 ]
 194                   & mconcat
 195                   & List.intersperse (Builder.charUtf8 ':')
 196                   & mconcat
 197               , [ [functionName & DOT.builderQuotedShortText]
 198                 , [inputName & ("input-" <>) & DOT.builderQuotedShortText]
 199                 , ["w"]
 200                 ]
 201                   & mconcat
 202                   & List.intersperse (Builder.charUtf8 ':')
 203                   & mconcat
 204               ]
 205               []
 206 td_checkbox =
 207   H.td
 208     ! H.valign "MIDDLE"
 209     ! H.bgcolor "white"
 210     ! H.width "0"
 211     ! H.height "200"
 212     -- ! H.customAttribute "fixedsize" "true"
 213     $ do
 214       H.font
 215         ! H.customAttribute "face" "Liberation Sans"
 216         ! H.customAttribute "point-size" "200"
 217         $ do
 218           "☐"
 219
 220 xhtml1_text :: HTML.ToMarkup s => s -> _
 221 xhtml1_text t =
 222   H.font
 223     ! H.customAttribute "face" "Linux Libertine Capitals"
 224     ! H.customAttribute "point-size" "200"
 225     $ do
 226       t & HTML.toHtml
 227
 228 xhtml1_quantity :: ShortText -> _
 229 xhtml1_quantity "" = return ()
 230 xhtml1_quantity q =
 231   H.font
 232     ! H.customAttribute "face" "Courier"
 233     ! H.customAttribute "point-size" "200"
 234     $ do
 235       H.b do
 236         q & HTML.toHtml
 237       " "
 238
 239 -- <TABLE BORDER="0" CELLBORDER="1" CELLSPACING="0" CELLPADDING="4">
 240 --   <TR><TD ALIGN="LEFT" BGCOLOR="white">☐ 70g SucreSemoule</TD></TR>
 241 -- </TABLE>