module Fay.Compiler.Misc where
import Fay.Compiler.PrimOp
import Fay.Control.Monad.IO
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.Applicative
import Control.Monad.Error
import Control.Monad.RWS
import Data.Char (isAlpha)
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.String
import Data.Version (parseVersion)
import Distribution.HaskellSuite.Modules
import Language.Haskell.Exts.Annotated hiding (name)
import Language.Haskell.Names
import Prelude hiding (exp, mod)
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 :: (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 :: 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 :: CompileConfig -> 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 = do
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 (runErrorT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty
runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a
runCompileModule 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 = defaultExtensions
, fixities = Just (preludeFixities ++ baseFixities)
}
shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a
shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn
defaultExtensions :: [Extension]
defaultExtensions = map EnableExtension
[GADTs
,ExistentialQuantification
,StandaloneDeriving
,PackageImports
,EmptyDataDecls
,TypeOperators
,RecordWildCards
,NamedFieldPuns
,FlexibleContexts
,FlexibleInstances
,KindSignatures
,TupleSections
] ++ map DisableExtension
[ImplicitPrelude]