1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ViewPatterns #-}
3module Hpack.Render.Hints (
4  FormattingHints (..)
5, sniffFormattingHints
6#ifdef TEST
7, sniffRenderSettings
8, extractFieldOrder
9, extractSectionsFieldOrder
10, sanitize
11, unindent
12, sniffAlignment
13, splitField
14, sniffIndentation
15, sniffCommaStyle
16#endif
17) where
18
19import           Data.Char
20import           Data.Maybe
21import           Data.List hiding (nub)
22import           Control.Applicative
23
24import           Hpack.Render.Dsl
25import           Hpack.Util
26
27data FormattingHints = FormattingHints {
28  formattingHintsFieldOrder :: [String]
29, formattingHintsSectionsFieldOrder :: [(String, [String])]
30, formattingHintsAlignment :: Maybe Alignment
31, formattingHintsRenderSettings :: RenderSettings
32} deriving (Eq, Show)
33
34sniffFormattingHints :: [String] -> FormattingHints
35sniffFormattingHints (sanitize -> input) = FormattingHints {
36  formattingHintsFieldOrder = extractFieldOrder input
37, formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input
38, formattingHintsAlignment = sniffAlignment input
39, formattingHintsRenderSettings = sniffRenderSettings input
40}
41
42sanitize :: [String] -> [String]
43sanitize = filter (not . isPrefixOf "cabal-version:") . filter (not . null) . map stripEnd
44
45stripEnd :: String -> String
46stripEnd = reverse . dropWhile isSpace . reverse
47
48extractFieldOrder :: [String] -> [String]
49extractFieldOrder = map fst . catMaybes . map splitField
50
51extractSectionsFieldOrder :: [String] -> [(String, [String])]
52extractSectionsFieldOrder = map (fmap extractFieldOrder) . splitSections
53  where
54    splitSections input = case break startsWithSpace input of
55      ([], []) -> []
56      (xs, ys) -> case span startsWithSpace ys of
57        (fields, zs) -> case reverse xs of
58          name : _ -> (name, unindent fields) : splitSections zs
59          _ -> splitSections zs
60
61    startsWithSpace :: String -> Bool
62    startsWithSpace xs = case xs of
63      y : _ -> isSpace y
64      _ -> False
65
66unindent :: [String] -> [String]
67unindent input = map (drop indentation) input
68  where
69    indentation = minimum $ map (length . takeWhile isSpace) input
70
71sniffAlignment :: [String] -> Maybe Alignment
72sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ input of
73  [n] -> Just (Alignment n)
74  _ -> Nothing
75  where
76
77    indentation :: (String, String) -> Maybe Int
78    indentation (name, value) = case span isSpace value of
79      (_, "") -> Nothing
80      (xs, _) -> (Just . succ . length $ name ++ xs)
81
82splitField :: String -> Maybe (String, String)
83splitField field = case span isNameChar field of
84  (xs, ':':ys) -> Just (xs, ys)
85  _ -> Nothing
86  where
87    isNameChar = (`elem` nameChars)
88    nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-"
89
90sniffIndentation :: [String] -> Maybe Int
91sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable"
92  where
93    sniffFrom :: String -> Maybe Int
94    sniffFrom section = case findSection . removeEmptyLines $ input of
95      _ : x : _ -> Just . length $ takeWhile isSpace x
96      _ -> Nothing
97      where
98        findSection = dropWhile (not . isPrefixOf section)
99
100    removeEmptyLines :: [String] -> [String]
101    removeEmptyLines = filter $ any (not . isSpace)
102
103sniffCommaStyle :: [String] -> Maybe CommaStyle
104sniffCommaStyle input
105  | any startsWithComma input = Just LeadingCommas
106  | any (startsWithComma . reverse) input = Just TrailingCommas
107  | otherwise = Nothing
108  where
109    startsWithComma = isPrefixOf "," . dropWhile isSpace
110
111sniffRenderSettings :: [String] -> RenderSettings
112sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle
113  where
114    indentation = max def $ fromMaybe def (sniffIndentation input)
115      where def = renderSettingsIndentation defaultRenderSettings
116
117    fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings
118    commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input)
119