no opinion on valid function names in servant-foreign

This commit is contained in:
Denis Redozubov 2015-09-22 13:17:43 +03:00
parent 7ff9e52a50
commit b59a62e012
8 changed files with 62 additions and 64 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -10,6 +10,8 @@ module Servant.JS.Internal
, jsGParams
, jsMParams
, paramToStr
, toValidFunctionName
, toJSHeader
-- re-exports
, (:<|>)(..)
, (:>)
@ -30,6 +32,11 @@ module Servant.JS.Internal
) where
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

View file

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

View file

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