Desugar: adding FFI type signatures on toplevel

* Add a desugar step which copies the type signature for toplevel FFI
  declarations to an explicit one in the RHS expression.
* Remove (now unnecessary) code from compileDecls and compileDecl

Still todo:
* Adding FFI type signatures in let/where bindings
* Find out why StrictWrapper test is broken. Seems to be ignoring the
  last statement in the do block.

Author: Harry Garrood

src/Fay/Compiler/Decl.hs

@@ -14,7 +14,6 @@ import           Fay.Compiler.GADT
 import           Fay.Compiler.Misc
 import           Fay.Compiler.Pattern
 import           Fay.Compiler.State
-import           Fay.Compiler.QName              (unname)
 import           Fay.Data.List.Extra
 import           Fay.Exts                        (convertFieldDecl, fieldDeclNames)
 import           Fay.Exts.NoAnnotation           (unAnn)
@@ -28,37 +27,7 @@ import           Language.Haskell.Exts.Annotated
 
 -- | Compile Haskell declaration.
 compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]
-compileDecls toplevel' decls' = go toplevel' decls'
-  where
-    isTypeSig (TypeSig _ _ _) = True
-    isTypeSig _               = False
-
-    typeSigs = filter isTypeSig decls'
-
-    getSigFor decl = case decl of
-      (PatBind _ (PVar _ name) _ _ _) ->
-        case filter (includesName name) typeSigs of
-          [] -> Nothing
-          [(TypeSig _ _ sig)] -> Just sig
-          _ -> error "(todo) multiple type signatures"
-      _ -> Nothing
-
-    -- Tests whether a type signature declares what the type of a given name is
-    includesName name (TypeSig _ names _) =
-      any (== (unname name)) $ map unname names
-    includesName _ _ = False
-
-    go toplevel decls = case decls of
-      [] -> return []
-      (bind@PatBind{}:decls) -> appendM (compilePatBind toplevel (getSigFor bind) bind)
-                                        (compileDecls toplevel decls)
-      (decl:decls) -> appendM (compileDecl toplevel decl)
-                              (go toplevel decls)
-
-    appendM m n = do x <- m
-                     xs <- n
-                     return (x ++ xs)
-
+compileDecls toplevel = fmap concat . sequence . map (compileDecl toplevel)
 
 -- | Compile a declaration.
 compileDecl :: Bool -> S.Decl -> Compile [JsStmt]
@@ -104,11 +73,7 @@ compilePatBind toplevel sig patDecl = case patDecl of
       sig)) Nothing ->
     compileFFI True ident' formatstr sig
   PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) Nothing ->
-    case ffiExp rhs of
-      Just formatstr -> case sig of
-        Just sig -> compileFFI False ident formatstr sig
-        Nothing  -> throwError $ FfiNeedsTypeSig patDecl
-      _ -> compileUnguardedRhs toplevel srcloc ident rhs
+      compileUnguardedRhs toplevel srcloc ident rhs
   -- TODO: Generalize to all patterns
   PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) (Just bdecls) ->
     compileUnguardedRhs toplevel srcloc ident (Let S.noI bdecls rhs)

src/Fay/Compiler/Desugar.hs

@@ -7,7 +7,8 @@ module Fay.Compiler.Desugar
   (desugar
   ) where
 
-import           Fay.Compiler.Misc               (hasLanguagePragma)
+import           Fay.Compiler.QName              (unname)
+import           Fay.Compiler.Misc               (hasLanguagePragma, ffiExp)
 import           Fay.Exts.NoAnnotation           (unAnn)
 import           Fay.Types                       (CompileError (..))
 
@@ -65,6 +66,7 @@ desugar emptyAnnotation md = runDesugar emptyAnnotation $
   >>= desugarDo
   >>= desugarTupleSection
   >>= desugarImplicitPrelude
+  >>= desugarToplevelFFITypeSigs
 
 -- | Desugaring
 
