From db1a1b84a64ceea9b9440e14f54f09619d8390e1 Mon Sep 17 00:00:00 2001 From: hyperfekt Date: Thu, 7 May 2020 14:07:58 +0200 Subject: [PATCH 1/3] rename PackageFile to CanonicalFilePath --- bin/Snack.hs | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/bin/Snack.hs b/bin/Snack.hs index 4e84128..646465b 100644 --- a/bin/Snack.hs +++ b/bin/Snack.hs @@ -111,7 +111,7 @@ mkSnackLib = fmap SnackLib . mkDirPath --- Package description (@package.yaml@, @package.nix@) -- | Like a FilePath, but Nix friendly -newtype PackageFile = PackageFile { unPackageFile :: FilePath } +newtype CanonicalFilePath = CanonicalFilePath { unpackCanonicalFilePath :: FilePath } -- | What package description (@package.yaml@, @package.nix@) to use data PackageFileConfig @@ -136,24 +136,24 @@ parsePackageFileConfig = -- Finding the package descriptions -mkPackageFileEither :: FilePath -> IO (Either String PackageFile) -mkPackageFileEither = fmap (fmap PackageFile) . mkFilePathEither +mkCanonicalFilePathEither :: FilePath -> IO (Either String CanonicalFilePath) +mkCanonicalFilePathEither = fmap (fmap CanonicalFilePath) . mkFilePathEither -mkPackageFile :: FilePath -> IO PackageFile -mkPackageFile = fmap PackageFile . mkFilePath +mkCanonicalFilePath :: FilePath -> IO CanonicalFilePath +mkCanonicalFilePath = fmap CanonicalFilePath . mkFilePath -preparePackage :: PackageFileConfig -> IO PackageFile +preparePackage :: PackageFileConfig -> IO CanonicalFilePath preparePackage = \case - PackageFileSpecific fp -> mkPackageFile fp + PackageFileSpecific fp -> mkCanonicalFilePath fp PackageFileDiscovery -> discoverPackageFile -- | Tries to find a package description. -discoverPackageFile :: IO PackageFile +discoverPackageFile :: IO CanonicalFilePath discoverPackageFile = do - eYaml <- mkPackageFileEither "package.yaml" - eNix <- mkPackageFileEither "package.nix" + eYaml <- mkCanonicalFilePathEither "package.yaml" + eNix <- mkCanonicalFilePathEither "package.nix" case (eYaml, eNix) of - (Right (PackageFile yaml), Right (PackageFile nix)) -> + (Right (CanonicalFilePath yaml), Right (CanonicalFilePath nix)) -> throwIO $ userError $ unlines [ "Please specify which package file to use, e.g.: " , " snack -p " <> yaml, "or" @@ -261,7 +261,7 @@ type Options = Options_ 'ConfigReady -- | The whole set of CLI options data Options_ c = Options { snackConfig :: SnackConfig_ c - , package :: Config c PackageFileConfig PackageFile + , package :: Config c PackageFileConfig CanonicalFilePath , command :: Command } @@ -415,24 +415,24 @@ nixBuild snackCfg extraNixArgs nixExpr = : [ argName narg , argValue narg ] nixCfg = snackNixCfg snackCfg -snackBuild :: SnackConfig -> PackageFile -> Sh [BuildResult] +snackBuild :: SnackConfig -> CanonicalFilePath -> Sh [BuildResult] snackBuild snackCfg packageFile = do NixPath out <- nixBuild snackCfg [ NixArg { argName = "packageFile" - , argValue = T.pack $ unPackageFile packageFile + , argValue = T.pack $ unpackCanonicalFilePath packageFile , argType = Arg } ] $ NixExpr "snack.inferBuild packageFile" decodeOrFail =<< liftIO (BS.readFile $ T.unpack out) -snackGhci :: SnackConfig -> PackageFile -> Sh GhciBuild +snackGhci :: SnackConfig -> CanonicalFilePath -> Sh GhciBuild snackGhci snackCfg packageFile = do NixPath out <- nixBuild snackCfg [ NixArg { argName = "packageFile" - , argValue = T.pack $ unPackageFile packageFile + , argValue = T.pack $ unpackCanonicalFilePath packageFile , argType = Arg } ] @@ -443,12 +443,12 @@ snackGhci snackCfg packageFile = do bs -> throwIO $ userError $ "Expected GHCi build, got " <> show bs -snackHoogle :: SnackConfig -> PackageFile -> Sh HoogleBuild +snackHoogle :: SnackConfig -> CanonicalFilePath -> Sh HoogleBuild snackHoogle snackCfg packageFile = do NixPath out <- nixBuild snackCfg [ NixArg { argName = "packageFile" - , argValue = T.pack $ unPackageFile packageFile + , argValue = T.pack $ unpackCanonicalFilePath packageFile , argType = Arg } ] @@ -458,7 +458,7 @@ snackHoogle snackCfg packageFile = do bs -> throwIO $ userError $ "Expected Hoogle build, got " <> show bs -runCommand :: SnackConfig -> PackageFile -> Command -> IO () +runCommand :: SnackConfig -> CanonicalFilePath -> Command -> IO () runCommand snackCfg packageFile = \case Build -> S.shelly $ void $ snackBuild snackCfg packageFile Run args -> quiet (snackBuild snackCfg packageFile) >>= runBuildResult args From 8b02e47c92753ad12a4770d6442c7d30df34c1b7 Mon Sep 17 00:00:00 2001 From: hyperfekt Date: Thu, 7 May 2020 14:10:48 +0200 Subject: [PATCH 2/3] fix indentation in snack-lib/default.nix --- snack-lib/default.nix | 44 +++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/snack-lib/default.nix b/snack-lib/default.nix index 3bc0f5a..2a877c2 100644 --- a/snack-lib/default.nix +++ b/snack-lib/default.nix @@ -173,28 +173,28 @@ with rec then pkgDescriptionsFromFile packagePath else abort "Don't know how to load package path of type ${pathType}"; - specsFromPackageFile = packagePath: - map mkPackageSpec (pkgDescriptionsFromPath packagePath); - - buildHoogle = packagePath: - let - concatUnion = lists: - let - sets = map (l: pkgs.lib.genAttrs l (_: null)) lists; - union = pkgs.lib.foldAttrs (n: a: null) {} sets; - in - builtins.attrNames union; - allDeps = concatUnion (map (spec: spec.packageDependencies {}) (specsFromPackageFile packagePath)); - drv = haskellPackages.hoogleLocal { packages = map (p: haskellPackages.${p}) allDeps; }; - in - writeText "hoogle-json" - ( builtins.toJSON - { build_type = "hoogle"; - result = { - exe_path = "${drv.out}/bin/hoogle"; - }; - } - ); + specsFromPackageFile = packagePath: + map mkPackageSpec (pkgDescriptionsFromPath packagePath); + + buildHoogle = packagePath: + let + concatUnion = lists: + let + sets = map (l: pkgs.lib.genAttrs l (_: null)) lists; + union = pkgs.lib.foldAttrs (n: a: null) {} sets; + in + builtins.attrNames union; + allDeps = concatUnion (map (spec: spec.packageDependencies {}) (specsFromPackageFile packagePath)); + drv = haskellPackages.hoogleLocal { packages = map (p: haskellPackages.${p}) allDeps; }; + in + writeText "hoogle-json" + ( builtins.toJSON + { build_type = "hoogle"; + result = { + exe_path = "${drv.out}/bin/hoogle"; + }; + } + ); }; { From 20449629f807da352ce03e92d574ade2ee394d47 Mon Sep 17 00:00:00 2001 From: hyperfekt Date: Thu, 7 May 2020 15:56:36 +0200 Subject: [PATCH 3/3] add hie-bios command --- bin/Snack.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ snack-lib/default.nix | 31 +++++++++++++++++++++++++++++++ 2 files changed, 73 insertions(+) diff --git a/bin/Snack.hs b/bin/Snack.hs index 646465b..3cf9649 100644 --- a/bin/Snack.hs +++ b/bin/Snack.hs @@ -237,6 +237,7 @@ data Command | Ghci [String] | Test | Hoogle + | HieBios String parseCommand :: Opts.Parser Command parseCommand = @@ -249,6 +250,9 @@ parseCommand = ( Ghci <$> Opts.many (Opts.argument Opts.str (Opts.metavar "ARG")) ) mempty) <> Opts.command "hoogle" (Opts.info (pure Hoogle) mempty) + <> Opts.command "hie-bios" (Opts.info + ( HieBios <$> Opts.argument Opts.str (Opts.metavar "FILE") + ) mempty) ) <|> Opts.hsubparser ( Opts.command "test" (Opts.info (pure Test) (Opts.progDesc "Use build, run or ghci commands with test suites.")) @@ -290,6 +294,7 @@ data BuildResult | BuiltExecutable ExecutableBuild | BuiltGhci GhciBuild | BuiltHoogle HoogleBuild + | BuiltHieBios HieBiosBuild deriving Show instance Aeson.FromJSON BuildResult where @@ -298,6 +303,7 @@ instance Aeson.FromJSON BuildResult where <|> BuiltExecutable <$> (guardBuildType "executable" v) <|> BuiltGhci <$> (guardBuildType "ghci" v) <|> BuiltHoogle <$> (guardBuildType "hoogle" v) + <|> BuiltHieBios <$> (guardBuildType "hie-bios" v) where guardBuildType :: FromJSON a => T.Text -> Aeson.Value -> Aeson.Parser a guardBuildType ty = Aeson.withObject "build result" $ \o -> do @@ -333,6 +339,15 @@ instance FromJSON HoogleBuild where parseJSON = Aeson.withObject "hoogle build" $ \o -> HoogleBuild <$> o .: "exe_path" +newtype HieBiosBuild = HieBiosBuild + { hieBiosFlags :: [T.Text] + } + deriving stock Show + +instance FromJSON HieBiosBuild where + parseJSON = Aeson.withObject "hie-bios build" $ \o -> + HieBiosBuild <$> o .: "hie-bios_flags" + data NixArg = NixArg { argType :: NixArgType , argName :: T.Text @@ -457,6 +472,24 @@ snackHoogle snackCfg packageFile = do BuiltHoogle hb -> pure hb bs -> throwIO $ userError $ "Expected Hoogle build, got " <> show bs +snackHieBios :: SnackConfig -> CanonicalFilePath -> CanonicalFilePath -> Sh HieBiosBuild +snackHieBios snackCfg packageFile haskellFile = do + NixPath out <- nixBuild snackCfg + [ NixArg + { argName = "packageFile" + , argValue = T.pack $ unpackCanonicalFilePath packageFile + , argType = Arg + } + , NixArg + { argName = "haskellFile" + , argValue = T.pack $ unpackCanonicalFilePath haskellFile + , argType = Arg + } + ] + $ NixExpr "snack.buildHieBios packageFile haskellFile" + liftIO (BS.readFile (T.unpack out)) >>= decodeOrFail >>= \case + BuiltHieBios hb -> pure hb + bs -> throwIO $ userError $ "Expected hie-bios flags, got " <> show bs runCommand :: SnackConfig -> CanonicalFilePath -> Command -> IO () runCommand snackCfg packageFile = \case @@ -467,6 +500,15 @@ runCommand snackCfg packageFile = \case Test -> noTest Hoogle -> flip runExe [ "server", "--local" ] =<< hoogleExePath <$> S.shelly (snackHoogle snackCfg packageFile) + HieBios haskellFile -> S.shelly $ do + maybeBiosFile <- S.get_env "HIE_BIOS_OUTPUT" + biosFile <- case maybeBiosFile of + Nothing -> fail $ "HIE_BIOS_OUTPUT environment variable not set" + Just x -> pure x + canonicalHaskellFile <- liftIO $ mkCanonicalFilePath haskellFile + result <- snackHieBios snackCfg packageFile canonicalHaskellFile + let flags = hieBiosFlags result + S.writefile (S.fromText biosFile) (T.unlines flags) noTest :: IO a diff --git a/snack-lib/default.nix b/snack-lib/default.nix index 2a877c2..71c59c2 100644 --- a/snack-lib/default.nix +++ b/snack-lib/default.nix @@ -196,6 +196,36 @@ with rec } ); + buildHieBios = packagePath: haskellPath: + let + flags = with lib; let + containingPackage = let + hasSource = let + isPrefix = xxs: xs: length xs == 0 || length xxs > 0 && head xs == head xxs && isPrefix (tail xxs) (tail xs); + components = p: strings.splitString "/" (builtins.toString p); # toString needed because otherwise the coercion of the path to a string will import it into the store first + in spec: any (isPrefix (components haskellPath)) (map components spec.packageSourceDirs) || any hasSource spec.packagePackages; + in findFirst hasSource (abort "Couldn't find package containing ${builtins.toString haskellPath} in ${builtins.toString packagePath} and the packages it references") (specsFromPackageFile packagePath); + srcdirs = let + sourceDirs = spec: spec.packageSourceDirs ++ (map sourceDirs spec.packagePackages); + in map builtins.toString (unique (sourceDirs containingPackage)); + modspecs = if containingPackage.packageIsExe then [ (executableMainModSpec containingPackage) ] else libraryModSpecs containingPackage; + deps = allTransitiveDeps modspecs; + exts = allTransitiveExtensions modspecs; + opts = allTransitiveGhcOpts modspecs; + db = let + ghc = ghcWith deps; + in "${ghc}/lib/ghc-${ghc.version}/package.conf.d"; + in [ "-no-global-package-db" "-package-db ${db}" ] ++ (map (p: "-package ${p}") deps) ++ (map (d: "-i${d}") srcdirs) ++ (map (e: "-X${e}") exts) ++ opts; + in + writeText "hie-bios-json" ( + builtins.toJSON { + build_type = "hie-bios"; + result = { + hie-bios_flags = flags; + }; + } + ); + }; { inherit @@ -205,5 +235,6 @@ with rec buildAsLibrary executable buildHoogle + buildHieBios ; }