{-# 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 :: JsExp -> JsExp
thunk JsExp
expr =
  case JsExp
expr of
    -- JS constants don't need to be in thunks, they're already strict.
    JsLit{} -> JsExp
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 :: JsExp
fun@JsFun{} [] -> JsName -> [JsExp] -> JsExp
JsNew JsName
JsThunk [JsExp
fun]
    -- Otherwise make a regular thunk.
    JsExp
_ -> JsName -> [JsExp] -> JsExp
JsNew JsName
JsThunk [Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [] [] (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just JsExp
expr)]

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

-- | Generate unique names.
uniqueNames :: [JsName]
uniqueNames :: [JsName]
uniqueNames = (Integer -> JsName) -> [Integer] -> [JsName]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> JsName
JsParam [Integer
1::Integer ..]

-- | Resolve a given maybe-qualified name to a fully qualifed name.
tryResolveName :: Show l => QName (Scoped l) -> Maybe N.QName
tryResolveName :: QName (Scoped l) -> Maybe QName
tryResolveName s :: QName (Scoped l)
s@Special{}                                      = QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ QName (Scoped l) -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName (Scoped l)
s
tryResolveName s :: QName (Scoped l)
s@(UnQual Scoped l
_ (Ident Scoped l
_ String
n)) | String
"$gen" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
n = QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ QName (Scoped l) -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName (Scoped l)
s
tryResolveName (QName (Scoped l) -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Qual () (ModuleName () String
"$Prelude") Name ()
n)  = QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ () -> ModuleName () -> Name () -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () String
"Prelude") Name ()
n
tryResolveName q :: QName (Scoped l)
q@(Qual Scoped l
_ (ModuleName Scoped l
_ String
"Fay$") Name (Scoped l)
_)               = QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ QName (Scoped l) -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName (Scoped l)
q
tryResolveName (Qual (Scoped NameInfo l
ni l
_) ModuleName (Scoped l)
_ Name (Scoped l)
_)                         = case NameInfo l
ni of
    GlobalValue SymValueInfo OrigName
n -> QName -> Maybe QName
replaceWithBuiltIns (QName -> Maybe QName)
-> (OrigName -> QName) -> OrigName -> Maybe QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> QName
origName2QName (OrigName -> Maybe QName) -> OrigName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ SymValueInfo OrigName -> OrigName
forall (i :: * -> *) n. HasOrigName i => i n -> n
origName SymValueInfo OrigName
n
    NameInfo l
_             -> Maybe QName
forall a. Maybe a
Nothing
    -- TODO should LocalValue just return the name for qualified imports?
tryResolveName q :: QName (Scoped l)
q@(UnQual (Scoped NameInfo l
ni l
_) (Name (Scoped l) -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name))         = case NameInfo l
ni of
    GlobalValue SymValueInfo OrigName
n -> QName -> Maybe QName
replaceWithBuiltIns (QName -> Maybe QName)
-> (OrigName -> QName) -> OrigName -> Maybe QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> QName
origName2QName (OrigName -> Maybe QName) -> OrigName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ SymValueInfo OrigName -> OrigName
forall (i :: * -> *) n. HasOrigName i => i n -> n
origName SymValueInfo OrigName
n
    LocalValue SrcLoc
_  -> QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () Name ()
name
    ScopeError Error l
_  -> QName (Scoped l) -> Maybe QName
forall a. QName a -> Maybe QName
resolvePrimOp QName (Scoped l)
q
    NameInfo l
_             -> Maybe QName
forall a. Maybe a
Nothing

origName2QName :: OrigName -> N.QName
origName2QName :: OrigName -> QName
origName2QName = GName -> QName
gname2Qname (GName -> QName) -> (OrigName -> GName) -> OrigName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> GName
origGName
  where
    gname2Qname :: GName -> N.QName
    gname2Qname :: GName -> QName
gname2Qname GName
g = case GName
g of
      GName String
"" String
s -> () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () (Name () -> QName) -> Name () -> QName
forall a b. (a -> b) -> a -> b
$ String -> Name ()
mkName String
s
      GName String
m  String
s -> () -> ModuleName () -> Name () -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () String
m) (Name () -> QName) -> Name () -> QName
forall a b. (a -> b) -> a -> b
$ String -> Name ()
mkName String
s
      where
        mkName :: String -> Name ()
