diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.3.0 +----- +* New implementation, forces use of Lift for the result, removes the unsafe + typeclass functions, and adds the option to add a custom error message. + 0.2.0.1 ------- * Turn examples into buildable tests, add readme, fix typos in documentation. diff --git a/ValidLiterals.hs b/ValidLiterals.hs --- a/ValidLiterals.hs +++ b/ValidLiterals.hs @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------- -- | -- Module : ValidLiterals --- Copyright : (C) 2015 Merijn Verstraaten +-- Copyright : (C) 2015-2019 Merijn Verstraaten -- License : BSD-style (see the file LICENSE) -- Maintainer : Merijn Verstraaten -- Stability : experimental @@ -32,26 +32,74 @@ -- This will check, at compile time, that the provided 'Integer' is, in fact, -- even and unwrap it from 'Maybe', avoiding the runtime check. ------------------------------------------------------------------------------- +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module ValidLiterals - ( Validate (fromLiteral) + ( Validate(..) + , ValidationFailure(..) , valid , validInteger , validRational , validString , validList + -- * Re-export from "Language.Haskell.TH.Syntax" + , Lift(..) ) where +import Control.Exception (Exception(displayException), throwIO) +import Data.Maybe (maybe) +import Data.Proxy (Proxy(Proxy)) +import Data.Typeable (Typeable) import Language.Haskell.TH.Syntax -import ValidLiterals.Class +-- | 'Exception' type for failed conversions. Useful for testing and more +-- gracefully handling compile time failures. +data ValidationFailure = ValidationFailure String deriving (Show, Typeable) +instance Exception ValidationFailure where + displayException (ValidationFailure s) = "Validation failure: " ++ s + +-- | Class for validated, compile-time, partial conversions from type 'a' to +-- 'b'. +class Validate a b where + -- | Converts 'a' values into validated 'b' values, 'Left' values are + -- reported in the compilation error. + fromLiteralWithError :: a -> Either String b + fromLiteralWithError = maybe (Left errMsg) Right . fromLiteral + where + errMsg = "An error occured during compile-time validation!" + + -- | Converts 'a' values into validated 'b' values, 'Nothing' values + -- produce a generic error message. Use 'fromLiteralWithError' for custom + -- error messages. + fromLiteral :: a -> Maybe b + fromLiteral = either (const Nothing) Just . fromLiteralWithError + + {-# MINIMAL fromLiteralWithError | fromLiteral #-} + + -- | Creates a Typed TH splice for the resulting 'b' values, useful for + -- avoiding the need for orphan 'Lift' instances and allowing complex + -- splices for types that can't be directly lifted. See the 'ByteString' + -- example module for an example. + liftResult :: Proxy a -> b -> Q (TExp b) + default liftResult :: Lift b => Proxy a -> b -> Q (TExp b) + liftResult _ val = [|| val ||] + -- | The core function of ValidLiterals, use this together with Typed Template -- Haskell splices to insert validated literals into your code. For example, if -- we assume @newtype ASCII = ASCII Char@ where @ASCII@ should only contain -- ASCII characters, we would write: -- +-- Polymorphic literals, such as numbers (or strings when @OverloadedStrings@ +-- is enabled) can result in ambiguous type errors with this function. Enabing +-- the @ExtendedDefaultRules@ extension will allow inputs to 'valid' to be +-- defaulted to 'Integer' or 'Double' allowing code to compile. A more robust +-- solution is to use the various explicitly defaulted functions in this +-- module, such as 'validInteger'. +-- -- @ -- {-\# LANGUAGE TemplateHaskell #-} -- @@ -60,10 +108,13 @@ -- x :: ASCII -- x = $$(valid \'c\') -- @ -valid :: Validate a b => a -> Q (TExp b) -valid input = case fromLiteral input of - Nothing -> fail "Invalid input used for type-safe validated literal!" - Just result -> spliceValid input result +valid :: forall a b . Validate a b => a -> Q (TExp b) +valid input = case fromLiteralWithError input of + Right result -> liftResult (Proxy :: Proxy a) result + Left err -> do + reportError $ unlines + [ "Invalid input used for type-safe validated literal!", err ] + runIO $ throwIO (ValidationFailure err) -- | Integer literals lead to obnoxious defaulting complaints by GHC, by -- using this function you can force the defaulting to 'Integer', silencing diff --git a/ValidLiterals/Class.hs b/ValidLiterals/Class.hs deleted file mode 100644 --- a/ValidLiterals/Class.hs +++ /dev/null @@ -1,66 +0,0 @@ -------------------------------------------------------------------------------- --- | --- Module : ValidLiterals --- Copyright : (C) 2015 Merijn Verstraaten --- License : BSD-style (see the file LICENSE) --- Maintainer : Merijn Verstraaten --- Stability : experimental --- Portability : portable --- --- __WARNING: For implementors of new 'Validate' instances only!__ --- --- This module exposes functions whose use is easily screwed up. Users of --- validated literals should use the interface exported by "ValidLiterals". --- This module only exists for implementers of new 'Validate' instances. -------------------------------------------------------------------------------- -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -module ValidLiterals.Class where - -import Data.Maybe -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- | Class for validated, compile-time, partial conversions from type 'a' to --- 'b'. -class Validate a b where - -- | Converts 'a' values into validated 'b' values - fromLiteral :: a -> Maybe b - - -- | __WARNING: Don't use! For implementors of 'Validate' instances only!__ - -- - -- Produces the actual Typed Template Haskell splice for the validated - -- value to splice into the source text. Since you may want to implement a - -- 'Validate' instance for types that cannot have 'Lift' instances, this - -- function receives __both__ the original 'a' value and the resulting 'b' - -- as input. - -- - -- This allows it to either: - -- - -- 1. Splice the resulting 'b' into the source using it's Lift - -- instance, or a custom splice. - -- 2. Splice the initial 'a' into the source using it's Lift instance, - -- and perform the conversion again at runtime, and coercing via, - -- e.g., 'fromJust'. Since 'fromLiteral' is pure (right?!) this should - -- be perfectly safe. - -- - -- Clearly, splicing the result directly is much safer (it avoids any - -- shenanigans with 'unsafePerformIO') and more efficient (no conversion at - -- runtime). However, this is just not always possible, since, for example, - -- @ByteString@ does not have a 'Lift' instance and we may still want to - -- have validated newtypes of @ByteString@. - -- - -- __Default implementation:__ The default implementation (using - -- DefaultSignatures) uses 'b''s 'Lift' instance to do the efficient thing - -- of directly splicing the resulting 'b' into the source. - spliceValid :: a -> b -> Q (TExp b) - default spliceValid :: Lift b => a -> b -> Q (TExp b) - spliceValid _ v = [|| v ||] - --- | Default implementation for 'spliceValid', uses the 'Lift' instance for 'a' --- and 'fromJust' to redo the conversion at runtime and (unsafely) coerce from --- 'Maybe b' to 'b'. . Since 'fromLiteral' is pure (right?!) this should be --- perfectly safe. -hackySpliceValid :: (Lift a, Validate a b) => a -> b -> Q (TExp b) -hackySpliceValid v _ = [|| fromJust (fromLiteral v) ||] diff --git a/examples/ByteString.hs b/examples/ByteString.hs --- a/examples/ByteString.hs +++ b/examples/ByteString.hs @@ -1,15 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} module ByteString (ByteString) where import Data.ByteString.Char8 (ByteString, pack) +import qualified Data.ByteString as BS import Data.Char +import Language.Haskell.TH.Syntax -import ValidLiterals.Class +import ValidLiterals instance Validate String ByteString where - fromLiteral s - | all ((<=255) . ord) s = Just $ pack s - | otherwise = Nothing + fromLiteralWithError s = case nonAsciiVals of + [] -> Right $ pack s + _ -> Left $ "Found non-ASCII values: " ++ show nonAsciiVals + where + nonAsciiVals = filter (not . (<=255) . ord) s - spliceValid = hackySpliceValid + liftResult _ v = unsafeTExpCoerce $ + AppE <$> [| BS.pack |] <*> lift (BS.unpack v) diff --git a/examples/Even.hs b/examples/Even.hs --- a/examples/Even.hs +++ b/examples/Even.hs @@ -1,20 +1,20 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} module Even where import Control.DeepSeq (NFData) import GHC.Generics (Generic) -import ValidLiterals.Class +import ValidLiterals -newtype Even = Even Integer deriving (Show, Generic) +newtype Even = Even Integer deriving (Show, Generic, Lift) instance NFData Even instance Integral a => Validate a Even where - fromLiteral i - | even i = Just . Even $ fromIntegral i - | otherwise = Nothing - - spliceValid _ (Even i) = [|| Even i ||] + fromLiteralWithError i + | even i = Right . Even $ integer + | otherwise = Left $ show integer ++ " is not even!" + where + integer = fromIntegral i diff --git a/examples/Examples.hs b/examples/Examples.hs --- a/examples/Examples.hs +++ b/examples/Examples.hs @@ -3,11 +3,10 @@ import Control.DeepSeq (NFData, force) import Control.Exception - (SomeException(SomeException), bracket_, displayException, evaluate, try) + (Exception(..), SomeException(..), bracket_, evaluate, try) import GHC.IO.Handle (hDuplicate, hDuplicateTo) import Language.Haskell.TH (Q, TExp, runQ) import System.IO (IOMode(WriteMode), stderr, hFlush, withFile) -import System.IO.Error (isUserError) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase) import Test.Tasty.Travis @@ -46,7 +45,7 @@ result <- try . withRedirectedStderr $ runQ thExpr case result of Right _ -> assertFailure "TH didn't fail!" - Left e | isUserError e -> return () + Left e | Just ValidationFailure{} <- fromException e -> return () | otherwise -> assertFailure "Unexpected TH failure!" allTests :: TestTree diff --git a/validated-literals.cabal b/validated-literals.cabal --- a/validated-literals.cabal +++ b/validated-literals.cabal @@ -1,21 +1,20 @@ -Name: validated-literals -Version: 0.2.0.1 +Name: validated-literals +Version: 0.3.0 -Homepage: https://github.com/merijn/validated-literals -Bug-Reports: https://github.com/merijn/validated-literals/issues +Homepage: https://github.com/merijn/validated-literals +Bug-Reports: https://github.com/merijn/validated-literals/issues -Author: Merijn Verstraaten -Maintainer: Merijn Verstraaten -Copyright: Copyright © 2015-2018 Merijn Verstraaten +Author: Merijn Verstraaten +Maintainer: Merijn Verstraaten +Copyright: Copyright © 2015-2018 Merijn Verstraaten -License: BSD3 -License-File: LICENSE +License: BSD3 +License-File: LICENSE -Category: Data -Cabal-Version: >= 1.10 -Build-Type: Simple -Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, - GHC == 8.6.1 +Category: Data +Cabal-Version: >= 1.10 +Build-Type: Simple +Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 Synopsis: Compile-time checking for partial smart-constructors @@ -51,15 +50,13 @@ Default-Language: Haskell2010 GHC-Options: -Wall - Default-Extensions: Other-Extensions: DefaultSignatures, FlexibleContexts, - MultiParamTypeClasses, TemplateHaskell + MultiParamTypeClasses, ScopedTypeVariables, + TemplateHaskell Exposed-Modules: ValidLiterals - ValidLiterals.Class - Other-Modules: - Build-Depends: base >=4.8 && <4.12 + Build-Depends: base >= 4.9 && < 4.13 , template-haskell Test-Suite examples @@ -70,12 +67,13 @@ Even GHC-Options: -Wall -fno-warn-unused-do-bind - Other-Extensions: TemplateHaskell + Other-Extensions: DeriveGeneric, DeriveLift, FlexibleInstances, + MultiParamTypeClasses, TemplateHaskell Hs-Source-Dirs: examples Build-Depends: base , bytestring == 0.10.* , deepseq == 1.4.* - , tasty >= 0.11 && < 1.1 + , tasty >= 0.11 && < 1.2 , tasty-hunit == 0.9.* , tasty-travis >= 0.2 && < 0.3 , template-haskell