Generate docs from test spec

build.sh

@@ -1,4 +1,5 @@
 stack build --install-ghc --stack-yaml stack-ghcjs.yaml \
   && cp static/* .stack-work/dist/x86_64-osx/Cabal-1.24.0.0_ghcjs/build/duet-web/duet-web.jsexe/ \
   && cp static/* .stack-work/dist/x86_64-osx/Cabal-1.24.0.0_ghcjs/build/duet-ide/duet-ide.jsexe/ \
-  && cp static/* .stack-work/dist/x86_64-osx/Cabal-1.24.0.0_ghcjs/build/duet-ide-test/duet-ide-test.jsexe/
+  && cp static/* .stack-work/dist/x86_64-osx/Cabal-1.24.0.0_ghcjs/build/duet-ide-test/duet-ide-test.jsexe/ \
+  && cp static/* .stack-work/dist/x86_64-osx/Cabal-1.24.0.0_ghcjs/build/duet-ide-doc/duet-ide-doc.jsexe/

duet.cabal

@@ -186,3 +186,54 @@ executable duet-ide-test
     basic-lens,
     deepseq,
     syb
+
+
+executable duet-ide-doc
+  if impl(ghcjs)
+    buildable: True
+  else
+    buildable: False
+  other-modules:
+    Shared
+    React.Flux.Persist
+    React.Flux.Events
+    Duet.IDE
+    Duet.IDE.Types
+    Duet.IDE.Constructors
+    Duet.IDE.Interpreters
+    Duet.IDE.View
+    Duet.IDE.Spec
+    Duet.IDE.Test
+    Duet.IDE.Doc
+  default-language:
+    Haskell2010
+  hs-source-dirs:
+    web, shared
+  main-is:
+    IDEDocs.hs
+  ghc-options:
+    -threaded -Wall -O0
+
+  if impl(ghcjs)
+    build-depends: ghcjs-base,
+      ghcjs-dom
+  if !impl(ghcjs)
+    build-depends: ghcjs-base-stub
+
+  build-depends:
+    duet,
+    base,
+    react-flux,
+    parsec,
+    text,
+    exceptions,
+    mtl,
+    containers,
+    aeson,
+    these,
+    bifunctors,
+    dependent-sum,
+    data-default,
+    basic-lens,
+    deepseq,
+    syb

static/index.html

@@ -106,6 +106,24 @@ margin-left: 0.3em;
 .duet-expression + .duet-expression, .duet-expression + .duet-implicit-parens {
 margin-left: 0.3em;
 }
+
+.duet-key-legend {
+  margin-right: 0.5em;
+}
+.duet-key-press {
+background: #008cd5;
+color: #fff;
+border-radius: 0.2em;
+padding: 0.25em;
+}
+.duet-key-press + .duet-key-press {
+margin-left: 0.5em;
+}
+.duet-key-name {
+margin-right: 0.5em;
+font-size: 70%;
+}
+
     </style>
     <script>
       // code based on: http://stackoverflow.com/questions/105034/create-guid-uuid-in-javascript

web/Duet/IDE/Doc.hs

@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
+
+-- |
+
+module Duet.IDE.Doc where
+
+import           Control.Monad
+import qualified Data.Text as T
+import           Duet.IDE.Test
+import           Duet.IDE.Types
+import qualified React.Flux as Flux
+
+renderDoc :: Test -> Flux.ReactElementM Flux.ViewEventHandler ()
+renderDoc t0 = go 2 t0
+  where
+    go indent =
+      \case
+        Group t ts -> do
+          heading indent t
+          mapM_ (go (indent + 2)) ts
+        Test name actions _ -> do
+          Flux.p_ (Flux.elemText (T.pack name))
+          Flux.p_ (do Flux.span_ ["className" Flux.@= "duet-key-legend"] "⌨"
+                      mapM_ renderAction actions)
+
+renderAction :: Interaction -> Flux.ReactElementM Flux.ViewEventHandler ()
+renderAction = go
+  where
+    go =
+      \case
+        KeyDownAction shift keydown -> do
+          when shift (key '⇧' " (shift) + ")
+          case keydown of
+            BackspaceKey -> key '⌫' " (backspace)"
+            TabKey -> key '⇥' " (tab)"
+            DownKey -> key '↓' " (down)"
+            UpKey -> key '↑' " (up)"
+            LeftKey -> key '←' " (left)"
+            RightKey -> key '→' " (right)"
+            ReturnKey -> key '⏎' " (enter/return)"
+        KeyPressAction c -> key c (T.pack [c])
+    key c title =
+      Flux.code_
+        ["className" Flux.@= "duet-key-press", "title" Flux.@= title]
+        (Flux.elemText (T.pack [c]))
+
+heading :: Int -> String -> Flux.ReactElementM Flux.ViewEventHandler ()
+heading n t =
+  case n of
+    1 -> Flux.h1_ [] (Flux.elemText (T.pack t))
+    2 -> Flux.h2_ [] (Flux.elemText (T.pack t))
+    3 -> Flux.h3_ [] (Flux.elemText (T.pack t))
+    _ -> Flux.h4_ [] (Flux.elemText (T.pack t))

web/Duet/IDE/Spec.hs

@@ -9,11 +9,11 @@ import Duet.IDE.Types
 import Duet.Types
 import React.Flux.Persist
 
-tests :: Test
+tests :: [Test]
 tests =
-  Group
-    "Value declarations"
-    [Group "LHS" lhsTests, switchToRHS (Group "RHS" rhsTests)]
+  [ Group "Definitions" lhsTests
+  , switchToRHS (Group "Expressions" valueTests)
+  ]
 
 lhsTests :: [Test]
 lhsTests =
@@ -27,12 +27,15 @@ lhsTests =
       (makeState "f" initExpression)
   ]
 
-rhsTests :: [Test]
-rhsTests =
-  [ Test "Tab to RHS" [] (rhsSelectedState initExpression)
-  , Test "Backspace no-op" typeBackspace (rhsSelectedState initExpression)
+valueTests :: [Test]
+valueTests =
+  [ Test "Hit tab to move to the next slot" [] (rhsSelectedState initExpression)
   , Test
-      "Parens"
+      "Hitting backspace does nothing"
+      typeBackspace
+      (rhsSelectedState initExpression)
+  , Test
+      "Hit open parenthesis to create balanced parentheses"
       (typeChars "(")
       (focus
          (UUID "2")
@@ -42,17 +45,13 @@ rhsTests =
                (ConstantExpression
                   (Label {labelUUID = UUID "2"})
                   (Identifier {identifierString = "_"})))))
-  , Group "If" ifTests
-  , Group "Lambda" lambdaTests
-  , Group
-      "Case"
-      caseTests
-  , Group "Variables" variableTests
-  , Group
-      "Literals"
-      literalTests
+  , Group "Variable expressions" variableTests
   , Group "Function application" functionApplicationTests
-  , Group "Infix" infixTests
+  , Group "Infix expressions" infixTests
+  , Group "If expressions" ifTests
+  , Group "Lambda expressions" lambdaTests
+  , Group "Case expressions" caseTests
+  , Group "Literal expressions" literalTests
   ]
 
 literalTests :: [Test]
@@ -65,7 +64,7 @@ literalTests =
             (Label {labelUUID = starterExprUUID})
             (IntegerLiteral 123)))
   , Test
-      "Type integer literal, invalid chars ignored"
+      "Type integer literal, invalid chars are ignored"
       (typeChars "123abc")
       (rhsSelectedState
          (LiteralExpression
@@ -184,7 +183,21 @@ functionApplicationTests =
                   (Label {labelUUID = UUID "1"})
                   (Identifier {identifierString = "_"})))))
   , Test
-      "Function completion (2 args)"
+      "Type variable argument and typing one argument"
+      (typeChars "f x")
+      (focus
+         (UUID "1")
+         (rhsSelectedState
+            (ApplicationExpression
+               (Label {labelUUID = UUID "2"})
+               (VariableExpression
+                  (Label {labelUUID = starterExprUUID})
+                  (Identifier {identifierString = "f"}))
+               (VariableExpression
+                  (Label {labelUUID = UUID "1"})
+                  (Identifier {identifierString = "x"})))))
+  , Test
+      "Function completion and typing two arguments"
       (typeChars "f x y")
       (focus
          (UUID "5")
@@ -203,21 +216,7 @@ functionApplicationTests =
                   (Label {labelUUID = UUID "5"})
                   (Identifier {identifierString = "y"})))))
   , Test
-      "Type variable argument"
-      (typeChars "f x")
-      (focus
-         (UUID "1")
-         (rhsSelectedState
-            (ApplicationExpression
-               (Label {labelUUID = UUID "2"})
-               (VariableExpression
-                  (Label {labelUUID = starterExprUUID})
-                  (Identifier {identifierString = "f"}))
-               (VariableExpression
-                  (Label {labelUUID = UUID "1"})
-                  (Identifier {identifierString = "x"})))))
-  , Test
-      "Delete argument"
+      "Delete an argument from a function application"
       (typeChars "f x" <> typeBackspace <> typeBackspace)
       (focus
          starterExprUUID
@@ -226,7 +225,7 @@ functionApplicationTests =
                (Label {labelUUID = starterExprUUID})
                (Identifier {identifierString = "f"}))))
   , Test
-      "Delete function"
+      "Delete the function from a function application"
       (typeChars "f x" <> typeLeft <> typeBackspace <> typeBackspace)
       (focus
          (UUID "1")
@@ -235,7 +234,7 @@ functionApplicationTests =
                (Label {labelUUID = UUID "1"})
                (Identifier {identifierString = "x"}))))
   , Test
-      "Add argument inbetween func and arg"
+      "Add argument inbetween function and argument"
       (typeChars "f x" <> typeLeft <> typeChars " ")
       (focus
          (UUID "3")
@@ -258,7 +257,7 @@ functionApplicationTests =
 infixTests :: [Test]
 infixTests =
   [ Test
-      "Infix completion (after hole)"
+      "Infix completion (after a hole)"
       (typeChars "*")
       (focus
          (UUID "1")
@@ -276,7 +275,7 @@ infixTests =
                   (Label {labelUUID = UUID "1"})
                   (Identifier {identifierString = "_"})))))
   , Test
-      "Infix completion (after name)"
+      "Infix completion (after a variable)"
       (typeChars "x*")
       (focus
          (UUID "1")
@@ -294,7 +293,7 @@ infixTests =
                   (Label {labelUUID = UUID "1"})
                   (Identifier {identifierString = "_"})))))
   , Test
-      "Infix completion (after function application of hole)"
+      "Infix completion (after function application of a hole)"
       (typeChars "x *")
       (focus
          (UUID "3")
@@ -312,7 +311,7 @@ infixTests =
                   (Label {labelUUID = UUID "3"})
                   (Identifier {identifierString = "_"})))))
   , Test
-      "Infix completion (after nested function application of hole)"
+      "Infix completion (after nested function application of a hole)"
       (typeChars "x*y *")
       (focus
          (UUID "6")
@@ -339,7 +338,7 @@ infixTests =
                      (Label {labelUUID = UUID "6"})
                      (Identifier {identifierString = "_"}))))))
   , Test
-      "Infix completion (after nested function application of hole)"
+      "Infix completion (after nested function application of a hole)"
       (typeChars "x*y +")
       (focus
          (UUID "6")
@@ -366,7 +365,7 @@ infixTests =
                   (Label {labelUUID = UUID "6"})
                   (Identifier {identifierString = "_"})))))
   , Test
-      "Infix preserves precedence"
+      "Infix preserves order of operations"
       (typeChars "*+/")
       (focus
          (UUID "7")
@@ -413,7 +412,7 @@ variableTests =
             (Label {labelUUID = starterExprUUID})
             (Identifier {identifierString = "foo"})))
   , Test
-      "Ignore uppercase beginning"
+      "Uppercase at the beginning of a variable name is ignored"
       (typeChars "Foo")
       (rhsSelectedState
          (VariableExpression
@@ -427,14 +426,14 @@ variableTests =
             (Label {labelUUID = starterExprUUID})
             (Identifier {identifierString = "f"})))
   , Test
-      "Type variable name, empty back to constant"
+      "Type variable name, backspace to a hole"
       (typeChars "foo" <> typeBackspace <> typeBackspace <> typeBackspace)
       (rhsSelectedState
          (ConstantExpression
             (Label {labelUUID = starterExprUUID})
             (Identifier {identifierString = "_"})))
   , Test
-      "Type variable name with digits"
+      "Type variable name with digits in it"
       (typeChars "foo123")
       (rhsSelectedState
          (VariableExpression

web/IDEDocs.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
+
+-- | IDE documentation.
+
+module Main (main) where
+
+import           Duet.IDE.Doc
+import           Duet.IDE.Spec
+import           React.Flux ((@=))
+import qualified React.Flux as Flux
+
+--------------------------------------------------------------------------------
+-- Main entry point
+
+data State = State
+data Action = Action
+
+instance Flux.StoreData State where
+  type StoreAction State = Action
+  transform Action State = pure State
+
+main :: IO ()
+main = do
+  Flux.reactRender
+    "app"
+    (Flux.defineControllerView
+       "State"
+       (Flux.mkStore State)
+       (\State () -> testview (mapM_ renderDoc tests)))
+    ()
+
+----------------------------------------------------------------------
+-- View
+
+testview ::
+     Flux.ReactElementM Flux.ViewEventHandler ()
+  -> Flux.ReactElementM Flux.ViewEventHandler ()
+testview view = do
+  Flux.h1_ ["key" @= "title"] (Flux.elemText "Editor functionality")
+  view

web/IDETest.hs

@@ -27,7 +27,7 @@ main = do
        store
        (\state () -> testview state (renderModule (stateCursor state) (stateAST state))))
     ()
-  runTest tests
+  mapM_ runTest tests
 
 ----------------------------------------------------------------------
 -- View