Add a damlc doctest command and test the standard library (digital-as…

…set#2157) There is lots of room for improvements here but I think this is a good first step. The 3 main things that could be improved imho are: - Rewrite source locations to point to the original file rather than the generated module - Provide some way to declare things like imports or more general, setup code that is added to the generated module. - Prettier/more helpful output during a run, e.g., print the list of successful tests.
kgeonw · Jul 16, 2019 · 5aa3cba · 5aa3cba
1 parent 0fc0ca6
commit 5aa3cba
Show file tree

Hide file tree

Showing 17 changed files with 538 additions and 56 deletions.
diff --git a/.hie-bios b/.hie-bios
@@ -11,6 +11,7 @@ echo \
     -i"${BAZEL_GENFILES}"/daml-lf/archive \
     -icompiler/damlc/daml-compiler/src \
     -icompiler/damlc/daml-doc/src \
+    -icompiler/damlc/daml-doctest/src \
     -icompiler/damlc/daml-ide/src \
     -icompiler/damlc/daml-ide-core/src \
     -icompiler/damlc/daml-lf-conversion/src \

diff --git a/compiler/damlc/BUILD.bazel b/compiler/damlc/BUILD.bazel
@@ -2,7 +2,7 @@
 # SPDX-License-Identifier: Apache-2.0
 
 load("//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library", "da_haskell_test")
-load("//rules_daml:daml.bzl", "daml_compile")
+load("//rules_daml:daml.bzl", "daml_compile", "daml_doc_test")
 load("@os_info//:os_info.bzl", "is_windows")
 load("//bazel_tools/packaging:packaging.bzl", "package_app")
 
@@ -265,3 +265,10 @@ genrule(
     tools = ["//compiler/damlc"],
     visibility = ["//visibility:public"],
 )
+
+daml_doc_test(
+    name = "daml-stdlib-doctest",
+    srcs = ["//compiler/damlc/daml-stdlib-src"],
+    damlc_flags = "--package-name=daml-stdlib",
+    ignored_srcs = ["LibraryModules.daml"],
+)
diff --git a/compiler/damlc/daml-compiler/BUILD.bazel b/compiler/damlc/daml-compiler/BUILD.bazel
@@ -23,6 +23,7 @@ da_haskell_library(
         "mtl",
         "safe",
         "safe-exceptions",
+        "shake",
         "text",
         "time",
         "transformers",
@@ -33,6 +34,7 @@ da_haskell_library(
     deps = [
         "//compiler/daml-lf-ast",
         "//compiler/daml-lf-proto",
+        "//compiler/damlc/daml-doctest",
         "//compiler/damlc/daml-ide-core",
         "//compiler/damlc/daml-opts:daml-opts-types",
         "//compiler/damlc/daml-preprocessor",

diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DocTest.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DocTest.hs
@@ -0,0 +1,46 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE OverloadedStrings #-}
+module DA.Daml.Compiler.DocTest (docTest) where
+
+import Control.Monad
+import DA.Daml.Options.Types
+import DA.Daml.DocTest
+import qualified Data.Set as Set
+import qualified Data.Text.Extended as T
+import Development.IDE.Core.API
+import Development.IDE.Core.RuleTypes.Daml
+import Development.IDE.Core.Shake
+import Development.IDE.Types.Diagnostics
+import Development.IDE.Types.Location
+import qualified Development.Shake as Shake
+import System.Directory
+import System.Exit
+import System.FilePath
+
+-- We might want merge the logic for `damlc doctest` and `damlc test`
+-- at some point but the requirements are slightly different (e.g., we
+-- will eventually want to remap source locations in `damlc doctest`
+-- to the doc comment) so for now we keep them separate.
+
+docTest :: IdeState -> [NormalizedFilePath] -> IO ()
+docTest ideState files = do
+    ms <- runAction ideState (uses_ GenerateDocTestModule files)
+    let docTestFile m = toNormalizedFilePath $
+            genDir </>
+            T.unpack (T.replace "." "/" (docTestModuleName $ genModuleName m)) -<.>
+            "daml"
+    let msWithPaths = map (\m -> (m, docTestFile m)) ms
+    forM_ msWithPaths $ \(m, path) -> do
+        createDirectoryIfMissing True (takeDirectory $ fromNormalizedFilePath path)
+        T.writeFileUtf8 (fromNormalizedFilePath path) (genModuleContent m)
+    setFilesOfInterest ideState (Set.fromList $ map snd msWithPaths)
+    runAction ideState $ do
+        void $ Shake.forP msWithPaths $ \(_, path) -> use_ RunScenarios path
+    -- This seems to make the gRPC issues on shutdown slightly less
+    -- frequent but sadly it doesn’t make them go away completely.
+    runActionSync ideState (pure ())
+    diags <- getDiagnostics ideState
+    when (any ((Just DsError ==) . _severity . snd) diags) exitFailure
+
diff --git a/compiler/damlc/daml-doctest/BUILD.bazel b/compiler/damlc/daml-doctest/BUILD.bazel
@@ -0,0 +1,22 @@
+# Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+# SPDX-License-Identifier: Apache-2.0
+
+load("//bazel_tools:haskell.bzl", "da_haskell_library")
+
+da_haskell_library(
+    name = "daml-doctest",
+    srcs = glob(["src/**/*.hs"]),
+    hazel_deps = [
+        "base",
+        "deepseq",
+        "ghc-lib",
+        "ghc-lib-parser",
+        "syb",
+        "text",
+    ],
+    src_strip_prefix = "src",
+    visibility = ["//visibility:public"],
+    deps = [
+        "//compiler/hie-core",
+    ],
+)
diff --git a/compiler/damlc/daml-doctest/src/DA/Daml/DocTest.hs b/compiler/damlc/daml-doctest/src/DA/Daml/DocTest.hs
@@ -0,0 +1,174 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE OverloadedStrings #-}
+module DA.Daml.DocTest
+    ( getDocTestModule
+    , docTestModuleName
+    , GeneratedModule(..)
+    ) where
+
+import Control.DeepSeq
+import Data.Char
+import Data.Generics hiding (Generic)
+import Data.List
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC hiding (parseModule)
+import GHC.Generics (Generic)
+
+-- Most of this code is a variation of the code in Haskell’s doctest, in particular
+-- the [Extract](https://github.com/sol/doctest/blob/master/src/Extract.hs) module for
+-- extracting doc comments from a `ParsedModule` and the
+-- [Parse](https://github.com/sol/doctest/blob/master/src/Parse.hs) module for
+-- extracting tests from doc comments.
+-- Our requirements are somewhat different (e.g. we don’t use actual GHCi commands)
+-- so we roll our own version.
+
+----------------------------------------------
+-- Types shared across the different stages --
+----------------------------------------------
+
+data DocTestModule a = DocTestModule
+    { dtModuleName :: Text
+    , dtModuleContent :: [a]
+    -- For now, we do not handle setup but we probably will
+    -- have to handle it at some point
+    } deriving (Eq, Show, Functor)
+
+--------------------------------
+-- Extraction of doc comments --
+--------------------------------
+
+extractFromModule :: ParsedModule -> DocTestModule LHsDocString
+extractFromModule m = DocTestModule name (map snd docs)
+    where
+        name = T.pack . moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary $ m
+        docs = docStringsFromModule m
+
+-- | We return a tuple of the doc comment name (if any) and the actual doc.
+-- The name allows us to differentiate between setup and regular doc comments.
+docStringsFromModule :: ParsedModule -> [(Maybe String, LHsDocString)]
+docStringsFromModule mod = docs
+      where
+          -- TODO We might want to mine docs from exports and the header as well.
+          docs = decls
+          source = unLoc . pm_parsed_source $ mod
+          decls = extractDocStrings $ hsmodDecls source
+
+-- | Extract all docstrings from given value.
+extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)]
+extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl
+    `extQ` fromLDocDecl
+    `extQ` fromLHsDocString
+    )
+  where
+    fromLHsDecl :: Selector (LHsDecl GhcPs)
+    fromLHsDecl (L loc decl) = case decl of
+        -- Top-level documentation has to be treated separately, because it has
+        -- no location information attached.  The location information is
+        -- attached to HsDecl instead.
+        DocD _ x -> select (fromDocDecl loc x)
+        _ -> (extractDocStrings decl, True)
+
+    fromLDocDecl :: Selector LDocDecl
+    fromLDocDecl (L loc x) = select (fromDocDecl loc x)
+
+    fromLHsDocString :: Selector LHsDocString
+    fromLHsDocString x = select (Nothing, x)
+
+    fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)
+    fromDocDecl loc x = case x of
+        DocCommentNamed name doc -> (Just name, L loc doc)
+        _                        -> (Nothing, L loc $ docDeclDoc x)
+
+type Selector a = a -> ([(Maybe String, LHsDocString)], Bool)
+select :: a -> ([a], Bool)
+select x = ([x], False)
+
+---------------------------------------
+-- Parse doc comments into doc tests --
+---------------------------------------
+
+data DocTest = DocTest
+    { dtExpr :: Text
+    , dtExpectedResult :: [Text]
+    }
+
+parseModule :: DocTestModule LHsDocString -> DocTestModule (Located DocTest)
+parseModule m = m { dtModuleContent = concatMap parseDocTests $ dtModuleContent m }
+
+parseDocTests :: LHsDocString -> [Located DocTest]
+parseDocTests docString =
+    map (L (getLoc docString)) .  go . T.lines . T.pack . unpackHDS . unLoc $ docString
+  where
+    isPrompt :: Text -> Bool
+    isPrompt = T.isPrefixOf ">>>" . T.dropWhile isSpace
+    dropPromptPrefix = T.drop 3 . T.dropWhile isSpace
+
+    isBlankLine :: Text -> Bool
+    isBlankLine  = T.all isSpace
+
+    isCodeBlockEnd :: Text -> Bool
+    isCodeBlockEnd = T.isInfixOf "```"
+
+    isEndOfInteraction :: Text -> Bool
+    isEndOfInteraction x = isPrompt x || isBlankLine x || isCodeBlockEnd x
+
+    go :: [Text] -> [DocTest]
+    go xs = case dropWhile (not . isPrompt) xs of
+        prompt:rest ->
+            let (ys,zs) = break isEndOfInteraction rest
+            in toDocTest (T.strip $ dropPromptPrefix prompt) ys : go zs
+        [] -> []
+
+toDocTest :: Text -> [Text] -> DocTest
+toDocTest = DocTest
+
+---------------------------
+-- Render doctest module --
+---------------------------
+
+-- | Identifier for a doctest. This allows us to map
+-- the doctest back to the source in the original module.
+newtype DocTestId = DocTestId Int
+    deriving (Eq, Ord, Show, Enum)
+
+renderDocTestModule :: DocTestModule (Located DocTest) -> Text
+renderDocTestModule DocTestModule{..} = rendered
+    where
+        testsWithIds = zip [DocTestId 0..] dtModuleContent
+        rendered = T.unlines $
+            [ "{-# OPTIONS_GHC -Wno-unused-imports #-}"
+            , "daml 1.2"
+            , "module " <> docTestModuleName dtModuleName <> " where"
+            , ""
+            , "import " <> dtModuleName
+            , "import DA.Assert"
+            , ""
+            ] <>
+            intercalate [""] (map (uncurry renderDocTest) testsWithIds)
+
+renderDocTest :: DocTestId -> Located DocTest -> [Text]
+renderDocTest (DocTestId i) (unLoc -> DocTest{..}) =
+    [ "doctest_" <> T.pack (show i) <> " = " <> "scenario do"
+    , "  (===) (" <> dtExpr <> ") $"
+    ] <>
+    map (indent 4) dtExpectedResult
+    where
+        indent i t = T.replicate i " " <> t
+
+getDocTestModule :: ParsedModule -> GeneratedModule
+getDocTestModule pm = case parseModule $ extractFromModule pm of
+    m -> GeneratedModule (dtModuleName m) (renderDocTestModule m)
+
+docTestModuleName :: Text -> Text
+docTestModuleName t = t <> "_doctest"
+
+data GeneratedModule = GeneratedModule
+  { genModuleName :: Text
+  , genModuleContent :: Text
+  } deriving (Show, Generic)
+
+instance NFData GeneratedModule
+
diff --git a/compiler/damlc/daml-ide-core/BUILD.bazel b/compiler/damlc/daml-ide-core/BUILD.bazel
@@ -49,6 +49,7 @@ da_haskell_library(
         "//compiler/daml-lf-ast",
         "//compiler/daml-lf-proto",
         "//compiler/daml-lf-tools",
+        "//compiler/damlc/daml-doctest",
         "//compiler/damlc/daml-lf-conversion",
         "//compiler/damlc/daml-opts:daml-opts-types",
         "//compiler/hie-core",

diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/RuleTypes/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/RuleTypes/Daml.hs
@@ -28,6 +28,7 @@ import Development.IDE.Core.Service.Daml
 import Development.IDE.Types.Location
 import Development.IDE.Core.RuleTypes
 
+import DA.Daml.DocTest
 import qualified DA.Daml.LF.Ast as LF
 import qualified DA.Daml.LF.ScenarioServiceClient as SS
 
@@ -161,6 +162,14 @@ instance NFData   GetHlintDiagnostics
 
 type instance RuleResult GetHlintDiagnostics = ()
 
+data GenerateDocTestModule = GenerateDocTestModule
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GenerateDocTestModule
+instance NFData   GenerateDocTestModule
+
+-- | File path of the generated module
+type instance RuleResult GenerateDocTestModule = GeneratedModule
+
 -- | Kick off things
 type instance RuleResult OfInterest = ()
 

diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
@@ -27,13 +27,13 @@ import Data.Maybe
 import qualified Data.NameMap as NM
 import Data.Set (Set)
 import qualified Data.Set as Set
-import qualified Data.Text as T
+import qualified Data.Text.Extended as T
 import Data.Tuple.Extra
 import Development.Shake hiding (Diagnostic, Env)
 import "ghc-lib" GHC
-import "ghc-lib-parser" Module (UnitId, stringToUnitId, UnitId(..), DefUnitId(..))
+import "ghc-lib-parser" Module (stringToUnitId, UnitId(..), DefUnitId(..))
 import Safe
-import System.Directory.Extra (listFilesRecursive)
+import System.Directory.Extra
 import System.FilePath
 
 import qualified Network.HTTP.Types as HTTP.Types
@@ -50,6 +50,7 @@ import qualified Language.Haskell.LSP.Types as LSP
 
 import Development.IDE.Core.RuleTypes.Daml
 
+import DA.Daml.DocTest
 import DA.Daml.LFConversion (convertModule, sourceLocToRange)
 import DA.Daml.LFConversion.UtilLF
 import qualified DA.Daml.LF.Ast as LF
@@ -198,6 +199,13 @@ generateDalfRule =
             mapLeft liftError $ LF.checkModule world lfVersion dalf
             pure dalf
 
+-- | Generate a doctest module based on the doc tests in the given module.
+generateDocTestModuleRule :: Rules ()
+generateDocTestModuleRule =
+    define $ \GenerateDocTestModule file -> do
+        pm <- use_ GetParsedModule file
+        pure ([], Just $ getDocTestModule pm)
+
 -- | Load all the packages that are available in the package database directories. We expect the
 -- filename to match the package name.
 -- TODO (drsk): We might want to change this to load only needed packages in the future.
@@ -605,6 +613,7 @@ damlRule :: Options -> Rules ()
 damlRule opts = do
     generateRawDalfRule
     generateDalfRule
+    generateDocTestModuleRule
     generatePackageMapRule opts
     generatePackageRule
     generateRawPackageRule opts