module Fay.Compiler.Misc where
import Fay.Compiler.Prelude
import Fay.Compiler.PrimOp
import Fay.Compiler.QName (unname)
import Fay.Config
import qualified Fay.Exts as F
import Fay.Exts.NoAnnotation (unAnn)
import qualified Fay.Exts.NoAnnotation as N
import qualified Fay.Exts.Scoped as S
import Fay.Types
import Control.Monad.Except
import Control.Monad.RWS (asks, gets, modify, runRWST)
import qualified Data.Map as M
import Data.Version (parseVersion)
import Distribution.HaskellSuite.Modules
import Language.Haskell.Exts.Annotated hiding (name)
import Language.Haskell.Names
import System.IO
import System.Process (readProcess)
import Text.ParserCombinators.ReadP (readP_to_S)
thunk :: JsExp -> JsExp
thunk expr =
case expr of
JsLit{} -> expr
JsApp fun@JsFun{} [] -> JsNew JsThunk [fun]
_ -> JsNew JsThunk [JsFun Nothing [] [] (Just expr)]
stmtsThunk :: [JsStmt] -> JsExp
stmtsThunk stmts = JsNew JsThunk [JsFun Nothing [] stmts Nothing]
uniqueNames :: [JsName]
uniqueNames = map JsParam [1::Integer ..]
tryResolveName :: Show l => QName (Scoped l) -> Maybe N.QName
tryResolveName s@Special{} = Just $ unAnn s
tryResolveName s@(UnQual _ (Ident _ n)) | "$gen" `isPrefixOf` n = Just $ unAnn s
tryResolveName (unAnn -> Qual () (ModuleName () "$Prelude") n) = Just $ Qual () (ModuleName () "Prelude") n
tryResolveName q@(Qual _ (ModuleName _ "Fay$") _) = Just $ unAnn q
tryResolveName (Qual (Scoped ni _) _ _) = case ni of
GlobalValue n -> replaceWithBuiltIns . origName2QName $ origName n
_ -> Nothing
tryResolveName q@(UnQual (Scoped ni _) (unAnn -> name)) = case ni of
GlobalValue n -> replaceWithBuiltIns . origName2QName $ origName n
LocalValue _ -> Just $ UnQual () name
ScopeError _ -> resolvePrimOp q
_ -> Nothing
origName2QName :: OrigName -> N.QName
origName2QName = gname2Qname . origGName
where
gname2Qname :: GName -> N.QName
gname2Qname g = case g of
GName "" s -> UnQual () $ mkName s
GName m s -> Qual () (ModuleName () m) $ mkName s
where
mkName s@(x:_)
| isAlpha x || x == '_' = Ident () s
| otherwise = Symbol () s
mkName "" = error "mkName \"\""
replaceWithBuiltIns :: N.QName -> Maybe N.QName
replaceWithBuiltIns n = findPrimOp n <|> return n
unsafeResolveName :: S.QName -> Compile N.QName
unsafeResolveName q = maybe (throwError $ UnableResolveQualified (unAnn q)) return $ tryResolveName q
lookupNewtypeConst :: S.QName -> Compile (Maybe (Maybe N.QName,N.Type))
lookupNewtypeConst n = do
let mName = tryResolveName n
case mName of
Nothing -> return Nothing
Just name -> do
newtypes <- gets stateNewtypes
case find (\(cname,_,_) -> cname == name) newtypes of
Nothing -> return Nothing
Just (_,dname,ty) -> return $ Just (dname,ty)
lookupNewtypeDest :: S.QName -> Compile (Maybe (N.QName,N.Type))
lookupNewtypeDest n = do
let mName = tryResolveName n
newtypes <- gets stateNewtypes
case find (\(_,dname,_) -> dname == mName) newtypes of
Nothing -> return Nothing
Just (cname,_,ty) -> return $ Just (cname,ty)
qualify :: Name a -> Compile N.QName
qualify (Ident _ name) = do
modulename <- gets stateModuleName
return (Qual () modulename (Ident () name))
qualify (Symbol _ name) = do
modulename <- gets stateModuleName
return (Qual () modulename (Symbol () name))
qualifyQName :: QName a -> Compile N.QName
qualifyQName (UnQual _ name) = qualify name
qualifyQName (unAnn -> n) = return n
bindToplevel :: Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt
bindToplevel toplevel msrcloc (unAnn -> name) expr =
if toplevel
then do
mod <- gets stateModuleName
return $ JsSetQName msrcloc (Qual () mod name) expr
else return $ JsVar (JsNameVar $ UnQual () name) expr
force :: JsExp -> JsExp
force expr
| isConstant expr = expr
| otherwise = JsApp (JsName JsForce) [expr]
isConstant :: JsExp -> Bool
isConstant JsLit{} = True
isConstant _ = False
parseResult :: ((F.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 :: (Config -> a) -> Compile a
config f = asks (f . readerConfig)
optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]
optimizePatConditions = id
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 :: S.Alt -> Bool
isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat
isWildCardPat :: S.Pat -> Bool
isWildCardPat PWildCard{} = True
isWildCardPat PVar{} = True
isWildCardPat _ = False
ffiExp :: Exp a -> Maybe String
ffiExp (App _ (Var _ (UnQual _ (Ident _ "ffi"))) (Lit _ (String _ formatstr _))) = Just formatstr
ffiExp _ = Nothing
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 :: (S.Name -> Compile a) -> Compile a
withScopedTmpName withName = do
depth <- gets stateNameDepth
modify $ \s -> s { stateNameDepth = depth + 1 }
ret <- withName $ Ident S.noI $ "$gen" ++ show depth
modify $ \s -> s { stateNameDepth = depth }
return ret
warn :: String -> Compile ()
warn "" = return ()
warn w = config id >>= io . (`ioWarn` w)
ioWarn :: Config -> String -> IO ()
ioWarn _ "" = return ()
ioWarn cfg w =
when (configWall cfg) $
hPutStrLn stderr $ "Warning: " ++ w
printSrcLoc :: S.SrcLoc -> String
printSrcLoc SrcLoc{..} = srcFilename ++ ":" ++ show srcLine ++ ":" ++ show srcColumn
printSrcSpanInfo :: SrcSpanInfo -> String
printSrcSpanInfo (SrcSpanInfo a b) = concat $ printSrcSpan a : map printSrcSpan b
printSrcSpan :: SrcSpan -> String
printSrcSpan SrcSpan{..} = srcSpanFilename ++ ": (" ++ show srcSpanStartLine ++ "," ++ show srcSpanStartColumn ++ ")-(" ++ show srcSpanEndLine ++ "," ++ show srcSpanEndColumn ++ ")"
typeToRecs :: QName a -> Compile [N.QName]
typeToRecs (unAnn -> typ) = fromMaybe [] . lookup typ <$> gets stateRecordTypes
recToFields :: S.QName -> Compile [N.Name]
recToFields con =
case tryResolveName con of
Nothing -> return []
Just c -> fromMaybe [] . lookup c <$> gets stateRecords
typeToFields :: QName a -> Compile [N.Name]
typeToFields (unAnn -> 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
runTopCompile
:: CompileReader
-> CompileState
-> Compile a
-> IO (Either CompileError (a,CompileState,CompileWriter))
runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty
runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a
runCompileModule reader' state' m = runExceptT (runRWST (unCompile m) reader' state')
shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a
shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn
hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool
hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas
where
flattenPragmas :: [ModulePragma l] -> [String]
flattenPragmas ps = concatMap pragmaName ps
pragmaName (LanguagePragma _ q) = map unname q
pragmaName _ = []
hasLanguagePragma :: String -> [ModulePragma l] -> Bool
hasLanguagePragma pr = hasLanguagePragmas [pr]
ifOptimizeNewtypes :: Compile a -> Compile a -> Compile a
ifOptimizeNewtypes then' else' = do
optimize <- config configOptimizeNewtypes
if optimize
then then'
else else'