Misc.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}

-- | Miscellaneous functions used throughout the compiler.

module Fay.Compiler.Misc where

import           Fay.Compiler.Prelude

import           Fay.Compiler.ModuleT            (runModuleT)
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            (runExceptT, throwError)
import           Control.Monad.RWS               (asks, gets, modify, runRWST)
import           Data.Version                    (parseVersion)
import           Language.Haskell.Exts hiding (name)
import           Language.Haskell.Names          (GName (GName), NameInfo (GlobalValue, LocalValue, ScopeError),
                                                  OrigName, Scoped (Scoped), origGName, origName)
import           System.IO
import           System.Process                  (readProcess)
import           Text.ParserCombinators.ReadP    (readP_to_S)

-- | Wrap an expression in a thunk.
thunk :: JsExp -> JsExp
-- thunk exp = JsNew (fayBuiltin "Thunk") [JsFun [] [] (Just exp)]
thunk expr =
  case expr of
    -- JS constants don't need to be in thunks, they're already strict.
    JsLit{} -> expr
    -- Functions (e.g. lets) used for introducing a new lexical scope
    -- aren't necessary inside a thunk. This is a simple aesthetic
    -- optimization.
    JsApp fun@JsFun{} [] -> JsNew JsThunk [fun]
    -- Otherwise make a regular thunk.
    _ -> JsNew JsThunk [JsFun Nothing [] [] (Just expr)]

-- | Wrap an expression in a thunk.
stmtsThunk :: [JsStmt] -> JsExp
stmtsThunk stmts = JsNew JsThunk [JsFun Nothing [] stmts Nothing]

-- | Generate unique names.
uniqueNames :: [JsName]
uniqueNames = map JsParam [1::Integer ..]

-- | Resolve a given maybe-qualified name to a fully qualifed name.
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
    -- TODO should LocalValue just return the name for qualified imports?
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

-- | Resolve a given maybe-qualified name to a fully qualifed name.
-- Use this when a resolution failure is a bug.
unsafeResolveName :: S.QName -> Compile N.QName
unsafeResolveName q = maybe (throwError $ UnableResolveQualified (unAnn q)) return $ tryResolveName q

-- | Resolve a newtype constructor.
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)

-- | Resolve a newtype destructor.
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 a name for the current module.
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))

-- | Qualify a QName for the current module if unqualified.
qualifyQName :: QName a -> Compile N.QName
qualifyQName (UnQual _ name) = qualify name
qualifyQName (unAnn -> n)    = return n

-- | Make a top-level binding.
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 an expression in a thunk.
force :: JsExp -> JsExp
force expr
  | isConstant expr = expr
  | otherwise = JsApp (JsName JsForce) [expr]

-- | Is a JS expression a literal (constant)?
isConstant :: JsExp -> Bool
isConstant JsLit{} = True
isConstant _       = False

-- | Deconstruct a parse result (a la maybe, foldr, either).
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)

-- | Get a config option.
config :: (Config -> a) -> Compile a
config f = asks (f . readerConfig)

-- | Optimize pattern matching conditions by merging conditions in common.
-- TODO This is buggy and no longer used. Fails on tests/case3
optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]
optimizePatConditions = id
  {- 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 a JS exception.
throw :: String -> JsExp -> JsStmt
throw msg expr = JsThrow (JsList [JsLit (JsStr msg),expr])

-- | Throw a JS exception (in an expression).
throwExp :: String -> JsExp -> JsExp
throwExp msg expr = JsThrowExp (JsList [JsLit (JsStr msg),expr])

-- | Is an alt a wildcard?
isWildCardAlt :: S.Alt -> Bool
isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat

-- | Is a pattern a wildcard?
isWildCardPat :: S.Pat -> Bool
isWildCardPat PWildCard{} = True
isWildCardPat PVar{}      = True
isWildCardPat _           = False

-- | Return formatter string if expression is a FFI call.
ffiExp :: Exp a -> Maybe String
ffiExp (App _ (Var _ (UnQual _ (Ident _ "ffi"))) (Lit _ (String _ formatstr _))) = Just formatstr
ffiExp _ = Nothing

-- | Generate a temporary, SCOPED name for testing conditions and
-- such.
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

-- | Generate a temporary, SCOPED name for testing conditions and
-- such. We don't have name tracking yet, so instead we use this.
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

-- | Print out a compiler warning.
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

-- | Pretty print a source location.
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 ++ ")"


-- | Lookup the record for a given type name.
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

-- | Get the fields for a given type.
typeToFields :: QName a -> Compile [N.Name]
typeToFields (unAnn -> typ) = do
  allrecs <- gets stateRecords
  typerecs <- typeToRecs typ
  return . concatMap snd . filter ((`elem` typerecs) . fst) $ allrecs

-- | Get the flag used for GHC, this differs between GHC-7.6.0 and
-- GHC-everything-else so we need to specially test for that. It's
-- lame, but that's random flag name changes for you.
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

-- | Run the top level compilation for all modules.
runTopCompile
  :: CompileReader
  -> CompileState
  -> Compile a
  -> IO (Either CompileError (a,CompileState,CompileWriter))
runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state'))

-- | Runs compilation for a single module.
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

-- | Check if the given language pragmas are all present.
hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool
hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas
  where
    flattenPragmas :: [ModulePragma l] -> [String]
    flattenPragmas = concatMap pragmaName
    pragmaName (LanguagePragma _ q) = map unname q
    pragmaName _ = []

hasLanguagePragma :: String -> [ModulePragma l] -> Bool
hasLanguagePragma pr = hasLanguagePragmas [pr]

-- | if then else for when 'configOptimizeNewtypes'.
ifOptimizeNewtypes :: Compile a -> Compile a -> Compile a
ifOptimizeNewtypes then' else' = do
  optimize <- config configOptimizeNewtypes
  if optimize
     then then'
     else else'