use assertions instead of errors, minor linting

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

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

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
 

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
+      hover   = GTK.StateFlagsPrelight `elem` flags
-      clicked = any ( == GTK.StateFlagsActive   ) flags
+      clicked = GTK.StateFlagsActive   `elem` flags
 
 drawCross :: Cairo.Render ()
 drawCross = do

src/app/MetaBrush/Document.hs

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

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

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
+                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
         NoBrush -> id
     in

src/app/MetaBrush/MetaParameter/AST.hs

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

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

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

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

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

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

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
+               , strokeUnique   = unsafeUnique 987654321
-               , strokeName     = undefined
+               , strokeName     = "Preview stroke (temporary)"
                , strokeBrushRef = NoBrush
                }
             )

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

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

src/lib/Math/Bezier/Stroke.hs

@@ -1,20 +1,18 @@
-{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE BlockArguments      #-}
-{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveAnyClass      #-}
-{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE DeriveTraversable   #-}
-{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DerivingStrategies  #-}
-{-# 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 TypeApplications    #-}
-{-# LANGUAGE TupleSections              #-}
-{-# LANGUAGE TypeApplications           #-}
 
 module Math.Bezier.Stroke
   ( Offset(..)
@@ -489,8 +487,8 @@ joinWithBrush
         pcs :: Maybe ( SplinePts Open )
         pcs = discardCurveData <$> dropCurves i1 openSpline
       in
-        fromMaybe empty
+        maybe empty fst
-          ( fst <$> ( splitFirstPiece t2 =<< snd <$> ( splitFirstPiece t1 =<< pcs ) ) )
+          ( splitFirstPiece t2 . snd =<< ( splitFirstPiece t1 =<< pcs ) )
     | otherwise
     = let
         start, middle, end :: SplinePts Open