Skip to content
Browse files

Use fully qualified names with name resolution. SEE COMMIT MESSAGE.

This may break your code. I added name resolution/scoping so that we
can have proper modules. This is the first step. Qualified imports and
"as" syntax will now be a trivial few line patch. But I had to change
almost every part of the computer, some things probably broke. All the
tests pass, and the two demo projects I've written, moogle and
fay-server, still work. But recompile your projects and see.
  • Loading branch information...
1 parent ca76b99 commit d43fd8c5d26071f011e7c28eb3922d5ecd59623d @chrisdone chrisdone committed Oct 28, 2012
View
4 fay.cabal
@@ -145,6 +145,7 @@ library
haskell-src-exts,
aeson,
unordered-containers,
+ containers,
attoparsec,
vector,
text,
@@ -187,6 +188,7 @@ executable fay
aeson,
syb,
unordered-containers,
+ containers,
attoparsec,
vector,
text,
@@ -219,6 +221,7 @@ executable fay-tests
aeson,
syb,
unordered-containers,
+ containers,
attoparsec,
vector,
text,
@@ -251,6 +254,7 @@ executable fay-docs
aeson,
syb,
unordered-containers,
+ containers,
attoparsec,
vector,
text,
View
7 hs/stdlib.hs
@@ -1,10 +1,3 @@
data Maybe a
= Just a
| Nothing
-
-show :: (Foreign a,Show a) => a -> String
-show = ffi "JSON.stringify(%1)"
-
--- There is only Double in JS.
-fromInteger x = x
-fromRational x = x
View
24 js/runtime.js
@@ -46,9 +46,8 @@ function Fay$$Monad(value){
}
// >>
-// encode_fay_to_js(">>=") → $62$$62$
-// This is used directly from Fay, but can be rebound or shadowed.
-function $62$$62$(a){
+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.
+function Fay$$then(a){
return function(b){
return new $(function(){
_(a,true);
@@ -58,9 +57,8 @@ function $62$$62$(a){
}
// >>=
-// encode_fay_to_js(">>=") → $62$$62$$61$
-// This is used directly from Fay, but can be rebound or shadowed.
-function $62$$62$$61$(m){
+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.
+function Fay$$bind(m){
return function(f){
return new $(function(){
var monad = _(m,true);
@@ -70,7 +68,7 @@ function $62$$62$$61$(m){
}
// This is used directly from Fay, but can be rebound or shadowed.
-function $_return(a){
+function Fay$$$_return(a){
return new Fay$$Monad(a);
}
@@ -283,7 +281,6 @@ function Fay$$mult(x){
});
};
}
-var $42$ = Fay$$mult;
// Built-in +.
function Fay$$add(x){
@@ -293,7 +290,6 @@ function Fay$$add(x){
});
};
}
-var $43$ = Fay$$add;
// Built-in -.
function Fay$$sub(x){
@@ -303,7 +299,6 @@ function Fay$$sub(x){
});
};
}
-var $45$ = Fay$$sub;
// Built-in /.
function Fay$$div(x){
@@ -313,7 +308,6 @@ function Fay$$div(x){
});
};
}
-var $47$ = Fay$$div;
/*******************************************************************************
* Booleans.
@@ -363,7 +357,6 @@ function Fay$$eq(x){
});
};
}
-var $61$$61$ = Fay$$eq;
// Built-in /=.
function Fay$$neq(x){
@@ -373,7 +366,6 @@ function Fay$$neq(x){
});
};
}
-var $47$$61$ = Fay$$neq;
// Built-in >.
function Fay$$gt(x){
@@ -383,7 +375,6 @@ function Fay$$gt(x){
});
};
}
-var $62$ = Fay$$gt;
// Built-in <.
function Fay$$lt(x){
@@ -393,7 +384,6 @@ function Fay$$lt(x){
});
};
}
-var $60$ = Fay$$lt;
// Built-in >=.
function Fay$$gte(x){
@@ -403,7 +393,6 @@ function Fay$$gte(x){
});
};
}
-var $62$$61$ = Fay$$gte;
// Built-in <=.
function Fay$$lte(x){
@@ -413,7 +402,6 @@ function Fay$$lte(x){
});
};
}
-var $60$$61$ = Fay$$lte;
// Built-in &&.
function Fay$$and(x){
@@ -423,7 +411,6 @@ function Fay$$and(x){
});
};
}
-var $38$$38$ = Fay$$and;
// Built-in ||.
function Fay$$or(x){
@@ -433,7 +420,6 @@ function Fay$$or(x){
});
};
}
-var $124$$124$ = Fay$$or;
/*******************************************************************************
* Mutable references.
View
13 src/Language/Fay.hs
@@ -67,18 +67,15 @@ compileFile :: CompileConfig -> FilePath -> IO (Either CompileError String)
compileFile config filein = do
runtime <- getDataFileName "js/runtime.js"
stdlibpath <- getDataFileName "hs/stdlib.hs"
- stdlibpathprelude <- getDataFileName "src/Language/Fay/Stdlib.hs"
+ srcdir <- fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs")
raw <- readFile runtime
stdlib <- readFile stdlibpath
- stdlibprelude <- readFile stdlibpathprelude
hscode <- readFile filein
compileToModule filein
- config
+ config { configDirectoryIncludes = configDirectoryIncludes config ++ [srcdir] }
raw
compileToplevelModule
- (hscode ++ "\n" ++ stdlib ++ "\n" ++ strip stdlibprelude)
-
- where strip = unlines . dropWhile (/="-- START") . lines
+ (hscode ++ "\n" ++ stdlib)
-- | Compile the given module to a runnable module.
compileToModule :: (Show from,Show to,CompilesTo from to)
@@ -114,7 +111,7 @@ compileToModule filepath config raw with hscode = do
,if not (configLibrary config)
then unlines [";"
,"var main = new " ++ modulename ++ "();"
- ,"main._(main.main);"
+ ,"main._(main." ++ modulename ++ "$main);"
]
else ""
]
@@ -168,3 +165,5 @@ showCompileError e =
Couldn'tFindImport i places ->
"could not find an import in the path: " ++ prettyPrint i ++ ", \n" ++
"searched in these places: " ++ intercalate ", " places
+ UnableResolveUnqualified name -> "unable to resolve unqualified name " ++ prettyPrint name
+ UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname
View
249 src/Language/Fay/Compiler.hs
@@ -22,24 +22,26 @@ module Language.Fay.Compiler
,compileToplevelModule)
where
-import Language.Fay.Compiler.FFI
-import Language.Fay.Compiler.Misc
-import Language.Fay.Print (printJSString)
-import Language.Fay.Types
-
-import Control.Applicative
-import Control.Monad.Error
-import Control.Monad.IO
-import Control.Monad.State
-import Data.Default (def)
-import Data.List
-import Data.List.Extra
-import Data.Maybe
-import Language.Haskell.Exts
-import System.Directory (doesFileExist)
-import System.FilePath ((</>))
-import System.IO
-import System.Process.Extra
+import Language.Fay.Compiler.FFI
+import Language.Fay.Compiler.Misc
+import Language.Fay.Print (printJSString)
+import Language.Fay.Types
+
+import Control.Applicative
+import Control.Monad.Error
+import Control.Monad.IO
+import Control.Monad.State
+import Data.Default (def)
+import Data.List
+import Data.List.Extra
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Language.Haskell.Exts
+import System.Directory (doesFileExist)
+import System.FilePath ((</>))
+import System.IO
+import System.Process.Extra
--------------------------------------------------------------------------------
-- Top level entry points
@@ -100,7 +102,8 @@ printCompile config with from = do
-- | Compile a String of Fay and print it as beautified JavaScript.
printTestCompile :: String -> IO ()
-printTestCompile = printCompile def { configWarn = False } compileModule
+printTestCompile = printCompile def { configWarn = False,
+ configDirectoryIncludes = ["/home/chris/Projects/me/fay/"] } compileModule
-- | Compile the given Fay code for the documentation. This is
-- specialised because the documentation isn't really “real”
@@ -129,12 +132,13 @@ compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _) = do
initialPass :: Module -> Compile ()
initialPass (Module _ _ _ Nothing _ imports decls) = do
- mapM_ initialPass_import imports
+ mapM_ initialPass_import (map translateModuleName imports)
mapM_ (initialPass_decl True) decls
initialPass mod = throwError (UnsupportedModuleSyntax mod)
initialPass_import :: ImportDecl -> Compile ()
+initialPass_import (ImportDecl _ "Prelude" _ _ _ _ _) = return ()
initialPass_import (ImportDecl _ name False _ Nothing Nothing Nothing) = do
void $ unlessImported name $ do
dirs <- configDirectoryIncludes <$> gets stateConfig
@@ -216,11 +220,21 @@ compileModule (Module _ modulename pragmas Nothing exports imports decls) = do
, stateExportAll = isNothing exports
}
mapM_ emitExport (fromMaybe [] exports)
- imported <- fmap concat (mapM compileImport imports)
+ imported <- fmap concat (mapM (compileImport . translateModuleName) imports)
current <- compileDecls True decls
return (imported ++ current)
compileModule mod = throwError (UnsupportedModuleSyntax mod)
+translateModuleName :: ImportDecl -> ImportDecl
+-- The *.Prelude module doesn't contain actual code, but code to
+-- appease GHC. The real code is in Stdlib, which could also be
+-- imported directly, but it seems nicer to use Prelude. And maybe we
+-- can fix this in the future so that Prelude contains the real
+-- code. Doubt it, but it could happen.
+translateModuleName (ImportDecl a (ModuleName "Language.Fay.Prelude") b c d e f) =
+ (ImportDecl a (ModuleName "Language.Fay.Stdlib") b c d e f)
+translateModuleName x = x
+
warn :: String -> Compile ()
warn "" = return ()
warn w = do
@@ -253,22 +267,40 @@ findImport alldirs = go alldirs where
-- | Compile the given import.
compileImport :: ImportDecl -> Compile [JsStmt]
+compileImport (ImportDecl _ "Prelude" _ _ _ _ _) = return []
compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) = do
unlessImported name $ do
dirs <- configDirectoryIncludes <$> gets stateConfig
(filepath,contents) <- findImport dirs name
state <- gets id
- result <- liftIO $ compileToAst filepath state compileModule contents
+ result <- liftIO $ compileToAst filepath state { stateModuleName = name } compileModule contents
case result of
Right (stmts,state) -> do
- modify $ \s -> s { stateFayToJs = stateFayToJs state
- , stateJsToFay = stateJsToFay state
+ modify $ \s -> s { stateFayToJs = stateFayToJs state
+ , stateJsToFay = stateJsToFay state
, stateImported = stateImported state
+ , stateScope = mergeScopes (addExportsToScope (stateExports state) (stateScope s))
+ (stateScope state)
}
return stmts
Left err -> throwError err
compileImport i = throwError $ UnsupportedImport i
+-- | Add the new scopes to the old one, stripping out local bindings.
+mergeScopes :: Map Name [NameScope] -> Map Name [NameScope] -> Map Name [NameScope]
+mergeScopes old new =
+ M.map (filter (/=ScopeBinding))
+ (foldr (\(key,val) -> M.insertWith (++) key val) old (M.assocs new))
+
+-- | Add
+addExportsToScope :: [QName] -> Map Name [NameScope] -> Map Name [NameScope]
+addExportsToScope exports mapping = foldr copy mapping exports where
+ copy e =
+ case e of
+ Qual modname name -> M.insertWith (++) name [ScopeImported modname Nothing]
+ UnQual name -> error $ "Exports should not be unqualified: " ++ prettyPrint name
+ Special{} -> error $ "Don't be silly."
+
-- | Don't re-import the same modules.
unlessImported :: ModuleName -> Compile [JsStmt] -> Compile [JsStmt]
unlessImported name importIt = do
@@ -284,14 +316,15 @@ compileDecls :: Bool -> [Decl] -> Compile [JsStmt]
compileDecls toplevel decls =
case decls of
[] -> return []
- (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind toplevel (Just sig) bind)
+ (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (scoped (compilePatBind toplevel (Just sig) bind))
(compileDecls toplevel decls)
- (decl:decls) -> appendM (compileDecl toplevel decl)
+ (decl:decls) -> appendM (scoped (compileDecl toplevel decl))
(compileDecls toplevel decls)
where appendM m n = do x <- m
xs <- n
return (x ++ xs)
+ scoped = if toplevel then withScope else id
-- | Compile a declaration.
compileDecl :: Bool -> Decl -> Compile [JsStmt]
@@ -322,7 +355,7 @@ compilePatBind toplevel sig pat =
Just sig -> compileFFI srcloc ident formatstr sig
Nothing -> throwError (FfiNeedsTypeSig pat)
_ -> compileUnguardedRhs srcloc toplevel ident rhs
- PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls ->
+ PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls -> do
compileUnguardedRhs srcloc toplevel ident (Let bdecls rhs)
_ -> throwError (UnsupportedDeclaration pat)
@@ -332,9 +365,11 @@ compilePatBind toplevel sig pat =
-- | Compile a normal simple pattern binding.
compileUnguardedRhs :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt]
compileUnguardedRhs srcloc toplevel ident rhs = do
- body <- compileExp rhs
- bind <- bindToplevel srcloc toplevel ident (thunk body)
- return [bind]
+ bindVar ident
+ withScope $ do
+ body <- compileExp rhs
+ bind <- bindToplevel srcloc toplevel ident (thunk body)
+ return [bind]
convertGADT :: GadtDecl -> QualConDecl
convertGADT d =
@@ -383,19 +418,22 @@ compileDataDecl toplevel _decl constructors =
-- Creates a constructor R_RecConstr for a Record
makeConstructor :: Name -> [Name] -> Compile JsStmt
makeConstructor name (map (JsNameVar . UnQual) -> fields) = do
+ qname <- qualify name
+ emitExport (EVar qname)
return $
- JsVar (JsConstructor (UnQual name)) $
+ JsVar (JsConstructor qname) $
JsFun fields (for fields $ \field -> JsSetProp JsThis field (JsName field))
Nothing
-- Creates a function to initialize the record by regular application
makeFunc :: Name -> [Name] -> Compile JsStmt
makeFunc name (map (JsNameVar . UnQual) -> fields) = do
- let fieldExps = map JsName fields
- return $ JsVar (JsNameVar (UnQual name)) $
- foldr (\slot inner -> JsFun [slot] [] (Just inner))
- (thunk $ JsNew (JsConstructor (UnQual name)) fieldExps)
- fields
+ let fieldExps = map JsName fields
+ qname <- qualify name
+ return $ JsVar (JsNameVar qname) $
+ foldr (\slot inner -> JsFun [slot] [] (Just inner))
+ (thunk $ JsNew (JsConstructor qname) fieldExps)
+ fields
-- Creates getters for a RecDecl's values
makeAccessors :: SrcLoc -> [Name] -> Compile [JsStmt]
@@ -414,6 +452,7 @@ compileFunCase :: Bool -> [Match] -> Compile [JsStmt]
compileFunCase _toplevel [] = return []
compileFunCase toplevel matches@(Match srcloc name argslen _ _ _:_) = do
pats <- fmap optimizePatConditions (mapM compileCase matches)
+ bindVar name
bind <- bindToplevel srcloc
toplevel
name
@@ -427,17 +466,20 @@ compileFunCase toplevel matches@(Match srcloc name argslen _ _ _:_) = do
compileCase :: Match -> Compile [JsStmt]
compileCase match@(Match _ _ pats _ rhs _) = do
- whereDecls' <- whereDecls match
- exp <- compileRhs rhs
- body <- if null whereDecls'
- then return exp
- else do
- binds <- mapM compileLetDecl whereDecls'
- return (JsApp (JsFun [] (concat binds) (Just exp)) [])
- foldM (\inner (arg,pat) ->
- compilePat (JsName arg) pat inner)
- [JsEarlyReturn body]
- (zip args pats)
+ withScope $ do
+ whereDecls' <- whereDecls match
+ generateScope $ mapM (\(arg,pat) -> compilePat (JsName arg) pat []) (zip args pats)
+ generateScope $ mapM compileLetDecl whereDecls'
+ exp <- compileRhs rhs
+ body <- if null whereDecls'
+ then return exp
+ else do
+ binds <- mapM compileLetDecl whereDecls'
+ return (JsApp (JsFun [] (concat binds) (Just exp)) [])
+ foldM (\inner (arg,pat) ->
+ compilePat (JsName arg) pat inner)
+ [JsEarlyReturn body]
+ (zip args pats)
whereDecls :: Match -> Compile [Decl]
whereDecls (Match _ _ _ _ _ (BDecls decls)) = return decls
@@ -469,7 +511,7 @@ compileExp :: Exp -> Compile JsExp
compileExp exp =
case exp of
Paren exp -> compileExp exp
- Var qname -> return (JsName (JsNameVar qname))
+ Var qname -> compileVar qname
Lit lit -> compileLit lit
App exp1 exp2 -> compileApp exp1 exp2
NegApp exp -> compileNegApp exp
@@ -482,14 +524,16 @@ compileExp exp =
Case exp alts -> compileCase exp alts
Con (UnQual (Ident "True")) -> return (JsLit (JsBool True))
Con (UnQual (Ident "False")) -> return (JsLit (JsBool False))
- Con exp -> return (JsName (JsNameVar exp))
+ Con qname -> compileVar qname
Do stmts -> compileDoBlock stmts
Lambda _ pats exp -> compileLambda pats exp
EnumFrom i -> do e <- compileExp i
- return (JsApp (JsName (JsNameVar "enumFrom")) [e])
+ name <- resolveName "enumFrom"
+ return (JsApp (JsName (JsNameVar name)) [e])
EnumFromTo i i' -> do f <- compileExp i
t <- compileExp i'
- return (JsApp (JsApp (JsName (JsNameVar "enumFromTo")) [f])
+ name <- resolveName "enumFromTo"
+ return (JsApp (JsApp (JsName (JsNameVar name)) [f])
[t])
RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates
RecUpdate rec fieldUpdates -> updateRec rec fieldUpdates
@@ -500,6 +544,11 @@ compileExp exp =
instance CompilesTo Exp JsExp where compileTo = compileExp
+compileVar :: QName -> Compile JsExp
+compileVar qname = do
+ qname <- resolveName qname
+ return (JsName (JsNameVar qname))
+
-- | Compile simple application.
compileApp :: Exp -> Exp -> Compile JsExp
compileApp exp1 exp2 = do
@@ -534,19 +583,20 @@ compileNegApp e = JsNegApp . force <$> compileExp e
-- | Compile an infix application, optimizing the JS cases.
compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp
-compileInfixApp exp1 op exp2 = do
- case getOp op of
- UnQual (Symbol symbol)
- | symbol `elem` words "* + - / < > || &&" -> do
- e1 <- compileExp exp1
- e2 <- compileExp exp2
- fn <- resolveOpToVar >=> compileExp $ op
- return $ JsApp (JsApp (force fn) [(force e1)]) [(force e2)]
- _ -> do
- var <- resolveOpToVar op
- compileExp (App (App var exp1) exp2)
-
- where getOp (QVarOp op) = op
+compileInfixApp exp1 ap exp2 = do
+ qname <- resolveName op
+ case qname of
+ -- We can optimize prim ops. :-)
+ Qual "Fay$" _
+ | prettyPrint ap `elem` words "* + - / < > || &&" -> do
+ e1 <- compileExp exp1
+ e2 <- compileExp exp2
+ fn <- compileExp (Var op)
+ return $ JsApp (JsApp (force fn) [force e1]) [force e2]
+ _ -> compileExp (App (App (Var qname) exp1) exp2)
+
+ where op = getOp ap
+ getOp (QVarOp op) = op
getOp (QConOp op) = op
-- | Compile a list expression.
@@ -568,18 +618,22 @@ compileIf cond conseq alt =
-- | Compile a lambda.
compileLambda :: [Pat] -> Exp -> Compile JsExp
compileLambda pats exp = do
- exp <- compileExp exp
- stmts <- foldM (\inner (param,pat) -> do
- stmts <- compilePat (JsName param) pat inner
- return [JsEarlyReturn (JsFun [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])
- [JsEarlyReturn exp]
- (reverse (zip uniqueNames pats))
- case stmts of
- [JsEarlyReturn fun@JsFun{}] -> return fun
- _ -> error "Unexpected statements in compileLambda"
+ withScope $ do
+ generateScope $ generateStatements JsNull
+ exp <- compileExp exp
+ stmts <- generateStatements exp
+ case stmts of
+ [JsEarlyReturn fun@JsFun{}] -> return fun
+ _ -> error "Unexpected statements in compileLambda"
where unhandledcase = throw "unhandled case" . JsName
allfree = all isWildCardPat pats
+ generateStatements exp =
+ foldM (\inner (param,pat) -> do
+ stmts <- compilePat (JsName param) pat inner
+ return [JsEarlyReturn (JsFun [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])
+ [JsEarlyReturn exp]
+ (reverse (zip uniqueNames pats))
-- | Compile list comprehensions.
desugarListComp :: Exp -> [QualStmt] -> Compile Exp
@@ -653,14 +707,16 @@ compileStmt inner stmt =
-- | Compile the given pattern against the given expression.
compilePatAlt :: JsExp -> Alt -> Compile [JsStmt]
compilePatAlt exp (Alt _ pat rhs _) = do
- alt <- compileGuardedAlt rhs
- compilePat exp pat [JsEarlyReturn alt]
+ withScope $ do
+ generateScope $ compilePat exp pat []
+ alt <- compileGuardedAlt rhs
+ compilePat exp pat [JsEarlyReturn alt]
-- | Compile the given pattern against the given expression.
compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat exp pat body =
case pat of
- PVar name -> return $ JsVar (JsNameVar (UnQual name)) exp : body
+ PVar name -> compilePVar name exp body
PApp cons pats -> compilePApp cons pats exp body
PLit literal -> compilePLit exp literal body
PParen pat -> compilePat exp pat body
@@ -672,11 +728,18 @@ compilePat exp pat body =
PRec name pats -> compilePatFields exp name pats body
pat -> throwError (UnsupportedPattern pat)
+-- | Compile a pattern variable e.g. x.
+compilePVar :: Name -> JsExp -> [JsStmt] -> Compile [JsStmt]
+compilePVar name exp body = do
+ bindVar name
+ return $ JsVar (JsNameVar (UnQual name)) exp : body
+
-- | Compile a record field pattern.
compilePatFields :: JsExp -> QName -> [PatField] -> [JsStmt] -> Compile [JsStmt]
compilePatFields exp name pats body = do
c <- liftM (++ body) (compilePats' [] pats)
- return [JsIf (force exp `JsInstanceOf` JsConstructor name) c []]
+ qname <- resolveName name
+ return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]
where -- compilePats' collects field names that had already been matched so that
-- wildcard generates code for the rest of the fields.
compilePats' :: [QName] -> [PatField] -> Compile [JsStmt]
@@ -685,6 +748,7 @@ compilePatFields exp name pats body = do
compilePats' names (PFieldPat fieldname (PVar varName):xs) = do
r <- compilePats' (fieldname : names) xs
+ bindVar varName
return $ JsVar (JsNameVar (UnQual varName))
(JsGetProp (force exp) (JsNameVar fieldname))
: r -- TODO: think about this force call
@@ -693,16 +757,21 @@ compilePatFields exp name pats body = do
records <- liftM stateRecords get
let fields = fromJust (lookup name records)
fields' = fields \\ names
- f = map (\fieldName -> JsVar (JsNameVar fieldName)
- (JsGetProp (force exp) (JsNameVar fieldName)))
- fields'
+ f <- mapM (\fieldName -> do bindVar (unQual fieldName)
+ return (JsVar (JsNameVar fieldName)
+ (JsGetProp (force exp) (JsNameVar fieldName))))
+ fields'
r <- compilePats' names xs
return $ f ++ r
compilePats' _ [] = return []
compilePats' _ (pat:_) = throwError (UnsupportedFieldPattern pat)
+ unQual (Qual _ n) = n
+ unQual (UnQual n) = n
+ unQual Special{} = error "Trying to unqualify a Special..."
+
-- | Compile a literal value from a pattern match.
compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt]
compilePLit exp literal body = do
@@ -723,6 +792,7 @@ compilePLit exp literal body = do
-- | Compile as binding in pattern match
compilePAsPat :: JsExp -> Name -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePAsPat exp name pat body = do
+ bindVar name
x <- compilePat exp pat body
return ([JsVar (JsNameVar (UnQual name)) exp] ++ x ++ body)
@@ -731,7 +801,8 @@ compilePAsPat exp name pat body = do
compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp
compileRecConstr name fieldUpdates = do
-- var obj = new $_Type()
- let record = JsVar (JsNameVar name) (JsNew (JsConstructor name) [])
+ qname <- qualifyQ name
+ let record = JsVar (JsNameVar name) (JsNew (JsConstructor qname) [])
setFields <- liftM concat (forM fieldUpdates (updateStmt name))
return $ JsApp (JsFun [] (record:setFields) (Just (JsName (JsNameVar name)))) []
where updateStmt :: QName -> FieldUpdate -> Compile [JsStmt]
@@ -790,7 +861,8 @@ compilePApp cons pats exp body = do
compilePat (JsGetProp forcedExp (JsNameVar field)) pat body)
body
(reverse (zip recordFields pats))
- return [JsIf (forcedExp `JsInstanceOf` JsConstructor cons)
+ qcons <- resolveName cons
+ return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons)
substmts
[]]
@@ -835,18 +907,21 @@ compileGuardedAlt alt =
-- | Compile a let expression.
compileLet :: [Decl] -> Exp -> Compile JsExp
compileLet decls exp = do
- body <- compileExp exp
- binds <- mapM compileLetDecl decls
- return (JsApp (JsFun [] (concat binds) (Just body)) [])
+ withScope $ do
+ generateScope $ mapM compileLetDecl decls
+ binds <- mapM compileLetDecl decls
+ body <- compileExp exp
+ return (JsApp (JsFun [] (concat binds) (Just body)) [])
-- | Compile let declaration.
compileLetDecl :: Decl -> Compile [JsStmt]
-compileLetDecl decl =
- case decl of
+compileLetDecl decl = do
+ v <- case decl of
decl@PatBind{} -> compileDecls False [decl]
decl@FunBind{} -> compileDecls False [decl]
TypeSig{} -> return []
_ -> throwError (UnsupportedLetBinding decl)
+ return v
-- | Compile Haskell literal.
compileLit :: Literal -> Compile JsExp
View
23 src/Language/Fay/Compiler/FFI.hs
@@ -54,14 +54,16 @@ compileFFI srcloc name formatstr sig = do
-- Make a Fay→JS encoder.
emitFayToJs :: Name -> [([Name],BangType)] -> Compile ()
-emitFayToJs name (explodeFields -> fieldTypes) =
- modify $ \s -> s { stateFayToJs = translator : stateFayToJs s }
+emitFayToJs name (explodeFields -> fieldTypes) = do
+ qname <- qualify name
+ modify $ \s -> s { stateFayToJs = translator qname : stateFayToJs s }
where
- translator = JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor (UnQual name)))
- [JsEarlyReturn (JsObj (("instance",JsLit (JsStr (printJSString name)))
- : zipWith declField [0..] fieldTypes))]
- []
+ translator qname =
+ JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor qname))
+ [JsEarlyReturn (JsObj (("instance",JsLit (JsStr (printJSString name)))
+ : zipWith declField [0..] fieldTypes))]
+ []
-- Declare/encode Fay→JS field
declField :: Int -> (Name,BangType) -> (String,JsExp)
declField _i (fname,typ) =
@@ -224,14 +226,15 @@ jsToFayDispatcher cases =
-- Make a JS→Fay decoder
emitJsToFay :: Name -> [([Name], BangType)] -> Compile ()
-emitJsToFay name (explodeFields -> fieldTypes) =
- modify $ \s -> s { stateJsToFay = translator : stateJsToFay s }
+emitJsToFay name (explodeFields -> fieldTypes) = do
+ qname <- qualify name
+ modify $ \s -> s { stateJsToFay = translator qname : stateJsToFay s }
where
- translator =
+ translator qname =
JsIf (JsEq (JsGetPropExtern (JsName transcodingObj) "instance")
(JsLit (JsStr (printJSString name))))
- [JsEarlyReturn (JsNew (JsConstructor (UnQual name))
+ [JsEarlyReturn (JsNew (JsConstructor qname)
(map decodeField fieldTypes))]
[]
-- Decode JS→Fay field
View
136 src/Language/Fay/Compiler/Misc.hs
@@ -5,15 +5,20 @@
module Language.Fay.Compiler.Misc where
-import Language.Fay.Types
+import Language.Fay.Types
-import Control.Monad.Error
-import Control.Monad.State
-import Data.List
-import Data.String
-import Language.Haskell.Exts (ParseResult(..))
-import Language.Haskell.Exts.Syntax
-import Prelude hiding (exp)
+import Control.Monad.Error
+import Control.Monad.State
+
+
+
+import Data.List
+import qualified Data.Map as M
+import Data.Maybe
+import Data.String
+import Language.Haskell.Exts (ParseResult(..))
+import Language.Haskell.Exts.Syntax
+import Prelude hiding (exp)
-- | Extra the string from an ident.
unname :: Name -> String
@@ -22,7 +27,7 @@ unname _ = error "Expected ident from uname." -- FIXME:
-- | Make an identifier from the built-in HJ module.
fayBuiltin :: String -> QName
-fayBuiltin = Qual (ModuleName "Fay") . Ident
+fayBuiltin = Qual (ModuleName "Fay$") . Ident
-- | Wrap an expression in a thunk.
thunk :: JsExp -> JsExp
@@ -46,25 +51,105 @@ stmtsThunk stmts = JsNew JsThunk [JsFun [] stmts Nothing]
uniqueNames :: [JsName]
uniqueNames = map JsParam [1::Integer ..]
+-- | Resolve a given maybe-qualified name to a fully qualifed name.
+resolveName :: QName -> Compile QName
+resolveName special@Special{} = return special
+resolveName (UnQual name) = do
+-- let echo = io . putStrLn
+-- echo $ "Resolving name " ++ prettyPrint name
+ names <- gets stateScope
+-- echo $ "Names are: " ++ show names
+ case M.lookup name names of
+ -- Unqualified and not imported? Current module.
+ Nothing -> qualify name
+ Just scopes -> case find localBinding scopes of
+ Just ScopeBinding -> return (UnQual name)
+ _ ->
+ case find simpleImport scopes of
+ Just (ScopeImported modulename replacement) -> return (Qual modulename (fromMaybe name replacement))
+ _ -> case find asImport scopes of
+ Just (ScopeImportedAs _ modulename _) -> return (Qual modulename name)
+ _ -> throwError $ UnableResolveUnqualified name
+
+ where asImport ScopeImportedAs{} = True
+ asImport _ = False
+
+ localBinding ScopeBinding = True
+ localBinding _ = False
+
+resolveName (Qual modulename name) = do
+ names <- gets stateScope
+ case M.lookup name names of
+ -- Qualified and not imported? It's correct, leave it as-is.
+ Nothing -> return (Qual modulename name)
+ Just scopes -> case find simpleImport scopes of
+ Just (ScopeImported _ replacement) -> return (Qual modulename (fromMaybe name replacement))
+ _ -> case find asMatch scopes of
+ Just (ScopeImported realname replacement) -> return (Qual realname (fromMaybe name replacement))
+ _ -> throwError $ UnableResolveQualified (Qual modulename name)
+
+ where asMatch i = case i of
+ ScopeImported{} -> True
+ ScopeImportedAs _ _ qmodulename -> qmodulename == moduleToName modulename
+ ScopeBinding -> False
+ where moduleToName (ModuleName n) = Ident n
+
+-- | Do have have a simple "import X" import on our hands?
+simpleImport :: NameScope -> Bool
+simpleImport ScopeImported{} = True
+simpleImport _ = False
+
-- | Qualify a name for the current module.
qualify :: Name -> Compile QName
qualify name = do
modulename <- gets stateModuleName
return (Qual modulename name)
+-- | Qualify a name for the current module.
+qualifyQ :: QName -> Compile QName
+qualifyQ (Qual _ name) = qualify name
+qualifyQ (UnQual name) = qualify name
+qualifyQ e = return e
+
-- | Make a top-level binding.
bindToplevel :: SrcLoc -> Bool -> Name -> JsExp -> Compile JsStmt
bindToplevel srcloc toplevel name expr = do
+ qname <- (if toplevel then qualify else return . UnQual) name
exportAll <- gets stateExportAll
- when (toplevel && exportAll) $ emitExport (EVar (UnQual name))
- return (JsMappedVar srcloc (JsNameVar (UnQual name)) expr)
+ when (toplevel && exportAll) $ emitExport (EVar qname)
+ return (JsMappedVar srcloc (JsNameVar qname) expr)
+
+-- | Create a temporary scope and discard it after the given computation.
+withScope :: Compile a -> Compile a
+withScope m = do
+ scope <- gets stateScope
+ value <- m
+ modify $ \s -> s { stateScope = scope }
+ return value
+
+-- | Run a compiler and just get the scope information.
+generateScope :: Compile a -> Compile ()
+generateScope m = do
+ st <- get
+ _ <- m
+ scope <- gets stateScope
+ put st { stateScope = scope }
+
+-- | Bind a variable in the current scope.
+bindVar :: Name -> Compile ()
+bindVar name = do
+ modify $ \s -> s { stateScope = M.insertWith (++) name [ScopeBinding] (stateScope s) }
-- | Emit exported names.
emitExport :: ExportSpec -> Compile ()
emitExport spec =
case spec of
- EVar name -> modify $ \s -> s { stateExports = name : stateExports s }
- _ -> throwError (UnsupportedExportSpec spec)
+ EVar (UnQual name) -> qualify name >>= emitExport . EVar
+ EVar name@Qual{} -> modify $ \s -> s { stateExports = name : stateExports s }
+ _ -> do
+ name <- gets stateModuleName
+ unless (name == "Language.Fay.Stdlib") $
+ throwError (UnsupportedExportSpec spec)
-- | Force an expression in a thunk.
force :: JsExp -> JsExp
@@ -142,28 +227,3 @@ withScopedTmpName withName = do
ret <- withName $ Ident $ "$gen" ++ show depth
modify $ \s -> s { stateNameDepth = depth }
return ret
-
--- | Resolve operators to only built-in (for now) functions.
-resolveOpToVar :: QOp -> Compile Exp
-resolveOpToVar op =
- case getOp op of
- UnQual (Symbol symbol)
- | symbol == "*" -> return (Var (fayBuiltin "mult"))
- | symbol == "+" -> return (Var (fayBuiltin "add"))
- | symbol == "-" -> return (Var (fayBuiltin "sub"))
- | symbol == "/" -> return (Var (fayBuiltin "div"))
- | symbol == "==" -> return (Var (fayBuiltin "eq"))
- | symbol == "/=" -> return (Var (fayBuiltin "neq"))
- | symbol == ">" -> return (Var (fayBuiltin "gt"))
- | symbol == "<" -> return (Var (fayBuiltin "lt"))
- | symbol == ">=" -> return (Var (fayBuiltin "gte"))
- | symbol == "<=" -> return (Var (fayBuiltin "lte"))
- | symbol == "&&" -> return (Var (fayBuiltin "and"))
- | symbol == "||" -> return (Var (fayBuiltin "or"))
- | otherwise -> return (Var (fromString symbol))
- n@(UnQual Ident{}) -> return (Var n)
- Special Cons -> return (Var (fayBuiltin "cons"))
- _ -> throwError (UnsupportedOperator op)
-
- where getOp (QVarOp o) = o
- getOp (QConOp o) = o
View
17 src/Language/Fay/Prelude.hs
@@ -8,16 +8,14 @@ module Language.Fay.Prelude
,Double
,Int
,Bool(..)
- ,Show(show)
+ ,Show
,Read
,Maybe(..)
,Typeable(..)
,Data(..)
,Monad
,Eq(..)
,read
- ,fromInteger
- ,fromRational
,(>>)
,(>>=)
,(+)
@@ -37,22 +35,11 @@ module Language.Fay.Prelude
import Language.Fay.Stdlib
import Language.Fay.Types (Fay)
-
import Data.Data
-
-import GHC.Real (Ratio)
import Prelude (Bool(..), Char, Double, Eq(..), Int, Integer, Maybe(..), Monad,
- Ord, Read(..), Show(..), String, error, read, (&&), (*), (+), (-),
+ Ord, Read(..), Show(), String, error, read, (&&), (*), (+), (-),
(/), (/=), (<), (<=), (==), (>), (>=), (||))
--- | Just to satisfy GHC.
-fromInteger :: Integer -> Double
-fromInteger = error "Language.Fay.Prelude.fromInteger: Used fromInteger outside JS."
-
--- | Just to satisfy GHC.
-fromRational :: Ratio Integer -> Double
-fromRational = error "Language.Fay.Prelude.fromRational Used fromRational outside JS."
-
(>>) :: Fay a -> Fay b -> Fay b
(>>) = error "Language.Fay.Prelude.(>>): Used (>>) outside JS."
infixl 1 >>
View
13 src/Language/Fay/Print.hs
@@ -50,19 +50,24 @@ instance Printable JsLit where
instance Printable QName where
printJS qname =
case qname of
- Qual moduleName name -> moduleName +> "$$" +> name
+ Qual moduleName name -> moduleName +> "$" +> name
UnQual name -> printJS name
Special con -> printJS con
-- | Print module name.
instance Printable ModuleName where
- printJS (ModuleName moduleName) =
- write $ encodeName moduleName
+ printJS (ModuleName "Fay$") =
+ write "Fay$"
+ printJS (ModuleName moduleName) = write $ go moduleName
+
+ where go ('.':xs) = '$' : go xs
+ go (x:xs) = normalizeName [x] ++ go xs
+ go [] = []
-- | Print special constructors (tuples, list, etc.)
instance Printable SpecialCon where
printJS specialCon =
- printJS $ (Qual (ModuleName "Fay") . Ident) $
+ printJS $ (Qual (ModuleName "Fay$") . Ident) $
case specialCon of
UnitCon -> "unit"
Cons -> "cons"
View
18 src/Language/Fay/Stdlib.hs
@@ -1,8 +1,12 @@
+{-# LANGUAGE NoImplicitPrelude #-}
module Language.Fay.Stdlib
(($)
,(++)
,(.)
,Ordering(..)
+ ,show
+ ,fromInteger
+ ,fromRational
,any
,compare
,concat
@@ -45,10 +49,18 @@ module Language.Fay.Stdlib
where
import Language.Fay.FFI
-import Prelude (Bool(..), Double, Eq(..), Int, Maybe(..), Monad(..), Num(..),
- Ord((>), (<)), (||))
+import Prelude (Bool(..), Double, Eq(..), Int, Maybe(..), Monad(..), Num((+)),
+ Ord((>), (<)), (||),String,Show,Integer,Rational,Fractional)
--- START
+show :: (Foreign a,Show a) => a -> String
+show = ffi "JSON.stringify(%1)"
+
+-- There is only Double in JS.
+fromInteger :: a -> a
+fromInteger x = x
+
+fromRational :: a -> a
+fromRational x = x
snd :: (t, t1) -> t1
snd (_,x) = x
View
55 src/Language/Fay/Types.hs
@@ -23,17 +23,17 @@ module Language.Fay.Types
,FundamentalType(..)
,PrintState(..)
,Printer(..)
- ,ModuleImport(..)
+ ,NameScope(..)
,Mapping(..))
where
-import Data.String
import Control.Applicative
import Control.Monad.Error (Error, ErrorT, MonadError)
import Control.Monad.Identity (Identity)
import Control.Monad.State
import Data.Default
-
+import Data.Map as M
+import Data.String
import Language.Haskell.Exts
--------------------------------------------------------------------------------
@@ -53,7 +53,7 @@ data CompileConfig = CompileConfig
, configFilePath :: Maybe FilePath
, configTypecheck :: Bool
, configWall :: Bool
- }
+ } deriving (Show)
-- | Default configuration.
instance Default CompileConfig where
@@ -71,11 +71,17 @@ data CompileState = CompileState
, stateJsToFay :: [JsStmt]
, stateImported :: [ModuleName]
, stateNameDepth :: Integer
-}
+ , stateScope :: Map Name [NameScope]
+} deriving (Show)
+
+-- | A name's scope, either imported or bound locally.
+data NameScope = ScopeImported ModuleName (Maybe Name)
+ | ScopeImportedAs Bool ModuleName Name
+ | ScopeBinding
--- | A module import.
-data ModuleImport = ModuleImport ModuleName | ModuleImportAs ModuleName Name
+ deriving (Show,Eq)
+-- | The default compiler state.
defaultCompileState :: CompileConfig -> CompileState
defaultCompileState config = CompileState {
stateConfig = config
@@ -85,11 +91,42 @@ defaultCompileState config = CompileState {
, stateRecords = [("Nothing",[]),("Just",["slot1"])]
, stateFayToJs = []
, stateJsToFay = []
- , stateImported = ["Language.Fay.Prelude","Language.Fay.FFI","Language.Fay.Types","Prelude"]
+ , stateImported = ["Language.Fay.FFI","Language.Fay.Types","Prelude"]
, stateNameDepth = 1
, stateFilePath = "<unknown>"
+ , stateScope = M.fromList primOps
}
+-- | The built-in operations that aren't actually compiled from
+-- anywhere, they come from runtime.js.
+--
+-- They're in the names list so that they can be overriden by the user
+-- in e.g. let a * b = a - b in 1 * 2.
+--
+-- So we resolve them to Fay$, i.e. the prefix used for the runtime
+-- support. $ is not allowed in Haskell module names, so there will be
+-- no conflicts if a user decicdes to use a module named Fay.
+--
+-- So e.g. will compile to (*) Fay$$mult, which is in runtime.js.
+primOps :: [(Name, [NameScope])]
+primOps =
+ [(Symbol ">>",[ScopeImported "Fay$" (Just "then")])
+ ,(Symbol ">>=",[ScopeImported "Fay$" (Just "bind")])
+ ,(Ident "return",[ScopeImported "Fay$" (Just "return")])
+ ,(Symbol "*",[ScopeImported "Fay$" (Just "mult")])
+ ,(Symbol "*",[ScopeImported "Fay$" (Just "mult")])
+ ,(Symbol "+",[ScopeImported "Fay$" (Just "add")])
+ ,(Symbol "-",[ScopeImported "Fay$" (Just "sub")])
+ ,(Symbol "/",[ScopeImported "Fay$" (Just "div")])
+ ,(Symbol "==",[ScopeImported "Fay$" (Just "eq")])
+ ,(Symbol "/=",[ScopeImported "Fay$" (Just "neq")])
+ ,(Symbol ">",[ScopeImported "Fay$" (Just "gt")])
+ ,(Symbol "<",[ScopeImported "Fay$" (Just "lt")])
+ ,(Symbol ">=",[ScopeImported "Fay$" (Just "gte")])
+ ,(Symbol "<=",[ScopeImported "Fay$" (Just "lte")])
+ ,(Symbol "&&",[ScopeImported "Fay$" (Just "and")])
+ ,(Symbol "||",[ScopeImported "Fay$" (Just "or")])]
+
-- | Compile monad.
newtype Compile a = Compile { unCompile :: StateT CompileState (ErrorT CompileError IO) a }
deriving (MonadState CompileState
@@ -158,6 +195,8 @@ data CompileError
| FfiFormatNoSuchArg Int
| FfiFormatIncompleteArg
| FfiFormatInvalidJavaScript String String
+ | UnableResolveUnqualified Name
+ | UnableResolveQualified QName
deriving (Show)
instance Error CompileError
View
5 tests/tailRecursion.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module Fib where
+module Tail where
import Language.Fay.FFI
import Language.Fay.Prelude
@@ -13,8 +13,5 @@ main = do
sum 0 acc = acc
sum n acc = sum (n - 1) (acc + n)
-getSeconds :: Fay Double
-getSeconds = ffi "new Date"
-
print :: Double -> Fay ()
print = ffi "console.log(%1)"

0 comments on commit d43fd8c

Please sign in to comment.
Something went wrong with that request. Please try again.