rest-gen 0.19.0.3 → 0.20.0.0

raw patch · 11 files changed

+330/−202 lines, 11 filesdep ~HUnitdep ~aesondep ~blaze-htmlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HUnit, aeson, blaze-html, directory, haskell-src-exts, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• rest-gen.cabal +5/−4
• src/Rest/Gen.hs +3/−2
• src/Rest/Gen/Base/ActionInfo.hs +8/−7
• src/Rest/Gen/Base/ActionInfo/Ident.hs +3/−3
• src/Rest/Gen/Haskell.hs +231/−161
• src/Rest/Gen/JavaScript.hs +2/−2
• src/Rest/Gen/NoAnnotation.hs +42/−0
• src/Rest/Gen/Ruby.hs +2/−2
• src/Rest/Gen/Types.hs +18/−18
• tests/Runner.hs +5/−3

@@ -1,5 +1,16 @@ # Changelog +## 0.20.0.0++* Upgrade to `haskell-src-exts 1.18.*`++#### 0.19.0.4++* Fix encoding issue with String inputs in generated clients.+  Non-ASCII characters would be mangled. Regenerate your client code+  to fix this. Newly generated code with String inputs needs to depend+  on rest-client >= 0.5.2, or it will fail to build.+ #### 0.19.0.3  * Allow rest-core-0.39.

@@ -1,5 +1,5 @@ name:                rest-gen-version:             0.19.0.3+version:             0.20.0.0 description:         Documentation and client generation from rest definition. synopsis:            Documentation and client generation from rest definition. maintainer:          code@silk.co@@ -46,12 +46,13 @@     Rest.Gen.Base.JSON.Pretty     Rest.Gen.Base.Link     Rest.Gen.Base.XML+    Rest.Gen.NoAnnotation     Rest.Gen.Utils   build-depends:       base >= 4.5 && < 4.10     , Cabal >= 1.16 && < 1.26     , HStringTemplate >= 0.6 && < 0.9-    , aeson >= 0.7 && < 0.12+    , aeson >= 0.7 && < 1.1     , base-compat >= 0.8 && < 0.10     , blaze-html >= 0.5 && < 0.9     , code-builder == 0.1.*@@ -59,7 +60,7 @@     , fclabels >= 1.0.4 && < 2.1     , filepath >= 1.2 && < 1.5     , hashable >= 1.1 && < 1.3-    , haskell-src-exts >= 1.15.0 && < 1.18+    , haskell-src-exts >= 1.18.1 && < 1.19     , hxt >= 9.2 && < 9.4     , json-schema >= 0.6 && < 0.8     , pretty >= 1.0 && < 1.2@@ -85,7 +86,7 @@       base >= 4.5 && < 4.10     , HUnit >= 1.2 && < 1.4     , fclabels >= 1.0.4 && < 2.1-    , haskell-src-exts >= 1.15.0 && < 1.18+    , haskell-src-exts >= 1.15.0 && < 1.19     , rest-core >= 0.38 && < 0.40     , rest-gen     , test-framework == 0.8.*

@@ -20,8 +20,9 @@ import Rest.Gen.Ruby (mkRbApi) import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation as N -generate :: Config -> String -> Api m -> [H.ModuleName] -> [H.ImportDecl] -> [(H.ModuleName, H.ModuleName)] -> IO ()+generate :: Config -> String -> Api m -> [N.ModuleName] -> [N.ImportDecl] -> [(N.ModuleName, N.ModuleName)] -> IO () generate config name api sources imports rewrites =   withVersion (get apiVersion config) api (putStrLn "Could not find api version" >> exitFailure) $ \ver (Some1 r) ->      case get action config of@@ -42,7 +43,7 @@        Nothing              -> return ()   where     packageName = map toLower name-    moduleName  = H.ModuleName $ upFirst packageName+    moduleName  = H.ModuleName () $ upFirst packageName  getTargetDir :: Config -> String -> IO String getTargetDir config str =

