module Fay.Compiler.Misc where
import qualified Fay.Compiler.ModuleScope as ModuleScope
import Fay.Types
import Control.Applicative
import Control.Monad.Error
import Control.Monad.IO
import Control.Monad.RWS
import Data.List
import Data.Maybe
import qualified Data.Set as S
import Data.String
import Data.Version (parseVersion)
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.Extension
import Prelude hiding (exp, mod)
import System.Directory
import System.FilePath
import System.IO
import System.Process (readProcess)
import Text.ParserCombinators.ReadP (readP_to_S)
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 $ addCurrentExport q
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
EThingAll (Qual _ _) -> return ()
e -> do
liftIO (print 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
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
findImport :: [FilePath] -> ModuleName -> Compile (FilePath,String)
findImport alldirs mname = go alldirs mname where
go (dir:dirs) name = do
exists <- io (doesFileExist path)
if exists
then fmap (path,) (fmap stdlibHack (io (readFile path)))
else go dirs name
where
path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"
replace c r = map (\x -> if x == c then r else x)
go [] name =
throwError $ Couldn'tFindImport name alldirs
stdlibHack
| mname == ModuleName "Language.Fay.Stdlib" = \s -> s ++ "\n\ndata Maybe a = Just a | Nothing"
| mname == ModuleName "Language.Fay.FFI" = const "module Language.Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined"
| otherwise = id
convertGADT :: GadtDecl -> QualConDecl
convertGADT d =
case d of
GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context
(ConDecl name (convertFunc typ))
where tyvars = []
context = []
convertFunc (TyCon _) = []
convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs
convertFunc (TyParen x) = convertFunc x
convertFunc _ = []
runCompile :: CompileReader -> CompileState
-> Compile a
-> IO (Either CompileError (a,CompileState,CompileWriter))
runCompile reader' state' m = runErrorT (runRWST (unCompile m) reader' state')
parseFay :: Parseable ast => FilePath -> String -> ParseResult ast
parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP
applyCPP :: String -> String
applyCPP =
unlines . loop NoCPP . lines
where
loop _ [] = []
loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest
loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest
loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest
loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest
loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest
loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest
loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest
toInclude NoCPP = True
toInclude (CPPIf x state') = x && toInclude state'
toInclude (CPPElse x state') = x && toInclude state'
data CPPState = NoCPP
| CPPIf Bool CPPState
| CPPElse Bool CPPState
parseMode :: ParseMode
parseMode = defaultParseMode
{ extensions = [GADTs
,StandaloneDeriving
,PackageImports
,EmptyDataDecls
,TypeOperators
,RecordWildCards
,NamedFieldPuns]
}