From ab3a12c983b0f753a9d77a0f6a5bda214109af74 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 15 Nov 2020 04:27:13 +0100 Subject: [PATCH] use assertions instead of errors, minor linting --- MetaBrush.cabal | 10 ++++++ src/app/MetaBrush/Assert.hs | 20 +++++++++++ src/app/MetaBrush/Asset/Brushes.hs | 2 -- src/app/MetaBrush/Asset/CloseTabButton.hs | 4 +-- src/app/MetaBrush/Document.hs | 1 - src/app/MetaBrush/Document/Draw.hs | 5 ++- src/app/MetaBrush/Document/Serialise.hs | 17 +++++---- src/app/MetaBrush/MetaParameter/AST.hs | 2 -- src/app/MetaBrush/MetaParameter/Eval.hs | 3 -- .../MetaBrush/MetaParameter/Interpolation.hs | 13 +------ src/app/MetaBrush/MetaParameter/Parse.hs | 3 +- src/app/MetaBrush/MetaParameter/Rename.hs | 2 -- src/app/MetaBrush/MetaParameter/TypeCheck.hs | 6 ++-- src/app/MetaBrush/Render/Document.hs | 7 ++-- src/app/MetaBrush/Unique.hs | 2 +- src/lib/Math/Bezier/Spline.hs | 2 -- src/lib/Math/Bezier/Stroke.hs | 36 +++++++++---------- 17 files changed, 74 insertions(+), 61 deletions(-) create mode 100644 src/app/MetaBrush/Assert.hs diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 89bd6fe..00faba1 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -23,6 +23,11 @@ description: The shape of the brush is allowed to vary along the path. +flag asserts + description: Enable debugging assertions. + default: False + manual: True + common common build-depends: @@ -122,6 +127,7 @@ executable MetaBrush , MetaBrush.Asset.TickBox , MetaBrush.Asset.Tools , MetaBrush.Asset.WindowIcons + , MetaBrush.Assert , MetaBrush.Brush , MetaBrush.Context , MetaBrush.Document @@ -160,6 +166,10 @@ executable MetaBrush ghc-options: -threaded -rtsopts + if flag(asserts) + cpp-options: + -DASSERTS + build-depends: MetaBrush , atomic-file-ops diff --git a/src/app/MetaBrush/Assert.hs b/src/app/MetaBrush/Assert.hs new file mode 100644 index 0000000..f059e2d --- /dev/null +++ b/src/app/MetaBrush/Assert.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} + +module MetaBrush.Assert + ( assert ) + where + +-- base +#ifdef ASSERTS +import Control.Exception + ( AssertionFailed(..), throw ) +#endif + +-------------------------------------------------------------------------------- + +assert :: String -> a -> a +#ifdef ASSERTS +assert message _ = throw ( AssertionFailed message ) +#else +assert _ a = a +#endif diff --git a/src/app/MetaBrush/Asset/Brushes.hs b/src/app/MetaBrush/Asset/Brushes.hs index f71792b..8645368 100644 --- a/src/app/MetaBrush/Asset/Brushes.hs +++ b/src/app/MetaBrush/Asset/Brushes.hs @@ -4,8 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} module MetaBrush.Asset.Brushes where diff --git a/src/app/MetaBrush/Asset/CloseTabButton.hs b/src/app/MetaBrush/Asset/CloseTabButton.hs index 83af930..758db21 100644 --- a/src/app/MetaBrush/Asset/CloseTabButton.hs +++ b/src/app/MetaBrush/Asset/CloseTabButton.hs @@ -59,8 +59,8 @@ drawCloseTabButton ( Colours {..} ) unsavedChanges flags = do pure True where hover, clicked :: Bool - hover = any ( == GTK.StateFlagsPrelight ) flags - clicked = any ( == GTK.StateFlagsActive ) flags + hover = GTK.StateFlagsPrelight `elem` flags + clicked = GTK.StateFlagsActive `elem` flags drawCross :: Cairo.Render () drawCross = do diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 5a0f708..940535c 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -8,7 +8,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index b692d02..56baa20 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -65,6 +65,8 @@ import Math.Module ( squaredNorm ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) +import MetaBrush.Assert + ( assert ) import MetaBrush.Brush ( BrushReference(NoBrush) ) import MetaBrush.Document @@ -205,7 +207,8 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) ) in prevSpline <> fmap setBrushData newSpline | otherwise - = error "addToAnchor: trying to add to a closed spline" + = assert ( "addToAnchor: trying to add to closed spline " <> show strokeUnique ) + prevSpline -- should never add to a closed spline in overStrokeSpline updateSpline stroke | otherwise diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 4cab9a2..6edf25d 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -176,6 +176,8 @@ import Math.Bezier.Stroke ( CachedStroke(..) ) import Math.Vector2D ( Point2D(..), Vector2D(..), Segment ) +import MetaBrush.Assert + ( assert ) import MetaBrush.Brush ( Brush(..), BrushReference(..), newBrushReference , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups @@ -656,14 +658,17 @@ encodeStroke brushes = JSON.Encoder.mapLikeObj mbEncodeBrush = case strokeBrushRef of BrushReference ( _ :: Proxy# brushFields1 ) unique -> case Map.lookup unique brushes of - Nothing -> error ( "encodeStroke: no brush with unique " <> show unique <> "in environment" ) + Nothing -> + assert ( "encodeStroke: no brush with unique " <> show unique <> "in environment" ) + id Just ( brush@BrushData { brushName, brushFunction = ( _ :: BrushFunction brushFields2 ) } ) -> case eqTys @brushFields1 @brushFields2 of - Nothing -> error - ( "encodeStroke: brush '" <> Text.unpack brushName <> "' has unexpected field types.\n\ - \Expected: " <> show ( sTypesI @brushFields1 ) <> "\n\ - \ Actual: " <> show ( sTypesI @brushFields2 ) - ) + Nothing -> + assert ( "encodeStroke: brush '" <> Text.unpack brushName <> "' has unexpected field types.\n\ + \Expected: " <> show ( sTypesI @brushFields1 ) <> "\n\ + \ Actual: " <> show ( sTypesI @brushFields2 ) + ) + id Just Refl -> JSON.Encoder.atKey' "brush" encodeBrush brush NoBrush -> id in diff --git a/src/app/MetaBrush/MetaParameter/AST.hs b/src/app/MetaBrush/MetaParameter/AST.hs index a1703ee..4fa5b83 100644 --- a/src/app/MetaBrush/MetaParameter/AST.hs +++ b/src/app/MetaBrush/MetaParameter/AST.hs @@ -1,7 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyCase #-} diff --git a/src/app/MetaBrush/MetaParameter/Eval.hs b/src/app/MetaBrush/MetaParameter/Eval.hs index 3170b49..9a65952 100644 --- a/src/app/MetaBrush/MetaParameter/Eval.hs +++ b/src/app/MetaBrush/MetaParameter/Eval.hs @@ -6,12 +6,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/app/MetaBrush/MetaParameter/Interpolation.hs b/src/app/MetaBrush/MetaParameter/Interpolation.hs index 8495547..0c4b182 100644 --- a/src/app/MetaBrush/MetaParameter/Interpolation.hs +++ b/src/app/MetaBrush/MetaParameter/Interpolation.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,23 +23,15 @@ import Data.Functor.Identity ( Identity(..) ) import Data.Kind ( Type ) -import Data.List - ( intercalate ) import Data.Monoid ( Sum ) -import GHC.Exts - ( Proxy#, proxy# ) import GHC.TypeLits - ( Symbol, KnownSymbol, symbolVal' ) + ( Symbol ) -- acts import Data.Act ( Act(..), Torsor(..) ) --- deepseq -import Control.DeepSeq - ( NFData ) - -- groups import Data.Group ( Group(..) ) @@ -60,8 +51,6 @@ import Math.Module ( Module(..) ) import Math.Vector2D ( Point2D, Vector2D ) -import MetaBrush.MetaParameter.AST - ( STypeI(..), STypesI ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/MetaParameter/Parse.hs b/src/app/MetaBrush/MetaParameter/Parse.hs index 944f58c..f4fd0e0 100644 --- a/src/app/MetaBrush/MetaParameter/Parse.hs +++ b/src/app/MetaBrush/MetaParameter/Parse.hs @@ -391,9 +391,8 @@ orientation :: Token -> Orientation orientation ( TokAlphabetic ori ) | Text.map Char.toLower ori == "ccw" = CCW - | Text.map Char.toLower ori == "cw" +orientation _ = CW -orientation tok = error ( "orientation: unexpected token " <> show tok ) curveTo :: forall clo r diff --git a/src/app/MetaBrush/MetaParameter/Rename.hs b/src/app/MetaBrush/MetaParameter/Rename.hs index 4eea648..e79de88 100644 --- a/src/app/MetaBrush/MetaParameter/Rename.hs +++ b/src/app/MetaBrush/MetaParameter/Rename.hs @@ -1,10 +1,8 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/app/MetaBrush/MetaParameter/TypeCheck.hs b/src/app/MetaBrush/MetaParameter/TypeCheck.hs index b1ebe4a..e18a688 100644 --- a/src/app/MetaBrush/MetaParameter/TypeCheck.hs +++ b/src/app/MetaBrush/MetaParameter/TypeCheck.hs @@ -34,9 +34,9 @@ import Data.Either import Data.Functor.Compose ( Compose(..) ) import Data.List - ( sortBy ) + ( sortOn ) import Data.Ord - ( comparing ) + ( Down(..) ) import Data.Proxy ( Proxy ) import Data.Type.Equality @@ -305,7 +305,7 @@ withDeclsRecord decls f = do -- as these would have been caught by the renamer. -- Sort in reverse order as we must add elements in decreasing label order. revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ] - revSortDecls = fmap ( sortBy ( flip $ comparing fst ) ) . traverse getDeclName + revSortDecls = fmap ( sortOn ( Down . fst ) ) . traverse getDeclName getDeclName :: Decl Tc -> m ( Text, ( UniqueName, TypedTerm ) ) getDeclName ( Decl ( Located loc _ ) pat term ) = case pat of PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, ( uniq, TypedTerm term ) ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 01a678b..99109af 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -12,6 +12,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -135,7 +136,7 @@ import MetaBrush.MetaParameter.Interpolation import MetaBrush.UI.ToolBar ( Mode(..) ) import MetaBrush.Unique - ( Unique ) + ( Unique, unsafeUnique ) import MetaBrush.Util ( withRGBA ) @@ -238,8 +239,8 @@ renderDocument = ( ( Stroke { strokeSpline = previewSpline , strokeVisible = True - , strokeUnique = undefined - , strokeName = undefined + , strokeUnique = unsafeUnique 987654321 + , strokeName = "Preview stroke (temporary)" , strokeBrushRef = NoBrush } ) diff --git a/src/app/MetaBrush/Unique.hs b/src/app/MetaBrush/Unique.hs index e946703..2fab38f 100644 --- a/src/app/MetaBrush/Unique.hs +++ b/src/app/MetaBrush/Unique.hs @@ -103,7 +103,7 @@ class Monad m => MonadUnique m where instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where freshUnique = do - UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply ) <$> ask + UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply ) liftIO $ STM.atomically do uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) ) diff --git a/src/lib/Math/Bezier/Spline.hs b/src/lib/Math/Bezier/Spline.hs index cc06673..957aa64 100644 --- a/src/lib/Math/Bezier/Spline.hs +++ b/src/lib/Math/Bezier/Spline.hs @@ -8,7 +8,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -16,7 +15,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index dd74c22..b063fbc 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -1,20 +1,18 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Math.Bezier.Stroke ( Offset(..) @@ -489,8 +487,8 @@ joinWithBrush pcs :: Maybe ( SplinePts Open ) pcs = discardCurveData <$> dropCurves i1 openSpline in - fromMaybe empty - ( fst <$> ( splitFirstPiece t2 =<< snd <$> ( splitFirstPiece t1 =<< pcs ) ) ) + maybe empty fst + ( splitFirstPiece t2 . snd =<< ( splitFirstPiece t1 =<< pcs ) ) | otherwise = let start, middle, end :: SplinePts Open