Implemented overloadable string literals using an in-scope fromString (closes #320).

Uses a combination of OverloadedStrings and RebindableSyntax.

Author: sebastiaanvisser

fay.cabal

@@ -136,6 +136,14 @@ extra-source-files:
   tests/Floating.res
   tests/fromInteger.hs
   tests/fromInteger.res
+  tests/FromString/Dep.hs
+  tests/FromString/Dep.res
+  tests/FromString/DepDep.hs
+  tests/FromString/DepDep.res
+  tests/FromString/FayText.hs
+  tests/FromString/FayText.res
+  tests/FromString.hs
+  tests/FromString.res
   tests/GADTs_without_records.hs
   tests/GADTs_without_records.res
   tests/guards.hs

src/Fay/Compiler.hs

@@ -158,6 +158,7 @@ compileModuleFromAST (Module _ modulename _pragmas Nothing _exports imports decl
     imported <- fmap concat (mapM compileImport imports)
     modify $ \s -> s { stateModuleName = modulename
                      , stateModuleScope = fromMaybe (error $ "Could not find stateModuleScope for " ++ show modulename) $ M.lookup modulename $ stateModuleScopes s
+                     , stateUseFromString = useFromString _pragmas
                      }
     current <- compileDecls True decls
 
@@ -175,6 +176,12 @@ compileModuleFromAST (Module _ modulename _pragmas Nothing _exports imports decl
               else stmts
 compileModuleFromAST mod = throwError (UnsupportedModuleSyntax mod)
 
+useFromString :: [ModulePragma] -> Bool
+useFromString pragmas = any (hasPragma "OverloadedStrings") pragmas
+                     && any (hasPragma "RebindableSyntax") pragmas
+  where hasPragma p (LanguagePragma _ q) | p `elem` q = True
+        hasPragma _ _                                 = False
+
 instance CompilesTo Module [JsStmt] where compileTo = compileModuleFromAST
 
 

src/Fay/Compiler/Defaults.hs

@@ -41,4 +41,5 @@ defaultCompileState = do
     , stateModuleScope = def
     , stateModuleScopes = M.empty
     , stateJsModulePaths = S.empty
+    , stateUseFromString = False
     }

src/Fay/Compiler/Exp.hs

@@ -84,8 +84,11 @@ compileLit lit =
     Frac rational -> return (JsLit (JsFloating (fromRational rational)))
     -- TODO: Use real JS strings instead of array, probably it will
     -- lead to the same result.
-    String string -> return (JsApp (JsName (JsBuiltIn "list"))
-                                   [JsLit (JsStr string)])
+    String string -> do
+      fromString <- gets stateUseFromString
+      if fromString
+        then return (JsLit (JsStr string))
+        else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)])
     lit           -> throwError (UnsupportedLiteral lit)
 
 -- | Compile simple application.

src/Fay/FFI.hs

@@ -12,6 +12,7 @@ module Fay.FFI
   ,ffi)
   where
 
+import           Data.String (IsString)
 import           Fay.Types
 import           Prelude      (Bool, Char, Double, Int, Maybe, String, error)
 
@@ -44,6 +45,7 @@ type Ptr a = a
 type Automatic a = a
 
 -- | Declare a foreign action.
-ffi :: String        -- ^ The foreign value.
+ffi :: IsString s
+    => s             -- ^ The foreign value.
     -> a             -- ^ Bottom.
 ffi = error "Fay.FFI.ffi: Used foreign function outside a JS engine context."

src/Fay/Types.hs

@@ -108,17 +108,18 @@ mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name"
 
 -- | State of the compiler.
 data CompileState = CompileState
-  { _stateExports     :: Map ModuleName (Set QName) -- ^ Collects exports from modules
-  , stateRecordTypes  :: [(QName,[QName])]          -- ^ Map types to constructors
-  , stateRecords      :: [(QName,[QName])]          -- ^ Map constructors to fields
-  , stateNewtypes     :: [(QName, Maybe QName, Type)] -- ^ Newtype constructor, destructor, wrapped type tuple
-  , stateImported     :: [(ModuleName,FilePath)]    -- ^ Map of all imported modules and their source locations.
-  , stateNameDepth    :: Integer                    -- ^ Depth of the current lexical scope.
-  , stateLocalScope   :: Set Name                   -- ^ Names in the current lexical scope.
-  , stateModuleScope  :: ModuleScope                -- ^ Names in the module scope.
-  , stateModuleScopes :: Map ModuleName ModuleScope
-  , stateModuleName   :: ModuleName                 -- ^ Name of the module currently being compiled.
+  { _stateExports      :: Map ModuleName (Set QName) -- ^ Collects exports from modules
+  , stateRecordTypes   :: [(QName,[QName])]          -- ^ Map types to constructors
+  , stateRecords       :: [(QName,[QName])]          -- ^ Map constructors to fields
+  , stateNewtypes      :: [(QName, Maybe QName, Type)] -- ^ Newtype constructor, destructor, wrapped type tuple
+  , stateImported      :: [(ModuleName,FilePath)]    -- ^ Map of all imported modules and their source locations.
+  , stateNameDepth     :: Integer                    -- ^ Depth of the current lexical scope.
+  , stateLocalScope    :: Set Name                   -- ^ Names in the current lexical scope.
+  , stateModuleScope   :: ModuleScope                -- ^ Names in the module scope.
+  , stateModuleScopes  :: Map ModuleName ModuleScope
+  , stateModuleName    :: ModuleName                 -- ^ Name of the module currently being compiled.
   , stateJsModulePaths :: Set ModulePath
+  , stateUseFromString :: Bool
   } deriving (Show)
 
 -- | Things written out by the compiler.

tests/FromString.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}
+module FromString where
+
+import Prelude
+import FromString.FayText
+import FromString.Dep (myString, depTest)
+
+main :: Fay ()
+main = do
+  print ("This is not a String" :: Text)
+  print "This is not a String"
+  putStrLn myString
+  print myString
+  depTest
+

tests/FromString.res

@@ -0,0 +1,5 @@
+This is not a String
+This is not a String
+test
+[ 't', 'e', 's', 't' ]
+This is also not a String

tests/FromString/Dep.hs

@@ -0,0 +1,11 @@
+module FromString.Dep where
+
+import Prelude
+import FromString.DepDep (myText)
+
+myString :: String
+myString = "test"
+
+depTest :: Fay ()
+depTest = print myText
+