module Language.Fay.Compiler.Misc where
import Language.Fay.Types
import Control.Applicative
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)
unname :: Name -> String
unname (Ident str) = str
unname _ = error "Expected ident from uname."
fayBuiltin :: String -> QName
fayBuiltin = Qual (ModuleName "Fay$") . Ident
thunk :: JsExp -> JsExp
thunk expr =
case expr of
JsLit{} -> expr
JsApp fun@JsFun{} [] -> JsNew JsThunk [fun]
_ -> JsNew JsThunk [JsFun [] [] (Just expr)]
stmtsThunk :: [JsStmt] -> JsExp
stmtsThunk stmts = JsNew JsThunk [JsFun [] stmts Nothing]
uniqueNames :: [JsName]
uniqueNames = map JsParam [1::Integer ..]
resolveName :: QName -> Compile QName
resolveName special@Special{} = return special
resolveName (UnQual name) = do
names <- gets stateScope
case M.lookup name names of
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
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
simpleImport :: NameScope -> Bool
simpleImport ScopeImported{} = True
simpleImport _ = False
qualify :: Name -> Compile QName
qualify name = do
modulename <- gets stateModuleName
return (Qual modulename name)
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)
withScope :: Compile a -> Compile a
withScope m = do
scope <- gets stateScope
value <- m
modify $ \s -> s { stateScope = scope }
return value
generateScope :: Compile a -> Compile ()
generateScope m = do
st <- get
_ <- m
scope <- gets stateScope
put st { stateScope = scope }
bindVar :: Name -> Compile ()
bindVar name = do
modify $ \s -> s { stateScope = M.insertWith (++) name [ScopeBinding] (stateScope s) }
emitExport :: ExportSpec -> Compile ()
emitExport spec =
case spec of
EVar (UnQual name) -> emitVar (UnQual name)
EVar name@Qual{} -> modify $ \s -> s { stateExports = name : stateExports s }
EThingAll (UnQual name) -> do
emitVar (UnQual name)
r <- lookup (UnQual name) <$> gets stateRecords
maybe (return ()) (mapM_ emitVar) r
EThingWith (UnQual name) ns -> do
emitVar (UnQual name)
mapM_ emitCName ns
EAbs _ -> return ()
_ -> do
name <- gets stateModuleName
unless (name == "Language.Fay.Stdlib") $
throwError (UnsupportedExportSpec spec)
where
emitVar n = resolveName n >>= emitExport . EVar
emitCName (VarName n) = emitVar (UnQual n)
emitCName (ConName n) = emitVar (UnQual n)
force :: JsExp -> JsExp
force expr
| isConstant expr = expr
| otherwise = JsApp (JsName JsForce) [expr]
isConstant :: JsExp -> Bool
isConstant JsLit{} = True
isConstant _ = False
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)
config :: (CompileConfig -> a) -> Compile a
config f = gets (f . stateConfig)
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 :: String -> JsExp -> JsStmt
throw msg expr = JsThrow (JsList [JsLit (JsStr msg),expr])
throwExp :: String -> JsExp -> JsExp
throwExp msg expr = JsThrowExp (JsList [JsLit (JsStr msg),expr])
isWildCardAlt :: Alt -> Bool
isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat
isWildCardPat :: Pat -> Bool
isWildCardPat PWildCard{} = True
isWildCardPat PVar{} = True
isWildCardPat _ = False
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
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