Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
230 lines (192 sloc) 7.71 KB
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS -Wall -fno-warn-orphans #-}
-- | Miscellaneous functions used throughout the compiler.
module Language.Fay.Compiler.Misc where
import Language.Fay.Types
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
unname (Ident str) = str
unname _ = error "Expected ident from uname." -- FIXME:
-- | Make an identifier from the built-in HJ module.
fayBuiltin :: String -> QName
fayBuiltin = Qual (ModuleName "Fay$") . Ident
-- | Wrap an expression in a thunk.
thunk :: JsExp -> JsExp
-- thunk exp = JsNew (fayBuiltin "Thunk") [JsFun [] [] (Just exp)]
thunk expr =
case expr of
-- JS constants don't need to be in thunks, they're already strict.
JsLit{} -> expr
-- Functions (e.g. lets) used for introducing a new lexical scope
-- aren't necessary inside a thunk. This is a simple aesthetic
-- optimization.
JsApp fun@JsFun{} [] -> JsNew JsThunk [fun]
-- Otherwise make a regular thunk.
_ -> JsNew JsThunk [JsFun [] [] (Just expr)]
-- | Wrap an expression in a thunk.
stmtsThunk :: [JsStmt] -> JsExp
stmtsThunk stmts = JsNew JsThunk [JsFun [] stmts Nothing]
-- | Generate unique names.
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 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 (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
force expr
| isConstant expr = expr
| otherwise = JsApp (JsName JsForce) [expr]
-- | Is a JS expression a literal (constant)?
isConstant :: JsExp -> Bool
isConstant JsLit{} = True
isConstant _ = False
-- | Extract the string from a qname.
-- qname :: QName -> String
-- qname (UnQual (Ident str)) = str
-- qname (UnQual (Symbol sym)) = jsEncodeName sym
-- qname i = error $ "qname: Expected unqualified ident, found: " ++ show i -- FIXME:
-- | Deconstruct a parse result (a la maybe, foldr, either).
parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b
parseResult die ok result =
case result of
ParseOk a -> ok a
ParseFailed srcloc msg -> die (srcloc,msg)
-- | Get a config option.
config :: (CompileConfig -> a) -> Compile a
config f = gets (f . stateConfig)
-- | Optimize pattern matching conditions by merging conditions in common.
optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]
optimizePatConditions = concatMap merge . groupBy sameIf where
sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2
sameIf _ _ = False
merge xs@([JsIf cond _ _]:_) =
[[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]]
merge noifs = noifs
getIfConsequent [JsIf _ cons _] = cons
getIfConsequent other = other
-- | Throw a JS exception.
throw :: String -> JsExp -> JsStmt
throw msg expr = JsThrow (JsList [JsLit (JsStr msg),expr])
-- | Throw a JS exception (in an expression).
throwExp :: String -> JsExp -> JsExp
throwExp msg expr = JsThrowExp (JsList [JsLit (JsStr msg),expr])
-- | Is an alt a wildcard?
isWildCardAlt :: Alt -> Bool
isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat
-- | Is a pattern a wildcard?
isWildCardPat :: Pat -> Bool
isWildCardPat PWildCard{} = True
isWildCardPat PVar{} = True
isWildCardPat _ = False
-- | Generate a temporary, SCOPED name for testing conditions and
-- such.
withScopedTmpJsName :: (JsName -> Compile a) -> Compile a
withScopedTmpJsName withName = do
depth <- gets stateNameDepth
modify $ \s -> s { stateNameDepth = depth + 1 }
ret <- withName $ JsTmp depth
modify $ \s -> s { stateNameDepth = depth }
return ret
-- | Generate a temporary, SCOPED name for testing conditions and
-- such. We don't have name tracking yet, so instead we use this.
withScopedTmpName :: (Name -> Compile a) -> Compile a
withScopedTmpName withName = do
depth <- gets stateNameDepth
modify $ \s -> s { stateNameDepth = depth + 1 }
ret <- withName $ Ident $ "$gen" ++ show depth
modify $ \s -> s { stateNameDepth = depth }
return ret
Something went wrong with that request. Please try again.