api-tools 0.4.0.1 → 0.5

raw patch · 24 files changed

+361/−137 lines, 24 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• api-tools.cabal +2/−2
• changelog +8/−0
• dist/build/Data/API/Parse.hs +37/−29
• main/Data/API/MigrationTool.hs +2/−2
• src/Data/API/API/Gen.hs +1/−1
• src/Data/API/Changes.hs +16/−10
• src/Data/API/Doc/Types.hs +2/−8
• src/Data/API/JSON.hs +62/−40
• src/Data/API/NormalForm.hs +2/−2
• src/Data/API/PP.hs +1/−1
• src/Data/API/Parse.y +27/−11
• src/Data/API/Tools.hs +11/−2
• src/Data/API/Tools/Combinators.hs +5/−0
• src/Data/API/Tools/Datatypes.hs +47/−5
• src/Data/API/Tools/Example.hs +1/−1
• src/Data/API/Tools/JSON.hs +42/−8
• src/Data/API/Tools/JSONTests.hs +9/−0
• src/Data/API/Tools/Lens.hs +7/−1
• src/Data/API/Tools/QuickCheck.hs +6/−6
• src/Data/API/Types.hs +15/−0
• tests/Data/API/Test/DSL.hs +10/−0
• tests/Data/API/Test/Gen.hs +10/−4
• tests/Data/API/Test/JSON.hs +37/−3
• tests/Data/API/Test/Migration.hs +1/−1

@@ -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

@@ -1,5 +1,13 @@ -*-change-log-*- +0.5 Adam Gundry <adam@well-typed.com> 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 <adam@well-typed.com> July 2014 	* Widen dependency compatibility to support GHC 7.8.3 

@@ -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             []                    -> "<EOF>"-            (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 "<command-line>" #-}-{-# LINE 8 "<command-line>" #-}+{-# LINE 10 "<command-line>" #-} # 1 "/usr/include/stdc-predef.h" 1 3 4  # 17 "/usr/include/stdc-predef.h" 3 4@@ -1521,7 +1529,7 @@   -{-# LINE 8 "<command-line>" #-}+{-# LINE 10 "<command-line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp  

@@ -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)

@@ -17,7 +17,7 @@  $(generateAPITools apiAPI                    [ enumTool-                   , jsonTool+                   , jsonTool'                    , quickCheckTool                    , lensTool                    , safeCopyTool

@@ -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

@@ -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 "<b><a class='reflink' href='%s' >%s</a></b>"

@@ -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

@@ -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]

@@ -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" 

@@ -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             []                    -> "<EOF>"-            (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|] }

@@ -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

@@ -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

@@ -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

@@ -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] 

@@ -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

@@ -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

@@ -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)

@@ -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:

@@ -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 =

@@ -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 |]

@@ -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

@@ -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

@@ -134,7 +134,7 @@ $(generate         startSchema) $(generateAPITools startSchema                    [ enumTool-                   , jsonTool+                   , jsonTool'                    , quickCheckTool                    ])