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.Map as M
import qualified Data.Set as S
import Data.String
import Data.Version (parseVersion)
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.Fixity
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.Syntax
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 Nothing [] [] (Just expr)]
stmtsThunk :: [JsStmt] -> JsExp
stmtsThunk stmts = JsNew JsThunk [JsFun Nothing [] stmts Nothing]
uniqueNames :: [JsName]
uniqueNames = map JsParam [1::Integer ..]
tryResolveName :: QName -> Compile (Maybe QName)
tryResolveName special@Special{} = return (Just special)
tryResolveName q@Qual{} = do
ModuleScope.resolveName q <$> gets stateModuleScope
tryResolveName u@(UnQual name) = do
names <- gets stateLocalScope
env <- gets stateModuleScope
if S.member name names
then return $ Just (UnQual name)
else maybe (Just <$> qualify name) (return . Just) $ ModuleScope.resolveName u env
unsafeResolveName :: QName -> Compile QName
unsafeResolveName q = maybe (throwError $ UnableResolveQualified q) return =<< tryResolveName q
lookupNewtypeConst :: QName -> Compile (Maybe (Maybe QName,Type))
lookupNewtypeConst n = do
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 :: QName -> Compile (Maybe (QName,Type))
lookupNewtypeDest n = do
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 -> Compile QName
qualify name = do
modulename <- gets stateModuleName
return (Qual modulename name)
qualifyQName :: QName -> Compile QName
qualifyQName (UnQual name) = qualify name
qualifyQName n = return n
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
cons <- typeToRecs (UnQual name)
fields <- typeToFields (UnQual name)
mapM_ (emitVar . unQName) $ cons ++ fields
EThingWith (UnQual _) ns -> mapM_ emitCName ns
EAbs _ -> return ()
EModuleContents mod -> do
known_exports <- gets _stateExports
current_scope <- gets stateModuleScope
let names = case M.lookup mod known_exports of
Just exports -> S.toList exports
Nothing -> ModuleScope.moduleLocals mod current_scope
mapM_ (emitExport . EVar) names
EThingAll (Qual _ _) -> return ()
e -> do
throwError $ UnsupportedExportSpec e
where
emitVar = return . UnQual >=> unsafeResolveName >=> 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
ffiExp :: Exp -> 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 :: (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
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
,ExistentialQuantification
,StandaloneDeriving
,PackageImports
,EmptyDataDecls
,TypeOperators
,RecordWildCards
,NamedFieldPuns
,FlexibleContexts
,FlexibleInstances
,KindSignatures]
, fixities = Just (preludeFixities ++ baseFixities)
}