diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,11 @@ Significant and compatibility-breaking changes. +Version 0.4.2: + - model.cabal: added upper bounds for dependencies + - Data.Model.Util: added error handling utilities + +Version 0.4.1: Cosmetic changes to documentation + Version 0.4: - Data.Model.Types: - Modified type of 'constructors' and 'constructorInfo' @@ -7,10 +13,10 @@ - Modified behaviour of conversion from String to QualName - Data.Model.Util: - modified type of 'mutualGroups' and 'transitiveClosure' + - added some error handling utilities Version 0.3: - Data.Model.Util: - - Removed 'dependencies' - - Added the (similar but not identical) function 'transitiveClosure' + - Removed 'dependencies', added (similar but not identical) 'transitiveClosure' diff --git a/model.cabal b/model.cabal --- a/model.cabal +++ b/model.cabal @@ -1,5 +1,5 @@ name: model -version: 0.4.1 +version: 0.4.2 synopsis: Derive a model of a data type using Generics description: See the . homepage: http://github.com/tittoassini/model @@ -29,11 +29,12 @@ , Data.Model.Util , Type.ANat,Type.Analyse build-depends: base >= 4.8 && < 5 - , containers >= 0.5.6.2 - , deepseq >= 1.4 - , pretty >= 1.1.2.0 - , transformers >= 0.4 - , convertible >= 1.1.1.0 + , containers == 0.5.* + , either > 4.3.2 && <5 + , deepseq == 1.4.* + , transformers >= 0.4.2.0 && < 0.6 + , pretty >= 1.1.2 && < 1.2 + , convertible == 1.1.* default-language: Haskell2010 other-extensions: DataKinds, DefaultSignatures, DeriveAnyClass, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction, OverloadedStrings, PolyKinds, ScopedTypeVariables, TupleSections, TypeFamilies, TypeOperators, UndecidableInstances ghc-options: -Wall -fno-warn-orphans @@ -43,14 +44,14 @@ hs-source-dirs: test main-is: Spec.hs other-modules: Test.Data,Test.Data2,Test.Data3,Test.Data.Model,Info - build-depends: base >= 4.8 && < 5 - , ghc-prim >= 0.3.1.0 - , tasty >= 0.11.0.2 - , tasty-hunit >= 0.9.2 - , tasty-quickcheck >=0.8.4 - , pretty >= 1.1.2.0 - , containers >= 0.5.6.2 + build-depends: base + , pretty + , containers , model + , ghc-prim + , tasty >= 0.11 && < 0.13 + , tasty-hunit >= 0.8 && < 0.10 + , tasty-quickcheck >=0.8.1 && < 0.9.2 default-language: Haskell2010 @@ -59,5 +60,5 @@ type: exitcode-stdio-1.0 ghc-options: -threaded main-is: DocSpec.hs - build-depends: base >4 && <5, doctest>=0.11.1, filemanip>=0.3.6.3 + build-depends: base, doctest>=0.11.1 && <0.14,filemanip>=0.3.6.3 && < 0.3.7 HS-Source-Dirs: test diff --git a/src/Data/Model/Types.hs b/src/Data/Model/Types.hs --- a/src/Data/Model/Types.hs +++ b/src/Data/Model/Types.hs @@ -34,12 +34,13 @@ import Control.Applicative import Control.DeepSeq -import Data.Bifunctor (first, second) -import qualified Data.Map as M +import Data.Bifunctor (first, second) +import Data.Either.Validation +import qualified Data.Map as M import Data.Maybe import Data.Model.Util import Data.Proxy -import Data.Word (Word8) +import Data.Word (Word8) import GHC.Generics -- |Haskell Environment @@ -270,28 +271,64 @@ data QualName = QualName {pkgName,mdlName,locName :: String} deriving (Eq, Ord, Show, NFData, Generic) --- |Return the qualified name, minus the package name. +{-|Return the qualified name, minus the package name. +>>> qualName (QualName {pkgName = "ab", mdlName = "cd.ef", locName = "gh"}) +"cd.ef.gh" + +-} qualName :: QualName -> String qualName n = convert $ n {pkgName=""} -instance Convertible String QualName where safeConvert = errorToConvertResult parseQualName +instance Convertible String QualName where safeConvert = errorsToConvertResult (validationToEither . asQualName) + instance Convertible QualName String where safeConvert n = Right $ dotted [pkgName n,mdlName n,locName n] --- |Parse the string as a QualName, if possible --- --- >>> parseQualName "ab.cd.ef.gh" --- Right (QualName {pkgName = "ab", mdlName = "cd.ef", locName = "gh"}) -parseQualName :: String -> Either String QualName -parseQualName "" = Left "Empty string" -parseQualName n = Right $ - let (p,r) = span (/= '.') n - in if null r - then QualName "" "" p - else let (l,r2) = span (/= '.') $ reverse $ tail r - in if null r2 - then QualName "" p (reverse l) - else let m = reverse $ tail r2 - in QualName p m (reverse l) +{-|Convert a String to a `QualName`, if possible + +>>> asQualName "ab.cd.ef.gh" +Success (QualName {pkgName = "ab", mdlName = "cd.ef", locName = "gh"}) + +>>> asQualName "ab.cd.ef" +Success (QualName {pkgName = "ab", mdlName = "cd", locName = "ef"}) + +>>> asQualName "ab.cd" +Success (QualName {pkgName = "", mdlName = "ab", locName = "cd"}) + +>>> asQualName "ab" +Success (QualName {pkgName = "", mdlName = "", locName = "ab"}) + +>>> asQualName "" +Failure ["Empty qualified name"] + +>>> asQualName "." +Failure ["Empty qualified name"] + +The conversion assumes that the input String is a well-formed Haskell fully qualified name. + +It will produce funny results if this is not the case: + +>>> asQualName "**.&&.!!" +Success (QualName {pkgName = "**", mdlName = "&&", locName = "!!"}) + +-} +asQualName :: String -> Validation Errors QualName +asQualName = + (\n -> + if nullQualName n + then Failure ["Empty qualified name"] + else Success n) . + asQualName_ + where + nullQualName n = pkgName n == "" && mdlName n == "" && locName n == "" + asQualName_ n = + let (p, r) = span (/= '.') n + in if null r + then QualName "" "" p + else let (l, r2) = span (/= '.') $ reverse $ tail r + in if null r2 + then QualName "" p (reverse l) + else let m = reverse $ tail r2 + in QualName p m (reverse l) -- |Simple name data Name = Name String deriving (Eq, Ord, Show, NFData, Generic) diff --git a/src/Data/Model/Util.hs b/src/Data/Model/Util.hs --- a/src/Data/Model/Util.hs +++ b/src/Data/Model/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} @@ -11,15 +12,18 @@ , Errors , toErrors , noErrors - -- * Convertible utilities - , Convertible(..) - , convert - , ConvertResult - , ConvertError(..) + , errsInContext + , inContext , errorToConvertResult , errorsToConvertResult , convertResultToError , convertResultToErrors + , convertOrError + -- * Convertible re-exports + , Convertible(..) + , convert + , ConvertResult + , ConvertError(..) -- * Formatting utilities , dotted ) where @@ -90,36 +94,52 @@ type Error = String --- |Either an error or a valid value --- type EitherError a = Either String a - --- |Either errors or a valid value --- type EitherErrors a = Either [String] a - -toErrors :: Either Error a -> Either Errors a +toErrors :: Bifunctor p => p a c -> p [a] c toErrors = first (:[]) noErrors :: Errors -> Bool noErrors = null -errorToConvertResult - :: (Typeable b, Typeable a, Show a) - => (a -> Either Error b) -> a -> ConvertResult b +errorToConvertResult :: (Typeable b, Typeable a, Show a) => (a -> Either Error b) -> a -> ConvertResult b errorToConvertResult conv a = either (\err -> convError err a) Right $ conv a -errorsToConvertResult - :: (Typeable b, Typeable a, Show a) - => (a -> Either Errors b) -> a -> ConvertResult b -errorsToConvertResult conv a = either (\errs -> convError (unwords errs) a) Right $ conv a +{-| +>>> errorsToConvertResult (const (Left ["Bad format","Invalid value"])) ".." :: ConvertResult Int +Left (ConvertError {convSourceValue = "\"..\"", convSourceType = "[Char]", convDestType = "Int", convErrorMessage = "Bad format, Invalid value"}) +-} +errorsToConvertResult :: (Typeable b, Typeable t, Show t) => (t -> Either Errors b) -> t -> ConvertResult b +errorsToConvertResult conv a = either (\errs -> convError (intercalate ", " errs) a) Right $ conv a -convertResultToError :: ConvertResult a -> Either Error a +{-| +>>> convertOrError 'a' :: Either Error Word +Right 97 + +>>> convertOrError (1E50::Double) :: Either Error Word +Left "Convertible: error converting source data 1.0e50 of type Double to type Word: Input value outside of bounds: (0,18446744073709551615)" +-} +convertOrError :: Convertible a c => a -> Either String c +convertOrError = convertResultToError . safeConvert + +convertResultToError :: Bifunctor p => p ConvertError c -> p String c convertResultToError = first prettyConvertError -convertResultToErrors :: ConvertResult a -> Either Errors a +convertResultToErrors :: Bifunctor p => p ConvertError c -> p [String] c convertResultToErrors = toErrors . convertResultToError instance Convertible String String where safeConvert = Right . id +-- |Prefix errors with a contextual note +errsInContext :: (Convertible ctx String, Bifunctor p) => ctx -> p [String] c -> p [String] c +errsInContext ctx = first (inContext ctx) + +{-|Prefix a list of strings with a contextual note + +>>> inContext "0/0" ["Zero denominator"] +["In 0/0: Zero denominator"] +-} +inContext :: Convertible ctx String => ctx -> [String] -> [String] +inContext ctx = map (\msg -> unwords ["In",convert ctx++":",msg]) + {-| Intercalate a dot between the non empty elements of a list of strings. >>> dotted [] @@ -138,3 +158,4 @@ dotted (h:t) = post h ++ dotted t where post s | null s = "" | otherwise = s ++ "." + diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # resolver: lts-6.35 #resolver: lts-7.24 -resolver: lts-9.11 +resolver: lts-9.12 #resolver: nightly-2017-10-30 packages: - '.' diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -51,7 +51,7 @@ namesTests :: TestTree namesTests = testGroup "QualName Tests" [ - tstErr "" "Empty string" + tstErr "" "Empty qualified name" ,tst "ab" $ QualName "" "" "ab" --,tstErr "a.b.c.d" "Too many components in qualified name 'a.b.c.d'" ,tst "ab.cd" $ QualName "" "ab" "cd"