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. The shape of the brush is allowed to vary along the path.
flag asserts
description: Enable debugging assertions.
default: False
manual: True
common common common common
build-depends: build-depends:
@ -122,6 +127,7 @@ executable MetaBrush
, MetaBrush.Asset.TickBox , MetaBrush.Asset.TickBox
, MetaBrush.Asset.Tools , MetaBrush.Asset.Tools
, MetaBrush.Asset.WindowIcons , MetaBrush.Asset.WindowIcons
, MetaBrush.Assert
, MetaBrush.Brush , MetaBrush.Brush
, MetaBrush.Context , MetaBrush.Context
, MetaBrush.Document , MetaBrush.Document
@ -160,6 +166,10 @@ executable MetaBrush
ghc-options: ghc-options:
-threaded -rtsopts -threaded -rtsopts
if flag(asserts)
cpp-options:
-DASSERTS
build-depends: build-depends:
MetaBrush MetaBrush
, atomic-file-ops , 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 OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Asset.Brushes where module MetaBrush.Asset.Brushes where

View file

@ -59,8 +59,8 @@ drawCloseTabButton ( Colours {..} ) unsavedChanges flags = do
pure True pure True
where where
hover, clicked :: Bool hover, clicked :: Bool
hover = any ( == GTK.StateFlagsPrelight ) flags hover = GTK.StateFlagsPrelight `elem` flags
clicked = any ( == GTK.StateFlagsActive ) flags clicked = GTK.StateFlagsActive `elem` flags
drawCross :: Cairo.Render () drawCross :: Cairo.Render ()
drawCross = do drawCross = do

View file

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

View file

@ -65,6 +65,8 @@ import Math.Module
( squaredNorm ) ( squaredNorm )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Assert
( assert )
import MetaBrush.Brush import MetaBrush.Brush
( BrushReference(NoBrush) ) ( BrushReference(NoBrush) )
import MetaBrush.Document import MetaBrush.Document
@ -205,7 +207,8 @@ addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strok
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) ) setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
in prevSpline <> fmap setBrushData newSpline in prevSpline <> fmap setBrushData newSpline
| otherwise | 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 in
overStrokeSpline updateSpline stroke overStrokeSpline updateSpline stroke
| otherwise | otherwise

View file

@ -176,6 +176,8 @@ import Math.Bezier.Stroke
( CachedStroke(..) ) ( CachedStroke(..) )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..), Segment ) ( Point2D(..), Vector2D(..), Segment )
import MetaBrush.Assert
( assert )
import MetaBrush.Brush import MetaBrush.Brush
( Brush(..), BrushReference(..), newBrushReference ( Brush(..), BrushReference(..), newBrushReference
, SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups
@ -656,14 +658,17 @@ encodeStroke brushes = JSON.Encoder.mapLikeObj
mbEncodeBrush = case strokeBrushRef of mbEncodeBrush = case strokeBrushRef of
BrushReference ( _ :: Proxy# brushFields1 ) unique -> BrushReference ( _ :: Proxy# brushFields1 ) unique ->
case Map.lookup unique brushes of 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 ) } ) -> Just ( brush@BrushData { brushName, brushFunction = ( _ :: BrushFunction brushFields2 ) } ) ->
case eqTys @brushFields1 @brushFields2 of case eqTys @brushFields1 @brushFields2 of
Nothing -> error Nothing ->
( "encodeStroke: brush '" <> Text.unpack brushName <> "' has unexpected field types.\n\ assert ( "encodeStroke: brush '" <> Text.unpack brushName <> "' has unexpected field types.\n\
\Expected: " <> show ( sTypesI @brushFields1 ) <> "\n\ \Expected: " <> show ( sTypesI @brushFields1 ) <> "\n\
\ Actual: " <> show ( sTypesI @brushFields2 ) \ Actual: " <> show ( sTypesI @brushFields2 )
) )
id
Just Refl -> JSON.Encoder.atKey' "brush" encodeBrush brush Just Refl -> JSON.Encoder.atKey' "brush" encodeBrush brush
NoBrush -> id NoBrush -> id
in in

View file

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

View file

@ -6,12 +6,9 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}

View file

