diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/rest-gen.cabal b/rest-gen.cabal --- a/rest-gen.cabal +++ b/rest-gen.cabal @@ -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.* diff --git a/src/Rest/Gen.hs b/src/Rest/Gen.hs --- a/src/Rest/Gen.hs +++ b/src/Rest/Gen.hs @@ -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 = diff --git a/src/Rest/Gen/Base/ActionInfo.hs b/src/Rest/Gen/Base/ActionInfo.hs --- a/src/Rest/Gen/Base/ActionInfo.hs +++ b/src/Rest/Gen/Base/ActionInfo.hs @@ -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 diff --git a/src/Rest/Gen/Base/ActionInfo/Ident.hs b/src/Rest/Gen/Base/ActionInfo/Ident.hs --- a/src/Rest/Gen/Base/ActionInfo/Ident.hs +++ b/src/Rest/Gen/Base/ActionInfo/Ident.hs @@ -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) diff --git a/src/Rest/Gen/Haskell.hs b/src/Rest/Gen/Haskell.hs --- a/src/Rest/Gen/Haskell.hs +++ b/src/Rest/Gen/Haskell.hs @@ -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 diff --git a/src/Rest/Gen/JavaScript.hs b/src/Rest/Gen/JavaScript.hs --- a/src/Rest/Gen/JavaScript.hs +++ b/src/Rest/Gen/JavaScript.hs @@ -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") diff --git a/src/Rest/Gen/NoAnnotation.hs b/src/Rest/Gen/NoAnnotation.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Gen/NoAnnotation.hs @@ -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 () diff --git a/src/Rest/Gen/Ruby.hs b/src/Rest/Gen/Ruby.hs --- a/src/Rest/Gen/Ruby.hs +++ b/src/Rest/Gen/Ruby.hs @@ -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 diff --git a/src/Rest/Gen/Types.hs b/src/Rest/Gen/Types.hs --- a/src/Rest/Gen/Types.hs +++ b/src/Rest/Gen/Types.hs @@ -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")) diff --git a/tests/Runner.hs b/tests/Runner.hs --- a/tests/Runner.hs +++ b/tests/Runner.hs @@ -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