add hie-bios command

nmattia · May 30, 2020 · 2044962 · 2044962
1 parent 8b02e47
commit 2044962
Show file tree

Hide file tree

Showing 2 changed files with 73 additions and 0 deletions.
diff --git 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
@@ -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
   ;
 }