module Data.Aeson.Schema.Helpers
( vectorUnique
, formatValidators
, validateFormat
, isDivisibleBy
, replaceHiddenModules
, cleanPatterns
, getUsedModules
) where
import Control.Monad (join)
import Data.Generics (Data, everything, everywhere, mkQ, mkT)
import Data.List (nub)
import Data.Maybe (maybeToList)
import Data.Scientific (Scientific, coefficient, base10Exponent)
import Data.Text (Text, unpack)
import qualified Data.Vector as V
import Language.Haskell.TH (Name, Pat (..), mkName, nameBase,
nameModule)
import Text.Regex.PCRE (makeRegexM)
import Text.Regex.PCRE.String (Regex)
vectorUnique :: (Eq a) => V.Vector a -> Bool
vectorUnique v = length (nub $ V.toList v) == V.length v
formatValidators :: [(Text, Maybe (Text -> Maybe String))]
formatValidators =
[ ("date-time", Nothing)
, ("data", Nothing)
, ("time", Nothing)
, ("utc-millisec", Nothing)
, ( "regex"
, Just $ \str -> case makeRegexM (unpack str) :: Maybe Regex of
Nothing -> Just $ "not a regex: " ++ show str
Just _ -> Nothing
)
, ("color", Nothing)
, ("style", Nothing)
, ("phone", Nothing)
, ("uri", Nothing)
, ("email", Nothing)
, ("ip-address", Nothing)
, ("ipv6", Nothing)
, ("host-name", Nothing)
]
validateFormat :: Text
-> Text
-> Maybe String
validateFormat format str = ($ str) =<< join (lookup format formatValidators)
isDivisibleBy :: Scientific -> Scientific -> Bool
isDivisibleBy a b =
let ca = coefficient a
ea = base10Exponent a
cb = coefficient b
eb = base10Exponent b
in if ea >= eb
then (10 ^ (ea eb)) * ca `mod` cb == 0
else ca `mod` (10 ^ (eb ea)) == 0
replaceHiddenModules :: Data a
=> a
-> a
replaceHiddenModules = everywhere $ mkT replaceModule
where
replacements =
[ ("Data.HashMap.Base", "Data.HashMap.Lazy")
, ("Data.Aeson.Types.Class", "Data.Aeson")
, ("Data.Aeson.Types.Internal", "Data.Aeson.Types")
, ("GHC.Integer.Type", "Prelude")
, ("GHC.Types", "Prelude")
, ("GHC.Real", "Prelude")
, ("Data.Text.Internal", "Data.Text")
, ("Data.Map.Base", "Data.Map")
]
replaceModule :: Name -> Name
replaceModule n = case nameModule n of
Just "Data.Aeson.Types.Internal" |nameBase n `elem` ["I", "D"] ->
mkName $ "Data.Attoparsec.Number." ++ nameBase n
Just "GHC.Tuple" -> mkName $ nameBase n
Just m -> case lookup m replacements of
Just r -> mkName $ r ++ ('.' : nameBase n)
Nothing -> n
_ -> n
cleanPatterns :: Data a => a -> a
cleanPatterns = everywhere $ mkT replacePattern
where
replacePattern (ConP n []) | nameBase n == "[]" = ListP []
replacePattern p = p
getUsedModules :: Data a => a -> [String]
getUsedModules = nub . everything (++) ([] `mkQ` extractModule)
where
extractModule :: Name -> [String]
extractModule = maybeToList . nameModule