@@ -164,7 +166,7 @@ desugarPatFieldPun = transformBi $ \pf -> case pf of
   PFieldPun l n -> PFieldPat l (UnQual l n) (PVar l n)
   _             -> pf
 
--- | Desugar l list comprehensions.
+-- | Desugar list comprehensions.
 desugarListComp :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
 desugarListComp = transformBiM $ \ex -> case ex of
     ListComp l exp stmts -> desugarListComp' l exp stmts
@@ -254,6 +256,63 @@ desugarImplicitPrelude m =
       noInfo <- asks readerNoInfo
       return $ ImportDecl noInfo (ModuleName noInfo "Prelude") False False Nothing Nothing Nothing
 
+-- | For each toplevel FFI pattern binding, search the module for the relevant
+-- type declaration; if found, add a type signature to the ffi expression.
+-- e.g.
+--  foo :: Int
+--  foo = ffi "3"
+-- becomes
+--  foo :: Int
+--  foo = (ffi "3" :: Int)
+desugarToplevelFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
+desugarToplevelFFITypeSigs m = case m of
+  Module a b c d decls -> do
+    let toplevelTypeSigs = getToplevelTypeSigs decls
+    decls' <- sequence $ go toplevelTypeSigs decls
+    return $ Module a b c d decls'
+  _ -> return m
+  where
+  getToplevelTypeSigs decls =
+    [ (unname n, typ) | TypeSig _ names typ <- decls, n <- names ]
+
+  go toplevelTypeSigs decls =
+    map (addTypeSig toplevelTypeSigs) decls
+
+  addTypeSig sigs decl = case decl of
+    (PatBind loc pat typ rhs binds) ->
+      case getUnguardedRhs rhs of
+        Just (srcInfo, rhExp) ->
+          if isFFI rhExp
+            then do
+              rhExp' <- addSigToExp sigs decl rhExp
+              return $ PatBind loc pat typ (UnGuardedRhs srcInfo rhExp') binds
+            else return decl
+        _ -> return decl
+    _ -> return decl
+
+  getUnguardedRhs rhs = case rhs of
+    (UnGuardedRhs srcInfo exp) -> Just (srcInfo, exp)
+    _ -> Nothing
+
+  isFFI = isJust . ffiExp
+
+  -- | Adds an explicit type signature to an expression (which is assumed to
+  -- be the RHS of a declaration). This should only need to be called for FFI
+  -- function declarations.
+  -- Arguments:
+  --  sigs:  List of toplevel type signatures
+  --  decl:  The declaration, which should be a PatBind.
+  --  rhExp: Expression comprising the RHS of the declaration
+  addSigToExp sigs decl rhExp = case getTypeFor sigs decl of
+    Just typ -> do
+      noInfo <- asks readerNoInfo
+      return $ ExpTypeSig noInfo rhExp typ
+    Nothing -> return rhExp
+
+  getTypeFor sigs decl = case decl of
+    (PatBind _ (PVar _ name) _ _ _) -> lookup (unname name) sigs
+    _ -> Nothing
+
 transformBi :: U.Biplate (from a) (to a) => (to a -> to a) -> from a -> from a
 transformBi = U.transformBi
 

tests/CorrectTypeSigFFI.hs

@@ -0,0 +1,28 @@
+module DesugarFFI where
+
+import Prelude
+import FFI
+
+-- top-level FFI call with multi type signature
+addOne, addTwo :: Int -> Int
+
+addOne = ffi "%1 + 1"
+addTwo = ffi "%1 + 2"
+
+-- FFI call in a let binding
+-- addThree :: Int -> Int
+-- addThree x =
+--   let go :: Int -> Int
+--       go = ffi "%1 + 3"
+--   in go x
+
+-- FFI call in a where binding
+-- addFour :: Int -> Int
+-- addFour x = go x
+--   where
+--   go :: Int -> Int
+--   go = ffi "%1 + 3"
+
+main = do
+  let result = addOne . addTwo {-.  addThree . addFour -} $ 0
+  putStrLn $ show result

tests/CorrectTypeSigFFI.res

@@ -0,0 +1 @@
+10