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.3
description: Documentation and client generation from rest definition.
synopsis: Documentation and client generation from rest definition.
maintainer: code@silk.co
@@ -46,24 +46,25 @@
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
+ base >= 4.5 && < 4.12
+ , Cabal >= 1.16 && < 2.2
, HStringTemplate >= 0.6 && < 0.9
- , aeson >= 0.7 && < 0.12
+ , aeson >= 0.7 && < 1.4
, base-compat >= 0.8 && < 0.10
- , blaze-html >= 0.5 && < 0.9
+ , blaze-html >= 0.5 && < 0.10
, code-builder == 0.1.*
- , directory >= 1.1 && < 1.3
+ , directory >= 1.1 && < 1.4
, 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.20 && < 1.21
, hxt >= 9.2 && < 9.4
, json-schema >= 0.6 && < 0.8
, pretty >= 1.0 && < 1.2
- , process >= 1.0 && < 1.5
+ , process >= 1.0 && < 1.7
, rest-core >= 0.38 && < 0.40
, safe >= 0.2 && < 0.4
, semigroups >= 0.5 && < 0.19
@@ -72,7 +73,7 @@
, text >= 0.11 && < 1.3
, uniplate >= 1.6.12 && < 1.7
, unordered-containers == 0.2.*
- , vector >= 0.10 && < 0.12
+ , vector >= 0.10 && < 0.13
if impl(ghc < 7.8)
build-depends: tagged >= 0.2 && < 0.9
@@ -82,10 +83,10 @@
type: exitcode-stdio-1.0
ghc-options: -Wall
build-depends:
- base >= 4.5 && < 4.10
- , HUnit >= 1.2 && < 1.4
+ base >= 4.5 && < 4.12
+ , HUnit >= 1.2 && < 1.7
, fclabels >= 1.0.4 && < 2.1
- , haskell-src-exts >= 1.15.0 && < 1.18
+ , haskell-src-exts >= 1.15.0 && < 1.21
, 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.hs b/src/Rest/Gen/Base.hs
--- a/src/Rest/Gen/Base.hs
+++ b/src/Rest/Gen/Base.hs
@@ -1,11 +1,6 @@
-module Rest.Gen.Base
- ( module Rest.Gen.Base.ActionInfo
- , module Rest.Gen.Base.ActionInfo.Ident
- , module Rest.Gen.Base.ApiTree
- , module Rest.Gen.Base.Link
- ) where
+module Rest.Gen.Base (module X) where
-import Rest.Gen.Base.ActionInfo
-import Rest.Gen.Base.ActionInfo.Ident (Ident (Ident, description))
-import Rest.Gen.Base.ApiTree
-import Rest.Gen.Base.Link
+import Rest.Gen.Base.ActionInfo as X
+import Rest.Gen.Base.ActionInfo.Ident as X (Ident (Ident, description))
+import Rest.Gen.Base.ApiTree as X
+import Rest.Gen.Base.Link as X
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
@@ -1,10 +1,14 @@
{-# LANGUAGE
- GADTs
+ CPP
+ , GADTs
, LambdaCase
, NoImplicitPrelude
, ScopedTypeVariables
, TemplateHaskell
#-}
+#if MIN_VERSION_base(4,9,0)
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+#endif
module Rest.Gen.Base.ActionInfo
( Accessor
, ActionInfo (..)
@@ -79,6 +83,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 +104,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 +145,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
@@ -178,9 +183,7 @@
dataTypesToAcceptHeader def = \case
[] -> dataTypeToAcceptHeader def
xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $
- if null (intersect xs [XML,JSON])
- then [def]
- else []
+ [def | null (xs `intersect` [XML, JSON])]
dataTypeToAcceptHeader :: DataType -> String
dataTypeToAcceptHeader = \case
@@ -218,7 +221,7 @@
intersection :: NonEmpty DataDescription -> NonEmpty DataDescription -> ResponseType
intersection o e =
-- Try to find a response type that can be used for both output and error.
- case intersect (f o) (f e) of
+ case f o `intersect` f e of
-- If the response types are disjoint we need to specify both.
[] ->
ResponseType
@@ -237,7 +240,7 @@
-- Prioritize formats
. sortBy (comparing cmp)
-- Pick only the data types in the intersection of outputs and errors
- . filter ((`elem` dts) . (L.get (dataType . desc)))
+ . filter ((`elem` dts) . L.get (dataType . desc))
. NList.toList
-- When we have an intersection with multiple possible
-- types, we prefer JSON over XML, and XML over the rest.
@@ -345,7 +348,7 @@
<$> mkMultiHandler id_ (const id) h
removeActionInfo :: Link -> Handler m -> ActionInfo
-removeActionInfo lnk = handlerActionInfo Nothing True Delete Self "" DELETE lnk
+removeActionInfo = handlerActionInfo Nothing True Delete Self "" DELETE
multiRemoveActionInfo :: Monad m => Id sid -> String -> Handler m -> Maybe ActionInfo
multiRemoveActionInfo id_ pth h = handlerActionInfo Nothing False DeleteMany Any pth DELETE []
@@ -395,9 +398,7 @@
makeLink
| postAct = ac ++ dirPart ++ identPart
| otherwise = dirPart ++ identPart
- where dirPart = if pth /= ""
- then [LAction pth]
- else []
+ where dirPart = [LAction pth | pth /= ""]
identPart = maybe [] ((:[]) . LParam . Ident.description) id_
@@ -464,6 +465,7 @@
-- so we stick with the convention of preferring JSON.
RawJsonAndXmlO -> defaultDescription File "File" haskellStringType
FileO -> defaultDescription File "File" haskellByteStringType
+ -- TODO: MultiPartO
-- | Extract input description from handlers
handlerErrors :: Handler m -> [DataDescription]
@@ -491,16 +493,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/Base/JSON.hs b/src/Rest/Gen/Base/JSON.hs
--- a/src/Rest/Gen/Base/JSON.hs
+++ b/src/Rest/Gen/Base/JSON.hs
@@ -7,6 +7,7 @@
, showExamples
) where
+import Control.Applicative ((<|>))
import Data.Aeson ((.=))
import Data.JSON.Schema
import Data.List (transpose)
@@ -104,7 +105,7 @@
boundExample :: Num a => Bound -> a
-boundExample b = fromIntegral $ fromMaybe 0 (maybe (lower b) Just (upper b))
+boundExample b = fromIntegral . fromMaybe 0 $ upper b <|> lower b
lengthBoundExample :: Num a => LengthBound -> a
-lengthBoundExample b = fromIntegral $ fromMaybe 0 (maybe (lowerLength b) Just (upperLength b))
+lengthBoundExample b = fromIntegral $ fromMaybe 0 (upperLength b <|> lowerLength b)
diff --git a/src/Rest/Gen/Base/JSON/Pretty.hs b/src/Rest/Gen/Base/JSON/Pretty.hs
--- a/src/Rest/Gen/Base/JSON/Pretty.hs
+++ b/src/Rest/Gen/Base/JSON/Pretty.hs
@@ -1,5 +1,7 @@
module Rest.Gen.Base.JSON.Pretty (pp_value) where
+import Prelude hiding ((<>))
+
import Control.Arrow (first)
import Data.Aeson.Types
import Data.Char
@@ -11,6 +13,8 @@
import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
+{-# ANN module "Hlint: ignore Use camelCase" #-}
+
pp_value :: Value -> Doc
pp_value v = case v of
Null -> pp_null
@@ -55,7 +59,7 @@
where pp_field (k,v) = pp_string k <> colon <+> pp_value v
pp_js_string :: String -> Doc
-pp_js_string x = pp_string x
+pp_js_string = pp_string
pp_js_object :: HashMap Text Value -> Doc
pp_js_object = pp_object . map (first unpack) . H.toList
diff --git a/src/Rest/Gen/Base/Link.hs b/src/Rest/Gen/Base/Link.hs
--- a/src/Rest/Gen/Base/Link.hs
+++ b/src/Rest/Gen/Base/Link.hs
@@ -69,16 +69,16 @@
getLinkIds :: Link -> [(String, [(String, String)])]
getLinkIds l =
case l of
- [] -> []
- (q: (LParam p) : rs) -> (itemString q, [(itemString q, p)]) : getLinkIds rs
- (q: (LAccess ls) : rs) -> (itemString q, concatMap snd $ concatMap (getLinkIds . (q : )) ls) : getLinkIds rs
- (_: rs) -> getLinkIds rs
+ [] -> []
+ (q: LParam p : rs) -> (itemString q, [(itemString q, p)]) : getLinkIds rs
+ (q: LAccess ls : rs) -> (itemString q, concatMap snd $ concatMap (getLinkIds . (q : )) ls) : getLinkIds rs
+ (_: rs) -> getLinkIds rs
setLinkIds :: Link -> [String] -> String
setLinkIds _ [] = error "Error in setLinkIds, not enough parameters"
setLinkIds l (p : ps) =
case l of
[] -> ""
- (_: (LParam _) : rs) -> "/" ++ p ++ setLinkIds rs ps
- (_: (LAccess _) : rs) -> "/" ++ p ++ setLinkIds rs ps
+ (_: LParam _ : rs) -> "/" ++ p ++ setLinkIds rs ps
+ (_: LAccess _ : rs) -> "/" ++ p ++ setLinkIds rs ps
(s: rs) -> "/" ++ itemString s ++ setLinkIds rs (p: ps)
diff --git a/src/Rest/Gen/Base/XML.hs b/src/Rest/Gen/Base/XML.hs
--- a/src/Rest/Gen/Base/XML.hs
+++ b/src/Rest/Gen/Base/XML.hs
@@ -41,9 +41,9 @@
++ indent (concatMap (showSchema' "") ss)
++ [""]
- showSchema' ats (Rep l u s) = showSchema' (ats ++ concatMap (' ':) (mn ++ mx)) s
- where mn = if l >= 0 then ["minOccurs=" ++ show l] else []
- mx = if u >= 0 then ["maxOccurs=" ++ show u] else []
+ showSchema' ats (Rep _ u s) = showSchema' (unwords $ ats : mn ++ mx) s
+ where mn = ["minOccurs=" ++ show u | u >= 0]
+ mx = ["maxOccurs=" ++ show u | u >= 0]
showSchema' ats (Element n (CharData dty)) = [""]
showSchema' ats (Element n (Seq [])) = [""]
diff --git a/src/Rest/Gen/Docs.hs b/src/Rest/Gen/Docs.hs
--- a/src/Rest/Gen/Docs.hs
+++ b/src/Rest/Gen/Docs.hs
@@ -11,7 +11,7 @@
, writeDocs
) where
-import Prelude hiding (div, head, id, id, span, (.))
+import Prelude hiding (div, head, span, (.))
import qualified Prelude as P
import Control.Category ((.))
@@ -24,10 +24,11 @@
import System.FilePath
import Text.Blaze.Html
import Text.Blaze.Html5 hiding (map, meta, style)
-import Text.Blaze.Html5.Attributes hiding (method, span, title)
+import Text.Blaze.Html5.Attributes hiding (id, method, span, title)
import Text.Blaze.Html.Renderer.String
import Text.StringTemplate
-import qualified Data.Label.Total as L
+import qualified Data.Label.Total as L
+import qualified Text.Blaze.Html5.Attributes as A
import Rest.Api (Router, Version)
import Rest.Gen.Base
@@ -101,10 +102,10 @@
-- | Recursively generate information for a resource structure
resourcesInfo :: DocsContext -> ApiResource -> Html
-resourcesInfo ctx = foldTree $ (\it -> sequence_ . (resourceInfo ctx it :) )
+resourcesInfo ctx = foldTree $ \it -> sequence_ . (resourceInfo ctx it :)
subResourcesInfo :: DocsContext -> ApiResource -> Html
-subResourcesInfo ctx = foldTreeChildren sequence_ $ (\it -> sequence_ . (resourceInfo ctx it :) )
+subResourcesInfo ctx = foldTreeChildren sequence_ $ \it -> sequence_ . (resourceInfo ctx it :)
-- | Generate information for one resource
resourceInfo :: DocsContext -> ApiResource -> Html
@@ -125,16 +126,16 @@
resourceIdentifiers lnk lnks =
case lnks of
[] -> [toHtml "No identifiers"]
- ls -> map (linkHtml . (lnk ++)) $ ls
+ ls -> map (linkHtml . (lnk ++)) ls
resourceTable :: ApiResource -> Html
resourceTable it =
let urlInfo = groupByFirst . concatMap (\ai -> map (,itemInfo ai) $ flattenLast $ itemLink ai) $ resItems it
in table ! cls "bordered-table resource-table" $
do thead $ mapM_ (\v -> th ! cls v $ toHtml v) ["URL", "Method", "Description", "Input", "Output", "Errors", "Parameters"]
- tbody $ flip mapM_ (zip [(1 :: Int)..] urlInfo) $ \(n, (url, ais)) ->
- do tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-main-row") $ mapM_ td $
- [ linkHtml $ url
+ tbody $ forM_ (zip [(1 :: Int)..] urlInfo) $ \(n, (url, ais)) ->
+ do tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-main-row") $ mapM_ td
+ [ linkHtml url
, toHtml $ show $ method $ P.head ais
, toHtml $ mkActionDescription (resName it) $ P.head ais
, dataDescriptions "None" $ inputs $ P.head ais
@@ -142,8 +143,8 @@
, dataDescriptions "None" $ errors $ P.head ais
, toHtml $ if null (params (P.head ais)) then "None" else intercalate ", " $ params $ P.head ais
]
- flip mapM_ (tail ais) $ \ai ->
- tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-data-row") $ mapM_ td $
+ forM_ (tail ais) $ \ai ->
+ tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-data-row") $ mapM_ td
[ return ()
, toHtml $ show $ method ai
, toHtml $ mkActionDescription (resName it) ai
@@ -172,13 +173,13 @@
mkCode :: String -> String -> String -> Html
mkCode lng cap cd =
let eid = "idv" ++ show (hash cd)
- in do div ! cls "modal hide fade code" ! id (toValue eid) $
+ in do div ! cls "modal hide fade code" ! A.id (toValue eid) $
do cdiv "modal-header" $
do a ! href (toValue "#") ! cls "close" $ toHtml "x"
h3 $ toHtml cap
cdiv "modal-body" $
div ! style (toValue "overflow:auto; max-height:600px") $
- pre ! cls ("prettyprint lang-" ++ lng) $ toHtml $ cd
+ pre ! cls ("prettyprint lang-" ++ lng) $ toHtml cd
button ! cls "btn open-modal"
! customAttribute (fromString "data-controls-modal") (toValue eid)
! customAttribute (fromString "data-backdrop") (toValue "true")
@@ -204,5 +205,5 @@
linkHtml = mapM_ linkItem
where linkItem (LParam idf) = toHtml ("/<" ++ idf ++ ">")
linkItem (LAccess lnks) = span ! class_ (toValue "link-block") $ sequence_ $ intersperse br
- $ map linkHtml $ reverse $ sortBy (compare `on` length) lnks
+ $ map linkHtml $ sortBy (flip compare `on` length) lnks
linkItem x = toHtml ("/" ++ itemString x)
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]
}
@@ -85,32 +86,58 @@
updateExposedModules modules = modify _condLibrary (Just . maybe (mkCondLibrary modules) (set (_exposedModules . _condTreeData) modules))
mkGenericPackageDescription :: String -> [Cabal.ModuleName] -> Cabal.GenericPackageDescription
-mkGenericPackageDescription name modules = Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []
+mkGenericPackageDescription name modules =
+#if MIN_VERSION_Cabal(2,0,0)
+ Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] [] [] []
+#else
+ Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []
+#endif
where
pkg = Cabal.emptyPackageDescription
- { Cabal.package = Cabal.PackageIdentifier (Cabal.PackageName name) (Cabal.Version [0, 1] [])
+ { Cabal.package = Cabal.PackageIdentifier (cabalPackageName name) (cabalVersion [0, 1])
, Cabal.buildType = Just Cabal.Simple
- , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (Cabal.Version [1, 8] []))
+ , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (cabalVersion [1, 8]))
}
mkCondLibrary :: [Cabal.ModuleName] -> Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library
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 (cabalPackageName "base") (Cabal.withinVersion $ cabalVersion [4] )
+ , Cabal.Dependency (cabalPackageName "rest-types") (Cabal.withinVersion $ cabalVersion [1, 10] )
+ , Cabal.Dependency (cabalPackageName "rest-client") (Cabal.withinVersion $ cabalVersion [0, 5, 2])
]
, Cabal.condTreeComponents = []
}
cabalLibrary :: [Cabal.ModuleName] -> Cabal.Library
+#if MIN_VERSION_Cabal(2,0,0)
+cabalLibrary mods = Cabal.emptyLibrary
+ { Cabal.exposedModules = mods
+ , Cabal.libBuildInfo = (Cabal.libBuildInfo Cabal.emptyLibrary) { Cabal.hsSourceDirs = ["src"] }
+ }
+#else
#if MIN_VERSION_Cabal(1,22,0)
cabalLibrary mods = Cabal.Library mods [] [] [] True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] }
#else
cabalLibrary mods = Cabal.Library mods True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] }
#endif
+#endif
+cabalVersion :: [Int] -> Cabal.Version
+#if MIN_VERSION_Cabal(2,0,0)
+cabalVersion = Cabal.mkVersion
+#else
+cabalVersion v = Cabal.Version v []
+#endif
+
+cabalPackageName :: String -> Cabal.PackageName
+#if MIN_VERSION_Cabal(2,0,0)
+cabalPackageName = Cabal.mkPackageName
+#else
+cabalPackageName = Cabal.PackageName
+#endif
+
writeRes :: HaskellContext -> ApiResource -> IO ()
writeRes ctx node =
do createDirectoryIfMissing True (targetPath ctx "src" modPath (namespace ctx ++ resParents node))
@@ -119,228 +146,296 @@
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) []
+ , 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"]
+ by = ["by" | target /= [] && (isJust (ident ai) || actionType ai == UpdateMany)]
+ get = ["get" | not (isAccessor ai)]
-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 +461,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 +470,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 +523,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
@@ -4,12 +4,10 @@
import Prelude hiding ((.))
import Control.Category ((.))
-import Control.Monad
import Data.Maybe
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 qualified Data.Label.Total as L
+import qualified Data.List.NonEmpty as NList
import Code.Build
import Code.Build.JavaScript
@@ -17,11 +15,12 @@
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")
+ do prelude <- render . setManyAttrib attrs . newSTMP <$> readContent "Javascript/prelude.js"
+ epilogue <- render . setManyAttrib attrs . newSTMP <$> readContent "Javascript/epilogue.js"
let cod = showCode $ mkStack
[ unModuleName ns ++ ".prototype.version" .=. string (show ver)
, mkJsCode (unModuleName ns) priv r
@@ -39,7 +38,7 @@
mkJs ns = foldTreeChildren mkStack (\i ls -> mkStack $ mkRes ns i : ls)
mkRes :: String -> ApiResource -> Code
-mkRes ns node = mkStack $
+mkRes ns node = mkStack
[ if hasAccessor node
then resourceLoc ns node .=. mkAccessorConstructor ns node
else resourceLoc ns node .=. jsObject []
@@ -80,8 +79,8 @@
let fParams = maybeToList mIdent
urlPart = (if resDir ai == "" then "" else resDir ai ++ "/")
++ maybe "" (\i -> "' + encodeURIComponent(" ++ i ++ ") + '/") mIdent
- mIdent = fmap (jsId . cleanName . description) $ ident ai
- in function fParams $
+ mIdent = jsId . cleanName . description <$> ident ai
+ in function fParams
[ var "postfix" $ "'" ++ urlPart ++ "'"
, var "accessor" $ new "this" . code $ "this.contextUrl + postfix, "
++ "this.secureContextUrl + postfix, "
@@ -100,16 +99,16 @@
urlPart = (if isAccessor ai then const "" else id) $
(if resDir ai == "" then "" else resDir ai ++ "/")
++ maybe "" (\i -> "' + encodeURIComponent(" ++ i ++ ") + '/") mIdent
- mIdent = (if isAccessor ai then const Nothing else id) $ fmap (jsId . cleanName . description) $ ident ai
+ mIdent = (if isAccessor ai then const Nothing else id) $ jsId . cleanName . description <$> ident ai
in function fParams $ ret $
call (ns ++ "." ++ "ajaxCall")
[ string (method ai)
- , code $ (if (https ai) then "this.secureContextUrl" else "this.contextUrl") ++ " + '" ++ urlPart ++ "'"
+ , code $ (if https ai then "this.secureContextUrl" else "this.contextUrl") ++ " + '" ++ urlPart ++ "'"
, code "params"
, code "success"
, code "error"
, string $ maybe "text/plain" snd3 mInp
- , string $ mOut
+ , string mOut
, maybe (code "undefined") (\(p, _, f) -> f (code p)) mInp
, code "callOpts"
, code "this.modifyRequest"
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
@@ -39,8 +39,8 @@
apiConstructor :: Version -> ApiResource -> Code
apiConstructor ver node =
- rbClass "BaseApi" $
- [ function "initialize" ["resUrl"] $ mkStack $
+ rbClass "BaseApi"
+ [ function "initialize" ["resUrl"] $ mkStack
[ "@url" .=. ("resUrl + '/v" ++ show ver ++ "/'")
, "@api" .=. "self"
]
@@ -68,11 +68,11 @@
]
mkPostFuncs :: ApiResource -> Code
-mkPostFuncs node = mkStack . map mkFunction . filter (postAction . itemInfo) . resItems $ node
+mkPostFuncs = mkStack . map mkFunction . filter (postAction . itemInfo) . resItems
mkPreFuncs :: ApiResource -> Code
mkPreFuncs node =
- let (acs, funcs) = partition (isAccessor . itemInfo) . filter ((\i -> not $ postAction i) . itemInfo) $ resItems node
+ let (acs, funcs) = partition (isAccessor . itemInfo) . filter (not . postAction . itemInfo) $ resItems node
in mkStack (map mkAccessor acs) <-> mkStack (map mkFunction funcs)
mkAccessor :: ApiAction -> Code
@@ -82,7 +82,7 @@
++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent
datType = maybe ":data" ((':':) . fst3 . mkType . L.get (dataType . desc) . chooseType)
. NList.nonEmpty . outputs $ ai
- mIdent = fmap (rbName . cleanName . description) $ ident ai
+ mIdent = rbName . cleanName . description <$> ident ai
in function (rbName $ mkFuncParts node) fParams $ ret $
new (className rid) ["@url + '" ++ urlPart ++ "'", "@api", datType]
@@ -96,9 +96,9 @@
mOut = fmap (mkType . L.get (dataType . desc) . chooseType) . NList.nonEmpty . outputs $ ai
urlPart = (if resDir ai == "" then "" else resDir ai ++ "/")
++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent
- mIdent = fmap (rbName . cleanName . description) $ ident ai
+ mIdent = rbName . cleanName . description <$> ident ai
in function (rbName $ mkFuncParts node) fParams $
- call ("internalSilkRequest")
+ call "internalSilkRequest"
[ code "@api"
, code $ ':' : map toLower (show $ method ai)
, code $ "@url + '" ++ urlPart ++ "'"
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)
@@ -24,7 +26,7 @@
import Rest.Schema
main :: IO ()
-main = do
+main =
defaultMain [ testCase "Listing has right parameters." testListingParams
, testCase "Selects should show up only once." testSingleSelect
, testCase "Removes should show up only once." testSingleRemove
@@ -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