|
| 1 | +{-# LANGUAGE OverloadedStrings #-} |
| 2 | + |
| 3 | +module Data.JSONTransform |
| 4 | + ( JSONTransform, transform, parseTransform |
| 5 | + ) where |
| 6 | + |
| 7 | +import Control.Monad |
| 8 | +import Data.Aeson |
| 9 | +import qualified Data.HashMap.Lazy as H |
| 10 | +import Data.List |
| 11 | +import Data.Monoid |
| 12 | +import Data.Scientific |
| 13 | +import qualified Data.Text as T |
| 14 | +import qualified Data.Vector as V |
| 15 | +import Text.Parsec |
| 16 | +import Text.Parsec.Error |
| 17 | + |
| 18 | +-- | A type to represent a transform from one json value to another |
| 19 | +newtype JSONTransform = JSONTransform TValue |
| 20 | + |
| 21 | +-- | Transform analog of Aeson Value. Instead of String values, there are expressions |
| 22 | +data TValue = TObject !(H.HashMap T.Text TValue) |
| 23 | + | TArray !(V.Vector TValue) |
| 24 | + | TExp ![ValueExp] |
| 25 | + | TNumber !Scientific |
| 26 | + | TBool !Bool |
| 27 | + | TNull deriving(Show) |
| 28 | + |
| 29 | +-- | A value expression which can either be a literal text value or |
| 30 | +-- an Accessor which is a list of keys. |
| 31 | +data ValueExp = Literal T.Text | Accessor [T.Text] deriving(Show) |
| 32 | + |
| 33 | +-- | Parses a json 'Value' and returns either a parse error or and error |
| 34 | +-- about why parsing failed. |
| 35 | +parseTransform :: Value -> Either T.Text JSONTransform |
| 36 | +parseTransform v = JSONTransform <$> fromJSONValue v |
| 37 | + |
| 38 | +-- | Transforms a json 'Value' using the supplied 'JSONTransform' |
| 39 | +transform :: JSONTransform -> Value -> Either T.Text Value |
| 40 | +transform (JSONTransform t) v = fromTValue v t |
| 41 | + |
| 42 | +fromJSONValue :: Value -> Either T.Text TValue |
| 43 | +fromJSONValue (Object o) = TObject <$> traverse fromJSONValue o |
| 44 | +fromJSONValue (Array vs) = TArray <$> traverse fromJSONValue vs |
| 45 | +fromJSONValue (String t) = either (Left . formatError t) (Right . TExp) (parse valueExpParser "" t) |
| 46 | +fromJSONValue (Number n) = Right $ TNumber n |
| 47 | +fromJSONValue (Bool b) = Right $ TBool b |
| 48 | +fromJSONValue Null = Right TNull |
| 49 | + |
| 50 | +fromTValue :: Value -> TValue -> Either T.Text Value |
| 51 | +fromTValue v (TObject o) = Object <$> traverse (fromTValue v) o |
| 52 | +fromTValue v (TArray vs) = Array <$> traverse (fromTValue v) vs |
| 53 | +fromTValue v (TExp es) = valueFromExpressions v es |
| 54 | +fromTValue _ (TNumber n) = Right $ Number n |
| 55 | +fromTValue _ (TBool b) = Right $ Bool b |
| 56 | +fromTValue _ TNull = Right Null |
| 57 | + |
| 58 | +formatError :: T.Text -> ParseError -> T.Text |
| 59 | +formatError expression e = T.concat ["Error parsing accessor: " |
| 60 | + , expression |
| 61 | + , "\n" |
| 62 | + , "at position " |
| 63 | + , T.pack $ show $ sourceColumn $ errorPos e |
| 64 | + , "\n" |
| 65 | + , T.pack parsecError] where |
| 66 | + -- Taken from parsec source - format error without line number |
| 67 | + parsecError = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) |
| 68 | + |
| 69 | +valueFromExpressions :: Value -> [ValueExp] -> Either T.Text Value |
| 70 | +valueFromExpressions v es = case traverse (valueFromExpression v) es of |
| 71 | + (Left err) -> Left err |
| 72 | + (Right vs) -> case foldM combineJSONValue Null vs of |
| 73 | + Nothing -> Left "Could not combine JSON values" |
| 74 | + Just c -> Right c |
| 75 | + |
| 76 | +valueFromExpression :: Value -> ValueExp -> Either T.Text Value |
| 77 | +valueFromExpression _ (Literal t) = Right $ String t |
| 78 | +valueFromExpression v (Accessor ks) = maybe (Left $ T.append "Can't read value: " (formatKeys ks)) Right (valueForKeys v ks) |
| 79 | + |
| 80 | +-- | Try to extract a 'Value' using a list of keys |
| 81 | +-- and a source json 'Value' |
| 82 | +valueForKeys :: Value -> [T.Text] -> Maybe Value |
| 83 | +valueForKeys o aks = go o ([],aks) where |
| 84 | + go v (_,[]) = Just v |
| 85 | + go (Object m) (ps,k:ks) = maybe Nothing (\v -> go v (k:ps,ks)) (H.lookup k m) |
| 86 | + go _ _ = Nothing |
| 87 | + |
| 88 | +formatKeys :: [T.Text] -> T.Text |
| 89 | +formatKeys = T.concat . intersperse "." |
| 90 | + |
| 91 | +-- | Combines two json 'Value's into a single Value. |
| 92 | +-- This might fail eg a bool and a number can't be |
| 93 | +-- sensibly combined |
| 94 | +combineJSONValue :: Value -> Value -> Maybe Value |
| 95 | +combineJSONValue v Null = Just v |
| 96 | +combineJSONValue Null v = Just v |
| 97 | +combineJSONValue (String t1) (String t2) = Just $ String $ t1 <> t2 |
| 98 | +combineJSONValue _ _ = Nothing |
| 99 | + |
| 100 | +-------------- |
| 101 | +-- Parsing |
| 102 | +-------------- |
| 103 | + |
| 104 | +valueExpParser :: Parsec T.Text () [ValueExp] |
| 105 | +valueExpParser = many (try accessorParser <|> literalParser) <* eof |
| 106 | + |
| 107 | +accessorParser :: Parsec T.Text () ValueExp |
| 108 | +accessorParser = do void $ char '$' |
| 109 | + between (char '(') (char ')') $ do |
| 110 | + ks <- sepBy1 (many1 $ noneOf ").") (char '.') |
| 111 | + return $ Accessor $ T.pack <$> ks |
| 112 | + |
| 113 | +literalParser :: Parsec T.Text () ValueExp |
| 114 | +literalParser = Literal . T.pack <$> litChars where |
| 115 | + litChars = many1 (try (string "$$" *> pure '$') <|> noneOf "$") |
0 commit comments