Don't use capitalized names on record creation to prevent name clashes with modules (fixes #368)

Author: bergmark

src/Fay/Compiler/Exp.hs

@@ -28,6 +28,7 @@ import           Fay.Types
 import           Control.Applicative
 import           Control.Monad.Error
 import           Control.Monad.RWS
+import qualified Data.Char                       as Char
 import           Language.Haskell.Exts.Annotated
 import           Language.Haskell.Names
 
@@ -276,18 +277,18 @@ compileEnumFromThenTo a b z = do
 compileRecConstr :: S.QName -> [S.FieldUpdate] -> Compile JsExp
 compileRecConstr name fieldUpdates = do
   -- var obj = new $_Type()
-  let unQualName = unQualify $ unAnn name
+  let unQualName = withIdent lowerFirst . unQualify $ unAnn name
   qname <- unsafeResolveName name
   let record = JsVar (JsNameVar unQualName) (JsNew (JsConstructor qname) [])
   setFields <- liftM concat (forM fieldUpdates (updateStmt name))
-  return $ JsApp (JsFun Nothing [] (record:setFields) (Just $ JsName $ JsNameVar $ unQualify $ unAnn name)) []
+  return $ JsApp (JsFun Nothing [] (record:setFields) (Just . JsName . JsNameVar . withIdent lowerFirst . unQualify $ unAnn name)) []
   where
     -- updateStmt :: QName a -> S.FieldUpdate -> Compile [JsStmt]
     updateStmt (unAnn -> o) (FieldUpdate _ (unAnn -> field) value) = do
       exp <- compileExp value
-      return [JsSetProp (JsNameVar $ unQualify o) (JsNameVar $ unQualify field) exp]
-    updateStmt name (FieldWildcard (wildcardFields -> fields)) = do
-      return $ for fields $ \fieldName -> JsSetProp (JsNameVar $ unAnn name)
+      return [JsSetProp (JsNameVar $ withIdent lowerFirst $ unQualify o) (JsNameVar $ unQualify field) exp]
+    updateStmt o (FieldWildcard (wildcardFields -> fields)) = do
+      return $ for fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o)
                                                     (JsNameVar fieldName)
                                                     (JsName $ JsNameVar fieldName)
     -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))
@@ -296,6 +297,9 @@ compileRecConstr name fieldUpdates = do
     wildcardFields l = case l of
       Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName) . map fst $ es
       _ -> []
+    lowerFirst :: String -> String
+    lowerFirst "" = ""
+    lowerFirst (x:xs) = '_' : Char.toLower x : xs
 
 -- | Compile a record update.
 compileRecUpdate :: S.Exp -> [S.FieldUpdate] -> Compile JsExp

src/Fay/Compiler/QName.hs

@@ -30,6 +30,17 @@ changeModule' :: (String -> String) -> QName a -> QName a
 changeModule' f (Qual l (ModuleName ml mn) n) = Qual l (ModuleName ml $ f mn) n
 changeModule' _ x = x
 
+withIdent :: (String -> String) -> QName a -> QName a
+withIdent f q = case q of
+  Qual l m n -> Qual l m $ withIdent' f n
+  UnQual l n -> UnQual l $ withIdent' f n
+  Special{} -> q
+  where
+    withIdent' :: (String -> String) -> Name a -> Name a
+    withIdent' f' n' = case n' of
+      Symbol{} -> n'
+      Ident l s -> Ident l (f' s)
+
 -- | Extract the string from a Name.
 unname :: Name a -> String
 unname (Ident _ s) = s

tests/ModuleRecordClash2.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import           FFI
+import           ModuleRecordClash2_Hello
+import           Prelude
+
+alert :: String -> Fay ()
+alert = ffi "console.log(%1)"
+
+main = do
+    alert (greeting defaultHello)

tests/ModuleRecordClash2.res

@@ -0,0 +1 @@
+Hello, world!

tests/ModuleRecordClash2_Hello.hs

@@ -0,0 +1,9 @@
+-- This module needs to be top level to do the intended test.
+module ModuleRecordClash2_Hello where
+
+import           Prelude
+
+defaultHello :: ModuleRecordClash2_Hello
+defaultHello = ModuleRecordClash2_Hello { greeting = "Hello, world!" }
+
+data ModuleRecordClash2_Hello = ModuleRecordClash2_Hello { greeting :: String }