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 ; }