diff --git a/registry.cabal b/registry.cabal --- a/registry.cabal +++ b/registry.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: f62fea26e4a94d61ae114fa4ed0dc7b12a90b5696c293f12cfea0ad413302ad3 +-- hash: 2d9c064c60106be14a1e61ac45b2d6250d4a76f9b3b436402edf91e00e107f04 name: registry -version: 0.1.9.0 +version: 0.1.9.1 synopsis: data structure for assembling components description: This library provides a "Registry" which is a data structure containing a list of functions and values representing dependencies in a directed acyclic graph. A `make` function can then be used to create a value of a specific type out of the registry. You can start with the [README](https://github.com/etorreborre/registry/blob/master/README.md) for a full description of the library. @@ -47,8 +47,8 @@ Paths_registry hs-source-dirs: src - default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns + default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -fwrite-ide-info -hiedir=.hie -Wincomplete-uni-patterns build-depends: base >=4.7 && <5 , containers >=0.5 && <0.7 @@ -104,8 +104,8 @@ Paths_registry hs-source-dirs: test - default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -optP-Wno-nonportable-include-path + default-extensions: BangPatterns DefaultSignatures EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms Rank2Types RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -optP-Wno-nonportable-include-path -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -optP-Wno-nonportable-include-path build-depends: MonadRandom <0.6 , async <2.3 diff --git a/src/Data/Registry/Internal/Dot.hs b/src/Data/Registry/Internal/Dot.hs --- a/src/Data/Registry/Internal/Dot.hs +++ b/src/Data/Registry/Internal/Dot.hs @@ -96,8 +96,9 @@ case lookup key valuesByType of Nothing -> Nothing -- this case should not happen given how the map is built Just hashes -> - if P.length hashes == 1 then Nothing - else (+1) <$> elemIndex valueHash hashes + case hashes of + [_] -> Nothing + _ -> (+1) <$> elemIndex valueHash hashes in adjust (nodeDescription (valDescription value) valueCounter) diff --git a/src/Data/Registry/Internal/Make.hs b/src/Data/Registry/Internal/Make.hs --- a/src/Data/Registry/Internal/Make.hs +++ b/src/Data/Registry/Internal/Make.hs @@ -2,11 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {- | @@ -108,11 +106,11 @@ makeInputs _ [] _ _ _ _ = pure [] makeInputs function (i : ins) c@(Context context) functions specializations modifiers = - if i `elem` (contextTypes c) + if i `elem` contextTypes c then lift $ Left $ toS - $ unlines + $ T.unlines $ ["cycle detected! The current types being built are "] <> (show <$> context) <> ["But we are trying to build again " <> show i] diff --git a/src/Data/Registry/Internal/Reflection.hs b/src/Data/Registry/Internal/Reflection.hs --- a/src/Data/Registry/Internal/Reflection.hs +++ b/src/Data/Registry/Internal/Reflection.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeInType #-} @@ -24,7 +23,7 @@ isFunction d = case d of SomeTypeRep (Fun _ _) -> True - _ -> False + _other -> False -- | Show the full type of a typeable value showFullValueType :: Typeable a => a -> Text @@ -49,7 +48,7 @@ App t1 t2 -> showNested (SomeTypeRep t1) (SomeTypeRep t2) - _ -> + _other -> showSingleType (SomeTypeRep a) -- | Show the full type of a typeable value @@ -70,7 +69,7 @@ App t1 t2 -> ([], showNested (SomeTypeRep t1) (SomeTypeRep t2)) - _ -> + _other -> ([], showSingleType (SomeTypeRep a)) -- | Show a type like @m a@ @@ -117,7 +116,7 @@ parenthesizeNested t = case T.splitOn " " t of [] -> t - [_] -> t + [_head] -> t [outer, inner] -> outer <> " " <> inner outer : rest -> outer <> " (" <> parenthesizeNested (T.intercalate " " rest) <> ")" diff --git a/src/Data/Registry/TH.hs b/src/Data/Registry/TH.hs --- a/src/Data/Registry/TH.hs +++ b/src/Data/Registry/TH.hs @@ -173,8 +173,8 @@ else reportErrorWith $ "We can only check the coverage of a Registry, got: " <> actual - _ -> - reportErrorWith $ "We can only check the coverage of a Registry. Use `checked = $(checkRegistry 'registry), Got: " <> show registryType + other -> + reportErrorWith $ "We can only check the coverage of a Registry. Use `checked = $(checkRegistry 'registry), Got: " <> show other other -> reportErrorWith $ "We can only check the coverage of a Registry. Use `checked = $(checkRegistry 'registry). Got: " <> show other diff --git a/test/Test/Data/Registry/THSpec.hs b/test/Test/Data/Registry/THSpec.hs --- a/test/Test/Data/Registry/THSpec.hs +++ b/test/Test/Data/Registry/THSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} + {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/test/Test/Tasty/Extensions.hs b/test/Test/Tasty/Extensions.hs --- a/test/Test/Tasty/Extensions.hs +++ b/test/Test/Tasty/Extensions.hs @@ -27,7 +27,6 @@ , withSeed ) where -import Data.Maybe (fromJust) import Data.MultiMap import GHC.Stack import Hedgehog as Hedgehog hiding (test) @@ -68,7 +67,10 @@ noShrink = localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit))) withSeed :: Prelude.String -> TestTree -> TestTree -withSeed seed = localOption (fromJust (parseValue seed :: Maybe HedgehogReplay)) +withSeed seed tree = + case parseValue seed of + Nothing -> prop ("cannot parse seed " <> seed) failure + Just (s :: HedgehogReplay) -> localOption s tree -- * GROUPING @@ -105,7 +107,7 @@ getModuleName = case getCallStack callStack of ((_, loc):_) -> srcLocModule loc - _ -> "root" + _other -> "root" -- | Option describing the current module name newtype ModuleName = ModuleName Text deriving (Eq, Show) diff --git a/test/Test/Tutorial/Application.hs b/test/Test/Tutorial/Application.hs --- a/test/Test/Tutorial/Application.hs +++ b/test/Test/Tutorial/Application.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE StrictData #-} + module Test.Tutorial.Application where import qualified Data.ByteString.Char8 as BS8