-------------------------------------------------------------------------------
-- |
-- Module      :  ValidLiterals
-- Copyright   :  (C) 2015-2021 Merijn Verstraaten
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Merijn Verstraaten <merijn@inconsistent.nl>
-- Stability   :  experimental
-- Portability :  portable
--
-- To disallow invalid input it is common to define (new)types with hidden
-- data constructors. Forcing the user to go through a smart-constructor that
-- enforces invariants and returns @Maybe ResultType@, preventing the
-- construction of data with invalid values.
--
-- However, it is __also__ common to want to include literal values of such
-- types in source text. Things of textual literals for HTML, HTTP, etc.
-- In such cases smart-constructors force us to handle potential conversion
-- failures at runtime, or abusing functions like @fromJust@ to break away all
-- the safety smart-constructors provide. All this despite the fact that we
-- can statically know at compile time that the conversion will always succeed
-- or always fails.
--
-- This package provides a typeclasses for using TH to validate the
-- correctness of provided literals at compile. This lets you define, e.g.,
-- @newtype Even = Even Integer@ and write:
--
-- @
-- x :: Even
-- x = $$(valid 38)
-- @
--
-- 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(..)
    , ValidationFailure(..)
    , valid
    , validInteger
    , validRational
    , validString
    , validList
    -- * Re-export from "Language.Haskell.TH.Syntax"
    , Lift(..)
    ) where

import Control.Exception (Exception(displayException), throwIO)
import Data.Proxy (Proxy(Proxy))
import Data.Typeable (Typeable)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Syntax.Compat (Splice, liftSplice)

-- | 'Exception' type for failed conversions. Useful for testing and more
-- gracefully handling compile time failures.
data ValidationFailure = ValidationFailure String deriving (Int -> ValidationFailure -> ShowS
[ValidationFailure] -> ShowS
ValidationFailure -> String
(Int -> ValidationFailure -> ShowS)
-> (ValidationFailure -> String)
-> ([ValidationFailure] -> ShowS)
-> Show ValidationFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationFailure] -> ShowS
$cshowList :: [ValidationFailure] -> ShowS
show :: ValidationFailure -> String
$cshow :: ValidationFailure -> String
showsPrec :: Int -> ValidationFailure -> ShowS
$cshowsPrec :: Int -> ValidationFailure -> ShowS
Show, Typeable)

instance Exception ValidationFailure where
    displayException :: ValidationFailure -> String
displayException (ValidationFailure String
s) = String
"Validation failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 = Either String b
-> (b -> Either String b) -> Maybe b -> Either String b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String b
forall a b. a -> Either a b
Left String
errMsg) b -> Either String b
forall a b. b -> Either a b
Right (Maybe b -> Either String b)
-> (a -> Maybe b) -> a -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
forall a b. Validate a b => a -> Maybe b
fromLiteral
      where
        errMsg :: String
errMsg = String
"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 = (String -> Maybe b) -> (b -> Maybe b) -> Either String b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe b -> String -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing) b -> Maybe b
forall a. a -> Maybe a
Just (Either String b -> Maybe b)
-> (a -> Either String b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String b
forall a b. Validate a b => a -> Either String b
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 -> Splice Q b
    default liftResult :: Lift b => Proxy a -> b -> Splice Q b
    liftResult Proxy a
_ b
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 #-}
--
-- import ValidLiterals
--
-- x :: ASCII
-- x = $$(valid \'c\')
-- @
valid :: forall a b . Validate a b => a -> Splice Q b
valid :: a -> Splice Q b
valid a
input = case a -> Either String b
forall a b. Validate a b => a -> Either String b
fromLiteralWithError a
input of
    Right b
result -> Proxy a -> b -> Splice Q b
forall a b. Validate a b => Proxy a -> b -> Splice Q b
liftResult (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) b
result
    Left String
err -> Splice Q b -> Splice Q b
forall a (m :: * -> *). m (TExp a) -> m (TExp a)
liftSplice (Splice Q b -> Splice Q b) -> Splice Q b -> Splice Q b
forall a b. (a -> b) -> a -> b
$ do
        String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"Invalid input used for type-safe validated literal!", String
err ]
        IO (TExp b) -> Splice Q b
forall a. IO a -> Q a
runIO (IO (TExp b) -> Splice Q b) -> IO (TExp b) -> Splice Q b
forall a b. (a -> b) -> a -> b
$ ValidationFailure -> IO (TExp b)
forall e a. Exception e => e -> IO a
throwIO (String -> ValidationFailure
ValidationFailure String
err)

-- | Integer literals lead to obnoxious defaulting complaints by GHC, by
-- using this function you can force the defaulting to 'Integer', silencing
-- these warnings.
--
-- Since 'Integral' literals use @fromInteger :: Num a => Integer -> a@ this
-- function cannot cost you any precision.
validInteger :: Validate Integer b => Integer -> Splice Q b
validInteger :: Integer -> Splice Q b
validInteger = Integer -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid

-- | Same as 'validInteger', but for 'Fractional' values.
--
-- Since 'Fractional' literals use
-- @fromRational :: Fractional a => Rational -> a@ this function cannot cost
-- you any precision.
validRational :: Validate Rational b => Rational -> Splice Q b
validRational :: Rational -> Splice Q b
validRational = Rational -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid

-- | Same as 'validInteger', but for when enabling @OverloadedStrings@ makes
-- 'String' literals polymorphic.
validString :: Validate String b => String -> Splice Q b
validString :: String -> Splice Q b
validString = String -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid

-- | Same as 'validInteger', but for when enabling @OverloadedLists@ makes list
-- literals polymorphic.
validList :: Validate [a] b => [a] -> Splice Q b
validList :: [a] -> Splice Q b
validList = [a] -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid