From e12242886fdfa3541def848968c57af876792432 Mon Sep 17 00:00:00 2001 From: Akos Marton Date: Sat, 9 Nov 2019 20:49:07 +0100 Subject: [PATCH] Increasing compiler warning level and resolving potential warnings. (#66) * Resolve ghc warnings and applying stylish-haskell. --- Setup.hs | 2 +- app/Main.hs | 8 ++-- erd.cabal | 6 +-- src/Erd/Config.hs | 10 ++--- src/Erd/ER.hs | 57 ++++++++++++++--------------- src/Erd/Parse.hs | 32 ++++++++-------- src/Text/Parsec/Erd/Parser.hs | 53 +++++++++++++-------------- test/Test/Erd/Render.hs | 1 - test/Test/Text/Parsec/Erd/Parser.hs | 44 ++++++++++++---------- 9 files changed, 103 insertions(+), 110 deletions(-) diff --git a/Setup.hs b/Setup.hs index 9a994af..4467109 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/app/Main.hs b/app/Main.hs index cce373f..681a625 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -34,10 +34,10 @@ main = do Left err -> do hPutStrLn stderr err exitFailure - Right er -> let dotted = dotER conf er + Right er -> let erDot = dotER conf er toFile h = SB.hGetContents h >>= SB.hPut (snd $ cout conf) fmt = fromMaybe Pdf (outfmt conf) - in graphvizWithHandle Dot dotted fmt toFile + in graphvizWithHandle Dot erDot fmt toFile hClose (snd $ cin conf) hClose (snd $ cout conf) @@ -71,9 +71,9 @@ htmlEntity e = H.Table H.HTable } where rows = headerRow : map htmlAttr (attribs e) headerRow = H.Cells [H.LabelCell [] $ H.Text text] - text = withLabelFmt " [%s]" (hoptions e) $ bold hname + text = withLabelFmt " [%s]" (hoptions e) $ boldFont hname hname = htmlFont (hoptions e) (name e) - bold s = [H.Format H.Bold s] + boldFont s = [H.Format H.Bold s] -- | Extracts and formats a graph title from the options given. -- The options should be title options from an ER value. diff --git a/erd.cabal b/erd.cabal index 7a39f37..733ba5f 100644 --- a/erd.cabal +++ b/erd.cabal @@ -75,7 +75,7 @@ executable erd Erd.Render Text.Parsec.Erd.Parser main-is: Main.hs - ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind + ghc-options: -Wall -W build-depends: base >= 4.5 && <5 , directory >= 1.3.3.0 , filepath >= 1.4.2.1 @@ -87,13 +87,11 @@ executable erd , yaml >= 0.11.0.0 , raw-strings-qq >= 1.1 - - test-suite spec default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Spec.hs - ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind + ghc-options: -Wall -W hs-source-dirs: test, src other-modules: diff --git a/src/Erd/Config.hs b/src/Erd/Config.hs index 17b6cf9..0434058 100644 --- a/src/Erd/Config.hs +++ b/src/Erd/Config.hs @@ -120,7 +120,7 @@ opts = (O.ReqArg (\fpath cIO -> do c <- cIO i <- openFile fpath ReadMode - return $ c { cin = (fpath, i) } + return $ c {cin = (fpath, i)} ) "FILE") ("When set, input will be read from the given file.\n" @@ -129,7 +129,7 @@ opts = (O.ReqArg (\fpath cIO -> do c <- cIO o <- openFile fpath WriteMode - return $ c { cout = (fpath, o) } + return $ c {cout = (fpath, o)} ) "FILE") ("When set, output will be written to the given file.\n" @@ -147,8 +147,7 @@ opts = Nothing -> do ef "'%s' is not a valid output format." fmt exitFailure - Just gfmt -> - return $ c { outfmt = Just gfmt } + Just gfmt -> return c {outfmt = Just gfmt} ) "FMT") (printf "Force the output format to one of:\n%s" @@ -161,8 +160,7 @@ opts = Nothing -> do ef "'%s' is not a valid type of edge." edge exitFailure - Just edgeType -> do - return $ c { edgeType = Just edgeType } + Just x -> return c {edgeType = Just x} ) "EDGE") (printf "Select one type of edge:\n%s" diff --git a/src/Erd/ER.hs b/src/Erd/ER.hs index d5549b6..10160a1 100644 --- a/src/Erd/ER.hs +++ b/src/Erd/ER.hs @@ -10,41 +10,38 @@ module Erd.ER ) where -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import Data.Text.Lazy -import Data.Word (Word8) -import Text.Printf (printf) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Data.Text.Lazy +import Data.Word (Word8) +import Text.Printf (printf) -import Data.GraphViz.Parsing (ParseDot, parse, runParser) -import qualified Data.GraphViz.Attributes.HTML as H -import Data.GraphViz.Attributes.Colors (Color) +import Data.GraphViz.Attributes.Colors (Color) +import qualified Data.GraphViz.Attributes.HTML as H +import Data.GraphViz.Parsing (ParseDot, parse, runParser) -- | Represents a single schema. data ER = ER { entities :: [Entity] - , rels :: [Relation] - , title :: Options - } - deriving (Show, Eq) + , rels :: [Relation] + , title :: Options + } deriving (Show, Eq) -- | Represents a single entity in a schema. -data Entity = Entity { name :: Text - , attribs :: [Attribute] +data Entity = Entity { name :: Text + , attribs :: [Attribute] , hoptions :: Options , eoptions :: Options - } - deriving (Show, Eq) + } deriving (Show, Eq) instance Ord Entity where e1 `compare` e2 = name e1 `compare` name e2 -- | Represents a single attribute in a particular entity. -data Attribute = Attribute { field :: Text - , pk :: Bool - , fk :: Bool +data Attribute = Attribute { field :: Text + , pk :: Bool + , fk :: Bool , aoptions :: Options - } - deriving (Show, Eq) + } deriving (Show, Eq) instance Ord Attribute where a1 `compare` a2 = field a1 `compare` field a2 @@ -105,15 +102,15 @@ optionParse :: ParseDot a => (a -> Option) -> String -> Either String Option optionParse con s = case fst $ runParser parse quoted of Left err -> Left (printf "%s (bad value '%s')" err s) - Right a -> Right (con a) + Right a -> Right (con a) where quoted = "\"" `append` pack s `append` "\"" -- | Selects an option if and only if it corresponds to a font attribute. optToFont :: Option -> Maybe H.Attribute -optToFont (Color c) = Just $ H.Color c +optToFont (Color c) = Just $ H.Color c optToFont (FontFace s) = Just $ H.Face s optToFont (FontSize d) = Just $ H.PointSize d -optToFont _ = Nothing +optToFont _ = Nothing -- | Selects an option if and only if it corresponds to an HTML attribute. -- In particular, for tables or table cells. @@ -131,7 +128,7 @@ optToHtml _ = Nothing -- | Selects an option if and only if it corresponds to a label. optToLabel :: Option -> Maybe Text optToLabel (Label s) = Just $ pack s -optToLabel _ = Nothing +optToLabel _ = Nothing -- | Represents a relationship between exactly two entities. After parsing, -- each `rel` is guaranteed to correspond to an entity defined in the same @@ -141,7 +138,7 @@ optToLabel _ = Nothing -- Those cardinalities are: 0 or 1, exactly 1, 0 or more and 1 or more. data Relation = Relation { entity1, entity2 :: Text , card1, card2 :: Cardinality - , roptions :: Options + , roptions :: Options } deriving (Show, Eq) @@ -151,10 +148,10 @@ data Cardinality = ZeroOne | OnePlus deriving (Eq) instance Show Cardinality where - show ZeroOne = "{0,1}" - show One = "1" + show ZeroOne = "{0,1}" + show One = "1" show ZeroPlus = "0..N" - show OnePlus ="1..N" + show OnePlus = "1..N" -- | Maps a string representation to a particular relationship cardinality. cardByName :: Char -> Maybe Cardinality @@ -162,7 +159,7 @@ cardByName '?' = Just ZeroOne cardByName '1' = Just One cardByName '*' = Just ZeroPlus cardByName '+' = Just OnePlus -cardByName _ = Nothing +cardByName _ = Nothing -- | Hard-coded default options for all graph titles. defaultTitleOpts :: Options diff --git a/src/Erd/Parse.hs b/src/Erd/Parse.hs index 2c77755..ba68850 100644 --- a/src/Erd/Parse.hs +++ b/src/Erd/Parse.hs @@ -4,25 +4,25 @@ module Erd.Parse ) where -import Control.Monad (when) -import Data.List (find) -import Data.Maybe -import Data.Text.Lazy hiding (find, map, reverse) -import Data.Text.Lazy.IO -import System.IO (Handle) -import Text.Parsec -import Text.Printf (printf) -import Text.Parsec.Erd.Parser (AST(..), GlobalOptions(..), document) +import Erd.ER -import Erd.ER +import Control.Monad (when) +import Data.List (find) +import Data.Maybe +import Data.Text.Lazy hiding (find, map, reverse) +import Data.Text.Lazy.IO +import System.IO (Handle) +import Text.Parsec +import Text.Parsec.Erd.Parser (AST (..), GlobalOptions (..), document) +import Text.Printf (printf) loadER :: String -> Handle -> IO (Either String ER) loadER fpath f = do s <- hGetContents f case parse (do { (opts, ast) <- document; return $ toER opts ast}) fpath s of - Left err -> return $ Left $ show err + Left err -> return $ Left $ show err Right err@(Left _) -> return err - Right (Right er) -> return $ Right er + Right (Right er) -> return $ Right er -- | Converts a list of syntactic categories in an entity-relationship -- description to an ER representation. If there was a problem with the @@ -32,14 +32,14 @@ loadER fpath f = do -- This preserves the ordering of the syntactic elements in the original -- description. toER :: GlobalOptions -> [AST] -> Either String ER -toER gopts = toER' (ER [] [] title) - where title = gtoptions gopts `mergeOpts` defaultTitleOpts +toER gopts = toER' (ER [] [] erTitle) + where erTitle = gtoptions gopts `mergeOpts` defaultTitleOpts toER' :: ER -> [AST] -> Either String ER toER' er [] = Right (reversed er) >>= validRels toER' ER { entities = [] } (A a:_) = - let name = show (field a) - in Left $ printf "Attribute '%s' comes before first entity." name + let fieldName = show (field a) + in Left $ printf "Attribute '%s' comes before first entity." fieldName toER' er@ER { entities = e':es } (A a:xs) = do let e = e' { attribs = a:attribs e' } toER' (er { entities = e:es }) xs diff --git a/src/Text/Parsec/Erd/Parser.hs b/src/Text/Parsec/Erd/Parser.hs index 2b87a93..adb3f09 100644 --- a/src/Text/Parsec/Erd/Parser.hs +++ b/src/Text/Parsec/Erd/Parser.hs @@ -1,28 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} + module Text.Parsec.Erd.Parser - ( - AST(..), + ( AST(..), GlobalOptions(..), document, globalOptions, entity, rel, attr, - comment, - ) -where - -import Control.Monad (liftM2, when, void) -import Data.Char (isAlphaNum, isSpace, isControl) -import qualified Data.GraphViz.Attributes.HTML as H -import qualified Data.Map as M -import Data.Maybe -import Data.Text.Lazy -import Text.Parsec -import Text.Parsec.Text.Lazy -import Text.Printf (printf) - -import Erd.ER + comment + ) where + +import Erd.ER + +import Control.Monad (liftM2, void, when) +import Data.Char (isAlphaNum, isControl, isSpace) +import qualified Data.Map as M +import Data.Maybe +import Data.Text.Lazy +import Text.Parsec +import Text.Parsec.Text.Lazy +import Text.Printf (printf) data AST = E Entity | A Attribute @@ -68,18 +66,17 @@ attr = do eolComment return $ Just - $ A Attribute { field = n, pk = ispk, fk = isfk, aoptions = opts <> defaultAttrOpts} + $ A Attribute {field = n, pk = ispk, fk = isfk, aoptions = opts <> defaultAttrOpts} rel :: Parser (Maybe AST) rel = do let ops = "?1*+" e1 <- ident op1 <- oneOf ops - string "--" + _ <- string "--" op2 <- oneOf ops e2 <- ident opts <- options - let getCard op = case cardByName op of Just t -> return t @@ -87,12 +84,12 @@ rel = do t1 <- getCard op1 t2 <- getCard op2 return $ Just $ R Relation { entity1 = e1, entity2 = e2 - , card1 = t1, card2 = t2, roptions = opts } + , card1 = t1, card2 = t2, roptions = opts } globalOptions :: GlobalOptions -> Parser GlobalOptions globalOptions gopts = option gopts $ try $ do - n <- ident + n <- ident opts <- options case n of "title" -> emptiness >> globalOptions (gopts { gtoptions = opts}) @@ -111,19 +108,19 @@ options = opt :: Parser (String, Option) opt = do - name <- liftM2 (:) letter (manyTill (letter <|> char '-') (char ':')) + optName <- liftM2 (:) letter (manyTill (letter <|> char '-') (char ':')) "option name" emptiness value <- between (char '"') (char '"') (many $ noneOf "\"") "option value" - case optionByName name value of + case optionByName optName value of Left err -> fail err - Right o' -> emptiness >> return (name, o') + Right o' -> emptiness >> return (optName, o') comment :: Parser (Maybe AST) comment = do - char '#' - manyTill anyChar $ try eol + _ <- char '#' + _ <- manyTill anyChar $ try eol return Nothing ident :: Parser Text @@ -139,7 +136,7 @@ identQuoted = do let p = satisfy (\c -> c /= quote && not (isControl c) ) "any character except " ++ [quote] ++ " or control characters" n <- fmap pack (many1 p) - char quote + _ <- char quote return n identNoSpace :: Parser Text diff --git a/test/Test/Erd/Render.hs b/test/Test/Erd/Render.hs index 42bee4f..9a422d3 100644 --- a/test/Test/Erd/Render.hs +++ b/test/Test/Erd/Render.hs @@ -8,7 +8,6 @@ import qualified Erd.ER as ER import Erd.Render (htmlAttr) import qualified Data.GraphViz.Attributes.HTML as H -import qualified Data.Map as M import Test.Tasty import Test.Tasty.HUnit diff --git a/test/Test/Text/Parsec/Erd/Parser.hs b/test/Test/Text/Parsec/Erd/Parser.hs index 9d51033..48a2b00 100644 --- a/test/Test/Text/Parsec/Erd/Parser.hs +++ b/test/Test/Text/Parsec/Erd/Parser.hs @@ -1,20 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} + module Test.Text.Parsec.Erd.Parser - (testEr) - where -import Test.Tasty -import Test.Tasty.HUnit -import Text.RawString.QQ (r) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Text.Parsec (parse) -import qualified Data.GraphViz.Attributes.HTML as H -import qualified Data.Map as M -import Data.Map (fromList) -import Erd.ER -import Text.Parsec.Erd.Parser (document, AST(..), GlobalOptions(..)) -import Data.GraphViz.Attributes.Colors (Color(..)) + (testEr + ) where + +import Data.GraphViz.Attributes.Colors (Color (..)) +import qualified Data.GraphViz.Attributes.HTML as H +import Data.Map (fromList) +import qualified Data.Map as M +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Erd.ER +import Test.Tasty +import Test.Tasty.HUnit +import Text.Parsec (parse) +import Text.Parsec.Erd.Parser (AST (..), GlobalOptions (..), + document) +import Text.RawString.QQ (r) parseDoc :: Text -> (GlobalOptions, [AST]) -> Assertion parseDoc input expect= Right expect `shouldBe` parse document "" (fromStrict input) where @@ -166,7 +169,9 @@ player 1--* play_player |] -data ChunckAST = CE [Entity] | CA [Attribute] | CR [Relation] deriving (Eq) +data ChunckAST = CE [Entity] | CA [Attribute] | CR [Relation] + deriving (Eq) + toAST :: ChunckAST -> [AST] toAST (CE x) = map E x toAST (CA x) = map A x @@ -175,8 +180,8 @@ toAST (CR x) = map R x nfldbResult :: (GlobalOptions, [AST]) nfldbResult = (opts, asts) where opts = GlobalOptions {gtoptions = fromList [("label",Label "nfldb Entity-Relationship diagram (condensed)"),("size",FontSize 20.0)], ghoptions = fromList [], geoptions = fromList [], groptions = fromList []} - asts = concatMap toAST $ entities:(attributes ++ [relations]) - entities = CE [ + asts = concatMap toAST $ es:(attributes ++ [relations]) + es = CE [ Entity {name = "player", attribs = [], hoptions = fromList [("bgcolor",BgColor (RGB {red = 208, green = 224, blue = 208}))], eoptions = fromList [("bgcolor",BgColor (RGB {red = 208, green = 224, blue = 208}))] @@ -272,5 +277,4 @@ nfldbResult = (opts, asts) where Relation {entity1 = "drive", entity2 = "play", card1 = One, card2 = ZeroPlus, roptions = fromList []}, Relation {entity1 = "drive", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []}, Relation {entity1 = "play", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []}, - Relation {entity1 = "player", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []} - ] + Relation {entity1 = "player", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []} ]