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 library
exposed-modules: Servant.Foreign exposed-modules: Servant.Foreign
build-depends: base == 4.* build-depends: base == 4.*
, charset
, lens >= 4 , lens >= 4
, servant >= 0.5 , servant >= 0.5
, text
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -21,7 +21,6 @@ module Servant.Foreign
, HeaderArg(..) , HeaderArg(..)
, ArgType(..) , ArgType(..)
, Req , Req
, toValidFunctionName
, captureArg , captureArg
, defReq , defReq
, concatCase , concatCase
@ -48,12 +47,8 @@ import Control.Applicative
#endif #endif
import Control.Lens hiding (List) import Control.Lens hiding (List)
import Data.Char (toLower, toUpper) import Data.Char (toLower, toUpper)
import qualified Data.CharSet as Set
import qualified Data.CharSet.Unicode.Category as Set
import Data.List import Data.List
import Data.Monoid
import Data.Proxy import Data.Proxy
import qualified Data.Text as T
import GHC.Exts (Constraint) import GHC.Exts (Constraint)
import GHC.TypeLits import GHC.TypeLits
import Servant.API import Servant.API
@ -105,59 +100,9 @@ data HeaderArg = HeaderArg
| ReplaceHeaderArg | ReplaceHeaderArg
{ headerArgName :: String { headerArgName :: String
, headerPattern :: 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 type MatrixArg = QueryArg
data Url = Url data Url = Url

View file

@ -41,8 +41,10 @@ library
Servant.JS.JQuery Servant.JS.JQuery
Servant.JS.Vanilla Servant.JS.Vanilla
build-depends: base >=4.5 && <5 build-depends: base >=4.5 && <5
, charset
, lens >= 4 , lens >= 4
, servant-foreign >= 0.1 , servant-foreign >= 0.1
, text
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
@ -82,4 +84,5 @@ test-suite spec
, lens >= 4 , lens >= 4
, servant , servant
, servant-js , servant-js
, text
default-language: Haskell2010 default-language: Haskell2010

View file

@ -109,7 +109,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
where headersStr = intercalate ", " $ map headerStr hs where headersStr = intercalate ", " $ map headerStr hs
headerStr header = "\"" ++ headerStr header = "\"" ++
headerArgName header ++ headerArgName header ++
"\": " ++ show header "\": " ++ toJSHeader header
namespace = namespace =
if hasService if hasService

View file

@ -104,7 +104,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
where headersStr = intercalate ", " $ map headerStr hs where headersStr = intercalate ", " $ map headerStr hs
headerStr header = "\"" ++ headerStr header = "\"" ++
headerArgName header ++ headerArgName header ++
"\": " ++ show header "\": " ++ toJSHeader header
namespace = namespace =
if hasNoModule if hasNoModule

View file

@ -10,6 +10,8 @@ module Servant.JS.Internal
, jsGParams , jsGParams
, jsMParams , jsMParams
, paramToStr , paramToStr
, toValidFunctionName
, toJSHeader
-- re-exports -- re-exports
, (:<|>)(..) , (:<|>)(..)
, (:>) , (:>)
@ -29,8 +31,13 @@ module Servant.JS.Internal
, Header , Header
) where ) where
import Control.Lens hiding (List) import Control.Lens hiding (List)
import Servant.Foreign 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 type AjaxReq = Req
@ -74,6 +81,51 @@ defCommonGeneratorOptions = CommonGeneratorOptions
, urlPrefix = "" , 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 :: [Segment] -> String
jsSegments [] = "" jsSegments [] = ""
jsSegments [x] = "/" ++ segmentToStr x False jsSegments [x] = "/" ++ segmentToStr x False

View file

@ -72,7 +72,7 @@ generateJQueryJSWith opts req = "\n" <>
where headersStr = intercalate ", " $ map headerStr hs where headersStr = intercalate ", " $ map headerStr hs
headerStr header = "\"" ++ headerStr header = "\"" ++
headerArgName header ++ headerArgName header ++
"\": " ++ show header "\": " ++ toJSHeader header
namespace = if null (moduleName opts) namespace = if null (moduleName opts)
then "var " then "var "

View file

@ -79,7 +79,7 @@ generateVanillaJSWith opts req = "\n" <>
where headersStr = intercalate "\n" $ map headerStr hs where headersStr = intercalate "\n" $ map headerStr hs
headerStr header = " xhr.setRequestHeader(\"" ++ headerStr header = " xhr.setRequestHeader(\"" ++
headerArgName header ++ headerArgName header ++
"\", " ++ show header ++ ");" "\", " ++ toJSHeader header ++ ");"
namespace = if null (moduleName opts) namespace = if null (moduleName opts)
then "var " then "var "