mkName s :: String
s@(Char
x:String
_)
          | Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
s
          | Bool
otherwise = () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
s
        mkName String
"" = String -> Name ()
forall a. HasCallStack => String -> a
error String
"mkName \"\""

replaceWithBuiltIns :: N.QName -> Maybe N.QName
replaceWithBuiltIns :: QName -> Maybe QName
replaceWithBuiltIns QName
n = QName -> Maybe QName
findPrimOp QName
n Maybe QName -> Maybe QName -> Maybe QName
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> QName -> Maybe QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
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 :: QName -> Compile QName
unsafeResolveName QName
q = Compile QName
-> (QName -> Compile QName) -> Maybe QName -> Compile QName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CompileError -> Compile QName
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile QName) -> CompileError -> Compile QName
forall a b. (a -> b) -> a -> b
$ QName -> CompileError
UnableResolveQualified (QName -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName
q)) QName -> Compile QName
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QName -> Compile QName) -> Maybe QName -> Compile QName
forall a b. (a -> b) -> a -> b
$ QName -> Maybe QName
forall l. Show l => QName (Scoped l) -> Maybe QName
tryResolveName QName
q

-- | Resolve a newtype constructor.
lookupNewtypeConst :: S.QName -> Compile (Maybe (Maybe N.QName,N.Type))
lookupNewtypeConst :: QName -> Compile (Maybe (Maybe QName, Type))
lookupNewtypeConst QName
n = do
  let mName :: Maybe QName
mName = QName -> Maybe QName
forall l. Show l => QName (Scoped l) -> Maybe QName
tryResolveName QName
n
  case Maybe QName
mName of
    Maybe QName
