mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
use assertions instead of errors, minor linting
This commit is contained in:
parent
1e4bb4bddc
commit
ab3a12c983
|
@ -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
|
||||
|
|
20
src/app/MetaBrush/Assert.hs
Normal file
20
src/app/MetaBrush/Assert.hs
Normal 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
|
|
@ -4,8 +4,6 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module MetaBrush.Asset.Brushes where
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -8,7 +8,6 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,7 +1,5 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE EmptyCase #-}
|
||||
|
|
|
@ -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 #-}
|
||||
|
|
|
@ -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 )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,10 +1,8 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE EmptyCase #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
|
|
@ -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 ) )
|
||||
|
|
|
@ -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
|
||||
}
|
||||
)
|
||||
|
|
|
@ -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 ) )
|
||||
|
|
|
@ -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 #-}
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue