diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2020 Torsten Schmits + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the +following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following + disclaimer. + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided with the distribution. + +Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those +receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except +for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell, +import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired +or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by: + + (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of + contributors, in source or binary form) alone; or + (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such + copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to + be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution. + +Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this +license, whether expressly, by implication, estoppel or otherwise. + +DISCLAIMER + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,3 @@ +module Main (main) where + +import Hix (main) diff --git a/hix.cabal b/hix.cabal new file mode 100644 --- /dev/null +++ b/hix.cabal @@ -0,0 +1,213 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.0. +-- +-- see: https://github.com/sol/hpack + +name: hix +version: 0.1.0.0 +synopsis: Haskell/Nix development build tools +description: See https://hackage.haskell.org/package/hix/docs/Hix.html +category: Build +homepage: https://git.tryp.io/tek/hix +bug-reports: https://github.com/tek/hix/issues +author: Torsten Schmits +maintainer: hackage@tryp.io +copyright: 2023 Torsten Schmits +license: BSD-2-Clause-Patent +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://git.tryp.io/tek/hix + +library + exposed-modules: + Hix + Hix.Cabal + Hix.Component + Hix.Data.Error + Hix.Data.GhciConfig + Hix.Data.GhciTest + Hix.Env + Hix.Ghci + Hix.Json + Hix.Monad + Hix.Options + Hix.Optparse + Hix.Preproc + hs-source-dirs: + lib + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DerivingStrategies + DerivingVia + DisambiguateRecordFields + DuplicateRecordFields + FunctionalDependencies + GADTs + LambdaCase + LiberalTypeSynonyms + MultiWayIf + OverloadedLabels + OverloadedLists + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternSynonyms + QuantifiedConstraints + QuasiQuotes + RecordWildCards + RecursiveDo + RoleAnnotations + TemplateHaskell + TypeFamilies + TypeFamilyDependencies + UndecidableInstances + UnicodeSyntax + ViewPatterns + OverloadedRecordDot + NoFieldSelectors + ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages + build-depends: + Cabal + , aeson ==2.0.* + , base ==4.* + , exon ==1.4.* + , extra ==1.7.* + , filepattern ==0.1.* + , generic-lens ==2.2.* + , incipit-base ==0.5.* + , lens ==5.1.* + , lens-regex-pcre ==1.1.* + , optparse-applicative ==0.17.* + , path ==0.9.* + , path-io ==1.7.* + , random ==1.2.* + , transformers + , unix + mixins: + base hiding (Prelude) + , incipit-base (IncipitBase as Prelude) + , incipit-base hiding (IncipitBase) + default-language: GHC2021 + +executable hix + main-is: Main.hs + hs-source-dirs: + app + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DerivingStrategies + DerivingVia + DisambiguateRecordFields + DuplicateRecordFields + FunctionalDependencies + GADTs + LambdaCase + LiberalTypeSynonyms + MultiWayIf + OverloadedLabels + OverloadedLists + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternSynonyms + QuantifiedConstraints + QuasiQuotes + RecordWildCards + RecursiveDo + RoleAnnotations + TemplateHaskell + TypeFamilies + TypeFamilyDependencies + UndecidableInstances + UnicodeSyntax + ViewPatterns + OverloadedRecordDot + NoFieldSelectors + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages + build-depends: + base ==4.* + , hix + , incipit-base ==0.5.* + mixins: + base hiding (Prelude) + , incipit-base (IncipitBase as Prelude) + , incipit-base hiding (IncipitBase) + default-language: GHC2021 + +test-suite hix-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Hix.Test.CabalFile + Hix.Test.CabalTest + Hix.Test.GhciTest + Hix.Test.PreprocTest + hs-source-dirs: + test + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DerivingStrategies + DerivingVia + DisambiguateRecordFields + DuplicateRecordFields + FunctionalDependencies + GADTs + LambdaCase + LiberalTypeSynonyms + MultiWayIf + OverloadedLabels + OverloadedLists + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternSynonyms + QuantifiedConstraints + QuasiQuotes + RecordWildCards + RecursiveDo + RoleAnnotations + TemplateHaskell + TypeFamilies + TypeFamilyDependencies + UndecidableInstances + UnicodeSyntax + ViewPatterns + OverloadedRecordDot + NoFieldSelectors + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages + build-depends: + Cabal + , base ==4.* + , exon ==1.4.* + , hedgehog ==1.1.* + , hix + , incipit-base ==0.5.* + , path ==0.9.* + , path-io ==1.7.* + , tasty ==1.4.* + , tasty-hedgehog ==1.3.* + , transformers + mixins: + base hiding (Prelude) + , incipit-base (IncipitBase as Prelude) + , incipit-base hiding (IncipitBase) + default-language: GHC2021 diff --git a/lib/Hix.hs b/lib/Hix.hs new file mode 100644 --- /dev/null +++ b/lib/Hix.hs @@ -0,0 +1,43 @@ +module Hix where + +import Control.Monad.Trans.Class (lift) +import Path.IO (getCurrentDir) + +import Hix.Data.Error (Error (..), printEnvError, printGhciError, printPreprocError, printFatalError) +import Hix.Env (printEnvRunner) +import Hix.Ghci (printGhciCmdline, printGhcidCmdline) +import Hix.Monad (M, runM) +import qualified Hix.Options as Options +import Hix.Options ( + Command (EnvRunner, GhciCmd, GhcidCmd, Preproc), + GlobalOptions (GlobalOptions), + Options (Options), + parseCli, + ) +import Hix.Preproc (preprocess) + +handleError :: + MonadIO m => + GlobalOptions -> + Error -> + m () +handleError GlobalOptions {verbose} = \case + PreprocError err -> printPreprocError err + EnvError err -> printEnvError err + GhciError err -> printGhciError err + NoMatch msg | fromMaybe False verbose -> printPreprocError msg + NoMatch _ -> unit + Fatal err -> printFatalError err + +runCommand :: Command -> M () +runCommand = \case + Preproc opts -> lift (preprocess opts) + EnvRunner opts -> printEnvRunner opts.options + GhcidCmd opts -> printGhcidCmdline opts + GhciCmd opts -> printGhciCmdline opts + +main :: IO () +main = do + Options global cmd <- parseCli + cwd <- getCurrentDir + leftA (handleError global) =<< runM cwd (runCommand cmd) diff --git a/lib/Hix/Cabal.hs b/lib/Hix/Cabal.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Cabal.hs @@ -0,0 +1,101 @@ +module Hix.Cabal where + +import Control.Monad.Trans.Except (ExceptT (ExceptT), throwE) +import Distribution.PackageDescription (BuildInfo (..), GenericPackageDescription (..)) +import Distribution.PackageDescription.Parsec (readGenericPackageDescription) +import Distribution.Types.Benchmark (benchmarkBuildInfo) +import Distribution.Types.CondTree (CondTree (..)) +import qualified Distribution.Types.Executable as Executable +import Distribution.Types.Library (Library (..)) +import Distribution.Types.TestSuite (testBuildInfo) +import Distribution.Utils.Path (getSymbolicPath) +import qualified Distribution.Verbosity as Cabal +import Exon (exon) +import Hix.Data.Error (Error (..), pathText, sourceError) +import Path ( + Abs, + Dir, + File, + Path, + Rel, + absdir, + isProperPrefixOf, + parent, + parseRelDir, + parseRelFile, + stripProperPrefix, + toFilePath, + (), + ) +import System.FilePattern.Directory (getDirectoryFiles) +import System.IO.Error (tryIOError) + +noMatch :: Text -> Path b File -> ExceptT Error IO a +noMatch reason source = + throwE (NoMatch (sourceError reason source)) + +cabalsInDir :: + Path Abs Dir -> + ExceptT Error IO [Path Abs File] +cabalsInDir dir = do + matches <- liftIO (getDirectoryFiles (toFilePath dir) ["*.cabal"]) + let err = PreprocError [exon|Internal error when parsing globbed paths in '#{pathText dir}': #{show matches}|] + maybe (throwE err) pure (traverse parse matches) + where + parse f = do + rel <- parseRelFile f + pure (dir rel) + +findCabal :: + Path Abs File -> + ExceptT Error IO (Path Abs File, Path Rel File) +findCabal source = + spin (parent source) + where + spin dir + | dir == [absdir|/nix/store|] = notFound + | dir == parent dir = notFound + | otherwise = tryDir dir + tryDir dir = + cabalsInDir dir >>= \case + [cabal] -> do + sub <- stripProperPrefix (parent cabal) source + pure (cabal, sub) + [] -> spin (parent dir) + _ -> throwE (PreprocError (sourceError "Multiple cabal files in parent dir of" source)) + notFound = + noMatch "No cabal file found for " source + +parseCabal :: Path Abs File -> ExceptT Error IO GenericPackageDescription +parseCabal path = + ExceptT $ fmap (first (PreprocError . show)) $ tryIOError do + readGenericPackageDescription Cabal.verbose (toFilePath path) + +buildInfo :: + (a -> BuildInfo) -> + (b, CondTree c d a) -> + BuildInfo +buildInfo f (_, t) = + f t.condTreeData + +matchComponent :: GenericPackageDescription -> Path Rel File -> ExceptT Error IO BuildInfo +matchComponent pkg source = + maybe (noMatch "cabal component" source) pure (find matchSource infos) + where + matchSource BuildInfo {..} = + any (matchSourceDir . getSymbolicPath) hsSourceDirs + matchSourceDir dir + | Just p <- parseRelDir dir, isProperPrefixOf p source = True + | otherwise = False + infos = + ((.condTreeData.libBuildInfo) <$> maybeToList pkg.condLibrary) <> + (buildInfo libBuildInfo <$> pkg.condSubLibraries) <> + (buildInfo Executable.buildInfo <$> pkg.condExecutables) <> + (buildInfo testBuildInfo <$> pkg.condTestSuites) <> + (buildInfo benchmarkBuildInfo <$> pkg.condBenchmarks) + +buildInfoForFile :: Path Abs File -> ExceptT Error IO BuildInfo +buildInfoForFile source = do + (cabalPath, sourceRel) <- findCabal source + pkg <- parseCabal cabalPath + matchComponent pkg sourceRel diff --git a/lib/Hix/Component.hs b/lib/Hix/Component.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Component.hs @@ -0,0 +1,115 @@ +module Hix.Component where + +import Control.Monad.Trans.Reader (ask) +import Data.List.Extra (firstJust) +import qualified Data.Map.Strict as Map +import Data.Map.Strict ((!?)) +import qualified Data.Text as Text +import Exon (exon) +import Path (Abs, Dir, File, Path, Rel, SomeBase (Abs, Rel), isProperPrefixOf, stripProperPrefix) + +import Hix.Data.Error (pathText) +import qualified Hix.Data.GhciConfig as GhciConfig +import Hix.Data.GhciConfig ( + ComponentConfig, + PackageConfig (PackageConfig), + PackageName (PackageName), + PackagesConfig, + SourceDir (SourceDir), + Target (Target), + ) +import qualified Hix.Monad as Monad +import Hix.Monad (Env (Env), M, noteEnv) +import qualified Hix.Options as Options +import Hix.Options ( + ComponentCoords, + ComponentSpec (ComponentSpec), + PackageSpec (PackageSpec), + TargetSpec (TargetForComponent, TargetForFile), + ) + +tryPackageByDir :: + PackagesConfig -> + Path Rel Dir -> + Maybe PackageConfig +tryPackageByDir config dir = + find match (Map.elems config) + where + match pkg = pkg.src == dir + +packageByDir :: + PackagesConfig -> + Path Rel Dir -> + M PackageConfig +packageByDir config dir = + noteEnv [exon|No package at this directory: #{pathText dir}|] (tryPackageByDir config dir) + +packageForSpec :: + PackagesConfig -> + PackageSpec -> + M PackageConfig +packageForSpec config = \case + PackageSpec _ (Just (Abs dir)) -> do + Env {root} <- ask + rel <- noteEnv [exon|Path is not a subdirectory of the project root: #{pathText dir}|] (stripProperPrefix root dir) + packageByDir config rel + PackageSpec (PackageName name) (Just (Rel dir)) | Text.elem '/' name -> + packageByDir config dir + PackageSpec name dir -> + noteEnv [exon|No package matching '##{name}'|] (config !? name <|> (tryDir =<< dir)) + where + tryDir = \case + Abs _ -> Nothing + Rel rd -> tryPackageByDir config rd + +matchComponent :: ComponentConfig -> ComponentSpec -> Bool +matchComponent candidate (ComponentSpec name dir) = + candidate.name == name || any (\ d -> elem @[] d (coerce candidate.sourceDirs)) dir + +componentError :: PackageName -> ComponentSpec -> Text +componentError pname spec = + [exon|No component with name or source dir '##{name}' in the package '##{pname}'|] + where + name = spec.name + +targetForComponent :: + PackagesConfig -> + ComponentCoords -> + M Target +targetForComponent config spec = do + package <- packageForSpec config spec.package + component <- noteEnv (componentError package.name spec.component) (find match (Map.elems package.components)) + pure Target {sourceDir = Nothing, ..} + where + match = flip matchComponent spec.component + +targetForFile :: + PackagesConfig -> + Path Abs File -> + M Target +targetForFile config file = do + Env {root} <- ask + fileRel <- stripProperPrefix root file + (package, subpath) <- pkgError (firstJust (matchPackage fileRel) (Map.elems config)) + (component, sourceDir) <- compError (firstJust (matchSourceDir subpath) (Map.elems package.components)) + pure Target {..} + where + matchPackage fileRel package@PackageConfig {src} = do + subpath <- stripProperPrefix src fileRel + pure (package, subpath) + matchSourceDir subpath component = do + let match d@(SourceDir dir) = if isProperPrefixOf dir subpath then Just d else Nothing + dir <- firstJust match (coerce component.sourceDirs) + pure (component, Just dir) + pkgError = noteEnv "No package contains this file" + compError = noteEnv "No component source dir contains this file" + +targetComponent :: + PackagesConfig -> + TargetSpec -> + M Target +targetComponent config = \case + TargetForComponent spec -> + targetForComponent config spec + TargetForFile spec -> + targetForFile config spec diff --git a/lib/Hix/Data/Error.hs b/lib/Hix/Data/Error.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Error.hs @@ -0,0 +1,68 @@ +module Hix.Data.Error where + +import Control.Monad.Trans.Except (ExceptT, throwE) +import qualified Data.Text.IO as Text +import Exon (exon) +import Path (Path, toFilePath) +import System.IO (stderr) +import System.IO.Error (tryIOError) + +data Error = + PreprocError Text + | + EnvError Text + | + GhciError Text + | + NoMatch Text + | + Fatal Text + deriving stock (Eq, Show, Generic) + +pathText :: Path b t -> Text +pathText = + toText . toFilePath + +printPreprocError :: + MonadIO m => + Text -> + m () +printPreprocError msg = + liftIO (Text.hPutStrLn stderr [exon|>>> Preprocessor generator failed: #{msg}|]) + +printEnvError :: + MonadIO m => + Text -> + m () +printEnvError msg = + liftIO (Text.hPutStrLn stderr [exon|>>> Invalid env config: #{msg}|]) + +printGhciError :: + MonadIO m => + Text -> + m () +printGhciError msg = + liftIO (Text.hPutStrLn stderr [exon|>>> Invalid ghci config: #{msg}|]) + +printFatalError :: + MonadIO m => + Text -> + m () +printFatalError msg = + liftIO (Text.hPutStrLn stderr [exon|>>> Fatal error: #{msg}|]) + +sourceError :: Text -> Path b t -> Text +sourceError reason source = + [exon|#{reason} the source file '#{pathText source}'|] + +tryIO :: + IO a -> + ExceptT Error IO a +tryIO ma = + liftIO (tryIOError ma) >>= \case + Right a -> pure a + Left err -> throwE (Fatal (show err)) + +note :: Text -> Maybe a -> ExceptT Error IO a +note err = + maybe (throwE (GhciError err)) pure diff --git a/lib/Hix/Data/GhciConfig.hs b/lib/Hix/Data/GhciConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/GhciConfig.hs @@ -0,0 +1,116 @@ +module Hix.Data.GhciConfig where + +import Data.Aeson (FromJSON (parseJSON), FromJSONKey) +import GHC.Exts (IsList) +import Path (Abs, Dir, File, Path, Rel) + +newtype PackagePath = + PackagePath { unPackagePath :: Path Rel Dir } + deriving stock (Eq, Show, Ord, Generic) + deriving newtype (FromJSON, FromJSONKey) + +newtype SourceDir = + SourceDir { unSourceDir :: Path Rel Dir } + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON) + +newtype SourceDirs = + SourceDirs { unSourceDirs :: [SourceDir] } + deriving stock (Eq, Show, Generic) + +instance FromJSON SourceDirs where + parseJSON v = + (SourceDirs <$> parseJSON v) + <|> + (SourceDirs . pure <$> parseJSON v) + +newtype PackageName = + PackageName { unPackageName :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey) + +newtype ModuleName = + ModuleName { unModuleName :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey) + +newtype ComponentName = + ComponentName { unComponentName :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey) + +newtype EnvName = + EnvName { unEnvName :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey) + +newtype EnvRunner = + EnvRunner (Path Abs File) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON) + +data ComponentConfig = + ComponentConfig { + name :: ComponentName, + sourceDirs :: SourceDirs, + runner :: Maybe EnvRunner + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +data PackageConfig = + PackageConfig { + name :: PackageName, + src :: Path Rel Dir, + components :: Map ComponentName ComponentConfig + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +data Target = + Target { + package :: PackageConfig, + component :: ComponentConfig, + sourceDir :: Maybe SourceDir + } + deriving stock (Eq, Show, Generic) + +newtype RunnerName = + RunnerName { unRunnerName :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSONKey) + +newtype GhciSetupCode = + GhciSetupCode { unGhciSetupCode :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, Semigroup, Monoid) + +newtype GhciRunExpr = + GhciRunExpr { unGhciRunExpr :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON) + +newtype GhciArgs = + GhciArgs { unGhciArgs :: [Text] } + deriving stock (Eq, Show, Generic) + deriving newtype (IsList, Ord, FromJSON) + +type PackagesConfig = Map PackageName PackageConfig + +data EnvConfig = + EnvConfig { + packages :: PackagesConfig, + defaultEnv :: EnvRunner + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +data GhciConfig = + GhciConfig { + packages :: PackagesConfig, + setup :: Map RunnerName GhciSetupCode, + run :: Map RunnerName GhciRunExpr, + args :: GhciArgs + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) diff --git a/lib/Hix/Data/GhciTest.hs b/lib/Hix/Data/GhciTest.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/GhciTest.hs @@ -0,0 +1,30 @@ +module Hix.Data.GhciTest where + +import Path (Abs, Dir, File, Path) + +import Hix.Data.GhciConfig (GhciArgs) + +data GhciTest = + GhciTest { + args :: GhciArgs, + searchPath :: [Path Abs Dir], + script :: Text, + test :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data GhciRun = + GhciRun { + test :: GhciTest, + shell :: Text, + run :: Maybe Text, + scriptFile :: Path Abs File + } + deriving stock (Eq, Show, Generic) + +data GhcidRun = + GhcidRun { + cmdline :: Text, + ghci :: GhciRun + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Env.hs b/lib/Hix/Env.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Env.hs @@ -0,0 +1,27 @@ +module Hix.Env where + +import qualified Data.Text.IO as Text + +import Hix.Component (targetComponent) +import Hix.Data.Error (pathText) +import qualified Hix.Data.GhciConfig as GhciConfig +import Hix.Data.GhciConfig (EnvRunner (EnvRunner), PackagesConfig, Target (Target)) +import Hix.Json (jsonConfig) +import Hix.Monad (M) +import qualified Hix.Options as Options +import Hix.Options (EnvRunnerOptions, TargetSpec) + +componentRunner :: PackagesConfig -> TargetSpec -> M (Maybe EnvRunner) +componentRunner config spec = do + Target {component} <- targetComponent config spec + pure component.runner + +envRunner :: EnvRunnerOptions -> M EnvRunner +envRunner opts = do + config <- either pure jsonConfig opts.config + fromMaybe config.defaultEnv . join <$> traverse (componentRunner config.packages) opts.component + +printEnvRunner :: EnvRunnerOptions -> M () +printEnvRunner opts = do + EnvRunner runner <- envRunner opts + liftIO (Text.putStrLn (pathText runner)) diff --git a/lib/Hix/Ghci.hs b/lib/Hix/Ghci.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Ghci.hs @@ -0,0 +1,187 @@ +module Hix.Ghci where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ask) +import Data.List.Extra (nubOrd) +import qualified Data.Map.Strict as Map +import Data.Map.Strict ((!?)) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Exon (exon) +import Path (Abs, Dir, File, Path, Rel, parseRelDir, reldir, splitExtension, stripProperPrefix, toFilePath, ()) +import Path.IO (createDirIfMissing, getCurrentDir, getTempDir, openTempFile) +import System.IO (hClose) +import System.Posix.User (getLoginName) + +import Hix.Component (targetComponent) +import Hix.Data.Error (Error, note, pathText, tryIO) +import qualified Hix.Data.GhciConfig as GhciConfig +import Hix.Data.GhciConfig ( + ComponentConfig, + GhciConfig, + GhciRunExpr (GhciRunExpr), + GhciSetupCode (GhciSetupCode), + ModuleName (ModuleName), + PackageConfig, + PackageName, + SourceDir (SourceDir), + Target (Target), + ) +import qualified Hix.Data.GhciTest as GhciTest +import Hix.Data.GhciTest (GhciRun (GhciRun), GhciTest (GhciTest), GhcidRun (GhcidRun)) +import Hix.Json (jsonConfig) +import qualified Hix.Monad as Monad +import Hix.Monad (Env (Env), M, noteGhci, tryIOM) +import qualified Hix.Options as Options +import Hix.Options ( + GhciOptions (GhciOptions), + TargetSpec (TargetForComponent, TargetForFile), + TestOptions (TestOptions), + ) + +relativeToComponent :: + PackageConfig -> + Maybe SourceDir -> + Path Abs File -> + M (Path Rel File) +relativeToComponent package mdir path = do + Env {root} <- ask + SourceDir dir <- noteGhci "Internal: No source dir for file target" mdir + noteGhci "Internal: Bad file target" (stripProperPrefix (root package.src dir) path) + +moduleName :: + PackageConfig -> + Maybe SourceDir -> + GhciOptions -> + M ModuleName +moduleName package component = \case + GhciOptions {component = TargetForComponent _, test} -> pure test.mod + GhciOptions {component = TargetForFile path} -> do + rel <- relativeToComponent package component path + pure (ModuleName (Text.replace "/" "." (withoutExt rel))) + where + withoutExt p = pathText (maybe p fst (splitExtension p)) + +ghciScript :: + GhciConfig -> + PackageConfig -> + Maybe SourceDir -> + GhciOptions -> + M Text +ghciScript config package component opt = do + ModuleName module_ <- moduleName package component opt + pure [exon|#{setup} +:load #{module_} +import #{module_}|] + where + GhciSetupCode setup = fold (flip Map.lookup config.setup =<< opt.test.runner) + +componentSearchPaths :: PackageConfig -> ComponentConfig -> [Path Rel Dir] +componentSearchPaths pkg comp = do + SourceDir dir <- coerce comp.sourceDirs + pure (pkg.src dir) + +librarySearchPaths :: Map PackageName PackageConfig -> [Path Rel Dir] +librarySearchPaths pkgs = do + pkg <- Map.elems pkgs + comp <- maybeToList (pkg.components !? "library") + componentSearchPaths pkg comp + +searchPath :: Map PackageName PackageConfig -> PackageConfig -> ComponentConfig -> [Path Rel Dir] +searchPath pkgs pkg comp = + nubOrd (componentSearchPaths pkg comp <> librarySearchPaths pkgs) + +testRun :: GhciConfig -> TestOptions -> Maybe Text +testRun config = \case + TestOptions {test, runner = Just runner} | Just (GhciRunExpr run) <- config.run !? runner -> + Just [exon|(#{run}) #{fold test}|] + TestOptions {test = Just test} -> + Just test + TestOptions {test = Nothing} -> + Nothing + +assemble :: GhciOptions -> M GhciTest +assemble opt = do + config <- either pure jsonConfig opt.config + cwd <- tryIOM getCurrentDir + Target {..} <- targetComponent config.packages opt.component + script <- ghciScript config package sourceDir opt + pure GhciTest { + script, + test = testRun config opt.test, + args = config.args, + searchPath = (cwd ) <$> searchPath config.packages package component + } + +hixTempDir :: + ExceptT Error IO (Path Abs Dir) +hixTempDir = do + tmp <- tryIO getTempDir + user <- note "Couldn't determine user name" . parseRelDir =<< tryIO getLoginName + let hixTmp = tmp [reldir|hix|] user + tryIO (createDirIfMissing True hixTmp) + pure hixTmp + +ghciScriptFile :: + Path Abs Dir -> + Text -> + ExceptT Error IO (Path Abs File) +ghciScriptFile tmp text = + tryIO do + (path, handle) <- openTempFile tmp "hix-ghci-.ghci" + Text.hPutStr handle text + hClose handle + pure path + +searchPathArg :: NonEmpty (Path Abs Dir) -> Text +searchPathArg paths = + [exon|-i#{colonSeparated}|] + where + colonSeparated = Text.intercalate ":" (pathText <$> toList paths) + +ghciCmdline :: + GhciTest -> + Path Abs File -> + Maybe (Path Abs File) -> + GhciRun +ghciCmdline test scriptFile runScriptFile = + GhciRun {..} + where + shell = [exon|##{Text.unwords (coerce test.args)} #{sp} -ghci-script=##{toFilePath scriptFile}|] + run = runScriptFile <&> \ f -> [exon|-ghci-script=##{toFilePath f}|] + sp = foldMap searchPathArg (nonEmpty test.searchPath) + +ghciCmdlineFromOptions :: + Path Abs Dir -> + GhciOptions -> + M GhciRun +ghciCmdlineFromOptions tmp opt = do + conf <- assemble opt + shellScriptFile <- lift (ghciScriptFile tmp conf.script) + runScriptFile <- lift (traverse (ghciScriptFile tmp) conf.test) + pure (ghciCmdline conf shellScriptFile runScriptFile) + +ghcidCmdlineFromOptions :: + Path Abs Dir -> + GhciOptions -> + M GhcidRun +ghcidCmdlineFromOptions tmp opt = do + ghci <- ghciCmdlineFromOptions tmp opt + pure (GhcidRun [exon|ghcid --command="ghci #{ghci.shell}" --test='##{fromMaybe "main" ghci.test.test}'|] ghci) + +printGhciCmdline :: + GhciOptions -> + M () +printGhciCmdline opt = do + tmp <- lift hixTempDir + cmd <- ghciCmdlineFromOptions tmp opt + liftIO (Text.putStrLn [exon|ghci #{cmd.shell} #{fold cmd.run}|]) + +printGhcidCmdline :: + GhciOptions -> + M () +printGhcidCmdline opt = do + tmp <- lift hixTempDir + cmd <- ghcidCmdlineFromOptions tmp opt + liftIO (Text.putStrLn cmd.cmdline) diff --git a/lib/Hix/Json.hs b/lib/Hix/Json.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Json.hs @@ -0,0 +1,25 @@ +module Hix.Json where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (throwE) +import qualified Data.Aeson as Aeson +import Data.Aeson (FromJSON, fromJSON) +import Exon (exon) + +import Hix.Data.Error (Error (GhciError)) +import Hix.Monad (M) +import Hix.Optparse (JsonConfig (JsonConfig)) + +jsonConfig :: + FromJSON a => + JsonConfig -> + M a +jsonConfig (JsonConfig mv) = + liftIO mv >>= \case + Left msg -> failure [exon|Invalid JSON: #{toText msg}|] + Right v -> case fromJSON v of + Aeson.Success a -> pure a + Aeson.Error err -> failure [exon|Invalid JSON: #{toText err} +#{show v}|] + where + failure = lift . throwE . GhciError diff --git a/lib/Hix/Monad.hs b/lib/Hix/Monad.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Monad.hs @@ -0,0 +1,34 @@ +module Hix.Monad where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.Reader (ReaderT (runReaderT)) +import Path (Abs, Dir, Path) + +import Hix.Data.Error (Error (GhciError), tryIO) + +data Env = + Env { + root :: Path Abs Dir + } + deriving stock (Eq, Show, Generic) + +type M a = ReaderT Env (ExceptT Error IO) a + +noteEnv :: Text -> Maybe a -> M a +noteEnv err = + maybe (lift (throwE (GhciError err))) pure + +noteGhci :: Text -> Maybe a -> M a +noteGhci err = + maybe (lift (throwE (GhciError err))) pure + +runM :: Path Abs Dir -> M a -> IO (Either Error a) +runM root ma = + runExceptT (runReaderT ma (Env root)) + +tryIOM :: + IO a -> + M a +tryIOM ma = + lift (tryIO ma) diff --git a/lib/Hix/Options.hs b/lib/Hix/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Options.hs @@ -0,0 +1,260 @@ +module Hix.Options where + +import Options.Applicative ( + CommandFields, + Mod, + Parser, + bashCompleter, + command, + completer, + customExecParser, + fullDesc, + header, + help, + helper, + hsubparser, + info, + long, + option, + prefs, + progDesc, + short, + showHelpOnEmpty, + showHelpOnError, + strOption, + switch, + value, + ) +import Path (Abs, Dir, File, Path, SomeBase, parseRelDir, parseSomeDir) +import Prelude hiding (Mod, mod) + +import Hix.Data.GhciConfig ( + ComponentName (ComponentName), + EnvConfig, + EnvName, + GhciConfig, + ModuleName, + PackageName (PackageName), + RunnerName, + SourceDir (SourceDir), + ) +import Hix.Optparse (JsonConfig, absFileOption, jsonOption) + +data PreprocOptions = + PreprocOptions { + source :: Path Abs File, + inFile :: Path Abs File, + outFile :: Path Abs File + } + deriving stock (Eq, Show, Generic) + +data PackageSpec = + PackageSpec { + name :: PackageName, + dir :: Maybe (SomeBase Dir) + } + deriving stock (Eq, Show, Generic) + +data ComponentSpec = + ComponentSpec { + name :: ComponentName, + dir :: Maybe SourceDir + } + deriving stock (Eq, Show, Generic) + +data ComponentCoords = + ComponentCoords { + package :: PackageSpec, + component :: ComponentSpec + } + deriving stock (Eq, Show, Generic) + +data TargetSpec = + TargetForFile (Path Abs File) + | + TargetForComponent ComponentCoords + deriving stock (Eq, Show, Generic) + +data TestOptions = + TestOptions { + mod :: ModuleName, + test :: Maybe Text, + runner :: Maybe RunnerName + } + deriving stock (Eq, Show, Generic) + +data EnvRunnerOptions = + EnvRunnerOptions { + config :: Either EnvConfig JsonConfig, + component :: Maybe TargetSpec + } + deriving stock (Show, Generic) + +data GhciOptions = + GhciOptions { + config :: Either GhciConfig JsonConfig, + component :: TargetSpec, + test :: TestOptions + } + deriving stock (Show, Generic) + +data EnvRunnerCommandOptions = + EnvRunnerCommandOptions { + options :: EnvRunnerOptions, + test :: TestOptions + } + deriving stock (Show, Generic) + +data Command = + Preproc PreprocOptions + | + EnvRunner EnvRunnerCommandOptions + | + GhcidCmd GhciOptions + | + GhciCmd GhciOptions + deriving stock (Show) + +data GlobalOptions = + GlobalOptions { + verbose :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + deriving anyclass (Default) + +data Options = + Options { + global :: GlobalOptions, + cmd :: Command + } + deriving stock (Show) + +fileParser :: + String -> + String -> + Parser (Path Abs File) +fileParser longName helpText = + option absFileOption (long longName <> completer (bashCompleter "file") <> help helpText) + +preprocParser :: Parser PreprocOptions +preprocParser = + PreprocOptions + <$> + fileParser "source" "The original source file" + <*> + fileParser "in" "The prepared input file" + <*> + fileParser "out" "The path to the output file" + +packageSpecParser :: Parser PackageSpec +packageSpecParser = do + name <- strOption (long "package" <> short 'p' <> help "The name or directory of the test package") + pure PackageSpec {name = PackageName name, dir = parseSomeDir (toString name)} + +componentSpecParser :: Parser ComponentSpec +componentSpecParser = do + name <- strOption (long "component" <> short 'c' <> help h <> value "test") + pure ComponentSpec {name = ComponentName name, dir = SourceDir <$> parseRelDir (toString name)} + where + h = "The name or relative directory of the test component" + +componentForModuleParser :: Parser ComponentCoords +componentForModuleParser = + ComponentCoords + <$> + packageSpecParser + <*> + componentSpecParser + +componentForFileParser :: Parser TargetSpec +componentForFileParser = + TargetForFile + <$> + option absFileOption (long "file" <> short 'f' <> help "The absolute file path of the test module") + +targetSpecParser :: Parser TargetSpec +targetSpecParser = + TargetForComponent <$> componentForModuleParser + <|> + componentForFileParser + +envNameParser :: Parser EnvName +envNameParser = + strOption (long "env" <> short 'e' <> help "The name of the environment") + +testParser :: Parser (Maybe Text) +testParser = + optional (strOption (long "test" <> short 't' <> help "The Haskell function that should be executed")) + +runnerParser :: Parser (Maybe RunnerName) +runnerParser = + optional (strOption ( + long "run" + <> + short 'r' + <> + help "The name of the command defined in the Hix option 'ghci.run'" + )) + +moduleParser :: Parser ModuleName +moduleParser = + strOption (long "module" <> short 'm' <> help "The module containing the test function" <> value "Main") + +jsonConfigParser :: + Parser JsonConfig +jsonConfigParser = + option jsonOption (long "config" <> short 'c' <> help "The Hix-generated config, file or text") + +testOptionsParser :: Parser TestOptions +testOptionsParser = do + test <- testParser + runner <- runnerParser + mod <- moduleParser + pure TestOptions {..} + +envParser :: Parser EnvRunnerCommandOptions +envParser = do + options <- do + config <- Right <$> jsonConfigParser + component <- optional targetSpecParser + pure EnvRunnerOptions {..} + test <- testOptionsParser + pure EnvRunnerCommandOptions {..} + +ghciParser :: Parser GhciOptions +ghciParser = do + config <- Right <$> jsonConfigParser + component <- targetSpecParser + test <- testOptionsParser + pure GhciOptions {..} + +commands :: + Mod CommandFields Command +commands = + command "preproc" (Preproc <$> info preprocParser (progDesc "Preprocess a source file for use with ghcid")) + <> + command "env" (EnvRunner <$> info envParser (progDesc "Print the env runner for a component or a named env")) + <> + command "ghci-cmd" (GhciCmd <$> info ghciParser (progDesc "Print a ghci cmdline to load a module in a Hix env")) + <> + command "ghcid-cmd" (GhcidCmd <$> info ghciParser (progDesc "Print a ghcid cmdline to run a function in a Hix env")) + +globalParser :: Parser GlobalOptions +globalParser = do + verbose <- optional (switch (long "verbose" <> short 'v' <> help "Verbose output")) + pure GlobalOptions {..} + +appParser :: + Parser Options +appParser = + Options <$> globalParser <*> hsubparser commands + +parseCli :: + IO Options +parseCli = do + customExecParser parserPrefs (info (appParser <**> helper) desc) + where + parserPrefs = + prefs (showHelpOnEmpty <> showHelpOnError) + desc = + fullDesc <> header "Tools for maintaining Hix projects" diff --git a/lib/Hix/Optparse.hs b/lib/Hix/Optparse.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Optparse.hs @@ -0,0 +1,42 @@ +-- |Combinators for @optparse-applicative@. +module Hix.Optparse where + +import Data.Aeson (Value, eitherDecodeFileStrict', eitherDecodeStrict') +import Exon (exon) +import Options.Applicative (ReadM, readerError) +import Options.Applicative.Types (readerAsk) +import Path (Abs, Dir, File, Path, Rel, parseAbsFile, parseRelDir, parseRelFile, toFilePath) +import qualified Text.Show as Show + +-- |An absolute file path option for @optparse-applicative@. +absFileOption :: ReadM (Path Abs File) +absFileOption = do + raw <- readerAsk + leftA (const (readerError [exon|not a valid absolute file path: #{raw}|])) (parseAbsFile raw) + +-- |A relative file path option for @optparse-applicative@. +relFileOption :: ReadM (Path Rel File) +relFileOption = do + raw <- readerAsk + leftA (const (readerError [exon|not a valid relative file path: #{raw}|])) (parseRelFile raw) + +-- |A relative dir path option for @optparse-applicative@. +relDirOption :: ReadM (Path Rel Dir) +relDirOption = do + raw <- readerAsk + leftA (const (readerError [exon|not a valid relative dir path: #{raw}|])) (parseRelDir raw) + +newtype JsonConfig = + JsonConfig { unJsonConfig :: IO (Either String Value) } + deriving stock (Generic) + +instance Show JsonConfig where + show (JsonConfig _) = "JsonConfig" + +jsonOption :: + ReadM JsonConfig +jsonOption = do + raw <- readerAsk + pure $ JsonConfig $ case parseAbsFile raw of + Just f -> eitherDecodeFileStrict' (toFilePath f) + Nothing -> pure (eitherDecodeStrict' (encodeUtf8 raw)) diff --git a/lib/Hix/Preproc.hs b/lib/Hix/Preproc.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Preproc.hs @@ -0,0 +1,463 @@ +module Hix.Preproc where + +import Control.Lens (IndexedTraversal', has, index, ix, preview, (%~), (.~), (^..)) +import Control.Lens.Regex.ByteString (Match, group, groups, match, regex) +import Control.Monad.Trans.Except (ExceptT, throwE) +import qualified Data.ByteString as ByteString +import Data.ByteString (elemIndex) +import qualified Data.ByteString.Builder as ByteStringBuilder +import Data.ByteString.Builder (Builder, byteString, charUtf8, stringUtf8) +import Data.Generics.Labels () +import Data.List.Extra (firstJust) +import qualified Distribution.ModuleName as ModuleName +import Distribution.ModuleName (ModuleName) +import Distribution.PackageDescription (BuildInfo (..), ModuleRenaming (..), unPackageName) +import Distribution.Simple (PerCompilerFlavor (PerCompilerFlavor)) +import Distribution.Types.IncludeRenaming (IncludeRenaming (..)) +import Distribution.Types.Mixin (Mixin (..)) +import qualified Exon +import Exon (exon) +import Language.Haskell.Extension ( + Extension (DisableExtension, EnableExtension, UnknownExtension), + Language (UnknownLanguage), + ) +import Path (Abs, File, Path, toFilePath) +import Prelude hiding (group) +import System.Random (randomRIO) + +import Hix.Cabal (buildInfoForFile) +import Hix.Data.Error (Error (..), sourceError, tryIO) +import Hix.Options (PreprocOptions (..)) + +type Regex = IndexedTraversal' Int ByteString Match + +data Prelude = + Prelude { + preludePackage :: ByteString, + preludeModule :: ByteString + } + deriving stock (Show) + +newtype DummyExportName = + DummyExportName { unDummyExportName :: ByteString } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord) + +noMatch :: Text -> Path b File -> ExceptT Error IO a +noMatch reason source = + throwE (NoMatch (sourceError reason source)) + +takeLine :: ByteString -> Maybe (ByteString, ByteString) +takeLine bs = + elemIndex 10 bs <&> \ i -> + let (xs, ys) = ByteString.splitAt i bs + in (xs, ByteString.tail ys) + +nl :: Builder +nl = charUtf8 '\n' + +lineB :: Builder -> Builder +lineB bs = + bs <> nl + +line :: ByteString -> Builder +line bs = + lineB (byteString bs) + +joinLinesReverse :: [ByteString] -> ByteString +joinLinesReverse = + foldr joinLine mempty + where + joinLine a b = b <> a <> "\n" + +joinLinesReverseBuilder :: [ByteString] -> Builder +joinLinesReverseBuilder = + foldr joinLine mempty + where + joinLine a b = b <> line a + +extension :: Extension -> Maybe Builder +extension = \case + EnableExtension ext -> Just (show ext) + DisableExtension ext -> Just ("No" <> show ext) + UnknownExtension _ -> Nothing + +languagePragma :: [Builder] -> Builder +languagePragma exts = + [exon|{-# language #{Exon.intercalate ", " exts} #-}|] + +extensionsPragma :: BuildInfo -> Maybe Builder +extensionsPragma info + | null exts = Nothing + | otherwise = Just (languagePragma exts) + where + exts = maybeToList (dlExtension =<< info.defaultLanguage) ++ mapMaybe extension info.defaultExtensions + dlExtension = \case + UnknownLanguage _ -> Nothing + lang -> Just (stringUtf8 (show lang)) + +optionsPragma :: Builder -> Builder +optionsPragma opts = + lineB [exon|{-# options_ghc #{opts} #-}|] + +noImplicitPreludeRegex :: Regex +noImplicitPreludeRegex = + [regex|\bNoImplicitPrelude\b|] + +commentRegex :: Regex +commentRegex = + [regex|^\s*--|] + +moduleRegex :: Regex +moduleRegex = + [regex|^\s*module\b\s+(\S+)|] + +moduleEndRegex :: Regex +moduleEndRegex = + [regex|\bwhere\b|] + +importsEndRegex :: Regex +importsEndRegex = + [regex|^\S|] + +importRegex :: Regex +importRegex = + [regex|^import\b|] + +containsNoImplicitPrelude :: ByteString -> Bool +containsNoImplicitPrelude = + has noImplicitPreludeRegex + +isComment :: ByteString -> Bool +isComment = + has commentRegex + +isModule :: ByteString -> Maybe ByteString +isModule = + preview (moduleRegex . group 0) + +isModuleEnd :: ByteString -> Bool +isModuleEnd = + has moduleEndRegex + +isImportsEnd :: ByteString -> Bool +isImportsEnd = + has importsEndRegex + +isImport :: ByteString -> Bool +isImport = + has importRegex + +data Phase = + PreModule + | + ModuleStart + | + ModuleExports + | + Imports + deriving stock (Eq, Show, Generic) + +data PreludeAction = + PreludeDefault + | + PreludeNoImplicit + | + PreludeReplaced + deriving stock (Eq, Show, Generic) + +data CustomPrelude = + CustomPrelude Prelude PreludeAction + | + NoCustomPrelude + deriving stock (Show, Generic) + +notPre :: Phase -> Bool +notPre = \case + PreModule -> False + _ -> True + +pattern NotPre :: Phase +pattern NotPre <- (notPre -> True) + +inModule :: Phase -> Bool +inModule = \case + ModuleStart -> True + ModuleExports -> True + _ -> False + +pattern InModule :: Phase +pattern InModule <- (inModule -> True) + +preludeRegex :: Regex +preludeRegex = + [regex|^import\s*((?:"[^"]+" )?\s*)(?:qualified )?\s*(Prelude)|] + +replacePrelude :: ByteString -> Prelude -> Maybe ByteString +replacePrelude l Prelude {..} + | has preludeRegex l = + Just (l & preludeRegex . groups %~ insertPrelude) + | otherwise = + Nothing + where + insertPrelude = + (ix 0 .~ [exon|"#{preludePackage}" |]) + . + (ix 1 .~ preludeModule) + +parenRegex :: Regex +parenRegex = + [regex|(\()|] + +dummyExportPlaceholder :: ByteString +dummyExportPlaceholder = + "HIX_DUMMY_EXPORT>" + +dummyExportPlaceholderRegex :: Regex +dummyExportPlaceholderRegex = + [regex|HIX_DUMMY_EXPORT>|] + +insertExport :: + ByteString -> + ByteString +insertExport = + parenRegex . index 0 . match .~ ("(" <> dummyExportPlaceholder) + +moduleExportsRegex :: Regex +moduleExportsRegex = + [regex|\bmodule ([\w.]+)\s*($|,|--|\))|] + +moduleExports :: + ByteString -> + [ByteString] +moduleExports l = + l ^.. moduleExportsRegex . group 0 + +data Header = + Header { + moduleLines :: [ByteString], + importLines :: [ByteString], + rest :: Builder, + moduleEndLine :: Int, + importsEndLine :: Int, + prelude :: CustomPrelude, + exportsSelf :: Bool + } + deriving stock (Show, Generic) + +data ScanState = + ScanState { + phase :: Phase, + moduleLines :: [ByteString], + importLines :: [ByteString], + moduleLength :: Int, + importsLength :: Int, + prelude :: CustomPrelude, + moduleName :: Maybe ByteString, + exportsSelf :: Bool + } + deriving stock (Show, Generic) + +scanHeader :: + Maybe Prelude -> + ByteString -> + Header +scanHeader customPrelude = + tryProcessLine ScanState { + phase = PreModule, + moduleLines = mempty, + importLines = mempty, + moduleLength = 1, + importsLength = 0, + prelude = initPrelude, + moduleName = Nothing, + exportsSelf = False + } + where + initPrelude = case customPrelude of + Just p -> CustomPrelude p PreludeDefault + Nothing -> NoCustomPrelude + + tryProcessLine s input = + case takeLine input of + Just (nextLine, inputRest) -> + processLine s nextLine inputRest + Nothing -> + finish s mempty + + processLine s l ls | isComment l || ByteString.isPrefixOf "#" l = + pushCurrent s l ls + processLine ScanState {phase = PreModule, prelude = CustomPrelude p PreludeDefault, ..} l ls | containsNoImplicitPrelude l = + pushModule ScanState {phase = PreModule, prelude = CustomPrelude p PreludeNoImplicit, ..} l ls + processLine s@ScanState {phase = PreModule} l ls | Just name <- isModule l = + changePhase (s & #moduleName .~ Just name) ModuleStart l ls + processLine s@ScanState {phase = ModuleStart} l ls | has parenRegex l = + changePhase s ModuleExports (insertExport l) ls + processLine s@ScanState {phase = ModuleExports, moduleName = Just name, exportsSelf = False} l ls + | exs <- moduleExports l + , elem name exs = + processLine (s & #exportsSelf .~ True) l ls + processLine ScanState {phase = InModule, ..} l ls | isModuleEnd l = + pushModule ScanState {phase = Imports, ..} l ls + processLine s@ScanState {phase = InModule} l ls | isImport l = + changePhase s Imports l ls + processLine ScanState {phase = Imports, prelude = CustomPrelude p action, ..} l ls | isImport l = + let + (replaced, newAction) = + case replacePrelude l p of + Just new -> (new, PreludeReplaced) + Nothing -> (l, action) + in pushImport ScanState {phase = Imports, prelude = CustomPrelude p newAction, ..} replaced ls + processLine s@ScanState {phase = Imports} l ls | isImportsEnd l = + finish s (line l <> byteString ls) + processLine s l ls = + pushCurrent s l ls + + changePhase s phase = processLine s {phase} + + pushCurrent s@ScanState {phase} + | Imports <- phase = pushImport s + | otherwise = pushModule s + + pushModule ScanState {..} l = + tryProcessLine ScanState { + moduleLines = l : moduleLines, + moduleLength = moduleLength + 1, + .. + } + + pushImport ScanState {..} l = + tryProcessLine ScanState {importLines = l : importLines, importsLength = importsLength + 1, ..} + + finish ScanState {..} rest = + Header { + moduleEndLine = moduleLength, + importsEndLine = moduleLength + importsLength, + .. + } + +preludeRenaming :: [(b, ModuleName)] -> Maybe b +preludeRenaming = + firstJust \case + (real, "Prelude") -> Just real + _ -> Nothing + +pattern PreludeRenaming :: ModuleName -> ModuleRenaming +pattern PreludeRenaming p <- ModuleRenaming (preludeRenaming -> Just p) + +pattern PreludeInclude :: ModuleName -> IncludeRenaming +pattern PreludeInclude p <- IncludeRenaming {includeProvidesRn = PreludeRenaming p} + +findPrelude :: [Mixin] -> Maybe Prelude +findPrelude = + firstJust \case + Mixin {mixinIncludeRenaming = PreludeInclude real, ..} -> + let + preludePackage = encodeUtf8 (unPackageName mixinPackageName) + preludeModule = Exon.intercalate "." (encodeUtf8 <$> ModuleName.components real) + in Just Prelude {..} + _ -> Nothing + +customPreludeImport :: Prelude -> Builder +customPreludeImport Prelude {..} = + lineB [exon|import "#{byteString preludePackage}" #{byteString preludeModule} as Prelude|] + +needPreludeExtensions :: PreludeAction -> Bool +needPreludeExtensions = \case + PreludeDefault -> True + PreludeNoImplicit -> False + PreludeReplaced -> True + +pattern NeedPreludeExtensions :: PreludeAction +pattern NeedPreludeExtensions <- (needPreludeExtensions -> True) + +needDummy :: CustomPrelude -> Bool +needDummy = \case + NoCustomPrelude -> False + CustomPrelude _ action -> needPreludeExtensions action + +pattern NeedDummy :: CustomPrelude +pattern NeedDummy <- (needDummy -> True) + +preludeExtensions :: CustomPrelude -> Builder +preludeExtensions = \case + CustomPrelude _ NeedPreludeExtensions -> + lineB (languagePragma ["PackageImports", "NoImplicitPrelude"]) + _ -> + mempty + +explicitPreludeImport :: + Builder -> + CustomPrelude -> + Builder +explicitPreludeImport lineNo = \case + CustomPrelude prelude PreludeDefault -> customPreludeImport prelude <> lineNo + _ -> mempty + +dummyDecl :: + CustomPrelude -> + Builder -> + DummyExportName -> + Builder +dummyDecl NeedDummy lineNo (DummyExportName n) = + lineB [exon|type #{byteString n} = Int|] <> lineNo +dummyDecl _ _ _ = + mempty + +replaceDummy :: + CustomPrelude -> + Bool -> + DummyExportName -> + ByteString -> + ByteString +replaceDummy NeedDummy False (DummyExportName n) = + dummyExportPlaceholderRegex . index 0 . match .~ [exon|#{n},|] +replaceDummy _ _ _ = + dummyExportPlaceholderRegex . index 0 . match .~ "" + +assemble :: + Path Abs File -> + Header -> + Maybe Builder -> + Maybe Builder -> + DummyExportName -> + Builder +assemble source Header {..} exts options dummyExportName = + foldMap optionsPragma options <> + foldMap lineB exts <> + preludeExtensions prelude <> + linePragma 1 <> + byteString (replaceDummy prelude exportsSelf dummyExportName moduleString) <> + explicitPreludeImport (linePragma moduleEndLine) prelude <> + importsString <> + dummyDecl prelude (linePragma importsEndLine) dummyExportName <> + rest + where + linePragma n = + lineB [exon|{-# line #{show n} "#{stringUtf8 (toFilePath source)}" #-}|] + moduleString = joinLinesReverse moduleLines + importsString = joinLinesReverseBuilder importLines + +preprocessModule :: + Path Abs File -> + BuildInfo -> + DummyExportName -> + ByteString -> + Builder +preprocessModule source info dummyExportName inLines = + assemble source header (extensionsPragma info) options dummyExportName + where + options = Exon.intercalate " " <$> nonEmpty (stringUtf8 <$> ghcOptions) + PerCompilerFlavor ghcOptions _ = info.options + customPrelude = findPrelude info.mixins + header = scanHeader customPrelude inLines + +-- TODO add common stanzas +preprocess :: PreprocOptions -> ExceptT Error IO () +preprocess PreprocOptions {..} = do + info <- buildInfoForFile source + inLines <- tryIO (ByteString.readFile (toFilePath inFile)) + dummyNumber :: Int <- randomRIO (10000, 10000000) + let dummyExportName = DummyExportName [exon|Hix_Dummy_#{show dummyNumber}|] + let result = preprocessModule source info dummyExportName inLines + tryIO (ByteStringBuilder.writeFile (toFilePath outFile) result) diff --git a/test/Hix/Test/CabalFile.hs b/test/Hix/Test/CabalFile.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/CabalFile.hs @@ -0,0 +1,73 @@ +module Hix.Test.CabalFile where + +import Distribution.Fields.ParseResult (parseString) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.Verbosity (silent) +import Exon (exon) + +testCabal :: ByteString +testCabal = + [exon|cabal-version: 2.2 +name: hix +version: 0.1.0.0 +common stuff + default-extensions: + ScopedTypeVariables +library + exposed-modules: + Hix + hs-source-dirs: + lib + default-extensions: + AllowAmbiguousTypes + NoApplicativeDo + ghc-options: -Wall -Wunused-imports + build-depends: + Cabal + , base >=4.12 && <5 + mixins: + base hiding (Prelude) + , incipit-base (IncipitBase as Prelude) + , incipit-base hiding (IncipitBase) + default-language: Haskell2010 +test-suite hix-unit + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test + build-depends: + base >=4.12 && <5 + default-language: Haskell2010 +|] + +testPackage :: IO (GenericPackageDescription) +testPackage = + parseString parseGenericPackageDescription silent "hix" testCabal + +testCabalNoPrelude :: ByteString +testCabalNoPrelude = + [exon|cabal-version: 2.2 +name: hix +version: 0.1.0.0 +common stuff + default-extensions: + ScopedTypeVariables +library + exposed-modules: + Hix + hs-source-dirs: + lib + default-extensions: + AllowAmbiguousTypes + NoApplicativeDo + ghc-options: -Wall -Wunused-imports + build-depends: + Cabal + , base >=4.12 && <5 + default-language: Haskell2010 +|] + +testPackageNoPrelude :: IO (GenericPackageDescription) +testPackageNoPrelude = + parseString parseGenericPackageDescription silent "hix" testCabalNoPrelude diff --git a/test/Hix/Test/CabalTest.hs b/test/Hix/Test/CabalTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/CabalTest.hs @@ -0,0 +1,32 @@ +module Hix.Test.CabalTest where + +import Control.Monad.Trans.Except (runExceptT) +import qualified Data.ByteString as ByteString +import Distribution.PackageDescription ( + BuildInfo (defaultExtensions), + CondTree (condTreeData), + GenericPackageDescription (condLibrary), + Library (libBuildInfo), + ) +import Hedgehog (TestT, (===)) +import Hix.Cabal (parseCabal) +import Language.Haskell.Extension ( + Extension (DisableExtension, EnableExtension), + KnownExtension (AllowAmbiguousTypes, ApplicativeDo), + ) +import Path (relfile, toFilePath, ()) +import Path.IO (withSystemTempDir) + +import Hix.Test.CabalFile (testCabal) + +target :: [Extension] +target = + [EnableExtension AllowAmbiguousTypes, DisableExtension ApplicativeDo] + +test_cabal :: TestT IO () +test_cabal = do + Right pkg <- liftIO $ withSystemTempDir "hix-unit" \ tmp -> do + let cabalFile = tmp [relfile|test.cabal|] + ByteString.writeFile (toFilePath cabalFile) testCabal + runExceptT (parseCabal cabalFile) + Just target === (pkg.condLibrary <&> \ l -> l.condTreeData.libBuildInfo.defaultExtensions) diff --git a/test/Hix/Test/GhciTest.hs b/test/Hix/Test/GhciTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/GhciTest.hs @@ -0,0 +1,164 @@ +module Hix.Test.GhciTest where + +import Control.Monad.Trans.Class (lift) +import Exon (exon) +import Hedgehog (TestT, evalEither, (===)) +import Path (Abs, Dir, File, Path, Rel, SomeBase (Rel), absdir, absfile, reldir, relfile, ()) +import Path.IO (getCurrentDir, withSystemTempDir) + +import Hix.Data.Error (pathText) +import Hix.Data.GhciConfig ( + ComponentConfig (..), + ComponentName, + EnvConfig (EnvConfig), + EnvRunner (EnvRunner), + GhciConfig (..), + PackageConfig (..), + PackagesConfig, + SourceDir (SourceDir), + SourceDirs (SourceDirs), + ) +import qualified Hix.Data.GhciTest as GhciTest +import Hix.Env (envRunner) +import Hix.Ghci (assemble, ghcidCmdlineFromOptions) +import Hix.Monad (runM) +import qualified Hix.Options as Options +import Hix.Options ( + ComponentCoords (ComponentCoords), + ComponentSpec (ComponentSpec), + EnvRunnerOptions (EnvRunnerOptions), + GhciOptions (GhciOptions, component), + PackageSpec (PackageSpec), + TargetSpec (TargetForComponent, TargetForFile), + TestOptions (TestOptions), + ) + +root :: Path Abs Dir +root = + [absdir|/project|] + +runner1 :: EnvRunner +runner1 = + EnvRunner [absfile|/runner1.bash|] + +runner2 :: EnvRunner +runner2 = + EnvRunner [absfile|/runner2.bash|] + +defaultRunner :: EnvRunner +defaultRunner = + EnvRunner [absfile|/default|] + +component :: ComponentName -> Path Rel Dir -> EnvRunner -> ComponentConfig +component name dir runner = + ComponentConfig { + name, + sourceDirs = SourceDirs [SourceDir dir], + runner = Just runner + } + +packages :: PackagesConfig +packages = + [ + ("api", PackageConfig { + name = "api", + src = [reldir|packages/api|], + components = [ + ("library", component "api" [reldir|lib|] runner1), + ("server", component "server" [reldir|app|] runner1), + ("api-test", component "api-test" [reldir|test|] runner1) + ] + }), + ("core", PackageConfig { + name = "core", + src = [reldir|packages/core|], + components = [ + ("library", component "core" [reldir|lib|] runner1), + ("core-test", component "core-test" [reldir|test|] runner2) + ] + }) + ] + +spec1 :: TargetSpec +spec1 = + TargetForComponent ComponentCoords { + package = PackageSpec "api" (Just (Rel [reldir|api|])), + component = ComponentSpec "test" (Just (SourceDir [reldir|test|])) + } + +options :: GhciOptions +options = + GhciOptions { + config = Left GhciConfig { + packages, + setup = [("generic", "import Test.Tasty")], + run = [("generic", ("check . property . test"))], + args = ["-Werror"] + }, + component = spec1, + test = TestOptions { + mod = "Api.ServerTest", + test = Just "test_server", + runner = Just "generic" + } + } + +ghcidTarget :: + Path Abs Dir -> + Path Abs File -> + Text +ghcidTarget cwd scriptFile = + [exon|ghcid --command="ghci -Werror -i#{path} -ghci-script=#{pathText scriptFile}" --test='#{test}'|] + where + test = "(check . property . test) test_server" + path = [exon|#{dir}packages/api/test/:#{dir}packages/api/lib/:#{dir}packages/core/lib/|] + dir = pathText cwd + +test_ghcid :: TestT IO () +test_ghcid = do + cwd <- getCurrentDir + res <- lift $ withSystemTempDir "hix-test" \ tmp -> + runM root (ghcidCmdlineFromOptions tmp options) + cmdline <- evalEither res + ghcidTarget cwd cmdline.ghci.scriptFile === cmdline.cmdline + +spec2 :: TargetSpec +spec2 = + TargetForFile (root [relfile|packages/core/test/Main.hs|]) + +spec3 :: TargetSpec +spec3 = + TargetForComponent ComponentCoords { + package = PackageSpec "packages/core" (Just (Rel [reldir|packages/core|])), + component = ComponentSpec "core-test" (Just (SourceDir [reldir|core-test|])) + } + +runnerFor :: EnvRunner -> TargetSpec -> TestT IO () +runnerFor target spec = do + res <- evalEither =<< liftIO (runM root (envRunner conf)) + target === res + where + conf = EnvRunnerOptions (Left (EnvConfig packages defaultRunner)) (Just spec) + +test_componentEnv :: TestT IO () +test_componentEnv = do + runnerFor runner1 spec1 + runnerFor runner2 spec2 + runnerFor runner2 spec3 + +spec4 :: TargetSpec +spec4 = + TargetForFile (root [relfile|packages/core/test/Core/Test/Main.hs|]) + +target_moduleName :: Text +target_moduleName = + [exon|import Test.Tasty +:load #{m} +import #{m}|] + where + m = "Core.Test.Main" + +test_moduleName :: TestT IO () +test_moduleName = do + conf <- evalEither =<< liftIO (runM root (assemble options { component = spec4 })) + target_moduleName === conf.script diff --git a/test/Hix/Test/PreprocTest.hs b/test/Hix/Test/PreprocTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/PreprocTest.hs @@ -0,0 +1,243 @@ +module Hix.Test.PreprocTest where + +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.Text as Text +import Distribution.PackageDescription ( + CondTree (condTreeData), + GenericPackageDescription (condLibrary), + Library (libBuildInfo), + ) +import Exon (exon) +import Hedgehog (TestT, evalMaybe, (===)) +import Path (absfile) + +import Hix.Preproc (preprocessModule) +import Hix.Test.CabalFile (testPackage, testPackageNoPrelude) + +pragmas :: Text +pragmas = + [exon|{-# options_ghc -Wall -Wunused-imports #-} +{-# language Haskell2010, AllowAmbiguousTypes, NoApplicativeDo #-}|] + +preprocTestNoPrelude :: + HasCallStack => + ByteString -> + Text -> + TestT IO () +preprocTestNoPrelude module_ target = + withFrozenCallStack do + pkg <- liftIO testPackageNoPrelude + info <- evalMaybe (pkg.condLibrary <&> \ l -> l.condTreeData.libBuildInfo) + let result = toLazyByteString (preprocessModule [absfile|/foo/bar/Foo.hs|] info "Hix_Dummy" module_) + Text.lines target === Text.lines (decodeUtf8 result) + +preprocTest :: + HasCallStack => + ByteString -> + Text -> + TestT IO () +preprocTest module_ target = + withFrozenCallStack do + pkg <- liftIO testPackage + info <- evalMaybe (pkg.condLibrary <&> \ l -> l.condTreeData.libBuildInfo) + let result = toLazyByteString (preprocessModule [absfile|/foo/bar/Foo.hs|] info "Hix_Dummy" module_) + Text.lines target === Text.lines (decodeUtf8 result) + +moduleInsert :: ByteString +moduleInsert = + [exon|{-# language OverloadedLabels #-} + +module Foo ( + moo, + +noo, +) where + +import Data.Char + +f :: Int +f = 1 +|] + +targetInsert :: Text +targetInsert = + [exon|#{pragmas} +{-# language PackageImports, NoImplicitPrelude #-} +{-# line 1 "/foo/bar/Foo.hs" #-} +{-# language OverloadedLabels #-} + +module Foo (Hix_Dummy, + moo, + +noo, +) where +import "incipit-base" IncipitBase as Prelude +{-# line 8 "/foo/bar/Foo.hs" #-} + +import Data.Char + +type Hix_Dummy = Int +{-# line 11 "/foo/bar/Foo.hs" #-} +f :: Int +f = 1 +|] + +test_preprocInsertPrelude :: TestT IO () +test_preprocInsertPrelude = + preprocTest moduleInsert targetInsert + +moduleReplace :: ByteString +moduleReplace = + [exon|{-# language OverloadedLabels #-} + +module Foo ( + moo, + + noo, + ) where + +import Data.Char +import "base" Prelude (sum) +import Data.List +import Prelude hiding (Maybe) +import Data.Maybe + +f :: Int +f = 1 +|] + +targetReplace :: Text +targetReplace = + [exon|#{pragmas} +{-# language PackageImports, NoImplicitPrelude #-} +{-# line 1 "/foo/bar/Foo.hs" #-} +{-# language OverloadedLabels #-} + +module Foo (Hix_Dummy, + moo, + + noo, + ) where + +import Data.Char +import "incipit-base" IncipitBase (sum) +import Data.List +import "incipit-base" IncipitBase hiding (Maybe) +import Data.Maybe + +type Hix_Dummy = Int +{-# line 15 "/foo/bar/Foo.hs" #-} +f :: Int +f = 1 +|] + +test_preprocReplacePrelude :: TestT IO () +test_preprocReplacePrelude = + preprocTest moduleReplace targetReplace + +moduleSingleLineModule :: ByteString +moduleSingleLineModule = + [exon|module Foo where + +f :: Int +f = 1 +|] + +targetSingleLineModule :: Text +targetSingleLineModule = + [exon|#{pragmas} +{-# language PackageImports, NoImplicitPrelude #-} +{-# line 1 "/foo/bar/Foo.hs" #-} +module Foo where +import "incipit-base" IncipitBase as Prelude +{-# line 2 "/foo/bar/Foo.hs" #-} + +type Hix_Dummy = Int +{-# line 3 "/foo/bar/Foo.hs" #-} +f :: Int +f = 1 +|] + +test_preprocSingleLineModule :: TestT IO () +test_preprocSingleLineModule = + preprocTest moduleSingleLineModule targetSingleLineModule + +moduleSelfExport :: ByteString +moduleSelfExport = + [exon|module Foo (module Foo) where + +f :: Int +f = 1 +|] + +targetSelfExport :: Text +targetSelfExport = + [exon|#{pragmas} +{-# language PackageImports, NoImplicitPrelude #-} +{-# line 1 "/foo/bar/Foo.hs" #-} +module Foo (module Foo) where +import "incipit-base" IncipitBase as Prelude +{-# line 2 "/foo/bar/Foo.hs" #-} + +type Hix_Dummy = Int +{-# line 3 "/foo/bar/Foo.hs" #-} +f :: Int +f = 1 +|] + +test_preprocSelfExport :: TestT IO () +test_preprocSelfExport = + preprocTest moduleSelfExport targetSelfExport + +moduleSelfExport2 :: ByteString +moduleSelfExport2 = + [exon|module Foo ( + module Bar, + module Foo, + module Baz, +) where + +f :: Int +f = 1 +|] + +targetSelfExport2 :: Text +targetSelfExport2 = + [exon|#{pragmas} +{-# language PackageImports, NoImplicitPrelude #-} +{-# line 1 "/foo/bar/Foo.hs" #-} +module Foo ( + module Bar, + module Foo, + module Baz, +) where +import "incipit-base" IncipitBase as Prelude +{-# line 6 "/foo/bar/Foo.hs" #-} + +type Hix_Dummy = Int +{-# line 7 "/foo/bar/Foo.hs" #-} +f :: Int +f = 1 +|] + +test_preprocSelfExport2 :: TestT IO () +test_preprocSelfExport2 = + preprocTest moduleSelfExport2 targetSelfExport2 + +moduleNoPrelude :: ByteString +moduleNoPrelude = + [exon|module Main where +import System.Exit (exitSuccess) +|] + +targetNoPrelude :: Text +targetNoPrelude = + [exon|#{pragmas} +{-# line 1 "/foo/bar/Foo.hs" #-} +module Main where +import System.Exit (exitSuccess) +|] + +test_preprocNoPrelude :: TestT IO () +test_preprocNoPrelude = + preprocTestNoPrelude moduleNoPrelude targetNoPrelude diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,45 @@ +module Main where + +import Hedgehog (TestT, property, test, withTests) +import Hix.Test.CabalTest (test_cabal) +import Hix.Test.GhciTest (test_componentEnv, test_ghcid, test_moduleName) +import Hix.Test.PreprocTest ( + test_preprocInsertPrelude, + test_preprocNoPrelude, + test_preprocReplacePrelude, + test_preprocSelfExport, + test_preprocSelfExport2, + test_preprocSingleLineModule, + ) +import Test.Tasty (TestName, TestTree, defaultMain, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +unitTest :: + HasCallStack => + TestName -> + TestT IO () -> + TestTree +unitTest desc t = + withFrozenCallStack do + testProperty desc (withTests 1 (property (test t))) + +tests :: TestTree +tests = + testGroup "all" [ + unitTest "parse cabal file" test_cabal, + testGroup "preprocess source file" [ + unitTest "insert prelude import" test_preprocInsertPrelude, + unitTest "replace prelude imports" test_preprocReplacePrelude, + unitTest "single line module decl" test_preprocSingleLineModule, + unitTest "self exporting module, inline" test_preprocSelfExport, + unitTest "self exporting module, separate line" test_preprocSelfExport2, + unitTest "self exporting module, separate line" test_preprocNoPrelude, + unitTest "run ghcid" test_ghcid, + unitTest "component env" test_componentEnv, + unitTest "extract module name from path" test_moduleName + ] + ] + +main :: IO () +main = + defaultMain tests