diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index a5bc48e1f..ca7165132 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -292,15 +292,9 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m) -> m value liftNumeric2 t v1 v2 = send (LiftNumeric2 (Numeric2Function t) v1 v2 pure) -data NumericFunction = NumericFunction (forall a . Num a => a -> a) +newtype NumericFunction = NumericFunction { runNumericFunction :: forall a . Num a => a -> a } -runNumericFunction :: Num a => NumericFunction -> a -> a -runNumericFunction (NumericFunction f) a = f a - -data Numeric2Function = Numeric2Function (forall a b. Number a -> Number b -> SomeNumber) - -runNumeric2Function :: Numeric2Function -> Number a -> Number b -> SomeNumber -runNumeric2Function (Numeric2Function f) a b = f a b +newtype Numeric2Function = Numeric2Function { runNumeric2Function :: forall a b. Number a -> Number b -> SomeNumber } data Numeric value (m :: * -> *) k = Integer Integer (value -> m k) @@ -347,15 +341,9 @@ unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m) -> m value unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure) -data BitwiseFunction = BitwiseFunction (forall a . Bits a => a -> a) +newtype BitwiseFunction = BitwiseFunction { runBitwiseFunction :: forall a . Bits a => a -> a } -runBitwiseFunction :: Bits a => BitwiseFunction -> a -> a -runBitwiseFunction (BitwiseFunction f) a = f a - -data Bitwise2Function = Bitwise2Function (forall a . (Integral a, Bits a) => a -> a -> a) - -runBitwise2Function :: (Integral a, Bits a) => Bitwise2Function -> a -> a -> a -runBitwise2Function (Bitwise2Function f) a b = f a b +newtype Bitwise2Function = Bitwise2Function { runBitwise2Function :: forall a . (Integral a, Bits a) => a -> a -> a } data Bitwise value (m :: * -> *) k = CastToInteger value (value -> m k) diff --git a/src/Control/Carrier/Parse/Simple.hs b/src/Control/Carrier/Parse/Simple.hs index 4dc1d6243..12dc5dcbe 100644 --- a/src/Control/Carrier/Parse/Simple.hs +++ b/src/Control/Carrier/Parse/Simple.hs @@ -63,7 +63,7 @@ runParser timeout blob@Blob{..} parser = case parser of let term = cmarkParser blobSource in length term `seq` pure term -data ParseFailure = ParseFailure String +newtype ParseFailure = ParseFailure String deriving (Show, Typeable) instance Exception ParseFailure diff --git a/src/Data/Diff.hs b/src/Data/Diff.hs index 94c0d3999..80b09616d 100644 --- a/src/Data/Diff.hs +++ b/src/Data/Diff.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE DataKinds, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances #-} module Data.Diff ( Diff(..) , DiffF(..) @@ -76,7 +76,7 @@ merging = cata (\ (In ann syntax) -> mergeF (In (ann, ann) syntax)) diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))] -diffPatches = para $ \ diff -> case diff of +diffPatches = para $ \case Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap snd) (foldMap snd) patch Merge merge -> foldMap snd merge diff --git a/src/Data/ImportPath.hs b/src/Data/ImportPath.hs index 22f9201a2..2cbe895bc 100644 --- a/src/Data/ImportPath.hs +++ b/src/Data/ImportPath.hs @@ -19,7 +19,7 @@ data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: IsRelative importPath :: Text -> ImportPath importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathType path) where - pathType xs | not (T.null xs), T.head xs == '.' = Relative -- head call here is safe + pathType xs | not (T.null xs), fmap fst (T.uncons xs) == Just '.' = Relative -- head call here is safe | otherwise = NonRelative defaultAlias :: ImportPath -> Name diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 0c166d8f9..6eff484f5 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -216,9 +216,7 @@ instance Evaluatable Class where currentScope' <- currentScope superScopes <- for classSuperclasses $ \superclass -> do - name <- case declaredName superclass of - Just name -> pure name - Nothing -> gensym + name <- maybeM gensym (declaredName superclass) scope <- associatedScope (Declaration name) slot <- lookupSlot (Declaration name) superclassFrame <- scopedEnvironment =<< deref slot diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index d6b03188c..81c318c87 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -77,7 +77,7 @@ tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f ann ann -- ^ The diff to compute the table of contents for. -> [(Change, a)] -- ^ A list of entries for relevant changed nodes in the diff. -tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of +tableOfContentsBy selector = fromMaybe [] . cata (\case Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just [] Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of (Just a, Just entries) -> Just ((Changed, a) : entries) diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 3b7d702b3..e66361d6d 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -46,10 +46,10 @@ type DomainC term address value m -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module. evaluate :: ( Carrier outerSig outer , derefSig ~ (Deref value :+: allocatorSig) - , derefC ~ (DerefC address value allocatorC) + , derefC ~ DerefC address value allocatorC , Carrier derefSig derefC , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig) - , allocatorC ~ (AllocatorC address (ReaderC ModuleInfo outer)) + , allocatorC ~ AllocatorC address (ReaderC ModuleInfo outer) , Carrier allocatorSig allocatorC , Effect outerSig , Member Fresh outerSig diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index dee30b8ea..0292605cf 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, LambdaCase #-} +{-# LANGUAGE FunctionalDependencies #-} module Semantic.Api.Bridge ( APIBridge (..) , APIConvert (..) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 351296fbc..5ee650b0a 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, - ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} + ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.Task ( TaskC , Level(..) diff --git a/src/Serializing/SExpression/Precise.hs b/src/Serializing/SExpression/Precise.hs index ae2cf6b21..70238e405 100644 --- a/src/Serializing/SExpression/Precise.hs +++ b/src/Serializing/SExpression/Precise.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Serializing.SExpression.Precise ( serializeSExpression , ToSExpression(..) diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs index c5d8eb516..b90174df2 100644 --- a/src/Tags/Taggable.hs +++ b/src/Tags/Taggable.hs @@ -12,7 +12,7 @@ identify a new syntax as Taggable, you need to: constructor name of this syntax. -} -{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Tags.Taggable ( Tagger , Token(..) diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index ae2d22e2c..4b06f0855 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -57,12 +57,11 @@ contextualizing :: ( Member (State [ContextToken]) sig contextualizing source toKind = Streaming.mapMaybeM $ \case Enter x r -> Nothing <$ enterScope (x, r) Exit x r -> Nothing <$ exitScope (x, r) - Iden iden loc docsLiteralRange -> get @[ContextToken] >>= pure . \case - ((x, r):("Context", cr):_) | Just kind <- toKind x - -> Just $ Tag iden kind loc (firstLine (slice r)) (Just (slice cr)) - ((x, r):_) | Just kind <- toKind x - -> Just $ Tag iden kind loc (firstLine (slice r)) (slice <$> docsLiteralRange) - _ -> Nothing + Iden iden loc docsLiteralRange -> fmap go (get @[ContextToken]) where + go = \case + ((x, r):("Context", cr):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine (slice r)) (Just (slice cr)) + ((x, r):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine (slice r)) (slice <$> docsLiteralRange) + _ -> Nothing where slice = stripEnd . Source.toText . Source.slice source firstLine = T.take 180 . fst . breakOn "\n"