Refactor

app/Main.hs

@@ -5,6 +5,7 @@ module Main where
 import Control.Monad
 import Control.Monad.Trans.Maybe
 import Data.Maybe
+import Hie.Cabal.Parser
 import Hie.Locate
 import Hie.Yaml
 import System.Directory
@@ -16,27 +17,29 @@ import System.IO
 main :: IO ()
 main = do
   pwd <- getCurrentDirectory
-  name <- resolveName pwd
-  cfs <- runMaybeT $ case name of
-    "cabal" -> cabalPkgs pwd
-    _ -> stackYamlPkgs pwd
+  ct <- resolveCradleType pwd
+  cfs <- runMaybeT $ case ct of
+    CabalCradle -> cabalPkgs pwd
+    StackCradle -> stackYamlPkgs pwd
   when (null cfs) $
     die $
-      "Used " <> name
+      "Used "
+        <> cradleTypeName ct
         <> "\n No .cabal files found under"
         <> pwd
         <> "\n You may need to run stack build."
   pkgs <- catMaybes <$> mapM (nestedPkg pwd) (concat cfs)
-  putStr <$> hieYaml name $ fmtPkgs name pkgs
+  putStr <$> hieYaml ct $ fmtPkgs ct pkgs
 
-resolveName :: FilePath -> IO String
-resolveName pwd = do
+resolveCradleType :: FilePath -> IO CradleType
+resolveCradleType pwd = do
   args <- getArgs
   files <- listDirectory pwd
   when ("--help" `elem` args || "-h" `elem` args) $ do
     progName <- getProgName
     hPutStrLn stderr $
-      "Usage: " <> progName
+      "Usage: "
+        <> progName
         <> " [ --cabal | --stack ]\n\n\
            \If neither argument is given then "
         <> progName
@@ -44,13 +47,13 @@ resolveName pwd = do
            \looking for dist-newstyle, .stack-work, cabal.project and stack.yaml in that order."
     exitSuccess
   let fileNames = map takeFileName files
-      name =
+      ct =
         if
-            | "--cabal" `elem` args -> "cabal"
-            | "--stack" `elem` args -> "stack"
-            | "dist-newstyle" `elem` fileNames -> "cabal"
-            | ".stack-work" `elem` fileNames -> "stack"
-            | "cabal.project" `elem` fileNames -> "cabal"
-            | "stack.yaml" `elem` fileNames -> "stack"
-            | otherwise -> "cabal"
-  return name
+            | "--cabal" `elem` args -> CabalCradle
+            | "--stack" `elem` args -> StackCradle
+            | "dist-newstyle" `elem` fileNames -> CabalCradle
+            | ".stack-work" `elem` fileNames -> StackCradle
+            | "cabal.project" `elem` fileNames -> CabalCradle
+            | "stack.yaml" `elem` fileNames -> StackCradle
+            | otherwise -> CabalCradle
+  return ct

src/Hie/Cabal/Parser.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -6,6 +7,9 @@ module Hie.Cabal.Parser
     Component (..),
     CompType (..),
     Name,
+    CradleType (..),
+    CradlePer (..),
+    cradleTypeName,
     extractPkgs,
     parsePackage',
   )
@@ -71,6 +75,17 @@ data Component
   = Comp CompType Name Path
   deriving (Show, Eq, Ord)
 
+data CradleType = StackCradle | CabalCradle
+  deriving (Eq, Show)
+
+cradleTypeName :: CradleType -> String
+cradleTypeName = \case
+  StackCradle -> "stack"
+  CabalCradle -> "cabal"
+
+data CradlePer = PerSrcDir | PerModule
+  deriving (Eq, Show)
+
 parseQuoted :: Parser Text
 parseQuoted = do
   q <- char '"' <|> char '\''

src/Hie/Yaml.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Hie.Yaml
@@ -6,17 +7,18 @@ module Hie.Yaml
     fmtPkgs,
     cabalComponent,
     stackComponent,
+    component,
   )
 where
 
 import qualified Data.Text as T
 import Hie.Cabal.Parser
 
-hieYaml :: String -> String -> String
-hieYaml sOrC pkgs =
+hieYaml :: CradleType -> String -> String
+hieYaml ct pkgs =
   "cradle:\n"
     <> indent'
-      (sOrC <> ":\n" <> indent' pkgs)
+      (cradleTypeName ct <> ":\n" <> indent' pkgs)
 
 indent' :: String -> String
 indent' =
@@ -28,6 +30,11 @@ indent' =
       )
     . lines
 
+component :: CradleType -> Name -> Component -> (FilePath, String)
+component = \case
+  CabalCradle -> cabalComponent
+  StackCradle -> stackComponent
+
 cabalComponent :: Name -> Component -> (FilePath, String)
 cabalComponent n (Comp Lib "" p) = (T.unpack p, T.unpack $ "lib:" <> n)
 cabalComponent n (Comp Lib cn p) = (T.unpack p, T.unpack $ n <> ":lib:" <> cn)
@@ -54,11 +61,10 @@ fmtComponent (p, c) =
 dropLast :: [a] -> [a]
 dropLast l = take (length l - 1) l
 
-fmtPkgs :: String -> [Package] -> String
-fmtPkgs sOrC pkgs = dropLast $ unlines l
+fmtPkgs :: CradleType -> [Package] -> String
+fmtPkgs ct pkgs = dropLast $ unlines l
   where
-    comp = if sOrC == "cabal" then cabalComponent else stackComponent
-    f (Package n cs) = map ((<> "\n") . fmtComponent . comp n) cs
+    f (Package n cs) = map ((<> "\n") . fmtComponent . component ct n) cs
     l = concatMap f pkgs
 
 dQuote :: String -> String