diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 43552f65..14b7cfad 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -20,10 +20,8 @@ source-repository head library exposed-modules: Servant.Foreign build-depends: base == 4.* - , charset , lens >= 4 , servant >= 0.5 - , text hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall \ No newline at end of file diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 70728a06..cdfebc31 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -21,7 +21,6 @@ module Servant.Foreign , HeaderArg(..) , ArgType(..) , Req - , toValidFunctionName , captureArg , defReq , concatCase @@ -48,12 +47,8 @@ import Control.Applicative #endif import Control.Lens hiding (List) import Data.Char (toLower, toUpper) -import qualified Data.CharSet as Set -import qualified Data.CharSet.Unicode.Category as Set import Data.List -import Data.Monoid import Data.Proxy -import qualified Data.Text as T import GHC.Exts (Constraint) import GHC.TypeLits import Servant.API @@ -105,59 +100,9 @@ data HeaderArg = HeaderArg | ReplaceHeaderArg { headerArgName :: String , headerPattern :: String - } deriving (Eq) + } deriving (Eq, Show) --- | -instance Show HeaderArg where - show (HeaderArg n) = toValidFunctionName ("header" <> n) - show (ReplaceHeaderArg n p) - | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\"" - | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv - | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) - <> "\"" - | otherwise = p - where - pv = toValidFunctionName ("header" <> n) - pn = "{" <> n <> "}" - rp = replace pn "" p - -- Use replace method from Data.Text - replace old new = T.unpack . - T.replace (T.pack old) (T.pack new) . - T.pack - --- | Attempts to reduce the function name provided to that allowed by @'Foreign'@. --- --- Here we are making an assumption that js identifiers are common enough. --- https://mathiasbynens.be/notes/javascript-identifiers --- Couldn't work out how to handle zero-width characters. --- TODO: compare it with other generated languages(such as ruby via lackey) --- and generalize. --- --- @TODO: specify better default function name, or throw error? -toValidFunctionName :: String -> String -toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs - where - setFirstChar c = if firstChar c - then c - else '_' - firstChar c = prefixOK c || any (Set.member c) firstLetterOK - remainder c = prefixOK c || any (Set.member c) remainderOK - -- Valid prefixes - prefixOK c = c `elem` ['$','_'] - -- Unicode character sets - firstLetterOK = [ Set.lowercaseLetter - , Set.uppercaseLetter - , Set.titlecaseLetter - , Set.modifierLetter - , Set.otherLetter - , Set.letterNumber ] - remainderOK = firstLetterOK <> [ Set.nonSpacingMark - , Set.spacingCombiningMark - , Set.decimalNumber - , Set.connectorPunctuation ] -toValidFunctionName [] = "_" - type MatrixArg = QueryArg data Url = Url diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index b06c47ee..602cbb43 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -41,8 +41,10 @@ library Servant.JS.JQuery Servant.JS.Vanilla build-depends: base >=4.5 && <5 + , charset , lens >= 4 , servant-foreign >= 0.1 + , text hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -82,4 +84,5 @@ test-suite spec , lens >= 4 , servant , servant-js + , text default-language: Haskell2010 diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 3ea38d1c..3dff4551 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -109,7 +109,7 @@ generateAngularJSWith ngOptions opts req = "\n" <> where headersStr = intercalate ", " $ map headerStr hs headerStr header = "\"" ++ headerArgName header ++ - "\": " ++ show header + "\": " ++ toJSHeader header namespace = if hasService diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 56c521f2..64f1920b 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -104,7 +104,7 @@ generateAxiosJSWith aopts opts req = "\n" <> where headersStr = intercalate ", " $ map headerStr hs headerStr header = "\"" ++ headerArgName header ++ - "\": " ++ show header + "\": " ++ toJSHeader header namespace = if hasNoModule diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index e502f49a..ec807dbd 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -10,6 +10,8 @@ module Servant.JS.Internal , jsGParams , jsMParams , paramToStr + , toValidFunctionName + , toJSHeader -- re-exports , (:<|>)(..) , (:>) @@ -29,8 +31,13 @@ module Servant.JS.Internal , Header ) where -import Control.Lens hiding (List) -import Servant.Foreign +import Control.Lens hiding (List) +import qualified Data.CharSet as Set +import qualified Data.CharSet.Unicode.Category as Set +import Data.List +import Data.Monoid +import qualified Data.Text as T +import Servant.Foreign type AjaxReq = Req @@ -74,6 +81,51 @@ defCommonGeneratorOptions = CommonGeneratorOptions , urlPrefix = "" } +-- | Attempts to reduce the function name provided to that allowed by @'Foreign'@. +-- +-- https://mathiasbynens.be/notes/javascript-identifiers +-- Couldn't work out how to handle zero-width characters. +-- +-- @TODO: specify better default function name, or throw error? +toValidFunctionName :: String -> String +toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs + where + setFirstChar c = if firstChar c then c else '_' + firstChar c = prefixOK c || any (Set.member c) firstLetterOK + remainder c = prefixOK c || any (Set.member c) remainderOK + -- Valid prefixes + prefixOK c = c `elem` ['$','_'] + -- Unicode character sets + firstLetterOK = [ Set.lowercaseLetter + , Set.uppercaseLetter + , Set.titlecaseLetter + , Set.modifierLetter + , Set.otherLetter + , Set.letterNumber ] + remainderOK = firstLetterOK + <> [ Set.nonSpacingMark + , Set.spacingCombiningMark + , Set.decimalNumber + , Set.connectorPunctuation ] +toValidFunctionName [] = "_" + +toJSHeader :: HeaderArg -> String +toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> n) +toJSHeader (ReplaceHeaderArg n p) + | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\"" + | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv + | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) + <> "\"" + | otherwise = p + where + pv = toValidFunctionName ("header" <> n) + pn = "{" <> n <> "}" + rp = replace pn "" p + -- Use replace method from Data.Text + replace old new = T.unpack + . T.replace (T.pack old) (T.pack new) + . T.pack + jsSegments :: [Segment] -> String jsSegments [] = "" jsSegments [x] = "/" ++ segmentToStr x False diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index 200310f1..5a0d458c 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -72,7 +72,7 @@ generateJQueryJSWith opts req = "\n" <> where headersStr = intercalate ", " $ map headerStr hs headerStr header = "\"" ++ headerArgName header ++ - "\": " ++ show header + "\": " ++ toJSHeader header namespace = if null (moduleName opts) then "var " diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index f5107795..fabbcaee 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -79,7 +79,7 @@ generateVanillaJSWith opts req = "\n" <> where headersStr = intercalate "\n" $ map headerStr hs headerStr header = " xhr.setRequestHeader(\"" ++ headerArgName header ++ - "\", " ++ show header ++ ");" + "\", " ++ toJSHeader header ++ ");" namespace = if null (moduleName opts) then "var "