Merge branch 'release/0.5.0'

package.yaml

@@ -1,5 +1,5 @@
 name:                cmt
-version:             0.4.0.0
+version:             0.5.0.0
 github:              "smallhadroncollider/cmt"
 license:             BSD3
 author:              "Small Hadron Collider / Mark Wales"
@@ -25,6 +25,7 @@ library:
   source-dirs: src
   dependencies:
   - attoparsec
+  - containers
   - text
   - directory
   - filepath

src/Cmt.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Cmt
     ( go
@@ -11,17 +12,18 @@ import Data.Text        (stripEnd)
 import System.Directory (removeFile)
 import System.Exit      (exitFailure, exitSuccess)
 
-import Cmt.IO.Config     (load, readCfg, checkFormat)
+import Cmt.IO.Config     (checkFormat, load, readCfg)
 import Cmt.IO.Git        (commit)
 import Cmt.IO.Input      (loop)
 import Cmt.Output.Format (format)
 import Cmt.Parser.Config (predefined)
-import Cmt.Types.Config  (Config, Output)
+import Cmt.Types.Config  (Config, Outputs)
 
 data Next
     = Previous
-    | PreDefined Text [Output]
-    | Continue [Output]
+    | PreDefined Text
+                 Outputs
+    | Continue Outputs
 
 backup :: FilePath
 backup = ".cmt.bkp"
@@ -38,7 +40,7 @@ send txt = do
             writeFile backup (encodeUtf8 txt)
             failure msg
 
-display :: Either Text (Config, [Output]) -> IO ()
+display :: Either Text (Config, Outputs) -> IO ()
 display (Left err) = putStrLn err
 display (Right (cfg, output)) = do
     parts <- loop cfg
@@ -50,15 +52,15 @@ previous = do
     removeFile backup
     send txt
 
-predef :: Text -> [Output] -> IO ()
+predef :: Text -> Outputs -> IO ()
 predef name output = do
     cfg <- load
     case predefined =<< cfg of
         Left msg -> failure msg
         Right pre ->
-            case find ((==) name . fst) pre of
-                Nothing       -> failure "No matching predefined message"
-                Just (_, cfg) -> display $ checkFormat output cfg
+            case lookup name pre of
+                Nothing -> failure "No matching predefined message"
+                Just cf -> display $ checkFormat output cf
 
 parseArgs :: [Text] -> Next
 parseArgs ["--prev"]        = Previous
@@ -73,6 +75,6 @@ go :: IO ()
 go = do
     next <- parseArgs <$> getArgs
     case next of
-        Continue output -> readCfg output >>= display
-        Previous        -> previous
+        Continue output        -> readCfg output >>= display
+        Previous               -> previous
         PreDefined name output -> predef name output

src/Cmt/IO/Config.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Cmt.IO.Config
     ( load
@@ -19,7 +20,7 @@ import Cmt.Types.Config
 configFile :: FilePath
 configFile = ".cmt"
 
-checkFormat :: [Output] -> Config -> Either Text (Config, [Output])
+checkFormat :: Outputs -> Config -> Either Text (Config, Outputs)
 checkFormat output (Config parts format) = do
     let partNames = nub $ partName <$> parts
     let formatNames = nub . catMaybes $ formatName <$> format
@@ -30,7 +31,7 @@ checkFormat output (Config parts format) = do
             | otherwise = Right (Config parts format, output)
     result
 
-parse :: [Output] -> Text -> Either Text (Config, [Output])
+parse :: Outputs -> Text -> Either Text (Config, Outputs)
 parse output cfg = config cfg >>= checkFormat output
 
 read :: FilePath -> IO Text
@@ -75,7 +76,7 @@ load = do
         Just path -> Right <$> read path
         Nothing   -> pure $ Left ".cmt file not found"
 
-readCfg :: [Output] -> IO (Either Text (Config, [Output]))
+readCfg :: Outputs -> IO (Either Text (Config, Outputs))
 readCfg output = do
     cfg <- load
     pure (parse output =<< cfg)

src/Cmt/IO/Input.hs

@@ -1,18 +1,22 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Cmt.IO.Input
     ( loop
     ) where
 
 import ClassyPrelude
 
+import Data.Map.Strict              (Map)
 import System.Console.Terminal.Size (size, width)
 
 import Cmt.IO.Git         (changed)
 import Cmt.Parser.Options (parse)
 import Cmt.Types.Config
 
+type Choice = Map Int Text
+
 prompt :: Text -> IO Text
 prompt s = do
     putStr $ s <> " "
@@ -25,23 +29,27 @@ getWidth = maybe 0 width <$> size
 putName :: Text -> IO ()
 putName name = putStrLn $ "\n" <> name <> ":"
 
-listItem :: (Int, Text) -> Text
-listItem (n, o) = tshow n <> ") " <> o
+listItem :: Int -> Text -> Text
+listItem n o = tshow n <> ") " <> o
 
-displayOptions :: [(Int, Text)] -> IO ()
+displayOptions :: Choice -> IO ()
 displayOptions opts = do
-    let long = intercalate "   " $ listItem <$> opts
+    let parts = mapWithKey listItem opts
+    let long = intercalate "   " parts
     maxLength <- getWidth
     if length long < maxLength
         then putStrLn long
-        else sequence_ $ putStrLn . listItem <$> opts
+        else sequence_ $ putStrLn <$> parts
+
+choice :: Choice -> Int -> Maybe Text
+choice opts chosen = lookup chosen opts
 
-choice :: [(Int, Text)] -> Int -> Maybe Text
-choice opts chosen = snd <$> find ((== chosen) . fst) opts
+choiceGen :: [Text] -> Choice
+choiceGen ts = mapFromList $ zip [1 ..] ts
 
 options :: [Text] -> IO Text
 options opts = do
-    let opts' = zip [1 ..] opts
+    let opts' = choiceGen opts
     displayOptions opts'
     chosen <- parse <$> prompt ">"
     case chosen of
@@ -66,11 +74,11 @@ line = do
         then line
         else pure value
 
-output :: Part -> IO (Name, Text)
+output :: Part -> IO Output
 output (Part name Line)           = putName name >> (,) name <$> line
 output (Part name (Options opts)) = putName name >> (,) name <$> options opts
 output (Part name Lines)          = putName name >> (,) name <$> (unlines <$> multiLine [])
 output (Part name Changed)        = putName name >> (,) name <$> (options =<< changed)
 
-loop :: Config -> IO [(Name, Text)]
-loop (Config parts _) = sequence $ output <$> parts
+loop :: Config -> IO Outputs
+loop (Config parts _) = mapFromList <$> traverse output parts

src/Cmt/Output/Format.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Cmt.Output.Format
     ( format
@@ -9,12 +9,9 @@ import ClassyPrelude
 
 import Cmt.Types.Config
 
-tidy :: [Output] -> FormatPart -> Text
-tidy _ (Literal c) = c
-tidy parts (Named name) =
-    case find ((== name) . fst) parts of
-        Just (_, t) -> t
-        Nothing     -> ""
+tidy :: Outputs -> FormatPart -> Maybe Text
+tidy _ (Literal c)      = pure c
+tidy parts (Named name) = lookup name parts
 
-format :: Config -> [Output] -> Text
-format (Config _ fmt) parts = concat $ tidy parts <$> fmt
+format :: Config -> Outputs -> Text
+format (Config _ fmt) parts = concat . catMaybes $ tidy parts <$> fmt

src/Cmt/Parser/Config.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Cmt.Parser.Config
     ( config
@@ -23,7 +24,7 @@ configP = do
     _ <- endOfInput
     pure $ Config parts format
 
-predefinedP :: Parser [PreDefinedPart]
+predefinedP :: Parser PreDefinedParts
 predefinedP = do
     parts <- partsP
     pre <- predefinedPartsP parts
@@ -39,7 +40,7 @@ config cfg =
         Left _ ->
             Left "Could not parse config. Check that your format doesn't contain any invalid parts."
 
-predefined :: Text -> Either Text [PreDefinedPart]
+predefined :: Text -> Either Text PreDefinedParts
 predefined cfg =
     case parseOnly predefinedP cfg of
         Right c -> Right c

src/Cmt/Parser/Config/PreDefined.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Cmt.Parser.Config.PreDefined
     ( predefinedPartsP
@@ -15,28 +15,24 @@ import Cmt.Types.Config
 
 -- predefined
 value :: Name -> [Part] -> Parser Config
-value name parts
-  = lexeme (char '"' *> takeTill (== '"') <* char '"')
-  >>= getConfig
+value name parts = lexeme (char '"' *> takeTill (== '"') <* char '"') >>= getConfig
   where
     getConfig :: Text -> Parser Config
     getConfig template =
-      case parseOnly (formatP $ partName <$> parts) template of
-        Left _ -> fail $ "Invalid predefined template: " ++ show name
-        Right fmt -> pure $ Config (filterParts fmt parts) fmt
-
+        case parseOnly (formatP $ partName <$> parts) template of
+            Left _    -> fail $ "Invalid predefined template: " ++ show name
+            Right fmt -> pure $ Config (filterParts fmt parts) fmt
     filterParts :: [FormatPart] -> [Part] -> [Part]
-    filterParts fps =
-      filter ((`elem` catMaybes (formatName <$> fps)) . partName)
+    filterParts fps = filter ((`elem` catMaybes (formatName <$> fps)) . partName)
 
 partP :: [Part] -> Parser PreDefinedPart
-partP ps = stripComments $ do
-  name <- (pack <$> many' letter <* lexeme (char '='))
-  conf <- stripComments (value name ps)
-  pure (name, conf)
+partP ps =
+    stripComments $ do
+        name <- pack <$> many' letter <* lexeme (char '=')
+        conf <- stripComments (value name ps)
+        pure (name, conf)
 
-predefinedPartsP :: [Part] -> Parser [PreDefinedPart]
+predefinedPartsP :: [Part] -> Parser PreDefinedParts
 predefinedPartsP ps =
-  option [] $
-    stripComments (char '{') *> many' (partP ps) <* stripComments (char '}')
-
+    mapFromList <$>
+    option [] (stripComments (char '{') *> many' (partP ps) <* stripComments (char '}'))

src/Cmt/Types/Config.hs

@@ -2,12 +2,17 @@
 
 module Cmt.Types.Config where
 
-import ClassyPrelude (Eq, Maybe (..), Show, Text)
+import ClassyPrelude   (Eq, Maybe (..), Show, Text)
+import Data.Map.Strict (Map)
 
 type Output = (Name, Text)
 
+type Outputs = Map Name Text
+
 type PreDefinedPart = (Text, Config)
 
+type PreDefinedParts = Map Text Config
+
 type Name = Text
 
 data FormatPart

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-13.8
+resolver: lts-13.13
 pvp-bounds: both
 packages:
 - .

test/Cmt/Parser/ConfigTest.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Cmt.Parser.ConfigTest where
@@ -50,27 +51,19 @@ pre = decodeUtf8 $(embedFile "test/data/.cmt-predefined")
 preWithVars :: Text
 preWithVars = decodeUtf8 $(embedFile "test/data/.cmt-predefined-with-vars")
 
-preConfig :: [PreDefinedPart]
+preConfig :: PreDefinedParts
 preConfig =
-    [ ("vb", Config [] [ Literal "chore (package.yaml): version bump"])
-    , ("readme", Config [] [ Literal "docs (README.md): updated readme"])
+    [ ("vb", Config [] [Literal "chore (package.yaml): version bump"])
+    , ("readme", Config [] [Literal "docs (README.md): updated readme"])
     ]
 
-preWithVarsConfig :: [PreDefinedPart]
+preWithVarsConfig :: PreDefinedParts
 preWithVarsConfig =
     [ ( "vb"
-      , Config
-          [ Part "Scope" Changed ]
-          [ Literal "chore (", Named "Scope", Literal "): version bump"]
-      )
+      , Config [Part "Scope" Changed] [Literal "chore (", Named "Scope", Literal "): version bump"])
     , ( "readme"
-      , Config
-          [ Part "Short Message" Line ]
-          [ Literal "docs (README.md): ", Named "Short Message" ]
-      )
-    , ( "multiline"
-      , Config [] [ Literal "This\nNow works # but comments are included\nI believe\n"]
-      )
+      , Config [Part "Short Message" Line] [Literal "docs (README.md): ", Named "Short Message"])
+    , ("multiline", Config [] [Literal "This\nNow works # but comments are included\nI believe\n"])
     ]
 
 -- import Test.Tasty.HUnit
@@ -97,15 +90,12 @@ test_config =
                     (assertEqual "Gives back correct format" (Right []) (predefined comments))
               , testCase
                     "predefined"
+                    (assertEqual "Gives back correct format" (Right preConfig) (predefined pre))
+              , testCase
+                    "predefined with variables"
                     (assertEqual
                          "Gives back correct format"
-                         (Right preConfig)
-                         (predefined pre))
-              , testCase
-                     "predefined with variables"
-                     (assertEqual
-                          "Gives back correct format"
-                          (Right preWithVarsConfig)
-                          (predefined preWithVars))
-               ]
+                         (Right preWithVarsConfig)
+                         (predefined preWithVars))
+              ]
         ]