module Language.Fay.Compiler.Misc where
import qualified Language.Fay.ModuleScope as ModuleScope
import Language.Fay.Types
import System.Process (readProcess)
import Text.ParserCombinators.ReadP (readP_to_S)
import Data.Version (parseVersion)
import Control.Applicative
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Data.List
import qualified Data.Set as S
import Data.Maybe
import Data.String
import Language.Haskell.Exts (ParseResult(..))
import Language.Haskell.Exts.Syntax
import Prelude hiding (exp, mod)
import System.IO
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 q@Qual{} = do
env <- gets stateModuleScope
maybe (throwError $ UnableResolveQualified q) return (ModuleScope.resolveName q env)
resolveName u@(UnQual name) = do
names <- gets stateLocalScope
env <- gets stateModuleScope
if S.member name names
then return (UnQual name)
else maybe (qualify name) return (ModuleScope.resolveName u env)
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
return (JsMappedVar srcloc (JsNameVar qname) expr)
withModuleScope :: Compile a -> Compile a
withModuleScope m = do
scope <- gets stateModuleScope
value <- m
modify $ \s -> s { stateModuleScope = scope }
return value
withScope :: Compile a -> Compile a
withScope m = do
scope <- gets stateLocalScope
value <- m
modify $ \s -> s { stateLocalScope = scope }
return value
generateScope :: Compile a -> Compile ()
generateScope m = do
st <- get
_ <- m
scope <- gets stateLocalScope
put st { stateLocalScope = scope }
bindVar :: Name -> Compile ()
bindVar name = do
modify $ \s -> s { stateLocalScope = S.insert name (stateLocalScope s) }
emitExport :: ExportSpec -> Compile ()
emitExport spec = case spec of
EVar (UnQual n) -> emitVar n
EVar q@Qual{} -> modify $ \s -> s { stateExports = q : stateExports s }
EThingAll (UnQual name) -> do
emitVar name
r <- lookup (UnQual name) <$> gets stateRecords
maybe (return ()) (mapM_ (emitVar . unQName)) r
EThingWith (UnQual name) ns -> do
emitVar name
mapM_ emitCName ns
EAbs _ -> return ()
EModuleContents mod ->
mapM_ (emitExport . EVar) =<< ModuleScope.moduleLocals mod <$> gets stateModuleScope
e -> throwError $ UnsupportedExportSpec e
where
emitVar = return . UnQual >=> resolveName >=> emitExport . EVar
emitCName (VarName n) = emitVar n
emitCName (ConName n) = emitVar n
unQName (UnQual u) = u
unQName _ = error "unQName Qual or Special -- should never happen"
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 = asks (f . readerConfig)
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
warn :: String -> Compile ()
warn "" = return ()
warn w = do
shouldWarn <- config configWarn
when shouldWarn . liftIO . hPutStrLn stderr $ "Warning: " ++ w
printSrcLoc :: SrcLoc -> String
printSrcLoc SrcLoc{..} = srcFilename ++ ":" ++ show srcLine ++ ":" ++ show srcColumn
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM p l = return . not . null =<< filterM p l
typeToRecs :: QName -> Compile [QName]
typeToRecs typ = fromMaybe [] . lookup typ <$> gets stateRecordTypes
typeToFields :: QName -> Compile [QName]
typeToFields typ = do
allrecs <- gets stateRecords
typerecs <- typeToRecs typ
return . concatMap snd . filter ((`elem` typerecs) . fst) $ allrecs
getGhcPackageDbFlag :: IO String
getGhcPackageDbFlag = do
s <- readProcess "ghc" ["--version"] ""
return $
case (mapMaybe readVersion $ words s, readVersion "7.6.0") of
(v:_, Just min') | v > min' -> "-package-db"
_ -> "-package-conf"
where
readVersion = listToMaybe . filter (null . snd) . readP_to_S parseVersion