diff --git a/api-tools.cabal b/api-tools.cabal --- a/api-tools.cabal +++ b/api-tools.cabal @@ -1,5 +1,5 @@ Name: api-tools -Version: 0.4.0.1 +Version: 0.5 Synopsis: DSL for generating API boilerplate and docs Description: api-tools provides a compact DSL for describing an API. It uses Template Haskell to generate the @@ -25,7 +25,7 @@ Source-Repository this Type: git Location: git://github.com/iconnect/api-tools.git - Tag: 0.4.0.1 + Tag: 0.5 Library Hs-Source-Dirs: src diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,13 @@ -*-change-log-*- +0.5 Adam Gundry October 2014 + * Tool to generate Aeson FromJSON instances, as well as FromJSONWithErrs + * Add more TypeKind alternatives for custom migrations + * Pretty-printing and error message fixes + * Report correct source locations in quasiquote parsers + * Extend JSON parser to optionally treat newtype filter violations as warnings + * Optionally generate smart constructors for filtered newtypes + 0.4.0.1 Adam Gundry July 2014 * Widen dependency compatibility to support GHC 7.8.3 diff --git a/dist/build/Data/API/Parse.hs b/dist/build/Data/API/Parse.hs --- a/dist/build/Data/API/Parse.hs +++ b/dist/build/Data/API/Parse.hs @@ -20,13 +20,15 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Version as V import Distribution.Text (simpleParse) +import Language.Haskell.TH import Language.Haskell.TH.Quote import Text.Printf import Text.Regex import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) --- parser produced by Happy Version 1.19.2 +-- parser produced by Happy Version 1.19.4 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -1378,45 +1380,44 @@ happyError_ 43# tk tks = happyError' tks happyError_ _ tk tks = happyError' (tk:tks) -newtype HappyIdentity a = HappyIdentity a -happyIdentity = HappyIdentity -happyRunIdentity (HappyIdentity a) = a - -instance Monad HappyIdentity where - return = HappyIdentity - (HappyIdentity p) >>= q = q p - -happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b +happyThen :: () => ParseM a -> (a -> ParseM b) -> ParseM b happyThen = (>>=) -happyReturn :: () => a -> HappyIdentity a +happyReturn :: () => a -> ParseM a happyReturn = (return) happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> HappyIdentity a +happyReturn1 :: () => a -> b -> ParseM a happyReturn1 = \a tks -> (return) a -happyError' :: () => [(PToken)] -> HappyIdentity a -happyError' = HappyIdentity . happyError +happyError' :: () => [(PToken)] -> ParseM a +happyError' = happyError -parse tks = happyRunIdentity happySomeParser where +parse tks = happySomeParser where happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut6 x)) -parse_with_changelog tks = happyRunIdentity happySomeParser where +parse_with_changelog tks = happySomeParser where happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut5 x)) happySeq = happyDontSeq -happyError :: [PToken] -> a -happyError tks = error $ printf "Syntax error at %s: %s\n" loc $ show (take 5 tks) +type ParseM = Either [PToken] + +happyError :: [PToken] -> ParseM a +happyError = Left + +parseAPI :: String -> (Int, Int) -> String -> API +parseAPI = wrap parse + +wrap :: ([PToken] -> ParseM a) -> String -> (Int, Int) -> String -> a +wrap parser fn (start_ln,_start_cn) s = case parser (scan s) of + Right v -> v + Left tks -> error $ printf "Syntax error at %s of %s:\n %s\n" (loc tks) fn $ show (take 5 tks) where - loc = case tks of + loc tks = case tks of [] -> "" - (AlexPn ad ln cn,_):_ -> printf "line %d, column %d (@%d)" ln cn ad - -parseAPI :: String -> API -parseAPI = parse . scan + (AlexPn ad ln cn,_):_ -> printf "line %d, column %d (@%d)" (start_ln+ln-1) (cn-1) ad -parseAPIWithChangelog :: String -> APIWithChangelog -parseAPIWithChangelog = parse_with_changelog . scan +parseAPIWithChangelog :: String -> (Int, Int) -> String -> APIWithChangelog +parseAPIWithChangelog = wrap parse_with_changelog data FieldChange = FldChAdd FieldName APIType (Maybe DefaultValue) @@ -1462,7 +1463,7 @@ api :: QuasiQuoter api = QuasiQuoter - { quoteExp = \s -> [| parseAPI s |] + { quoteExp = located [|parseAPI|] , quotePat = error "api QuasiQuoter used in patten context" , quoteType = error "api QuasiQuoter used in type context" , quoteDec = error "api QuasiQuoter used in declaration context" @@ -1471,15 +1472,22 @@ apiWithChangelog :: QuasiQuoter apiWithChangelog = QuasiQuoter - { quoteExp = \s -> [| parseAPIWithChangelog s |] + { quoteExp = located [|parseAPIWithChangelog|] , quotePat = error "apiWithChangelog QuasiQuoter used in patten context" , quoteType = error "apiWithChangelog QuasiQuoter used in type context" , quoteDec = error "apiWithChangelog QuasiQuoter used in declaration context" } + +located :: ExpQ -> String -> ExpQ +located e s = do + l <- location + let fn = loc_filename l + ls = loc_start l + [|$(e) fn ls s|] {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} -{-# LINE 8 "" #-} +{-# LINE 10 "" #-} # 1 "/usr/include/stdc-predef.h" 1 3 4 # 17 "/usr/include/stdc-predef.h" 3 4 @@ -1521,7 +1529,7 @@ -{-# LINE 8 "" #-} +{-# LINE 10 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp diff --git a/main/Data/API/MigrationTool.hs b/main/Data/API/MigrationTool.hs --- a/main/Data/API/MigrationTool.hs +++ b/main/Data/API/MigrationTool.hs @@ -68,7 +68,7 @@ writeJsonFile file = BS.writeFile file . JS.encodePretty readApiFile :: FilePath -> IO APIWithChangelog -readApiFile file = fmap parseAPIWithChangelog (readFile file) +readApiFile file = fmap (parseAPIWithChangelog file (0,0)) (readFile file) data ChangeTag = None deriving (Read, Show) @@ -94,4 +94,4 @@ parse :: FilePath -> IO () parse file = do s <- readFile file - print (parseAPIWithChangelog s) + print (parseAPIWithChangelog file (0,0) s) diff --git a/src/Data/API/API/Gen.hs b/src/Data/API/API/Gen.hs --- a/src/Data/API/API/Gen.hs +++ b/src/Data/API/API/Gen.hs @@ -17,7 +17,7 @@ $(generateAPITools apiAPI [ enumTool - , jsonTool + , jsonTool' , quickCheckTool , lensTool , safeCopyTool diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -419,7 +419,7 @@ | TableChangeError { afCustomMessage :: String } -- ^ custom error in tableChange deriving (Eq, Show) -data TypeKind = TKRecord | TKUnion | TKEnum +data TypeKind = TKRecord | TKUnion | TKEnum | TKNewtype | TKTypeSynonym deriving (Eq, Show) @@ -958,19 +958,25 @@ instance PP TypeKind where - pp TKRecord = "record" - pp TKUnion = "union" - pp TKEnum = "enum" + pp TKRecord = "record" + pp TKUnion = "union" + pp TKEnum = "enum" + pp TKNewtype = "newtype" + pp TKTypeSynonym = "type" ppATypeKind :: TypeKind -> String -ppATypeKind TKRecord = "a record" -ppATypeKind TKUnion = "a union" -ppATypeKind TKEnum = "an enum" +ppATypeKind TKRecord = "a record" +ppATypeKind TKUnion = "a union" +ppATypeKind TKEnum = "an enum" +ppATypeKind TKNewtype = "a newtype" +ppATypeKind TKTypeSynonym = "a type synonym" ppMemberWord :: TypeKind -> String -ppMemberWord TKRecord = "field" -ppMemberWord TKUnion = "alternative" -ppMemberWord TKEnum = "value" +ppMemberWord TKRecord = "field" +ppMemberWord TKUnion = "alternative" +ppMemberWord TKEnum = "value" +ppMemberWord TKNewtype = "member" +ppMemberWord TKTypeSynonym = "member" instance PPLines APIChange where diff --git a/src/Data/API/Doc/Types.hs b/src/Data/API/Doc/Types.hs --- a/src/Data/API/Doc/Types.hs +++ b/src/Data/API/Doc/Types.hs @@ -18,6 +18,7 @@ , mk_link ) where +import Data.API.PP import Data.API.Types import Text.Printf @@ -103,15 +104,8 @@ renderAPIType di (TyList ty ) = "[" ++ renderAPIType di ty ++ "]" renderAPIType di (TyMaybe ty ) = "?" ++ renderAPIType di ty renderAPIType di (TyName tn ) = mk_link (doc_info_type_url di tn) (_TypeName tn) -renderAPIType _ (TyBasic bt ) = renderBasicType bt +renderAPIType _ (TyBasic bt ) = pp bt renderAPIType _ TyJSON = "json" - -renderBasicType :: BasicType -> String -renderBasicType BTstring{} = "string" -renderBasicType BTbinary{} = "binary" -renderBasicType BTbool {} = "bool" -renderBasicType BTint {} = "int" -renderBasicType BTutc {} = "utc" mk_link :: URL -> String -> String mk_link = printf "%s" diff --git a/src/Data/API/JSON.hs b/src/Data/API/JSON.hs --- a/src/Data/API/JSON.hs +++ b/src/Data/API/JSON.hs @@ -11,6 +11,7 @@ module Data.API.JSON ( -- * Representation of JSON parsing errors JSONError(..) + , JSONWarning , Expected(..) , FormatExpected(..) , Position @@ -21,7 +22,7 @@ -- * Parser with multiple error support , ParserWithErrs - , ParseFlags(useDefaults, enforceReadOnlyFields) + , ParseFlags(useDefaults, enforceReadOnlyFields, enforceFilters) , defaultParseFlags , runParserWithErrsTop @@ -29,8 +30,10 @@ , FromJSONWithErrs(..) , fromJSONWithErrs , fromJSONWithErrs' + , fromJSONWithErrs'' , decodeWithErrs , decodeWithErrs' + , parseJSONDefault -- * ParserWithErrs combinators , withParseFlags @@ -63,6 +66,7 @@ import Control.Applicative import qualified Data.Aeson as JS import qualified Data.Aeson.Parser as JS +import qualified Data.Aeson.Types as JS import Data.Aeson.TH import Data.Attoparsec.ByteString import qualified Data.ByteString.Char8 as B @@ -98,6 +102,9 @@ | SyntaxError String deriving (Eq, Show) +-- | At present, we do not distinguish between errors and warnings +type JSONWarning = JSONError + -- | JSON type expected at a particular position, when a value of a -- different type was encountered data Expected = ExpArray @@ -186,30 +193,29 @@ -- -- * @pf \`ap\` ps@ returns errors from @pf@ only newtype ParserWithErrs a = ParserWithErrs { - runParserWithErrs :: ParseFlags -> Position -> Either [(JSONError, Position)] a } + runParserWithErrs :: ParseFlags -> Position -> ([(JSONError, Position)], Maybe a) } deriving Functor instance Applicative ParserWithErrs where - pure x = ParserWithErrs $ \ _ _ -> Right x + pure x = ParserWithErrs $ \ _ _ -> ([], Just x) pf <*> ps = ParserWithErrs $ \ q z -> - case (runParserWithErrs pf q z, runParserWithErrs ps q z) of - (Right f, Right s) -> Right $ f s - (Left es, Right _) -> Left es - (Right _, Left es) -> Left es - (Left es, Left es') -> Left $ es ++ es' + let (es_f, mb_f) = runParserWithErrs pf q z + (es_s, mb_s) = runParserWithErrs ps q z + in (es_f ++ es_s, mb_f <*> mb_s) instance Alternative ParserWithErrs where empty = failWith $ SyntaxError "No alternative" px <|> py = ParserWithErrs $ \ q z -> case runParserWithErrs px q z of - Right v -> Right v - Left _ -> runParserWithErrs py q z + r@(_, Just _) -> r + (_, Nothing) -> runParserWithErrs py q z instance Monad ParserWithErrs where return = pure px >>= f = ParserWithErrs $ \ q z -> case runParserWithErrs px q z of - Right x -> runParserWithErrs (f x) q z - Left es -> Left es + (es, Just x ) -> let (es', r) = runParserWithErrs (f x) q z + in (es ++ es', r) + (es, Nothing) -> (es, Nothing) fail = failWith . SyntaxError @@ -221,6 +227,9 @@ , enforceReadOnlyFields :: Bool -- ^ If true, fields in the schema marked read-only will be -- overwritten with default values + , enforceFilters :: Bool + -- ^ If true, parse errors will be generated when invalid values + -- are supplied for filtered newtypes } -- | Use this as a basis for overriding individual fields of the @@ -228,10 +237,16 @@ defaultParseFlags :: ParseFlags defaultParseFlags = ParseFlags { useDefaults = False , enforceReadOnlyFields = False + , enforceFilters = True } -runParserWithErrsTop :: ParseFlags -> ParserWithErrs a -> Either [(JSONError, Position)] a -runParserWithErrsTop q p = runParserWithErrs p q [] +-- | Run a parser with given flags, starting in the outermost +-- location, and returning warnings even if the parse was successful +runParserWithErrsTop :: ParseFlags -> ParserWithErrs a + -> Either [(JSONError, Position)] (a, [(JSONWarning, Position)]) +runParserWithErrsTop q p = case runParserWithErrs p q [] of + (es, Nothing) -> Left es + (es, Just v) -> Right (v, es) -------------------------------------------------- @@ -307,9 +322,16 @@ -- errors with their positions. This version allows the 'ParseFlags' -- to be specified. fromJSONWithErrs' :: FromJSONWithErrs a => ParseFlags -> JS.Value -> Either [(JSONError, Position)] a -fromJSONWithErrs' q = runParserWithErrsTop q . parseJSONWithErrs +fromJSONWithErrs' q = fmap fst . fromJSONWithErrs'' q +-- | Run the JSON parser on a value to produce a result or a list of +-- errors with their positions. This version allows the 'ParseFlags' +-- to be specified, and produces warnings even if the parse succeeded. +fromJSONWithErrs'' :: FromJSONWithErrs a => ParseFlags -> JS.Value + -> Either [(JSONError, Position)] (a, [(JSONWarning, Position)]) +fromJSONWithErrs'' q = runParserWithErrsTop q . parseJSONWithErrs + -- | Decode a 'ByteString' and run the JSON parser decodeWithErrs :: FromJSONWithErrs a => BL.ByteString -> Either [(JSONError, Position)] a decodeWithErrs = decodeWithErrs' defaultParseFlags @@ -322,6 +344,15 @@ Right v -> fromJSONWithErrs' q v +-- | Suitable as an implementation of 'parseJSON' that uses the +-- 'FromJSONWithErrs' instance (provided said instance was not defined +-- using 'fromJSON'!). +parseJSONDefault :: FromJSONWithErrs a => JS.Value -> JS.Parser a +parseJSONDefault v = case fromJSONWithErrs v of + Right x -> return x + Left es -> fail $ prettyJSONErrorPositions es + + --------------------------------- -- ParserWithErrs combinators -- @@ -330,8 +361,11 @@ withParseFlags k = ParserWithErrs $ \ q -> runParserWithErrs (k q) q failWith :: JSONError -> ParserWithErrs a -failWith e = ParserWithErrs $ \ _ z -> Left [(e, z)] +failWith e = ParserWithErrs $ \ _ z -> ([(e, z)], Nothing) +warning :: JSONError -> ParserWithErrs () +warning e = ParserWithErrs $ \ _ z -> ([(e, z)], Just ()) + stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a stepInside s p = ParserWithErrs $ \ q z -> runParserWithErrs p q (s:z) @@ -340,13 +374,19 @@ modifyTopError :: (JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a modifyTopError f p = ParserWithErrs $ \ q z -> case runParserWithErrs p q z of - Left es -> Left $ map (modifyIfAt z) es - r -> r + (es, r) -> (map (modifyIfAt z) es, r) where modifyIfAt z x@(e, z') | z == z' = (f e, z') | otherwise = x +-- | If the conditional is false, fail with an error (if filters are +-- not being enforced) or report a warning and continue (if they are). +withFilter :: Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a +withFilter p err m | p = m + | otherwise = withParseFlags $ \ pf -> if enforceFilters pf then failWith err + else warning err >> m + -- It's contrary to my principles, but I'll accept a string containing -- a number instead of an actual number... withInt :: String -> (Int -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a @@ -362,15 +402,7 @@ withIntRange :: IntRange -> String -> (Int -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a -withIntRange ir dg f = withInt dg g - where - g i | i `inIntRange` ir = f i - | otherwise = failWith $ IntRangeError dg i ir - - _ `inIntRange` IntRange Nothing Nothing = True - i `inIntRange` IntRange (Just lo) Nothing = lo <= i - i `inIntRange` IntRange Nothing (Just hi) = i <= hi - i `inIntRange` IntRange (Just lo) (Just hi) = lo <= i && i <= hi +withIntRange ir dg f = withInt dg $ \ i -> withFilter (i `inIntRange` ir) (IntRangeError dg i ir) (f i) withBinary :: String -> (Binary -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a withBinary lab f = withText lab g @@ -395,11 +427,9 @@ withRegEx :: RegEx -> String -> (T.Text -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a -withRegEx re dg f = withText dg g +withRegEx re dg f = withText dg $ \ txt -> withFilter (ok txt) (RegexError dg txt re) (f txt) where - g txt = case matchRegex (re_regex re) $ T.unpack txt of - Just _ -> f txt - Nothing -> failWith $ RegexError dg txt re + ok txt = isJust $ matchRegex (re_regex re) $ T.unpack txt withUTC :: String -> (UTCTime -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a @@ -409,15 +439,7 @@ withUTCRange :: UTCRange -> String -> (UTCTime -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a -withUTCRange ur dg f = withUTC dg g - where - g u | u `inUTCRange` ur = f u - | otherwise = failWith $ UTCRangeError dg u ur - - _ `inUTCRange` UTCRange Nothing Nothing = True - u `inUTCRange` UTCRange (Just lo) Nothing = lo <= u - u `inUTCRange` UTCRange Nothing (Just hi) = u <= hi - u `inUTCRange` UTCRange (Just lo) (Just hi) = lo <= u && u <= hi +withUTCRange ur dg f = withUTC dg $ \ u -> withFilter (u `inUTCRange` ur) (UTCRangeError dg u ur) (f u) withVersion :: String -> (Version -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a diff --git a/src/Data/API/NormalForm.hs b/src/Data/API/NormalForm.hs --- a/src/Data/API/NormalForm.hs +++ b/src/Data/API/NormalForm.hs @@ -232,10 +232,10 @@ ppLines (NRecordType flds) = "record" : map (\ (f, ty) -> " " ++ pp f ++ " :: " ++ pp ty) (Map.toList flds) - ppLines (NUnionType alts) = "union" : map (\ (f, ty) -> " " ++ pp f + ppLines (NUnionType alts) = "union" : map (\ (f, ty) -> " | " ++ pp f ++ " :: " ++ pp ty) (Map.toList alts) - ppLines (NEnumType vals) = "enum" : map (\ v -> " " ++ pp v) + ppLines (NEnumType vals) = "enum" : map (\ v -> " | " ++ pp v) (Set.toList vals) ppLines (NTypeSynonym t) = [pp t] ppLines (NNewtype b) = ["basic " ++ pp b] diff --git a/src/Data/API/PP.hs b/src/Data/API/PP.hs --- a/src/Data/API/PP.hs +++ b/src/Data/API/PP.hs @@ -67,7 +67,7 @@ instance PP BasicType where pp BTstring = "string" pp BTbinary = "binary" - pp BTbool = "bool" + pp BTbool = "boolean" pp BTint = "integer" pp BTutc = "utc" diff --git a/src/Data/API/Parse.y b/src/Data/API/Parse.y --- a/src/Data/API/Parse.y +++ b/src/Data/API/Parse.y @@ -19,6 +19,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Version as V import Distribution.Text (simpleParse) +import Language.Haskell.TH import Language.Haskell.TH.Quote import Text.Printf import Text.Regex @@ -29,6 +30,7 @@ %tokentype { PToken } +%monad { ParseM } { >>= } { return } %token ';' { (,) _ Semi } @@ -294,18 +296,25 @@ : typeiden { $1 } { -happyError :: [PToken] -> a -happyError tks = error $ printf "Syntax error at %s: %s\n" loc $ show (take 5 tks) +type ParseM = Either [PToken] + +happyError :: [PToken] -> ParseM a +happyError = Left + +parseAPI :: String -> (Int, Int) -> String -> API +parseAPI = wrap parse + +wrap :: ([PToken] -> ParseM a) -> String -> (Int, Int) -> String -> a +wrap parser fn (start_ln,_start_cn) s = case parser (scan s) of + Right v -> v + Left tks -> error $ printf "Syntax error at %s of %s:\n %s\n" (loc tks) fn $ show (take 5 tks) where - loc = case tks of + loc tks = case tks of [] -> "" - (AlexPn ad ln cn,_):_ -> printf "line %d, column %d (@%d)" ln cn ad - -parseAPI :: String -> API -parseAPI = parse . scan + (AlexPn ad ln cn,_):_ -> printf "line %d, column %d (@%d)" (start_ln+ln-1) (cn-1) ad -parseAPIWithChangelog :: String -> APIWithChangelog -parseAPIWithChangelog = parse_with_changelog . scan +parseAPIWithChangelog :: String -> (Int, Int) -> String -> APIWithChangelog +parseAPIWithChangelog = wrap parse_with_changelog data FieldChange = FldChAdd FieldName APIType (Maybe DefaultValue) @@ -351,7 +360,7 @@ api :: QuasiQuoter api = QuasiQuoter - { quoteExp = \s -> [| parseAPI s |] + { quoteExp = located [|parseAPI|] , quotePat = error "api QuasiQuoter used in patten context" , quoteType = error "api QuasiQuoter used in type context" , quoteDec = error "api QuasiQuoter used in declaration context" @@ -360,9 +369,16 @@ apiWithChangelog :: QuasiQuoter apiWithChangelog = QuasiQuoter - { quoteExp = \s -> [| parseAPIWithChangelog s |] + { quoteExp = located [|parseAPIWithChangelog|] , quotePat = error "apiWithChangelog QuasiQuoter used in patten context" , quoteType = error "apiWithChangelog QuasiQuoter used in type context" , quoteDec = error "apiWithChangelog QuasiQuoter used in declaration context" } + +located :: ExpQ -> String -> ExpQ +located e s = do + l <- location + let fn = loc_filename l + ls = loc_start l + [|$(e) fn ls s|] } diff --git a/src/Data/API/Tools.hs b/src/Data/API/Tools.hs --- a/src/Data/API/Tools.hs +++ b/src/Data/API/Tools.hs @@ -3,7 +3,7 @@ -- by one or more calls to 'generateAPITools', like so: -- -- > $(generate myAPI) --- > $(generateAPITools [enumTool, jsonTool, quickCheckTool] myAPI) +-- > $(generateAPITools [enumTool, jsonTool', quickCheckTool] myAPI) -- -- If you wish to override any of the instances generated by the -- tools, you can do so by writing instance declarations after the @@ -14,14 +14,18 @@ , generateAPITools -- * Tool settings + , generateWith , generateAPIToolsWith + , ToolSettings , defaultToolSettings , warnOnOmittedInstance + , newtypeSmartConstructors -- * Individual tools , enumTool , exampleTool , jsonTool + , jsonTool' , jsonTestsTool , lensTool , quickCheckTool @@ -46,7 +50,12 @@ -- | Generate the datatypes corresponding to an API. generate :: API -> Q [Dec] -generate api = generateAPITools api [datatypesTool] +generate = generateWith defaultToolSettings + +-- | Generate the datatypes corresponding to an API, allowing the +-- 'ToolSettings' to be overriden. +generateWith :: ToolSettings -> API -> Q [Dec] +generateWith ts api = generateAPIToolsWith ts api [datatypesTool] -- | Apply a list of tools to an 'API', generating TH declarations. -- See the individual tool descriptions for details. Note that diff --git a/src/Data/API/Tools/Combinators.hs b/src/Data/API/Tools/Combinators.hs --- a/src/Data/API/Tools/Combinators.hs +++ b/src/Data/API/Tools/Combinators.hs @@ -19,6 +19,7 @@ -- * Tool settings , ToolSettings , warnOnOmittedInstance + , newtypeSmartConstructors , defaultToolSettings ) where @@ -36,12 +37,16 @@ { warnOnOmittedInstance :: Bool -- ^ Generate a warning when an instance declaration is omitted -- because it already exists + , newtypeSmartConstructors :: Bool + -- ^ Rename the constructors of filtered newtypes and generate + -- smart constructors that enforce the invariants } -- | Default settings designed to be overridden. defaultToolSettings :: ToolSettings defaultToolSettings = ToolSettings { warnOnOmittedInstance = False + , newtypeSmartConstructors = False } -- | A @'Tool' a@ is something that can generate TH declarations from diff --git a/src/Data/API/Tools/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs --- a/src/Data/API/Tools/Datatypes.hs +++ b/src/Data/API/Tools/Datatypes.hs @@ -6,28 +6,33 @@ , nodeT , nodeRepT , nodeConE + , nodeNewtypeConE , nodeFieldE , nodeAltConE , nodeAltConP , newtypeProjectionE ) where +import Data.API.TH import Data.API.Tools.Combinators import Data.API.Types +import Control.Applicative import Data.Aeson import qualified Data.CaseInsensitive as CI import Data.Char +import Data.Maybe import Data.String import qualified Data.Text as T import Data.Time import Data.Typeable import Language.Haskell.TH +import Text.Regex -- | Tool to generate datatypes and type synonyms corresponding to an API datatypesTool :: APITool -datatypesTool = apiNodeTool $ apiSpecTool (simpleTool $ uncurry gen_sn_dt) +datatypesTool = apiNodeTool $ apiSpecTool (mkTool $ uncurry . gen_sn_dt) (simpleTool $ uncurry gen_sr_dt) (simpleTool $ uncurry gen_su_dt) (simpleTool $ uncurry gen_se_dt) @@ -43,11 +48,21 @@ -- -- > newtype JobId = JobId { _JobId :: T.Text } -- > deriving (Show,IsString,Eq,Typeable) +-- +-- If a filter has been applied, and smart constructors are enabled, +-- instead generate this: +-- +-- > newtype EmailAddress = UnsafeMkEmailAddress { _EmailAddress :: T.Text } +-- > deriving (Show,Eq,Typeable) +-- > mkEmailAddress :: T.Text -> Maybe EmailAddress +-- > mkEmailAddress t = ... -- check filter -gen_sn_dt :: APINode -> SpecNewtype -> Q [Dec] -gen_sn_dt as sn = return [NewtypeD [] nm [] c $ derive_leaf_nms ++ iss] +gen_sn_dt :: ToolSettings -> APINode -> SpecNewtype -> Q [Dec] +gen_sn_dt ts as sn = (nd :) <$> if smart then sc else return [] where - c = RecC nm [(newtype_prj_nm as,NotStrict,mk_type $ TyBasic (snType sn))] + nd = NewtypeD [] nm [] c $ derive_leaf_nms ++ iss + c = RecC (newtype_con_nm smart as) [(newtype_prj_nm as,NotStrict,wrapped_ty)] + wrapped_ty = mk_type $ TyBasic (snType sn) nm = rep_type_nm as @@ -58,8 +73,20 @@ BTint -> [] BTutc -> [] + smart = newtypeSmartConstructors ts && isJust (snFilter sn) + sc = simpleSigD (newtype_smart_con_nm as) [t| $(return wrapped_ty) -> Maybe $(nodeRepT as) |] $ + case snFilter sn of + Just (FtrStrg re) -> [| \ s -> if isJust (matchRegex (re_regex re) (T.unpack s)) + then Just ($nt_con s) else Nothing |] + Just (FtrIntg ir) -> [| \ i -> if i `inIntRange` ir then Just ($nt_con i) else Nothing |] + Just (FtrUTC ur) -> [| \ u -> if u `inUTCRange` ur then Just ($nt_con u) else Nothing |] + Nothing -> [| Just . $nt_con |] + nt_con = nodeNewtypeConE ts as sn + + + -- | Generate a record type definition, like this: -- -- > data JobSpecId @@ -158,6 +185,17 @@ newtype_prj_nm :: APINode -> Name newtype_prj_nm an = mkName $ "_" ++ rep_type_s an +-- | Name of the constructor of a newtype, which will be same as the +-- representation type unless a smart constructor is requested, in +-- which case we just prefix it with "UnsafeMk". +newtype_con_nm :: Bool -> APINode -> Name +newtype_con_nm smart an | smart = mkName $ "UnsafeMk" ++ rep_type_s an + | otherwise = mkName $ rep_type_s an + +-- | Name of the smart constructor of a newtype, prefixed with "mk". +newtype_smart_con_nm :: APINode -> Name +newtype_smart_con_nm an = mkName $ "mk" ++ rep_type_s an + rep_type_s :: APINode -> String rep_type_s an = f $ _TypeName $ anName an where @@ -186,9 +224,13 @@ nodeRepT :: APINode -> TypeQ nodeRepT = conT . rep_type_nm --- | The constructor for a newtype or record API node +-- | The constructor for a record API node nodeConE :: APINode -> ExpQ nodeConE = conE . rep_type_nm + +-- | The constructor for a newtype, which might be renamed +nodeNewtypeConE :: ToolSettings -> APINode -> SpecNewtype -> ExpQ +nodeNewtypeConE ts an sn = conE $ newtype_con_nm (newtypeSmartConstructors ts && isJust (snFilter sn)) an -- | A record field in an API node, as an expression nodeFieldE :: APINode -> FieldName -> ExpQ diff --git a/src/Data/API/Tools/Example.hs b/src/Data/API/Tools/Example.hs --- a/src/Data/API/Tools/Example.hs +++ b/src/Data/API/Tools/Example.hs @@ -96,7 +96,7 @@ gen_sn_ex = mkTool $ \ ts (an, sn) -> case snFilter sn of Just (FtrStrg _) -> return [] Just _ -> inst ts an [e| QC.arbitrary |] - Nothing -> inst ts an [e| fmap $(nodeConE an) example |] + Nothing -> inst ts an [e| fmap $(nodeNewtypeConE ts an sn) example |] where inst ts an e = optionalInstanceD ts ''Example [nodeRepT an] [simpleD 'example e] diff --git a/src/Data/API/Tools/JSON.hs b/src/Data/API/Tools/JSON.hs --- a/src/Data/API/Tools/JSON.hs +++ b/src/Data/API/Tools/JSON.hs @@ -2,8 +2,10 @@ module Data.API.Tools.JSON ( jsonTool + , jsonTool' , toJsonNodeTool , fromJsonNodeTool + , fromJsonWithErrsNodeTool ) where import Data.API.JSON @@ -17,6 +19,7 @@ import Data.Aeson hiding (withText, withBool) import Control.Applicative import qualified Data.HashMap.Strict as HMap +import Data.Maybe import qualified Data.Map as Map import Data.Monoid import qualified Data.Text as T @@ -25,21 +28,38 @@ -- | Tool to generate 'ToJSON' and 'FromJSONWithErrs' instances for -- types generated by 'datatypesTool'. This depends on 'enumTool'. +-- For historical reasons this does not generate 'FromJSON' instances; +-- you probably want to use 'jsonTool'' instead. jsonTool :: APITool -jsonTool = apiNodeTool $ toJsonNodeTool <> fromJsonNodeTool +jsonTool = apiNodeTool $ toJsonNodeTool <> fromJsonWithErrsNodeTool +-- | Tool to generate 'ToJSON', 'FromJSON' and 'FromJSONWithErrs' +-- instances for types generated by 'datatypesTool'. This depends on +-- 'enumTool'. Note that generated 'FromJSON' and 'FromJSONWithErrs' +-- instances will always agree on the decoding of a value, but that +-- the 'FromJSONWithErrs' instances for basic types are more liberal +-- than 'FromJSON'. +jsonTool' :: APITool +jsonTool' = apiNodeTool $ toJsonNodeTool <> fromJsonNodeTool + <> fromJsonWithErrsNodeTool + -- | Tool to generate 'ToJSON' instance for an API node toJsonNodeTool :: APINodeTool toJsonNodeTool = apiSpecTool gen_sn_to gen_sr_to gen_su_to gen_se_to mempty <> gen_pr --- | Tool to generate 'FromJSONWithErrs' instance for an API node +-- | Tool to generate 'FromJSON' instance for an API node, which +-- relies on the 'FromJSONWithErrs' instance. fromJsonNodeTool :: APINodeTool -fromJsonNodeTool = apiSpecTool gen_sn_fm gen_sr_fm gen_su_fm gen_se_fm mempty - <> gen_in +fromJsonNodeTool = gen_FromJSON +-- | Tool to generate 'FromJSONWithErrs' instance for an API node +fromJsonWithErrsNodeTool :: APINodeTool +fromJsonWithErrsNodeTool = apiSpecTool gen_sn_fm gen_sr_fm gen_su_fm gen_se_fm mempty + <> gen_in + {- instance ToJSON JobId where toJSON = String . _JobId @@ -66,9 +86,9 @@ gen_sn_fm :: Tool (APINode, SpecNewtype) gen_sn_fm = mkTool $ \ ts (an, sn) -> optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an] - [simpleD 'parseJSONWithErrs (bdy an sn)] + [simpleD 'parseJSONWithErrs (bdy ts an sn)] where - bdy an sn = [e| $(wth sn) $(typeNameE (anName an)) (pure . $(nodeConE an)) |] + bdy ts an sn = [e| $(wth sn) $(typeNameE (anName an)) (pure . $(nodeNewtypeConE ts an sn)) |] wth sn = case (snType sn, snFilter sn) of @@ -212,8 +232,22 @@ prj = varE $ mkName $ _FieldName prj_fn -alternatives :: Alternative t => t a -> [t a] -> t a -alternatives none = foldr (<|>) none +-- | Generate 'FromJSON' instances like this: +-- +-- > instance FromJSON T where +-- > parseJSON = parseJSONDefault +gen_FromJSON :: Tool APINode +gen_FromJSON = mkTool $ \ ts an -> do + (++) <$> genIf (not (isSynonym an)) ts (nodeRepT an) + <*> genIf (isJust (anConvert an)) ts (nodeT an) + where + genIf b ts t | b = optionalInstanceD ts ''FromJSON [t] [simpleD 'parseJSON [e|parseJSONDefault|]] + | otherwise = pure [] + + isSynonym an = case anSpec an of + SpSynonym _ -> True + _ -> False + mkInt :: Int -> Value mkInt = Number . fromInteger . toInteger diff --git a/src/Data/API/Tools/JSONTests.hs b/src/Data/API/Tools/JSONTests.hs --- a/src/Data/API/Tools/JSONTests.hs +++ b/src/Data/API/Tools/JSONTests.hs @@ -8,6 +8,7 @@ module Data.API.Tools.JSONTests ( jsonTestsTool , prop_decodesTo + , prop_decodesTo' , prop_resultsMatchRoundtrip ) where @@ -45,6 +46,14 @@ prop_decodesTo v x = case fromJSONWithErrs v :: Either [(JSONError, Position)] a of Right y | x == y -> True _ -> False + +-- | QuickCheck property that a 'Value' decodes to an expected Haskell +-- value, using 'fromJSONWithErrs'' with the given 'ParseFlags' +prop_decodesTo' :: forall a . (Eq a, FromJSONWithErrs a) + => ParseFlags -> JS.Value -> a -> Bool +prop_decodesTo' pf v x = case fromJSONWithErrs' pf v :: Either [(JSONError, Position)] a of + Right y | x == y -> True + _ -> False -- | QuickCheck property that Haskell values can be encoded with -- 'toJSON' and decoded with 'fromJSONWithErrs' to get the original diff --git a/src/Data/API/Tools/Lens.hs b/src/Data/API/Tools/Lens.hs --- a/src/Data/API/Tools/Lens.hs +++ b/src/Data/API/Tools/Lens.hs @@ -13,7 +13,13 @@ -- | Tool to make lenses for fields in generated types. lensTool :: APITool -lensTool = apiDataTypeTool $ simpleTool $ makeLenses . rep_type_nm +lensTool = apiDataTypeTool $ mkTool $ \ ts an -> + if ok ts an then makeLenses $ rep_type_nm an else return [] + where + -- Exclude newtypes if we are using smart constructors, because + -- the lens can be used to bypass the invariant + ok ts an | SpNewtype (SpecNewtype _ (Just _)) <- anSpec an = not (newtypeSmartConstructors ts) + | otherwise = True $(makeLenses ''Binary) diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -33,14 +33,14 @@ -- values). gen_sn_ab :: Tool (APINode, SpecNewtype) gen_sn_ab = mkTool $ \ ts (an, sn) -> case snFilter sn of - Nothing | snType sn == BTint -> mk_instance ts an [e| QC.arbitraryBoundedIntegral |] - | otherwise -> mk_instance ts an [e| arbitrary |] - Just (FtrIntg ir) -> mk_instance ts an [e| arbitraryIntRange ir |] - Just (FtrUTC ur) -> mk_instance ts an [e| arbitraryUTCRange ur |] + Nothing | snType sn == BTint -> mk_instance ts an sn [e| QC.arbitraryBoundedIntegral |] + | otherwise -> mk_instance ts an sn [e| arbitrary |] + Just (FtrIntg ir) -> mk_instance ts an sn [e| arbitraryIntRange ir |] + Just (FtrUTC ur) -> mk_instance ts an sn [e| arbitraryUTCRange ur |] Just (FtrStrg _) -> return [] where - mk_instance ts an arb = optionalInstanceD ts ''Arbitrary [nodeRepT an] - [simpleD 'arbitrary [e| fmap $(nodeConE an) $arb |]] + mk_instance ts an sn arb = optionalInstanceD ts ''Arbitrary [nodeRepT an] + [simpleD 'arbitrary [e| fmap $(nodeNewtypeConE ts an sn) $arb |]] -- | Generate an 'Arbitrary' instance for a record: diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -29,6 +29,9 @@ , RegEx(..) , Binary(..) , defaultValueAsJsValue + , mkRegEx + , inIntRange + , inUTCRange ) where import Data.API.Utils @@ -135,6 +138,12 @@ instance Lift IntRange where lift (IntRange lo hi) = [e| IntRange lo hi |] +inIntRange :: Int -> IntRange -> Bool +_ `inIntRange` IntRange Nothing Nothing = True +i `inIntRange` IntRange (Just lo) Nothing = lo <= i +i `inIntRange` IntRange Nothing (Just hi) = i <= hi +i `inIntRange` IntRange (Just lo) (Just hi) = lo <= i && i <= hi + data UTCRange = UTCRange { ur_lo :: Maybe UTCTime @@ -151,6 +160,12 @@ liftMaybeUTCTime :: Maybe UTCTime -> ExpQ liftMaybeUTCTime Nothing = [e| Nothing |] liftMaybeUTCTime (Just u) = [e| Just $(liftUTC u) |] + +inUTCRange :: UTCTime -> UTCRange -> Bool +_ `inUTCRange` UTCRange Nothing Nothing = True +u `inUTCRange` UTCRange (Just lo) Nothing = lo <= u +u `inUTCRange` UTCRange Nothing (Just hi) = u <= hi +u `inUTCRange` UTCRange (Just lo) (Just hi) = lo <= u && u <= hi data RegEx = diff --git a/tests/Data/API/Test/DSL.hs b/tests/Data/API/Test/DSL.hs --- a/tests/Data/API/Test/DSL.hs +++ b/tests/Data/API/Test/DSL.hs @@ -89,4 +89,14 @@ urec :: URec = record foo :: utc + + +fi :: FilteredInt + = basic integer | >= 3, <= 5 + +fs :: FilteredString + = basic string | "cab*age" + +fu :: FilteredUTC + = basic utc | >= 2014-10-13T15:20:11Z |] diff --git a/tests/Data/API/Test/Gen.hs b/tests/Data/API/Test/Gen.hs --- a/tests/Data/API/Test/Gen.hs +++ b/tests/Data/API/Test/Gen.hs @@ -17,7 +17,7 @@ $(generate DSL.example) $(generateAPITools DSL.example [ enumTool - , jsonTool + , jsonTool' , quickCheckTool , lensTool , safeCopyTool @@ -26,7 +26,7 @@ , jsonTestsTool (mkName "exampleSimpleTests") ]) -$(generate example2) +$(generateWith (defaultToolSettings { newtypeSmartConstructors = True }) example2) data Coord = Coord Int Int deriving (Eq,Show) @@ -89,9 +89,15 @@ prj_enum (ENUM False) = ENM_e1 prj_enum (ENUM True ) = ENM_e2 -$(generateAPITools example2 + +instance Arbitrary FilteredString where + arbitrary = pure $ UnsafeMkFilteredString "cabbage" + +instance Example FilteredString + +$(generateAPIToolsWith (defaultToolSettings { newtypeSmartConstructors = True }) example2 [ enumTool - , jsonTool + , jsonTool' , quickCheckTool , lensTool , safeCopyTool diff --git a/tests/Data/API/Test/JSON.hs b/tests/Data/API/Test/JSON.hs --- a/tests/Data/API/Test/JSON.hs +++ b/tests/Data/API/Test/JSON.hs @@ -6,15 +6,18 @@ ( jsonTests ) where -import Data.API.API.Gen +import Data.API.API.Gen ( apiAPISimpleTests ) import Data.API.JSON import Data.API.Tools import Data.API.Tools.JSONTests -import Data.API.Test.Gen (exampleSimpleTests, example2SimpleTests) +import Data.API.Test.Gen hiding ( Foo ) import Data.API.Test.MigrationData +import Data.API.Types +import Data.API.Utils import qualified Data.Aeson as JS import qualified Data.HashMap.Strict as HMap +import Data.Time import Test.Tasty import Test.Tasty.HUnit @@ -24,7 +27,7 @@ $(generate startSchema) $(generateAPITools startSchema [ enumTool - , jsonTool + , jsonTool' , quickCheckTool ]) @@ -44,11 +47,18 @@ , help (JS.Object (HMap.singleton "id" (JS.Number 3))) (Recursive (Id 3) Nothing) True + , help' noFilter (JS.Number 0) (UnsafeMkFilteredInt 0) True + , help' noFilter (JS.String "cabcage") (UnsafeMkFilteredString "cabcage") True + , help' noFilter (JS.String "2014-10-13T15:20:10Z") (UnsafeMkFilteredUTC (pUTC "2014-10-13T15:20:10Z")) True ] where help v x yes = assertBool ("Failed on " ++ show v ++ " " ++ show x) (prop_decodesTo v x == yes) + help' pf v x yes = assertBool ("Failed on " ++ show v ++ " " ++ show x) + (prop_decodesTo' pf v x == yes) + noFilter = defaultParseFlags { enforceFilters = False } + -- | Test that the correct errors are generated for bad JSON data errorDecoding :: [TestTree] errorDecoding = [ help "not enough input" "" (proxy :: Int) @@ -63,6 +73,12 @@ [(UnexpectedEnumVal ["bar", "foo"] "no", [InElem 0])] , help "missing field" "{}" (proxy :: Bar) [(MissingField, [InField "id"])] + , help "int out of range" "[0]" (proxy :: [FilteredInt]) + [(IntRangeError "FilteredInt" 0 (IntRange (Just 3) (Just 5)), [InElem 0])] + , help "string mismatch" "[\"cabcage\"]" (proxy :: [FilteredString]) + [(RegexError "FilteredString" "cabcage" (mkRegEx "cab*age"), [InElem 0])] + , help "utc out of range" "[\"2014-10-13T15:20:10Z\"]" (proxy :: [FilteredUTC]) + [(UTCRangeError "FilteredUTC" (pUTC "2014-10-13T15:20:10Z") (UTCRange (parseUTC_ "2014-10-13T15:20:11Z") Nothing), [InElem 0])] ] where proxy = error "proxy" @@ -74,10 +90,28 @@ ++ "\ninstead of\n" ++ prettyJSONErrorPositions es) (es == es') +-- | Test that smart constructors correctly enforce the invariants +smartConstructors :: [TestTree] +smartConstructors = + [ testCase "mkFilteredInt" $ do mkFilteredInt 2 @?= Nothing + mkFilteredInt 3 @?= Just (UnsafeMkFilteredInt 3) + , testCase "mkFilteredUTC" $ do mkFilteredUTC bad_time @?= Nothing + mkFilteredUTC good_time @?= Just (UnsafeMkFilteredUTC good_time) + , testCase "mkFilteredString" $ do mkFilteredString "cabcage" @?= Nothing + mkFilteredString "cabbage" @?= Just (UnsafeMkFilteredString "cabbage") + ] + where + bad_time = pUTC "2014-10-13T15:20:10Z" + good_time = pUTC "2014-10-13T15:20:13Z" + +pUTC :: String -> UTCTime +pUTC = maybe (error "pUTC") id . parseUTC_ + jsonTests :: TestTree jsonTests = testGroup "JSON" [ testCase "Basic value decoding" basicValueDecoding , testGroup "Decoding invalid data" errorDecoding + , testGroup "Smart constructors" smartConstructors , testGroup "Round-trip tests" [ testGroup "example" $ map (uncurry QC.testProperty) exampleSimpleTests , testGroup "example2" $ map (uncurry QC.testProperty) example2SimpleTests diff --git a/tests/Data/API/Test/Migration.hs b/tests/Data/API/Test/Migration.hs --- a/tests/Data/API/Test/Migration.hs +++ b/tests/Data/API/Test/Migration.hs @@ -134,7 +134,7 @@ $(generate startSchema) $(generateAPITools startSchema [ enumTool - , jsonTool + , jsonTool' , quickCheckTool ])