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