diff --git a/.hie-bios b/.hie-bios index e3443b76aeca..2dd9693c646f 100755 --- 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 index 4696cd621aa8..0b884bd5ab98 100644 --- 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 index 1db2181ef2c1..e82b0d09079b 100644 --- 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 new file mode 100644 index 000000000000..734c367076bf --- /dev/null +++ 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 new file mode 100644 index 000000000000..8cebea1d838f --- /dev/null +++ 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 new file mode 100644 index 000000000000..21344c1333e6 --- /dev/null +++ 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 index c41b0ab9786d..259995676f8d 100644 --- 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 index ecbcadbe9cf1..71399780fd4e 100644 --- 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 index 0b135e22e11a..9c260320d803 100644 --- 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 diff --git a/compiler/damlc/daml-stdlib-src/DA/Bifunctor.daml b/compiler/damlc/daml-stdlib-src/DA/Bifunctor.daml index a3a0b42e8a53..c4522e1697d3 100644 --- a/compiler/damlc/daml-stdlib-src/DA/Bifunctor.daml +++ b/compiler/damlc/daml-stdlib-src/DA/Bifunctor.daml @@ -52,13 +52,13 @@ class Bifunctor p where -- @'bimap' f g ≡ 'first' f '.' 'second' g@ -- -- ==== __Examples__ - -- >>> bimap toUpper (+1) ('j', 3) - -- ('J',4) + -- >>> bimap not (+1) (True, 3) + -- (False,4) -- - -- >>> bimap toUpper (+1) (Left 'j') - -- Left 'J' + -- >>> bimap not (+1) (Left True) + -- Left False -- - -- >>> bimap toUpper (+1) (Right 3) + -- >>> bimap not (+1) (Right 3) -- Right 4 bimap : (a -> b) -> (c -> d) -> p a c -> p b d bimap f g = first f . second g @@ -69,11 +69,11 @@ class Bifunctor p where -- @'first' f ≡ 'bimap' f 'identity'@ -- -- ==== __Examples__ - -- >>> first toUpper ('j', 3) - -- ('J',3) + -- >>> first not (True, 3) + -- (False,3) -- - -- >>> first toUpper (Left 'j') - -- Left 'J' + -- >>> first not (Left True : Either Bool Int) + -- Left False first : (a -> b) -> p a c -> p b c first f = bimap f identity @@ -83,10 +83,10 @@ class Bifunctor p where -- @'second' ≡ 'bimap' 'identity'@ -- -- ==== __Examples__ - -- >>> second (+1) ('j', 3) - -- ('j',4) + -- >>> second (+1) (True, 3) + -- (True,4) -- - -- >>> second (+1) (Right 3) + -- >>> second (+1) (Right 3 : Either Bool Int) -- Right 4 second : (b -> c) -> p a b -> p a c second = bimap identity diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Prelude.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Prelude.daml index 8612cf36027e..5640f5bbd275 100644 --- a/compiler/damlc/daml-stdlib-src/DA/Internal/Prelude.daml +++ b/compiler/damlc/daml-stdlib-src/DA/Internal/Prelude.daml @@ -231,24 +231,18 @@ instance ActionFail Optional where -- Basic usage: -- -- ``` --- >>> optional False odd (Some 3) +-- >>> optional False (> 2) (Some 3) -- True -- ``` -- -- ``` --- >>> optional False odd None +-- >>> optional False (> 2) None -- False -- ``` -- --- Read an Int from a string using `readOptional`. If we succeed, --- return twice the Int; that is, apply `(*2)` to it. If instead --- we fail to parse an Int, return `0` by default: --- --- ``` --- >>> import Text.Read ( readOptional ) --- >>> optional 0 (*2) (readOptional "5") +-- >>> optional 0 (*2) (Some 5) -- 10 --- >>> optional 0 (*2) (readOptional "") +-- >>> optional 0 (*2) None -- 0 -- ``` -- @@ -259,7 +253,7 @@ instance ActionFail Optional where -- ``` -- >>> optional "" show (Some 5) -- "5" --- >>> optional "" show None +-- >>> optional "" show (None : Optional Int) -- "" -- ``` -- @@ -291,17 +285,15 @@ instance ActionFail (Either Text) where -- -- #### Examples -- --- We create two values of type `Either String Int`, one using the +-- We create two values of type `Either [Int] Int`, one using the -- `Left` constructor and another using the `Right` constructor. Then --- we apply "either" the `length` function (if we have a `String`) +-- we apply "either" the `length` function (if we have a `[Int]`) -- or the "times-two" function (if we have an `Int`): -- -- ``` --- >>> let s = Left "foo" :: Either String Int --- >>> let n = Right 3 :: Either String Int --- >>> either length (*2) s +-- >>> let s = Left [1,2,3] : Either [Int] Int in either length (*2) s -- 3 --- >>> either length (*2) n +-- >>> let n = Right 3 : Either [Int] Int in either length (*2) n -- 6 -- ``` -- diff --git a/compiler/damlc/lib/DA/Cli/Damlc.hs b/compiler/damlc/lib/DA/Cli/Damlc.hs index 232e558537f3..0b09a5655ad1 100644 --- a/compiler/damlc/lib/DA/Cli/Damlc.hs +++ b/compiler/damlc/lib/DA/Cli/Damlc.hs @@ -23,6 +23,7 @@ import DA.Cli.Damlc.IdeState import DA.Cli.Damlc.Test import DA.Cli.Visual import DA.Daml.Compiler.Dar +import DA.Daml.Compiler.DocTest import DA.Daml.Compiler.Scenario import DA.Daml.Compiler.Upgrade import qualified DA.Daml.LF.Ast as LF @@ -46,20 +47,21 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import Data.FileEmbed (embedFile) import Data.Graph -import Data.List +import qualified Data.Set as Set +import Data.List.Extra import qualified Data.List.Split as Split import qualified Data.Map.Strict as MS import Data.Maybe import qualified Data.NameMap as NM -import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Development.IDE.Core.API -import Development.IDE.Core.RuleTypes.Daml (DalfPackage(..)) +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake import Development.IDE.Core.Rules import Development.IDE.Core.Rules.Daml (getDalf) -import Development.IDE.Core.Service (runAction) -import Development.IDE.GHC.Util +import Development.IDE.Core.RuleTypes.Daml (DalfPackage(..), GetParsedModule(..)) +import Development.IDE.GHC.Util (fakeDynFlags, moduleImportPaths) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import "ghc-lib-parser" DynFlags @@ -75,9 +77,9 @@ import System.Directory import System.Environment import System.Exit import System.FilePath -import System.IO -import System.Process (callCommand) -import qualified Text.PrettyPrint.ANSI.Leijen as PP +import System.IO.Extra +import System.Process(callCommand) +import qualified Text.PrettyPrint.ANSI.Leijen as PP -------------------------------------------------------------------------------- -- Commands @@ -233,6 +235,16 @@ cmdMigrate numProcessors = <*> inputDarOpt <*> targetSrcDirOpt +cmdDocTest :: Int -> Mod CommandFields Command +cmdDocTest numProcessors = + command "doctest" $ + info (helper <*> cmd) $ + progDesc "doc tests" <> fullDesc + where + cmd = execDocTest + <$> optionsParser numProcessors (EnableScenarioService True) optPackageName + <*> many inputFileOpt + -------------------------------------------------------------------------------- -- Execution -------------------------------------------------------------------------------- @@ -562,7 +574,7 @@ execPackage projectOpts filePath opts mbOutFile dumpPom dalfInput = withProjectR putErrLn $ "ERROR: Not creating pom file as package name '" <> name <> "' is not a valid Maven coordinate (expected '::')" exitFailure - putErrLn = hPutStrLn System.IO.stderr + putErrLn = hPutStrLn stderr execInspect :: FilePath -> FilePath -> Bool -> Command execInspect inFile outFile jsonOutput = do @@ -764,6 +776,23 @@ execMigrate projectOpts opts0 inFile1_ inFile2_ mbDir = do pure $ NM.lookup modName $ LF.packageModules pkg + +execDocTest :: Options -> [FilePath] -> IO () +execDocTest opts files = do + let files' = map toNormalizedFilePath files + logger <- getLogger opts "doctest" + -- We don’t add a logger here since we will otherwise emit logging messages twice. + importPaths <- + withDamlIdeState opts { optScenarioService = EnableScenarioService False } + logger (const $ pure ()) $ \ideState -> runAction ideState $ do + pmS <- catMaybes <$> uses GetParsedModule files' + -- This is horrible but we do not have a way to change the import paths in a running + -- IdeState at the moment. + pure $ nubOrd $ mapMaybe moduleImportPaths pmS + opts <- mkOptions opts { optImportPath = importPaths <> optImportPath opts} + withDamlIdeState opts logger diagnosticsLogger $ \ideState -> + docTest ideState files' + -------------------------------------------------------------------------------- -- main -------------------------------------------------------------------------------- @@ -879,6 +908,7 @@ options numProcessors = <> cmdDamlDoc <> cmdVisual <> cmdInspectDar + <> cmdDocTest numProcessors ) <|> subparser (internal -- internal commands diff --git a/compiler/damlc/tests/BUILD.bazel b/compiler/damlc/tests/BUILD.bazel index c1da0983cd29..0c06d6e80f01 100644 --- a/compiler/damlc/tests/BUILD.bazel +++ b/compiler/damlc/tests/BUILD.bazel @@ -108,6 +108,31 @@ da_haskell_test( ], ) +# Tests for daml-doctest +da_haskell_test( + name = "daml-doctest", + srcs = ["src/DA/Test/DamlDocTest.hs"], + data = ["//compiler/damlc/pkg-db"], + hazel_deps = [ + "base", + "extra", + "tasty", + "tasty-hunit", + "text", + ], + main_function = "DA.Test.DamlDocTest.main", + src_strip_prefix = "src", + visibility = ["//visibility:public"], + deps = [ + "//compiler/damlc:damlc-lib", + "//compiler/damlc/daml-doctest", + "//compiler/damlc/daml-opts", + "//compiler/damlc/daml-opts:daml-opts-types", + "//compiler/hie-core", + "//libs-haskell/da-hs-base", + ], +) + # Tests of damlc at the Shake API layer da_haskell_test( name = "shake", diff --git a/compiler/damlc/tests/src/DA/Test/DamlDocTest.hs b/compiler/damlc/tests/src/DA/Test/DamlDocTest.hs new file mode 100644 index 000000000000..226331b83e1c --- /dev/null +++ b/compiler/damlc/tests/src/DA/Test/DamlDocTest.hs @@ -0,0 +1,113 @@ +-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE OverloadedStrings #-} +module DA.Test.DamlDocTest (main) where + +import qualified Data.Text.Extended as T +import System.IO.Extra +import Test.Tasty +import Test.Tasty.HUnit + +import DA.Daml.DocTest +import DA.Daml.Options.Types +import DA.Daml.Options +import Development.IDE.Core.FileStore +import Development.IDE.Core.Rules +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Development.IDE.Types.Logger + +main :: IO () +main = defaultMain $ testGroup "daml-doctest" + [ generateTests + ] + +generateTests :: TestTree +generateTests = testGroup "generate doctest module" + [ testCase "empty module" $ + [] `shouldGenerate` [] + , testCase "example in doc comment" $ + [ "-- |" + , "-- >>> 1 + 1" + , "-- 2" + ] `shouldGenerate` + [ "doctest_0 = scenario do" + , " (===) (1 + 1) $" + , " 2" + ] + , testCase "example in non-doc comment" $ + [ "-- >>> 1 + 1" + , "-- 2" + ] `shouldGenerate` + [] + , testCase "multiple examples in one comment" $ + [ "-- |" + , "-- >>> 1 + 1" + , "-- 2" + , "-- >>> 2 + 2" + , "-- 4" + ] `shouldGenerate` + [ "doctest_0 = scenario do" + , " (===) (1 + 1) $" + , " 2" + , "" + , "doctest_1 = scenario do" + , " (===) (2 + 2) $" + , " 4" + ] + , testCase "example in code block" $ + [ "-- |" + , "-- ```" + , "-- >>> 1 + 1" + , "-- 2" + , "-- ```" + ] `shouldGenerate` + [ "doctest_0 = scenario do" + , " (===) (1 + 1) $" + , " 2" + ] + , testCase "multiline result" $ + [ "-- |" + , "-- >>> map (+1) [1,2,3]" + , "-- [ 2" + , "-- , 3" + , "-- , 4" + , "-- ]" + ] `shouldGenerate` + [ "doctest_0 = scenario do" + , " (===) (map (+1) [1,2,3]) $" + , " [ 2" + , " , 3" + , " , 4" + , " ]" + ] + ] + +testModuleHeader :: [T.Text] +testModuleHeader = + [ "daml 1.2" + , "module Test where" + ] + +doctestHeader :: [T.Text] +doctestHeader = + [ "{-# OPTIONS_GHC -Wno-unused-imports #-}" + , "daml 1.2" + , "module Test_doctest where" + , "" + , "import Test" + , "import DA.Assert" + , "" + ] + +shouldGenerate :: [T.Text] -> [T.Text] -> Assertion +shouldGenerate input expected = withTempFile $ \tmpFile -> do + T.writeFileUtf8 tmpFile $ T.unlines $ testModuleHeader <> input + opts <- defaultOptionsIO Nothing + vfs <- makeVFSHandle + ideState <- initialise mainRule (const $ pure ()) noLogging (toCompileOpts opts) vfs + Just pm <- runAction ideState $ use GetParsedModule $ toNormalizedFilePath tmpFile + genModuleContent (getDocTestModule pm) @?= T.unlines (doctestHeader <> expected) + diff --git a/compiler/hie-core/src/Development/IDE/Core/Compile.hs b/compiler/hie-core/src/Development/IDE/Core/Compile.hs index c8ae213ad485..fdb6925bcf24 100644 --- a/compiler/hie-core/src/Development/IDE/Core/Compile.hs +++ b/compiler/hie-core/src/Development/IDE/Core/Compile.hs @@ -137,19 +137,6 @@ addRelativeImport :: ParsedModule -> DynFlags -> DynFlags addRelativeImport modu dflags = dflags {importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags} -moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath -moduleImportPaths pm - | rootModDir == "." = Just rootPathDir - | otherwise = - dropTrailingPathSeparator <$> stripSuffix (normalise rootModDir) (normalise rootPathDir) - where - ms = GHC.pm_mod_summary pm - file = GHC.ms_hspp_file ms - mod' = GHC.ms_mod ms - rootPathDir = takeDirectory file - rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod' - - mkTcModuleResult :: GhcMonad m => InterfaceDirectory diff --git a/compiler/hie-core/src/Development/IDE/GHC/Util.hs b/compiler/hie-core/src/Development/IDE/GHC/Util.hs index 7eb8b76885fc..193ea1b1ac5c 100644 --- a/compiler/hie-core/src/Development/IDE/GHC/Util.hs +++ b/compiler/hie-core/src/Development/IDE/GHC/Util.hs @@ -14,10 +14,12 @@ module Development.IDE.GHC.Util( fakeDynFlags, prettyPrint, runGhcEnv, - textToStringBuffer + textToStringBuffer, + moduleImportPaths ) where import Config +import Data.List.Extra import Fingerprint import GHC import GhcMonad @@ -28,6 +30,7 @@ import FileCleanup import Platform import qualified Data.Text as T import StringBuffer +import System.FilePath ---------------------------------------------------------------------- @@ -90,3 +93,15 @@ fakeDynFlags = defaultDynFlags settings ([], []) { pc_DYNAMIC_BY_DEFAULT=False , pc_WORD_SIZE=8 } + +moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath +moduleImportPaths pm + | rootModDir == "." = Just rootPathDir + | otherwise = + dropTrailingPathSeparator <$> stripSuffix (normalise rootModDir) (normalise rootPathDir) + where + ms = GHC.pm_mod_summary pm + file = GHC.ms_hspp_file ms + mod' = GHC.ms_mod ms + rootPathDir = takeDirectory file + rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod' diff --git a/rules_daml/daml.bzl b/rules_daml/daml.bzl index 22ca8d224bd8..225587f06d4d 100644 --- a/rules_daml/daml.bzl +++ b/rules_daml/daml.bzl @@ -144,6 +144,55 @@ daml_test = rule( test = True, ) +def _daml_doctest_impl(ctx): + script = """ + set -eou pipefail + DAMLC=$(rlocation $TEST_WORKSPACE/{damlc}) + rlocations () {{ for i in $@; do echo $(rlocation $TEST_WORKSPACE/$i); done; }} + $DAMLC doctest {damlc_flags} $(rlocations "{files}") + """.format( + damlc = ctx.executable.damlc.short_path, + damlc_flags = ctx.attr.damlc_flags, + files = " ".join([ + f.short_path + for f in ctx.files.srcs + if all([not f.short_path.endswith(ignore) for ignore in ctx.attr.ignored_srcs]) + ]), + ) + ctx.actions.write( + output = ctx.outputs.executable, + content = script, + ) + damlc_runfiles = ctx.attr.damlc[DefaultInfo].data_runfiles + runfiles = ctx.runfiles( + collect_data = True, + files = ctx.files.srcs, + ).merge(damlc_runfiles) + return [DefaultInfo(runfiles = runfiles)] + +daml_doc_test = rule( + implementation = _daml_doctest_impl, + attrs = { + "srcs": attr.label_list( + allow_files = [".daml"], + default = [], + doc = "DAML source files that should be tested.", + ), + "ignored_srcs": attr.string_list( + default = [], + doc = "DAML source files that should be ignored.", + ), + "damlc": attr.label( + executable = True, + cfg = "host", + allow_files = True, + default = Label("//compiler/damlc"), + ), + "damlc_flags": attr.string(), + }, + test = True, +) + _daml_binary_script_template = """ #!/usr/bin/env sh {java} -jar {sandbox} $@ {dar}