@@ -79,6 +79,7 @@ import qualified Rest.Gen.Base.ActionInfo.Ident as Ident import qualified Rest.Gen.Base.JSON             as J import qualified Rest.Gen.Base.XML              as X+import qualified Rest.Gen.NoAnnotation          as N  -------------------- -- * The types describing a resource's actions.@@ -99,8 +100,8 @@ -- | Core information about the type of the input/output data DataDesc = DataDesc   { _dataType       :: DataType-  , _haskellType    :: H.Type-  , _haskellModules :: [H.ModuleName]+  , _haskellType    :: N.Type+  , _haskellModules :: [N.ModuleName]   } deriving (Show, Eq)  mkLabel ''DataDesc@@ -140,7 +141,7 @@ isAccessor :: ActionInfo -> Bool isAccessor ai = actionType ai == Retrieve && actionTarget ai == Self -defaultDescription :: DataType -> String -> H.Type -> DataDescription+defaultDescription :: DataType -> String -> N.Type -> DataDescription defaultDescription typ typeDesc htype =   DataDescription     { _desc = DataDesc@@ -491,16 +492,16 @@                         (tyConName tyCon)                         (concatMap (\t -> " (" ++ typeString' t ++ ")") subs) -modString :: forall a. Typeable a => Proxy a -> [H.ModuleName]-modString _ = map H.ModuleName . filter (\v -> v /= "" && take 4 v /= "GHC.") . modString' . typeOf $ (undefined :: a)+modString :: forall a. Typeable a => Proxy a -> [N.ModuleName]+modString _ = map (H.ModuleName ()) . filter (\v -> v /= "" && take 4 v /= "GHC.") . modString' . typeOf $ (undefined :: a)   where modString' tr =           let (tyCon, subs) = splitTyConApp tr           in  tyConModule tyCon : concatMap modString' subs -toHaskellType :: forall a. Typeable a => Proxy a -> H.Type+toHaskellType :: forall a. Typeable a => Proxy a -> N.Type toHaskellType ty =   case H.parseType (typeString ty) of-    H.ParseOk parsedType -> parsedType+    H.ParseOk parsedType -> void parsedType     H.ParseFailed _loc msg -> error msg  idIdent :: Id id -> Ident

@@ -1,9 +1,9 @@ module Rest.Gen.Base.ActionInfo.Ident (Ident (..)) where -import qualified Language.Haskell.Exts.Syntax as H+import qualified Rest.Gen.NoAnnotation as N  data Ident = Ident   { description    :: String-  , haskellType    :: H.Type-  , haskellModules :: [H.ModuleName]+  , haskellType    :: N.Type+  , haskellModules :: [N.ModuleName]   } deriving (Show, Eq)