@ -2,7 +2,6 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -24,23 +23,15 @@ import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.Kind import Data.Kind
( Type ) ( Type )
import Data.List
( intercalate )
import Data.Monoid import Data.Monoid
( Sum ) ( Sum )
import GHC.Exts
( Proxy#, proxy# )
import GHC.TypeLits import GHC.TypeLits
( Symbol, KnownSymbol, symbolVal' ) ( Symbol )
-- acts -- acts
import Data.Act import Data.Act
( Act(..), Torsor(..) ) ( Act(..), Torsor(..) )
-- deepseq
import Control.DeepSeq
( NFData )
-- groups -- groups
import Data.Group import Data.Group
( Group(..) ) ( Group(..) )
@ -60,8 +51,6 @@ import Math.Module
( Module(..) ) ( Module(..) )
import Math.Vector2D import Math.Vector2D
( Point2D, Vector2D ) ( Point2D, Vector2D )
import MetaBrush.MetaParameter.AST
( STypeI(..), STypesI )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -391,9 +391,8 @@ orientation :: Token -> Orientation
orientation ( TokAlphabetic ori ) orientation ( TokAlphabetic ori )
| Text.map Char.toLower ori == "ccw" | Text.map Char.toLower ori == "ccw"
= CCW = CCW
| Text.map Char.toLower ori == "cw" orientation _
= CW = CW
orientation tok = error ( "orientation: unexpected token " <> show tok )
curveTo curveTo
:: forall clo r :: forall clo r

View file

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

View file

@ -34,9 +34,9 @@ import Data.Either
import Data.Functor.Compose import Data.Functor.Compose
( Compose(..) ) ( Compose(..) )
import Data.List import Data.List
( sortBy ) ( sortOn )
import Data.Ord import Data.Ord
( comparing ) ( Down(..) )
import Data.Proxy import Data.Proxy
( Proxy ) ( Proxy )
import Data.Type.Equality import Data.Type.Equality
@ -305,7 +305,7 @@ withDeclsRecord decls f = do
-- as these would have been caught by the renamer. -- as these would have been caught by the renamer.
-- Sort in reverse order as we must add elements in decreasing label order. -- Sort in reverse order as we must add elements in decreasing label order.
revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ] 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 Tc -> m ( Text, ( UniqueName, TypedTerm ) )
getDeclName ( Decl ( Located loc _ ) pat term ) = case pat of getDeclName ( Decl ( Located loc _ ) pat term ) = case pat of
PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, ( uniq, TypedTerm term ) ) PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, ( uniq, TypedTerm term ) )

View file

@ -12,6 +12,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
@ -135,7 +136,7 @@ import MetaBrush.MetaParameter.Interpolation
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Mode(..) ) ( Mode(..) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique, unsafeUnique )
import MetaBrush.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
@ -238,8 +239,8 @@ renderDocument
= ( ( Stroke = ( ( Stroke
{ strokeSpline = previewSpline { strokeSpline = previewSpline
, strokeVisible = True , strokeVisible = True
, strokeUnique = undefined , strokeUnique = unsafeUnique 987654321
, strokeName = undefined , strokeName = "Preview stroke (temporary)"
, strokeBrushRef = NoBrush , 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 instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where
freshUnique = do freshUnique = do
UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply ) <$> ask UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply )
liftIO $ STM.atomically do liftIO $ STM.atomically do
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) ) STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )

View file

@ -8,7 +8,6 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE QuantifiedConstraints #-}
@ -16,7 +15,6 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}

View file

@ -8,12 +8,10 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Math.Bezier.Stroke module Math.Bezier.Stroke
@ -489,8 +487,8 @@ joinWithBrush
pcs :: Maybe ( SplinePts Open ) pcs :: Maybe ( SplinePts Open )
pcs = discardCurveData <$> dropCurves i1 openSpline pcs = discardCurveData <$> dropCurves i1 openSpline
in in
fromMaybe empty maybe empty fst
( fst <$> ( splitFirstPiece t2 =<< snd <$> ( splitFirstPiece t1 =<< pcs ) ) ) ( splitFirstPiece t2 . snd =<< ( splitFirstPiece t1 =<< pcs ) )
| otherwise | otherwise
= let = let
start, middle, end :: SplinePts Open start, middle, end :: SplinePts Open