Nothing -> Maybe (Maybe QName, Type) -> Compile (Maybe (Maybe QName, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe QName, Type)
forall a. Maybe a
Nothing
    Just QName
name -> do
      [(QName, Maybe QName, Type)]
newtypes <- (CompileState -> [(QName, Maybe QName, Type)])
-> Compile [(QName, Maybe QName, Type)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> [(QName, Maybe QName, Type)]
stateNewtypes
      case ((QName, Maybe QName, Type) -> Bool)
-> [(QName, Maybe QName, Type)] -> Maybe (QName, Maybe QName, Type)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(QName
cname,Maybe QName
_,Type
_) -> QName
cname QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
name) [(QName, Maybe QName, Type)]
newtypes of
        Maybe (QName, Maybe QName, Type)
Nothing -> Maybe (Maybe QName, Type) -> Compile (Maybe (Maybe QName, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe QName, Type)
forall a. Maybe a
Nothing
        Just (QName
_,Maybe QName
dname,Type
ty) -> Maybe (Maybe QName, Type) -> Compile (Maybe (Maybe QName, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Maybe QName, Type) -> Compile (Maybe (Maybe QName, Type)))
-> Maybe (Maybe QName, Type) -> Compile (Maybe (Maybe QName, Type))
forall a b. (a -> b) -> a -> b
$ (Maybe QName, Type) -> Maybe (Maybe QName, Type)
forall a. a -> Maybe a
Just (Maybe QName
dname,Type
ty)

-- | Resolve a newtype destructor.
lookupNewtypeDest :: S.QName -> Compile (Maybe (N.QName,N.Type))
lookupNewtypeDest :: QName -> Compile (Maybe (QName, Type))
lookupNewtypeDest QName
n = do
  let mName :: Maybe QName
mName = QName -> Maybe QName
forall l. Show l => QName (Scoped l) -> Maybe QName
tryResolveName QName
n
  [(QName, Maybe QName, Type)]
newtypes <- (CompileState -> [(QName, Maybe QName, Type)])
-> Compile [(QName, Maybe QName, Type)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> [(QName, Maybe QName, Type)]
stateNewtypes
  case ((QName, Maybe QName, Type) -> Bool)
-> [(QName, Maybe QName, Type)] -> Maybe (QName, Maybe QName, Type)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(QName
_,Maybe QName
dname,Type
_) -> Maybe QName
dname Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mName) [(QName, Maybe QName, Type)]
newtypes of
    Maybe (QName, Maybe QName, Type)
Nothing -> Maybe (QName, Type) -> Compile (Maybe (QName, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (QName, Type)
forall a. Maybe a
Nothing
    Just (QName
cname,Maybe QName
_,Type
ty) -> Maybe (QName, Type) -> Compile (Maybe (QName, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (QName, Type) -> Compile (Maybe (QName, Type)))
-> Maybe (QName, Type) -> Compile (Maybe (QName, Type))
forall a b. (a -> b) -> a -> b
$ (QName, Type) -> Maybe (QName, Type)
forall a. a -> Maybe a
Just (QName
cname,Type
ty)

-- | Qualify a name for the current module.
qualify :: Name a -> Compile N.QName
qualify :: Name a -> Compile QName
qualify (Ident a
_ String
name) = do
  ModuleName ()
modulename <- (CompileState -> ModuleName ()) -> Compile (ModuleName ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> ModuleName ()
stateModuleName
  QName -> Compile QName
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> ModuleName () -> Name () -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
modulename (() -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
name))
qualify (Symbol a
_ String
name) = do
  ModuleName ()
modulename <- (CompileState -> ModuleName ()) -> Compile (ModuleName ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> ModuleName ()
stateModuleName
  QName -> Compile QName
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> ModuleName () -> Name () -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
modulename (() -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
name))

-- | Qualify a QName for the current module if unqualified.
qualifyQName :: QName a -> Compile N.QName
qualifyQName :: QName a -> Compile QName
qualifyQName (UnQual a
_ Name a
name) = Name a -> Compile QName
forall a. Name a -> Compile QName
qualify Name a
name
qualifyQName (QName a -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
n)    = QName -> Compile QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
n

-- | Make a top-level binding.
bindToplevel :: Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt
bindToplevel :: Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt
bindToplevel Bool
toplevel Maybe SrcSpan
msrcloc (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) JsExp
expr =
  if Bool
toplevel
    then do
      ModuleName ()
mod <- (CompileState -> ModuleName ()) -> Compile (ModuleName ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> ModuleName ()
stateModuleName
      JsStmt -> Compile JsStmt
forall (m :: * -> *) a. Monad m => a -> m a
return (JsStmt -> Compile JsStmt) -> JsStmt -> Compile JsStmt
forall a b. (a -> b) -> a -> b
$ Maybe SrcSpan -> QName -> JsExp -> JsStmt
JsSetQName Maybe SrcSpan
msrcloc (() -> ModuleName () -> Name () -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
mod Name ()
name) JsExp
expr
    else JsStmt -> Compile JsStmt
forall (m :: * -> *) a. Monad m => a -> m a
return (JsStmt -> Compile JsStmt) -> JsStmt -> Compile JsStmt
forall a b. (a -> b) -> a -> b
$ JsName -> JsExp -> JsStmt
JsVar (QName -> JsName
JsNameVar (QName -> JsName) -> QName -> JsName
forall a b. (a -> b) -> a -> b
$ () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () Name ()
name) JsExp
expr

-- | Force an expression in a thunk.
force :: JsExp -> JsExp
force :: JsExp -> JsExp
force JsExp
expr
  | JsExp -> Bool
isConstant JsExp
expr = JsExp
expr
  | Bool
otherwise = JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName JsName
JsForce) [JsExp
expr]

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

-- | Deconstruct a parse result (a la maybe, foldr, either).
parseResult :: ((F.SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b
parseResult :: ((SrcLoc, String) -> b) -> (a -> b) -> ParseResult a -> b
parseResult (SrcLoc, String) -> b
die a -> b
ok ParseResult a
result = case ParseResult a
result of
  ParseOk a
a -> a -> b
ok a
a
  ParseFailed SrcLoc
srcloc String
msg -> (SrcLoc, String) -> b
die (SrcLoc
srcloc,String
msg)

-- | Get a config option.
config :: (Config -> a) -> Compile a
config :: (Config -> a) -> Compile a
config Config -> a
f = (CompileReader -> a) -> Compile a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config -> a
f (Config -> a) -> (CompileReader -> Config) -> CompileReader -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileReader -> Config
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 :: [[JsStmt]] -> [[JsStmt]]
optimizePatConditions = [[JsStmt]] -> [[JsStmt]]
forall a. a -> a
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 :: String -> JsExp -> JsStmt
throw String
msg JsExp
expr = JsExp -> JsStmt
JsThrow ([JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (String -> JsLit
JsStr String
msg),JsExp
expr])

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

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

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

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

-- | Generate a temporary, SCOPED name for testing conditions and
-- such.
withScopedTmpJsName :: (JsName -> Compile a) -> Compile a
withScopedTmpJsName :: (JsName -> Compile a) -> Compile a
withScopedTmpJsName JsName -> Compile a
withName = do
  Integer
depth <- (CompileState -> Integer) -> Compile Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> Integer
stateNameDepth
  (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateNameDepth :: Integer
stateNameDepth = Integer
depth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 }
  a
ret <- JsName -> Compile a
withName (JsName -> Compile a) -> JsName -> Compile a
forall a b. (a -> b) -> a -> b
$ Integer -> JsName
JsTmp Integer
depth
  (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateNameDepth :: Integer
stateNameDepth = Integer
depth }
  a -> Compile a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: (Name -> Compile a) -> Compile a
withScopedTmpName Name -> Compile a
withName = do
  Integer
depth <- (CompileState -> Integer) -> Compile Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> Integer
stateNameDepth
  (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateNameDepth :: Integer
stateNameDepth = Integer
depth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 }
  a
ret <- Name -> Compile a
withName (Name -> Compile a) -> Name -> Compile a
forall a b. (a -> b) -> a -> b
$ X -> String -> Name
forall l. l -> String -> Name l
Ident X
S.noI (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"$gen" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
depth
  (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateNameDepth :: Integer
stateNameDepth = Integer
depth }
  a -> Compile a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret

-- | Print out a compiler warning.
warn :: String -> Compile ()
warn :: String -> Compile ()
warn String
"" = () -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
warn String
w = (Config -> Config) -> Compile Config
forall a. (Config -> a) -> Compile a
config Config -> Config
forall a. a -> a
id Compile Config -> (Config -> Compile ()) -> Compile ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> Compile ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> Compile ()) -> (Config -> IO ()) -> Config -> Compile ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> String -> IO ()
`ioWarn` String
w)

ioWarn :: Config -> String -> IO ()
ioWarn :: Config -> String -> IO ()
ioWarn Config
_ String
"" = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ioWarn Config
cfg String
w =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configWall Config
cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
w

-- | Pretty print a source location.
printSrcLoc :: S.SrcLoc -> String
printSrcLoc :: SrcLoc -> String
printSrcLoc SrcLoc{Int
String
srcFilename :: SrcLoc -> String
srcLine :: SrcLoc -> Int
srcColumn :: SrcLoc -> Int
srcColumn :: Int
srcLine :: Int
srcFilename :: String
..} = String
srcFilename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcColumn

printSrcSpanInfo :: SrcSpanInfo -> String
printSrcSpanInfo :: SrcSpanInfo -> String
printSrcSpanInfo (SrcSpanInfo SrcSpan
a [SrcSpan]
b) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String
printSrcSpan SrcSpan
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (SrcSpan -> String) -> [SrcSpan] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SrcSpan -> String
printSrcSpan [SrcSpan]
b

printSrcSpan :: SrcSpan -> String
printSrcSpan :: SrcSpan -> String
printSrcSpan SrcSpan{Int
String
srcSpanFilename :: SrcSpan -> String
srcSpanStartLine :: SrcSpan -> Int
srcSpanStartColumn :: SrcSpan -> Int
srcSpanEndLine :: SrcSpan -> Int
srcSpanEndColumn :: SrcSpan -> Int
srcSpanEndColumn :: Int
srcSpanEndLine :: Int
srcSpanStartColumn :: Int
srcSpanStartLine :: Int
srcSpanFilename :: String
..} = String
srcSpanFilename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcSpanStartLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcSpanStartColumn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")-(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcSpanEndLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcSpanEndColumn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"


-- | Lookup the record for a given type name.
typeToRecs :: QName a -> Compile [N.QName]
typeToRecs :: QName a -> Compile [QName]
typeToRecs (QName a -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
typ) = [QName] -> Maybe [QName] -> [QName]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [QName] -> [QName])
-> ([(QName, [QName])] -> Maybe [QName])
-> [(QName, [QName])]
-> [QName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [(QName, [QName])] -> Maybe [QName]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
typ ([(QName, [QName])] -> [QName])
-> Compile [(QName, [QName])] -> Compile [QName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompileState -> [(QName, [QName])]) -> Compile [(QName, [QName])]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> [(QName, [QName])]
stateRecordTypes

recToFields :: S.QName -> Compile [N.Name]
recToFields :: QName -> Compile [Name ()]
recToFields QName
con =
  case QName -> Maybe QName
forall l. Show l => QName (Scoped l) -> Maybe QName
tryResolveName QName
con of
    Maybe QName
Nothing -> [Name ()] -> Compile [Name ()]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just QName
c -> [Name ()] -> Maybe [Name ()] -> [Name ()]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Name ()] -> [Name ()])
-> ([(QName, [Name ()])] -> Maybe [Name ()])
-> [(QName, [Name ()])]
-> [Name ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [(QName, [Name ()])] -> Maybe [Name ()]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
c ([(QName, [Name ()])] -> [Name ()])
-> Compile [(QName, [Name ()])] -> Compile [Name ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompileState -> [(QName, [Name ()])])
-> Compile [(QName, [Name ()])]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> [(QName, [Name ()])]
stateRecords

-- | Get the fields for a given type.
typeToFields :: QName a -> Compile [N.Name]
typeToFields :: QName a -> Compile [Name ()]
typeToFields (QName a -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
typ) = do
  [(QName, [Name ()])]
allrecs <- (CompileState -> [(QName, [Name ()])])
-> Compile [(QName, [Name ()])]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> [(QName, [Name ()])]
stateRecords
  [QName]
typerecs <- QName -> Compile [QName]
forall a. QName a -> Compile [QName]
typeToRecs QName
typ
  [Name ()] -> Compile [Name ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name ()] -> Compile [Name ()])
-> ([(QName, [Name ()])] -> [Name ()])
-> [(QName, [Name ()])]
-> Compile [Name ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((QName, [Name ()]) -> [Name ()])
-> [(QName, [Name ()])] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName, [Name ()]) -> [Name ()]
forall a b. (a, b) -> b
snd ([(QName, [Name ()])] -> [Name ()])
-> ([(QName, [Name ()])] -> [(QName, [Name ()])])
-> [(QName, [Name ()])]
-> [Name ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((QName, [Name ()]) -> Bool)
-> [(QName, [Name ()])] -> [(QName, [Name ()])]
forall a. (a -> Bool) -> [a] -> [a]
filter ((QName -> [QName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QName]
typerecs) (QName -> Bool)
-> ((QName, [Name ()]) -> QName) -> (QName, [Name ()]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, [Name ()]) -> QName
forall a b. (a, b) -> a
fst) ([(QName, [Name ()])] -> Compile [Name ()])
-> [(QName, [Name ()])] -> Compile [Name ()]
forall a b. (a -> b) -> a -> b
$ [(QName, [Name ()])]
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 :: IO String
getGhcPackageDbFlag = do
  String
s <- String -> [String] -> String -> IO String
readProcess String
"ghc" [String
"--version"] String
""
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
      case ((String -> Maybe (Version, String))
-> [String] -> [(Version, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (Version, String)
readVersion ([String] -> [(Version, String)])
-> [String] -> [(Version, String)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
s, String -> Maybe (Version, String)
readVersion String
"7.6.0") of
          ((Version, String)
v:[(Version, String)]
_, Just (Version, String)
min') | (Version, String)
v (Version, String) -> (Version, String) -> Bool
forall a. Ord a => a -> a -> Bool
> (Version, String)
min' -> String
"-package-db"
          ([(Version, String)], Maybe (Version, String))
_ -> String
"-package-conf"
  where
    readVersion :: String -> Maybe (Version, String)
readVersion = [(Version, String)] -> Maybe (Version, String)
forall a. [a] -> Maybe a
listToMaybe ([(Version, String)] -> Maybe (Version, String))
-> (String -> [(Version, String)])
-> String
-> Maybe (Version, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, String) -> Bool)
-> [(Version, String)] -> [(Version, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> ((Version, String) -> String) -> (Version, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, String) -> String
forall a b. (a, b) -> b
snd) ([(Version, String)] -> [(Version, String)])
-> (String -> [(Version, String)]) -> String -> [(Version, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP Version -> String -> [(Version, String)]
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion

-- | Run the top level compilation for all modules.
runTopCompile
  :: CompileReader
  -> CompileState
  -> Compile a
  -> IO (Either CompileError (a,CompileState,CompileWriter))
runTopCompile :: CompileReader
-> CompileState
-> Compile a
-> IO (Either CompileError (a, CompileState, CompileWriter))
runTopCompile CompileReader
reader' CompileState
state' Compile a
m = (Either CompileError (a, CompileState, CompileWriter),
 Map ModuleName Symbols)
-> Either CompileError (a, CompileState, CompileWriter)
forall a b. (a, b) -> a
fst ((Either CompileError (a, CompileState, CompileWriter),
  Map ModuleName Symbols)
 -> Either CompileError (a, CompileState, CompileWriter))
-> IO
     (Either CompileError (a, CompileState, CompileWriter),
      Map ModuleName Symbols)
-> IO (Either CompileError (a, CompileState, CompileWriter))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleT
  Symbols IO (Either CompileError (a, CompileState, CompileWriter))
-> IO
     (Either CompileError (a, CompileState, CompileWriter),
      Map ModuleName Symbols)
forall (m :: * -> *) i a.
(Monad m, Monoid i) =>
ModuleT i m a -> m (a, Map ModuleName i)
runModuleT (ExceptT
  CompileError (ModuleT Symbols IO) (a, CompileState, CompileWriter)
-> ModuleT
     Symbols IO (Either CompileError (a, CompileState, CompileWriter))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (RWST
  CompileReader
  CompileWriter
  CompileState
  (ExceptT CompileError (ModuleT Symbols IO))
  a
-> CompileReader
-> CompileState
-> ExceptT
     CompileError (ModuleT Symbols IO) (a, CompileState, CompileWriter)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (Compile a
-> RWST
     CompileReader
     CompileWriter
     CompileState
     (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO))
     a
forall a.
Compile a
-> RWST
     CompileReader
     CompileWriter
     CompileState
     (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO))
     a
unCompile Compile a
m) CompileReader
reader' CompileState
state'))

-- | Runs compilation for a single module.
runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a
runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a
runCompileModule CompileReader
reader' CompileState
state' Compile a
m = ExceptT
  CompileError (ModuleT Symbols IO) (a, CompileState, CompileWriter)
-> CompileModule a
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (RWST
  CompileReader
  CompileWriter
  CompileState
  (ExceptT CompileError (ModuleT Symbols IO))
  a
-> CompileReader
-> CompileState
-> ExceptT
     CompileError (ModuleT Symbols IO) (a, CompileState, CompileWriter)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (Compile a
-> RWST
     CompileReader
     CompileWriter
     CompileState
     (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO))
     a
forall a.
Compile a
-> RWST
     CompileReader
     CompileWriter
     CompileState
     (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO))
     a
unCompile Compile a
m) CompileReader
reader' CompileState
state')

shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a
shouldBeDesugared :: f l -> Compile a
shouldBeDesugared = CompileError -> Compile a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile a)
-> (f l -> CompileError) -> f l -> Compile a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CompileError
ShouldBeDesugared (String -> CompileError) -> (f l -> String) -> f l -> CompileError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f () -> String
forall a. Show a => a -> String
show (f () -> String) -> (f l -> f ()) -> f l -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f l -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn

-- | Check if the given language pragmas are all present.
hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool
hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool
hasLanguagePragmas [String]
pragmas [ModulePragma l]
modulePragmas = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
pragmas) (Int -> Bool) -> ([String] -> Int) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> ([String] -> [String]) -> [String] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
pragmas) ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [ModulePragma l] -> [String]
forall l. [ModulePragma l] -> [String]
flattenPragmas [ModulePragma l]
modulePragmas
  where
    flattenPragmas :: [ModulePragma l] -> [String]
    flattenPragmas :: [ModulePragma l] -> [String]
flattenPragmas = (ModulePragma l -> [String]) -> [ModulePragma l] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModulePragma l -> [String]
forall a. ModulePragma a -> [String]
pragmaName
    pragmaName :: ModulePragma a -> [String]
pragmaName (LanguagePragma a
_ [Name a]
q) = (Name a -> String) -> [Name a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name a -> String
forall a. Name a -> String
unname [Name a]
q
    pragmaName ModulePragma a
_ = []

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

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