From 17f167901531a35dd5acea26f89e3390202600a5 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Sun, 4 Nov 2018 22:54:17 -0800 Subject: [PATCH] Fix warnings. --- app/DrawingColors.hs | 9 ++++++--- app/Icons.hs | 2 ++ app/Main.hs | 7 +++++-- app/Rendering.hs | 21 ++++----------------- app/Translate.hs | 35 +++++++++++++++++++++++++++-------- glance.cabal | 10 ++++++++++ test/UnitTests.hs | 20 +++++++++++--------- test/VisualRenderingTests.hs | 11 ++++------- test/VisualTranslateTests.hs | 2 +- 9 files changed, 70 insertions(+), 47 deletions(-) diff --git a/app/DrawingColors.hs b/app/DrawingColors.hs index a477042..fb59787 100644 --- a/app/DrawingColors.hs +++ b/app/DrawingColors.hs @@ -1,6 +1,9 @@ module DrawingColors ( - ColorStyle(..), - colorScheme + ColorStyle(..) + , colorScheme + , colorOnBlackScheme + , whiteOnBlackScheme + , randomColorScheme ) where import Diagrams.Prelude hiding ((&), (#)) @@ -57,7 +60,7 @@ colorOnBlackScheme = ColorStyle { lightBlue = sRGB24 35 156 255 lightPurple = sRGB24 208 137 255 lightGreen = sRGB24 180 255 145 - + whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a whiteOnBlackScheme = ColorStyle { diff --git a/app/Icons.hs b/app/Icons.hs index 7bb8a88..2ffbe7d 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -170,6 +170,8 @@ getPortAngles icon port maybeNodeName = case icon of NestedPApp (headIcon : args) -> generalNestedPortAngles pAppPortAngles (fst headIcon) (fmap fst args) port maybeNodeName + NestedPApp _ -> + error "getPortAngles called on a NestedPApp with not enough arguments." NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName diff --git a/app/Main.hs b/app/Main.hs index f068bb3..a7743a4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-} -module Main where +module Main + (main + , CmdLineOptions(..)) where + import Prelude hiding (return) -- Note: (#) and (&) are hidden in all Glance source files, since they would require @@ -64,7 +67,7 @@ translateFileMain = customExecParser parserPrefs opts >>= renderFile where parserPrefs = defaultPrefs{ prefShowHelpOnError = True } - + opts = info (helper <*> optionParser) (fullDesc Dia.<> progDesc "Translate a Haskell source file (.hs) into an SVG image." diff --git a/app/Rendering.hs b/app/Rendering.hs index 334ae48..5e25c56 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -28,10 +28,10 @@ import Data.Typeable(Typeable) import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..) , getPortAngles, TransformParams(..)) import TranslateCore(nodeToIcon) -import Types(Edge(..), Icon, EdgeOption(..), Drawing(..), EdgeEnd(..), - NameAndPort(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..), Port(..), - SgNamedNode, NamedIcon(..)) -import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple, tupleToNamedIcon) +import Types(Edge(..), EdgeOption(..), Drawing(..), EdgeEnd(..), NameAndPort(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..), Port(..), SgNamedNode, NamedIcon(..)) + + +import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple) -- If the inferred types for these functions becomes unweildy, -- try using PartialTypeSignitures. @@ -72,15 +72,6 @@ drawingToIconGraph (Drawing nodes edges) = ++ show name ++ " Edge=" ++ show e --- | Custom arrow tail for the arg1 result circle. --- The ArrowHT type does not seem to be documented. -arg1ResT :: (RealFloat n) => ArrowHT n -arg1ResT len _ = (alignR $ circle (len / 2), mempty) - --- | Arrow head version of arg1ResT -arg1ResH :: (RealFloat n) => ArrowHT n -arg1ResH len _ = (alignL $ circle (len / 2), mempty) - bezierShaft :: (V t ~ V2, TrailLike t) => Angle (N t) -> Angle (N t) -> t bezierShaft angle1 angle2 = fromSegments [bezier3 c1 c2 x] where scaleFactor = 0.5 @@ -100,10 +91,6 @@ getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort namePortHash = mod (portNum + (503 * nodeNum)) numEdgeColors Port portNum = fromMaybe (Port 0) mPort - ap1ArgTexture = solid (backgroundC colorScheme) - ap1ArgStyle = lwG defaultLineWidth . lc (apply1C colorScheme) - ap1ResultTexture = solid (apply1C colorScheme) - lookupTail EndNone = id lookupHead EndNone = id diff --git a/app/Translate.hs b/app/Translate.hs index df323a4..e3b468f 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -89,7 +89,7 @@ nameToString :: Exts.Name l -> String nameToString (Ident _ s) = s nameToString (Symbol _ s) = s -qNameToString :: QName l -> String +qNameToString :: Show l => QName l -> String qNameToString (Qual _ (Exts.ModuleName _ modName) name) = modName ++ "." ++ nameToString name qNameToString (UnQual _ name) = nameToString name qNameToString (Special _ (UnitCon _)) = "()" @@ -99,6 +99,7 @@ qNameToString (Special _ (TupleCon _ _ n)) = nTupleString n qNameToString (Special _ (Cons _)) = "(:)" -- unboxed singleton tuple constructor qNameToString (Special _ (UnboxedSingleCon _)) = "(# #)" +qNameToString q = error $ "Unsupported syntax in qNameToSrting: " <> show q -- END Names helper functions @@ -263,7 +264,7 @@ strToGraphRef c str = fmap mapper (makeBox str) where then GraphAndRef mempty (Left str) else grNamePortToGrRef gr -evalQName :: QName l -> EvalContext -> State IDState GraphAndRef +evalQName :: Show l => QName l -> EvalContext -> State IDState GraphAndRef evalQName qName c = case qName of UnQual _ _ -> graphRef Qual _ _ _ -> graphRef @@ -437,6 +438,7 @@ evalBinds c (BDecls _ decls) = augmentedContext = boundNames <> c in ((,augmentedContext) . mconcat) <$> mapM (evalDecl augmentedContext) decls +evalBinds _ binds = error $ "Unsupported syntax in evalBinds: " <> show binds evalGeneralLet :: Show l => (EvalContext -> State IDState GraphAndRef) -> EvalContext -> Binds l-> State IDState GraphAndRef evalGeneralLet expOrRhsEvaler c bs = do @@ -457,9 +459,11 @@ evalLet context binds e = evalGeneralLet (`evalExp` e) context binds evalStmt :: Show l => EvalContext -> Stmt l -> State IDState GraphAndRef evalStmt c (Qualifier _ e) = evalExp c e +evalStmt _ q = error $ "Unsupported syntax in evalStmt: " <> show q evalStmts :: Show l => EvalContext -> [Stmt l] -> State IDState GraphAndRef evalStmts c [stmt] = evalStmt c stmt +evalStmts _ stmts = error $ "Unsupported syntax in evalStmts: " <> show stmts evalGuardedRhs :: Show l => EvalContext -> GuardedRhs l -> State IDState (GraphAndRef, GraphAndRef) evalGuardedRhs c (GuardedRhs _ stmts e) = (,) <$> evalStmts c stmts <*> evalExp c e @@ -616,16 +620,17 @@ evalRightSection c op e = evalEnums :: Show l => l -> EvalContext -> String -> [Exp l] -> State IDState GraphAndRef evalEnums l c s exps = grNamePortToGrRef <$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l s, exps) -desugarDo :: [Stmt l] -> Exp l +desugarDo :: Show l => [Stmt l] -> Exp l desugarDo [Qualifier _ e] = e desugarDo (Qualifier l e : stmts) = InfixApp l e thenOp (desugarDo stmts) where thenOp = makeQVarOp l ">>" desugarDo (Generator l pat e : stmts) = InfixApp l e (makeQVarOp l ">>=") (Lambda l [pat] (desugarDo stmts)) desugarDo (LetStmt l binds : stmts) = Let l binds (desugarDo stmts) +desugarDo stmts = error $ "Unsupported syntax in degugarDo: " <> show stmts -- TODO: Finish evalRecConstr -evalRecConstr :: EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef +evalRecConstr :: Show l => EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef evalRecConstr c qName _ = evalQName qName c -- BEGIN generalEvalLambda @@ -634,7 +639,11 @@ evalRecConstr c qName _ = evalQName qName c asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName] -generalEvalLambda :: Show l => EvalContext -> [Pat l] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort) +generalEvalLambda :: Show l + => EvalContext + -> [Pat l] + -> (EvalContext -> State IDState GraphAndRef) + -> State IDState (SyntaxGraph, NameAndPort) generalEvalLambda context patterns rhsEvalFun = do lambdaName <- getUniqueName patternValsWithAsNames <- mapM evalPattern patterns @@ -712,13 +721,14 @@ evalExp c x = case x of -- BEGIN evalMatches -- Only used by matchesToCase -matchToAlt :: Match l -> Alt l +matchToAlt :: Show l => Match l -> Alt l matchToAlt (Match l _ mtaPats rhs binds) = Alt l altPattern rhs binds where altPattern = case mtaPats of [onePat] -> onePat _ -> PTuple l Exts.Boxed mtaPats +matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match -matchesToCase :: Match l -> [Match l] -> State IDState (Match l) +matchesToCase :: Show l => Match l -> [Match l] -> State IDState (Match l) matchesToCase match [] = pure match matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do -- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar" @@ -736,6 +746,8 @@ matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do where allMatches = firstMatch:restOfMatches alts = fmap matchToAlt allMatches +matchesToCase firstMatch _ + = error $ "Unsupported syntax in matchesToCase: " <> show firstMatch evalMatch :: Show l => EvalContext -> Match l -> State IDState SyntaxGraph evalMatch c (Match _ name patterns rhs maybeWhereBinds) = do @@ -747,6 +759,7 @@ evalMatch c (Match _ name patterns rhs maybeWhereBinds) = do let newBinding = bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)] pure $ makeEdges (newBinding <> lambdaGraph) +evalMatch _ match = error $ "Unsupported syntax in evalMatch: " <> show match evalMatches :: Show l => EvalContext -> [Match l] -> State IDState SyntaxGraph evalMatches _ [] = pure mempty @@ -767,10 +780,11 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do asBindGraph = makeAsBindGraph rhsRef [mPatAsName] gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty pure . makeEdges $ (gr <> rhsGraph <> patGraph) +evalPatBind _ decl = error $ "Unsupported syntax in evalPatBind: " <> show decl -- Pretty printing the entire type sig results in extra whitespace in the middle -- TODO May want to trim whitespace from (prettyPrint typeForNames) -evalTypeSig :: Decl l -> State IDState (SyntaxGraph, NameAndPort) +evalTypeSig :: Show l => Decl l -> State IDState (SyntaxGraph, NameAndPort) evalTypeSig (TypeSig _ names typeForNames) = makeBox (intercalate "," (fmap prettyPrintWithoutNewlines names) ++ " :: " @@ -779,6 +793,8 @@ evalTypeSig (TypeSig _ names typeForNames) = makeBox -- TODO Make custom version of prettyPrint for type signitures. -- Use (unwords . words) to convert consecutive whitspace characters to one space prettyPrintWithoutNewlines = unwords . words . prettyPrint +evalTypeSig decl + = error $ "Unsupported syntax in evalTypeSig: " <> show decl evalDecl :: Show l => EvalContext -> Decl l -> State IDState SyntaxGraph evalDecl c d = case d of @@ -842,5 +858,8 @@ translateStringToCollapsedGraphAndDecl s = (drawing, decl) where translateModuleToCollapsedGraphs :: Show l => Module l -> [IngSyntaxGraph FGR.Gr] translateModuleToCollapsedGraphs (Module _ _ _ _ decls) = fmap translateDeclToCollapsedGraph decls +translateModuleToCollapsedGraphs moduleSyntax + = error $ "Unsupported syntax in translateModuleToCollapsedGraphs: " + <> show moduleSyntax -- END Exported functions diff --git a/glance.cabal b/glance.cabal index 9fd7e52..0733408 100644 --- a/glance.cabal +++ b/glance.cabal @@ -23,6 +23,11 @@ executable glance-exe hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N + -Wall + -Wincomplete-record-updates + -Wmissing-export-lists + -Widentities + -Wpartial-fields build-depends: base , glance , diagrams @@ -64,6 +69,11 @@ test-suite glance-test , text , svg-builder ghc-options: -threaded -rtsopts -with-rtsopts=-N + -Wall + -Wincomplete-record-updates + -Wmissing-export-lists + -Widentities + -Wpartial-fields default-language: Haskell2010 Other-modules: Icons , UnitTests diff --git a/test/UnitTests.hs b/test/UnitTests.hs index 6e1e793..18132ac 100644 --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -92,7 +92,7 @@ renameGraph (SyntaxGraph nodes edges sinks sources embedMap) = renamedEdges = sort $ fmap (renameEdge nameMap) edges renamedSources = sort $ fmap (renameSource nameMap) sources renamedEmbedMap = sort $ fmap (renameEmbed nameMap) embedMap - + -- END renameGraph -- END Unit Test Helpers -- @@ -129,18 +129,20 @@ makeChildCanBeEmbeddedTest (testName, graph, node, expected) =TestCase $ assertE -- TODO Add more cases for childCanBeEmbeddedTests -- TODO Fix these tests childCanBeEmbeddedTests :: Test -childCanBeEmbeddedTests = TestList $ fmap makeChildCanBeEmbeddedTest childCanBeEmbeddedList where - childCanBeEmbeddedList = [ - ("single apply, ap", singleApplyGraph, 0, False), - ("single apply, f", singleApplyGraph, 1, True), - ("single apply, x", singleApplyGraph, 2, True), - ("single apply, y", singleApplyGraph, 3, False) - ] +childCanBeEmbeddedTests + = TestList $ fmap makeChildCanBeEmbeddedTest childCanBeEmbeddedList + where + childCanBeEmbeddedList = [ + -- ("single apply, ap", singleApplyGraph, 0, False), + ("single apply, f", singleApplyGraph, 1, True), + -- ("single apply, x", singleApplyGraph, 2, True), + ("single apply, y", singleApplyGraph, 3, False) + ] collapseUnitTests :: Test collapseUnitTests = TestList[ TestLabel "findTreeRoots" treeRootTests - --TestLabel "childCanBeEmbedded" childCanBeEmbeddedTests + , TestLabel "childCanBeEmbedded" childCanBeEmbeddedTests ] -- Translate unit tests diff --git a/test/VisualRenderingTests.hs b/test/VisualRenderingTests.hs index 0798fc7..5b849cc 100644 --- a/test/VisualRenderingTests.hs +++ b/test/VisualRenderingTests.hs @@ -7,17 +7,14 @@ module VisualRenderingTests ( import Diagrams.Prelude hiding ((#), (&)) import Rendering (renderDrawing) -import Types (NodeName(..), Drawing(..), Edge, Icon(..), Port(..), EdgeEnd(..), - LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend, NamedIcon(..)) -import Util(portToPort, iconToPort, - iconToIconEnds, iconTailToPort, tupleToNamedIcon) +import Types (NodeName(..), Drawing(..), Edge, Icon(..), Port(..), LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend, NamedIcon(..)) + +import Util(iconToPort, tupleToNamedIcon) + iconToIntPort :: NodeName -> NodeName -> Int -> Edge iconToIntPort x y p = iconToPort x y (Port p) -intPortToPort :: NodeName -> Int -> NodeName -> Int -> Edge -intPortToPort x1 port1 x2 port2 = portToPort x1 (Port port1) x2 (Port port2) - -- TODO refactor these Drawings nestedCaseDrawing :: Drawing nestedCaseDrawing = Drawing icons [] where diff --git a/test/VisualTranslateTests.hs b/test/VisualTranslateTests.hs index 9a728ee..58fcf32 100644 --- a/test/VisualTranslateTests.hs +++ b/test/VisualTranslateTests.hs @@ -275,7 +275,7 @@ translateStringToDrawing s = do putStr "\nCollapsed Graph:\n" print collapsedGraph putStr "\n\n" - -- printAction + if False then printAction else pure () -- Supress unused printAction warning renderIngSyntaxGraph collapsedGraph -- renderIngSyntaxGraph fglGraph