use assertions instead of errors, minor linting

This commit is contained in:
sheaf 2020-11-15 04:27:13 +01:00
parent 1e4bb4bddc
commit ab3a12c983
17 changed files with 74 additions and 61 deletions

View file

@ -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

View file

@ -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

View file

@ -4,8 +4,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Asset.Brushes where

View file

@ -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

View file

@ -8,7 +8,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

View file

@ -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

View file

@ -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

View file

@ -1,7 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}

View file

@ -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 #-}

View file

@ -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 )
--------------------------------------------------------------------------------

View file

@ -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

View file

@ -1,10 +1,8 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

View file

@ -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 ) )

View file

@ -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
}
)

View file

@ -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 ) )

View file

@ -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 #-}

View file

@ -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