@@ -42,6 +42,7 @@ import Rest.Gen.Base import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation          as N import qualified Rest.Gen.Base.ActionInfo.Ident as Ident  mkLabelsNamed ("_" ++) [''Cabal.GenericPackageDescription, ''Cabal.CondTree, ''Cabal.Library]@@ -52,9 +53,9 @@     , targetPath     :: String     , wrapperName    :: String     , includePrivate :: Bool-    , sources        :: [H.ModuleName]-    , imports        :: [H.ImportDecl]-    , rewrites       :: [(H.ModuleName, H.ModuleName)]+    , sources        :: [N.ModuleName]+    , imports        :: [N.ImportDecl]+    , rewrites       :: [(N.ModuleName, N.ModuleName)]     , namespace      :: [String]     } @@ -97,9 +98,9 @@ mkCondLibrary modules = Cabal.CondNode   { Cabal.condTreeData        = cabalLibrary modules   , Cabal.condTreeConstraints =-     [ Cabal.Dependency (Cabal.PackageName "base")        (Cabal.withinVersion $ Cabal.Version [4]     [])-     , Cabal.Dependency (Cabal.PackageName "rest-types")  (Cabal.withinVersion $ Cabal.Version [1, 10] [])-     , Cabal.Dependency (Cabal.PackageName "rest-client") (Cabal.withinVersion $ Cabal.Version [0,  4] [])+     [ Cabal.Dependency (Cabal.PackageName "base")        (Cabal.withinVersion $ Cabal.Version [4]       [])+     , Cabal.Dependency (Cabal.PackageName "rest-types")  (Cabal.withinVersion $ Cabal.Version [1, 10]   [])+     , Cabal.Dependency (Cabal.PackageName "rest-client") (Cabal.withinVersion $ Cabal.Version [0, 5, 2] [])      ]   , Cabal.condTreeComponents  = []   }@@ -119,228 +120,295 @@ mkRes :: HaskellContext -> ApiResource -> String mkRes ctx node = H.prettyPrint $ buildHaskellModule ctx node pragmas Nothing   where-    pragmas = [ H.LanguagePragma noLoc [H.Ident "OverloadedStrings"],-                H.OptionsPragma noLoc (Just H.GHC) "-fno-warn-unused-imports"]+    pragmas :: [N.ModulePragma]+    pragmas = [ H.LanguagePragma () [H.Ident () "OverloadedStrings"]+              , H.OptionsPragma () (Just H.GHC) "-fno-warn-unused-imports"+              ]     _warningText = "Warning!! This is automatically generated code, do not modify!"  buildHaskellModule :: HaskellContext -> ApiResource ->-                      [H.ModulePragma] -> Maybe H.WarningText ->-                      H.Module+                      [N.ModulePragma] -> Maybe N.WarningText ->+                      N.Module buildHaskellModule ctx node pragmas warningText =   rewriteModuleNames (rewrites ctx) $-     H.Module noLoc name pragmas warningText exportSpecs importDecls decls+     H.Module () (Just $ H.ModuleHead () name warningText exportSpecs) pragmas importDecls decls   where-    name = H.ModuleName $ qualModName $ namespace ctx ++ resId node+    name :: N.ModuleName+    name = H.ModuleName () $ qualModName $ namespace ctx ++ resId node+    exportSpecs :: Maybe N.ExportSpecList     exportSpecs = Nothing+    importDecls :: [N.ImportDecl]     importDecls = nub $ namedImport "Rest.Client.Internal"                       : extraImports                      ++ parentImports                      ++ dataImports                      ++ idImports+    decls :: [N.Decl]     decls = idData node ++ concat funcs +    extraImports :: [N.ImportDecl]     extraImports = imports ctx+    parentImports :: [N.ImportDecl]     parentImports = map mkImport . tail . inits . resParents $ node+    dataImports :: [N.ImportDecl]     dataImports = map (qualImport . unModuleName) datImp+    idImports :: [N.ImportDecl]     idImports = concat . mapMaybe (return . map (qualImport . unModuleName) . Ident.haskellModules <=< snd) . resAccessors $ node +    funcs :: [[N.Decl]]+    datImp :: [N.ModuleName]     (funcs, datImp) = second (nub . concat) . unzip . map (mkFunction (apiVersion ctx) . resName $ node) $ resItems node-    mkImport p = (namedImport importName) { H.importQualified = True,-                                            H.importAs = importAs' }-      where importName = qualModName $ namespace ctx ++ p-            importAs' = fmap (H.ModuleName . modName) . lastMay $ p+    mkImport :: [String] -> N.ImportDecl+    mkImport p = (namedImport importName)+                   { H.importQualified = True+                   , H.importAs        = importAs'+                   }+      where+        importName :: String+        importName = qualModName $ namespace ctx ++ p+        importAs' :: Maybe N.ModuleName+        importAs' = fmap (H.ModuleName () . modName) . lastMay $ p -rewriteModuleNames :: [(H.ModuleName, H.ModuleName)] -> H.Module -> H.Module+rewriteModuleNames :: [(N.ModuleName, N.ModuleName)] -> N.Module -> N.Module rewriteModuleNames rews = U.transformBi $ \m -> lookupJustDef m m rews -#if MIN_VERSION_haskell_src_exts(1,17,0)-noBinds :: Maybe H.Binds+noBinds :: Maybe N.Binds noBinds = Nothing-#else-noBinds :: H.Binds-noBinds = H.BDecls []-#endif -use :: H.Name -> H.Exp-use = H.Var . H.UnQual+use :: N.Name -> N.Exp+use = H.Var () . H.UnQual () -useMQual :: (Maybe H.ModuleName) -> H.Name -> H.Exp+useMQual :: Maybe N.ModuleName -> N.Name -> N.Exp useMQual Nothing = use-useMQual (Just qual) = H.Var . (H.Qual $ qual)+useMQual (Just qual) = H.Var () . (H.Qual () qual) -mkFunction :: Version -> String -> ApiAction -> ([H.Decl], [H.ModuleName])+mkFunction :: Version -> String -> ApiAction -> ([N.Decl], [N.ModuleName]) mkFunction ver res (ApiAction _ lnk ai) =-  ([H.TypeSig noLoc [funName] fType,-    H.FunBind [H.Match noLoc funName fParams Nothing rhs noBinds]],+  ([H.TypeSig () [funName] fType,+    H.FunBind () [H.Match () funName fParams rhs noBinds]],     responseModules errorI ++ responseModules output ++ maybe [] inputModules mInp)      where+       funName :: N.Name        funName = mkHsName ai-       fParams = map H.PVar $ lPars+       fParams :: [N.Pat]+       fParams = map (H.PVar ()) $ lPars                            ++ maybe [] ((:[]) . hsName . cleanName . description) (ident ai)                            ++ maybe [] (const [input]) mInp                            ++ (if null (params ai) then [] else [pList])+       lUrl :: N.Exp+       lPars :: [N.Name]        (lUrl, lPars) = linkToURL res lnk        mInp :: Maybe InputInfo-       mInp    = fmap (inputInfo . L.get desc . chooseType) . NList.nonEmpty . inputs $ ai-       fType   = H.TyForall Nothing [H.ClassA (H.UnQual cls) [m]] $ fTypify tyParts-         where cls = H.Ident "ApiStateC"-               m = H.TyVar $ H.Ident "m"-               fTypify :: [H.Type] -> H.Type-               fTypify [] = error "Rest.Gen.Haskell.mkFunction.fTypify - expects at least one type"-               fTypify [ty1] = ty1-               fTypify [ty1, ty2] = H.TyFun ty1 ty2-               fTypify (ty1 : tys) = H.TyFun ty1 (fTypify tys)-               tyParts = map qualIdent lPars-                         ++ maybe [] (return . Ident.haskellType) (ident ai)-                         ++ inp-                         ++ (if null (params ai) then []-                             else [H.TyList (H.TyTuple H.Boxed [haskellStringType,-                                                                haskellStringType])])-                         ++ [H.TyApp m (H.TyApp-                                         (H.TyApp-                                           (H.TyCon $ H.UnQual (H.Ident "ApiResponse"))-                                           (responseHaskellType errorI))-                                         (responseHaskellType output))]-               qualIdent (H.Ident s)-                 | s == cleanHsName res = H.TyCon $ H.UnQual tyIdent-                 | otherwise = H.TyCon $ H.Qual (H.ModuleName $ modName s) tyIdent-               qualIdent H.Symbol{} = error "Rest.Gen.Haskell.mkFunction.qualIdent - not expecting a Symbol"-               inp | Just i  <- mInp-                   , i' <- inputHaskellType i = [i']-                   | otherwise = []-       input = H.Ident "input"-       pList = H.Ident "pList"-       rhs = H.UnGuardedRhs $ H.Let binds expr-         where binds = H.BDecls [rHeadersBind, requestBind]-               rHeadersBind =-                 H.PatBind noLoc (H.PVar rHeaders)-#if !MIN_VERSION_haskell_src_exts(1,16,0)-                    Nothing-#endif-                    (H.UnGuardedRhs $ H.List [H.Tuple H.Boxed [use hAccept     , H.Lit $ H.String $ dataTypesToAcceptHeader JSON $ responseAcceptType responseType],-                                              H.Tuple H.Boxed [use hContentType, H.Lit $ H.String $ maybe "text/plain" inputContentType mInp]])-                              noBinds+       mInp = fmap (inputInfo . L.get desc . chooseType) . NList.nonEmpty . inputs $ ai+       fType :: N.Type+       fType = H.TyForall () Nothing (Just ctx) $ fTypify tyParts+         where+           ctx :: N.Context+           ctx = H.CxSingle () $ H.ClassA () (H.UnQual () cls) [m]+           cls :: N.Name+           cls = H.Ident () "ApiStateC"+           m :: N.Type+           m = H.TyVar () $ H.Ident () "m"+           fTypify :: [N.Type] -> N.Type+           fTypify = \case+             []          -> error "Rest.Gen.Haskell.mkFunction.fTypify - expects at least one type"+             [ty1]       -> ty1+             [ty1, ty2]  -> H.TyFun () ty1 ty2+             (ty1 : tys) -> H.TyFun () ty1 (fTypify tys)+           tyParts :: [N.Type]+           tyParts = map qualIdent lPars+                  ++ maybe [] (return . Ident.haskellType) (ident ai)+                  ++ inp+                  ++ (if null (params ai)+                      then []+                      else [H.TyList ()+                              (H.TyTuple () H.Boxed+                                [ haskellStringType+                                , haskellStringType+                                ])])+                  ++ [H.TyApp () m+                        (H.TyApp ()+                          (H.TyApp ()+                            (H.TyCon () $ H.UnQual () (H.Ident () "ApiResponse"))+                            (responseHaskellType errorI))+                          (responseHaskellType output))]+           qualIdent :: N.Name -> N.Type+           qualIdent = \case+             (H.Ident _ s)+               | s == cleanHsName res -> H.TyCon () $ H.UnQual () tyIdent+               | otherwise            -> H.TyCon () $ H.Qual () (H.ModuleName () $ modName s) tyIdent+             H.Symbol{}               -> error "Rest.Gen.Haskell.mkFunction.qualIdent - not expecting a Symbol"+           inp :: [N.Type]+           inp | Just i <- mInp+               , i' <- inputHaskellType i = [i']+               | otherwise = []+       input :: N.Name+       input = H.Ident () "input"+       pList :: N.Name+       pList = H.Ident () "pList"+       rhs :: N.Rhs+       rhs = H.UnGuardedRhs () $ H.Let () binds expr+         where+           binds :: N.Binds+           binds = H.BDecls () [rHeadersBind, requestBind]+           rHeadersBind :: N.Decl+           rHeadersBind =+             H.PatBind () (H.PVar () rHeaders)+               (H.UnGuardedRhs () $+                 H.List ()+                   [ H.Tuple () H.Boxed+                     [ use hAccept+                     , stringLit $ dataTypesToAcceptHeader JSON $ responseAcceptType responseType+                     ]+                   , H.Tuple () H.Boxed+                     [ use hContentType+                     , stringLit $ maybe "text/plain" inputContentType mInp+                     ]])+               noBinds -               rHeaders     = H.Ident "rHeaders"-               hAccept      = H.Ident "hAccept"-               hContentType = H.Ident "hContentType"-               doRequest    = H.Ident "doRequest"+           rHeaders     :: N.Name+           rHeaders     = H.Ident () "rHeaders"+           hAccept      :: N.Name+           hAccept      = H.Ident () "hAccept"+           hContentType :: N.Name+           hContentType = H.Ident () "hContentType"+           doRequest    :: N.Name+           doRequest    = H.Ident () "doRequest" -               requestBind =-                 H.PatBind noLoc (H.PVar request)-#if !MIN_VERSION_haskell_src_exts(1,16,0)-                    Nothing-#endif-                    (H.UnGuardedRhs $-                      appLast-                        (H.App-                          (H.App-                            (H.App-                              (H.App (H.App (use makeReq) (H.Lit $ H.String $ show $ method ai))-                                     (H.Lit $ H.String ve))-                              url)-                            (if null (params ai) then (H.List []) else (use pList)))-                          (use rHeaders))) noBinds-               appLast e-                 | Just i <- mInp = H.App e (H.App (use $ H.Ident $ inputFunc i) (use input))-                 | otherwise = H.App e (H.Lit $ H.String "")-               makeReq = H.Ident "makeReq"-               request = H.Ident "request"+           requestBind :: N.Decl+           requestBind =+             H.PatBind () (H.PVar () request)+                (H.UnGuardedRhs () $+                  appLast+                    (H.App ()+                      (H.App ()+                        (H.App ()+                          (H.App () (H.App () (use makeReq) (stringLit str)) (stringLit ve))+                          url)+                        (if null (params ai) then H.List () [] else use pList))+                      (use rHeaders))) noBinds+             where+               str = show $ method ai+           appLast :: N.Exp -> N.Exp+           appLast e+             | Just i <- mInp = H.App () e (H.App () (use $ H.Ident () $ inputFunc i) (use input))+             | otherwise = H.App () e (stringLit "")+           makeReq :: N.Name+           makeReq = H.Ident () "makeReq"+           request :: N.Name+           request = H.Ident () "request" -               expr = H.App (H.App (H.App (use doRequest)-                                          (use $ H.Ident $ responseFunc errorI))-                                          (use $ H.Ident $ responseFunc output)) (use request)+           expr :: N.Exp+           expr = H.App () (H.App () (H.App () (use doRequest)+                                      (use . H.Ident () $ responseFunc errorI))+                                      (use . H.Ident () $ responseFunc output))+                                      (use request) +       ve :: String+       url :: N.Exp        (ve, url) = ("v" ++ show ver, lUrl)        errorI :: ResponseInfo        errorI = errorInfo responseType        output :: ResponseInfo        output = outputInfo responseType+       responseType :: ResponseType        responseType = chooseResponseType ai -linkToURL :: String -> Link -> (H.Exp, [H.Name])-linkToURL res lnk = first H.List $ urlParts res lnk ([], [])+linkToURL :: String -> Link -> (N.Exp, [N.Name])+linkToURL res lnk = first (H.List ()) $ urlParts res lnk ([], []) -urlParts :: String -> Link -> ([H.Exp], [H.Name]) -> ([H.Exp], [H.Name])+urlParts :: String -> Link -> ([N.Exp], [N.Name]) -> ([N.Exp], [N.Name]) urlParts res lnk ac@(rlnk, pars) =   case lnk of     [] -> ac     (LResource r : a@(LAccess _) : xs)-      | not (hasParam a) -> urlParts res xs (rlnk ++ [H.List [H.Lit $ H.String r]], pars)-      | otherwise -> urlParts res xs (rlnk', pars ++ [H.Ident . cleanHsName $ r])-           where rlnk' = rlnk ++ (H.List [H.Lit $ H.String $ r] : tailed)-                 tailed = [H.App (useMQual qual $ H.Ident "readId")-                                 (use $ hsName (cleanName r))]-                   where qual | r == res = Nothing-                              | otherwise = Just $ H.ModuleName $ modName r-    (LParam p : xs) -> urlParts res xs (rlnk ++ [H.List [H.App (use $ H.Ident "showUrl")+      | not (hasParam a) -> urlParts res xs (rlnk ++ [H.List () [stringLit r]], pars)+      | otherwise -> urlParts res xs (rlnk', pars ++ [H.Ident () . cleanHsName $ r])+           where+             rlnk' = rlnk ++ (H.List () [stringLit r] : tailed)+             tailed = [H.App () (useMQual qual $ H.Ident () "readId")+                             (use . hsName $ cleanName r)]+               where+                 qual :: Maybe N.ModuleName+                 qual | r == res  = Nothing+                      | otherwise = Just . H.ModuleName () $ modName r+    (LParam p : xs) -> urlParts res xs (rlnk ++ [H.List () [H.App () (use $ H.Ident () "showUrl")                                                           (use $ hsName (cleanName p))]], pars)-    (i : xs) -> urlParts res xs (rlnk ++ [H.List [H.Lit $ H.String $ itemString i]], pars)+    (i : xs) -> urlParts res xs (rlnk ++ [H.List () [stringLit $ itemString i]], pars) -idData :: ApiResource -> [H.Decl]+idData :: ApiResource -> [N.Decl] idData node =   case resAccessors node of     [] -> []     [(_pth, Nothing)] -> []     [(pth, Just i)] ->       let pp xs | null pth = xs-                | otherwise = H.Lit (H.String pth) : xs-      in [ H.TypeDecl noLoc tyIdent [] (Ident.haskellType i),-           H.TypeSig noLoc [funName] fType,-           H.FunBind [ H.Match noLoc funName [H.PVar x] Nothing-                       (H.UnGuardedRhs $ H.List $ pp [ showURLx ]) noBinds] ]+                | otherwise = stringLit pth : xs+      in [ H.TypeDecl () (H.DHead () tyIdent) (Ident.haskellType i),+           H.TypeSig () [funName] fType,+           H.FunBind () [ H.Match () funName [H.PVar () x]+                            (H.UnGuardedRhs () $ H.List () $ pp [showURLx])+                            noBinds+                        ]+         ]     ls ->-      let ctor (pth,mi) =-            H.QualConDecl noLoc [] [] (H.ConDecl (H.Ident (dataName pth)) $ maybe [] f mi)-#if MIN_VERSION_haskell_src_exts(1,16,0)-              where f ty = [Ident.haskellType ty]-#else-              where f ty = [H.UnBangedTy $ Ident.haskellType ty]-#endif-          fun (pth, mi) = [-                           H.FunBind [H.Match noLoc funName fparams Nothing rhs noBinds]]-            where (fparams, rhs) =-                    case mi of-                      Nothing ->-                        ([H.PVar $ H.Ident (dataName pth)],-                         (H.UnGuardedRhs $ H.List [H.Lit (H.String pth)]))-                      Just{}  ->  -- Pattern match with data constructor-                        ([H.PParen $ H.PApp (H.UnQual $ H.Ident (dataName pth)) [H.PVar x]],-                         (H.UnGuardedRhs $ H.List [H.Lit $ H.String pth, showURLx]))-      in [ H.DataDecl noLoc H.DataType [] tyIdent [] (map ctor ls) []-         , H.TypeSig noLoc [funName] fType+      let ctor :: (String, Maybe Ident) -> N.QualConDecl+          ctor (pth,mi) =+            H.QualConDecl () Nothing Nothing (H.ConDecl () (H.Ident () (dataName pth)) $ maybe [] f mi)+              where+                f ty = [Ident.haskellType ty]+          fun :: (String, Maybe Ident) -> [N.Decl]+          fun (pth, mi) = [H.FunBind () [H.Match () funName fparams rhs noBinds]]+            where+              (fparams, rhs) =+                case mi of+                  Nothing ->+                    ([H.PVar () $ H.Ident () (dataName pth)],+                     (H.UnGuardedRhs () $ H.List () [stringLit pth]))+                  Just{}  ->  -- Pattern match with data constructor+                    ([H.PParen () $ H.PApp () (H.UnQual () $ H.Ident () (dataName pth)) [H.PVar () x]],+                     (H.UnGuardedRhs () $ H.List () [stringLit pth, showURLx]))+      in [ H.DataDecl () (H.DataType ()) Nothing (H.DHead () tyIdent) (map ctor ls) Nothing+         , H.TypeSig () [funName] fType          ] ++ concatMap fun ls     where-      x        = H.Ident "x"-      fType    = H.TyFun (H.TyCon $ H.UnQual tyIdent) (H.TyList haskellStringType)-      funName  = H.Ident "readId"-      showURLx = H.App (H.Var $ H.UnQual $ H.Ident "showUrl") (H.Var $ H.UnQual $ x)+      x        :: N.Name+      x        = H.Ident () "x"+      fType    :: N.Type+      fType    = H.TyFun () (H.TyCon () $ H.UnQual () tyIdent) (H.TyList () haskellStringType)+      funName  :: N.Name+      funName  = H.Ident () "readId"+      showURLx :: N.Exp+      showURLx = H.App () (H.Var () $ H.UnQual () $ H.Ident () "showUrl") (H.Var () $ H.UnQual () $ x) -tyIdent :: H.Name-tyIdent = H.Ident "Identifier"+tyIdent :: N.Name+tyIdent = H.Ident () "Identifier" -mkHsName :: ActionInfo -> H.Name+mkHsName :: ActionInfo -> N.Name mkHsName ai = hsName $ concatMap cleanName parts   where       parts = case actionType ai of-                Retrieve   -> let nm = get ++ by ++ target-                              in if null nm then ["access"] else nm-                Create     -> ["create"] ++ by ++ target-                -- Should be delete, but delete is a JS keyword and causes problems in collect.-                Delete     -> ["remove"] ++ by ++ target-                DeleteMany -> ["removeMany"] ++ by ++ target-                List       -> ["list"]   ++ by ++ target-                Update     -> ["save"]   ++ by ++ target-                UpdateMany -> ["saveMany"] ++ by ++ target-                Modify   -> if resDir ai == "" then ["do"] else [resDir ai]+        Retrieve   -> case nm of+          [] -> ["access"]+          _  -> nm+          where+            nm = get ++ by ++ target+        Create     -> ["create"] ++ by ++ target+        -- Should be delete, but delete is a JS keyword and causes problems in collect.+        Delete     -> ["remove"] ++ by ++ target+        DeleteMany -> ["removeMany"] ++ by ++ target+        List       -> ["list"] ++ by ++ target+        Update     -> ["save"] ++ by ++ target+        UpdateMany -> ["saveMany"] ++ by ++ target+        Modify   -> if resDir ai == "" then ["do"] else [resDir ai]        target = if resDir ai == "" then maybe [] ((:[]) . description) (ident ai) else [resDir ai]       by     = if target /= [] && (isJust (ident ai) || actionType ai == UpdateMany) then ["by"] else []       get    = if isAccessor ai then [] else ["get"] -hsName :: [String] -> H.Name-hsName []       = H.Ident ""-hsName (x : xs) = H.Ident $ cleanHsName $ downFirst x ++ concatMap upFirst xs+hsName :: [String] -> N.Name+hsName []       = H.Ident () ""+hsName (x : xs) = H.Ident () $ cleanHsName $ downFirst x ++ concatMap upFirst xs  cleanHsName :: String -> String cleanHsName s =@@ -366,8 +434,8 @@ modName = concatMap upFirst . cleanName  data InputInfo = InputInfo-  { inputModules     :: [H.ModuleName]-  , inputHaskellType :: H.Type+  { inputModules     :: [N.ModuleName]+  , inputHaskellType :: N.Type   , inputContentType :: String   , inputFunc        :: String   } deriving (Eq, Show)@@ -375,16 +443,15 @@ inputInfo :: DataDesc -> InputInfo inputInfo dsc =   case L.get dataType dsc of-    String -> InputInfo [] (haskellStringType) "text/plain" "fromString"-    -- TODO fromJusts+    String -> InputInfo [] haskellStringType "text/plain" "toLbs"     XML    -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/xml" "toXML"     JSON   -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/json" "toJSON"     File   -> InputInfo [] haskellByteStringType "application/octet-stream" "id"     Other  -> InputInfo [] haskellByteStringType "text/plain" "id"  data ResponseInfo = ResponseInfo-  { responseModules     :: [H.ModuleName]-  , responseHaskellType :: H.Type+  { responseModules     :: [N.ModuleName]+  , responseHaskellType :: N.Type   , responseFunc        :: String   } deriving (Eq, Show) @@ -429,5 +496,8 @@   DataDesc     { _dataType       = dt     , _haskellType    = haskellVoidType-    , _haskellModules = [ModuleName "Rest.Types.Void"]+    , _haskellModules = [ModuleName () "Rest.Types.Void"]     }++stringLit :: String -> N.Exp+stringLit s = H.Lit () $ H.String () s s

@@ -9,7 +9,6 @@ import Text.StringTemplate import qualified Data.Label.Total             as L import qualified Data.List.NonEmpty           as NList-import qualified Language.Haskell.Exts.Syntax as H  import Code.Build import Code.Build.JavaScript@@ -17,8 +16,9 @@ import Rest.Gen.Base import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation as N -mkJsApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String+mkJsApi :: N.ModuleName -> Bool -> Version -> Router m s -> IO String mkJsApi ns priv ver r =   do prelude <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/prelude.js")      epilogue <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/epilogue.js")

@@ -0,0 +1,42 @@+module Rest.Gen.NoAnnotation where++import qualified Language.Haskell.Exts as A++type Alt = A.Alt ()+type BangType = A.BangType ()+type Binds = A.Binds ()+type ClassDecl = A.ClassDecl ()+type Context = A.Context ()+type Decl = A.Decl ()+type DeclHead = A.DeclHead ()+type Exp = A.Exp ()+type ExportSpec = A.ExportSpec ()+type ExportSpecList = A.ExportSpecList ()+type FieldDecl = A.FieldDecl ()+type FieldUpdate = A.FieldUpdate ()+type GadtDecl = A.GadtDecl ()+type GuardedRhs = A.GuardedRhs ()+type ImportDecl = A.ImportDecl ()+type ImportSpec = A.ImportSpec ()+type Literal = A.Literal ()+type Match = A.Match ()+type Module = A.Module ()+type ModuleName = A.ModuleName ()+type ModulePragma = A.ModulePragma ()+type Name = A.Name ()+type Pat = A.Pat ()+type PatField = A.PatField ()+type QName = A.QName ()+type QOp = A.QOp ()+type QualConDecl = A.QualConDecl ()+type QualStmt = A.QualStmt ()+type Rhs = A.Rhs ()+type Sign = A.Sign ()+type SpecialCon = A.SpecialCon ()+type SrcLoc = A.SrcLoc+type SrcSpan = A.SrcSpan+type SrcSpanInfo = A.SrcSpanInfo+type Stmt = A.Stmt ()+type TyVarBind = A.TyVarBind ()+type Type = A.Type ()+type WarningText = A.WarningText ()

@@ -10,7 +10,6 @@ import Data.Maybe import qualified Data.Label.Total             as L import qualified Data.List.NonEmpty           as NList-import qualified Language.Haskell.Exts.Syntax as H  import Code.Build import Code.Build.Ruby@@ -18,8 +17,9 @@ import Rest.Gen.Base import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation as N -mkRbApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String+mkRbApi :: N.ModuleName -> Bool -> Version -> Router m s -> IO String mkRbApi ns priv ver r =   do rawPrelude <- readContent "Ruby/base.rb"      let prelude = replace "SilkApi" (unModuleName ns) rawPrelude

@@ -17,43 +17,43 @@ import Language.Haskell.Exts.SrcLoc (noLoc) import Language.Haskell.Exts.Syntax (ImportDecl (..), ModuleName (..), Name (..), QName (..), SpecialCon (..), Type (..)) -unModuleName :: ModuleName -> String-unModuleName (ModuleName name) = name+import qualified Rest.Gen.NoAnnotation as N -overModuleName :: (String -> String) -> ModuleName -> ModuleName-overModuleName f = ModuleName . f . unModuleName+unModuleName :: N.ModuleName -> String+unModuleName (ModuleName _ name) = name +overModuleName :: (String -> String) -> N.ModuleName -> N.ModuleName+overModuleName f = ModuleName () . f . unModuleName+ -- | Create a simple named basic import, to be updated with other fields --   as needed.-namedImport :: String -> ImportDecl+namedImport :: String -> N.ImportDecl namedImport name = ImportDecl-  { importLoc       = noLoc+  { importAnn       = ()   , importQualified = False-  , importModule    = ModuleName name+  , importModule    = ModuleName () name   , importSrc       = False-#if MIN_VERSION_haskell_src_exts(1,16,0)   , importSafe      = False-#endif   , importPkg       = Nothing   , importAs        = Nothing   , importSpecs     = Nothing   }  -- | Qualified import with given name-qualImport :: String -> ImportDecl+qualImport :: String -> N.ImportDecl qualImport name = (namedImport name) { importQualified = True } -haskellStringType :: Type+haskellStringType :: N.Type haskellStringType = haskellSimpleType "String" -haskellByteStringType :: Type+haskellByteStringType :: N.Type haskellByteStringType = haskellSimpleType "ByteString" -haskellSimpleType :: String -> Type-haskellSimpleType = TyCon . UnQual . Ident+haskellSimpleType :: String -> N.Type+haskellSimpleType = TyCon () . UnQual () . Ident () -haskellUnitType :: Type-haskellUnitType = TyCon (Special UnitCon)+haskellUnitType :: N.Type+haskellUnitType = TyCon () (Special () (UnitCon ())) -haskellVoidType :: Type-haskellVoidType = TyCon (Qual (ModuleName "Rest.Types.Void") (Ident "Void"))+haskellVoidType :: N.Type+haskellVoidType = TyCon () (Qual () (ModuleName () "Rest.Types.Void") (Ident () "Void"))

@@ -1,12 +1,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE-    OverloadedStrings+    FlexibleInstances+  , OverloadedStrings   , ScopedTypeVariables   #-}  import Prelude hiding ((.))  import Control.Category ((.))+import Control.Monad (void) import Data.String import Test.Framework (defaultMain) import Test.Framework.Providers.HUnit (testCase)@@ -88,5 +90,5 @@     resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler }     listHandler () = mkListing xmlJsonO $ \_ -> return [()] -instance IsString H.Type where-  fromString = H.fromParseResult . H.parse+instance IsString (H.Type ()) where+  fromString = void . H.fromParseResult . H.parseType