{-# 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 expr :: 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.
    _ -> 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 stmts :: [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 [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 _ (Ident _ n :: String
n)) | "$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 () "$Prelude") n :: 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 () "Prelude") Name ()
n
tryResolveName q :: QName (Scoped l)
q@(Qual _ (ModuleName _ "Fay$") _)               = 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 ni :: NameInfo l
ni _) _ _)                         = case NameInfo l
ni of
    GlobalValue n :: 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
    _             -> 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 ni :: NameInfo l
ni _) (Name (Scoped l) -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name))         = case NameInfo l
ni of
    GlobalValue n :: 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 _  -> 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 _  -> QName (Scoped l) -> Maybe QName
forall a. QName a -> Maybe QName
resolvePrimOp QName (Scoped l)
q
    _             -> 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 g :: GName
g = case GName
g of
      GName "" s :: 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 m :: String
m  s :: 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@(x :: Char
x:_)
          | Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' = () -> 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 -> Name ()
forall a. HasCallStack => String -> a
error "mkName \"\""

replaceWithBuiltIns :: N.QName -> Maybe N.QName
replaceWithBuiltIns :: QName -> Maybe QName
replaceWithBuiltIns n :: 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 q :: 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 n :: 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
    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 name :: 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 (\(cname :: QName
cname,_,_) -> QName
cname QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
name) [(QName, Maybe QName, Type)]
newtypes of
        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 (_,dname :: Maybe QName
dname,ty :: 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 n :: 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 (\(_,dname :: Maybe QName
dname,_) -> Maybe QName
dname Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mName) [(QName, Maybe QName, Type)]
newtypes of
    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 (cname :: QName
cname,_,ty :: 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 _ name :: 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 _ name :: 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 _ name :: 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 toplevel :: Bool
toplevel msrcloc :: Maybe SrcSpan
msrcloc (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) expr :: 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 expr :: 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 _       = 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 die :: (SrcLoc, String) -> b
die ok :: a -> b
ok result :: ParseResult a
result = case ParseResult a
result of
  ParseOk a :: a
a -> a -> b
ok a
a
  ParseFailed srcloc :: SrcLoc
srcloc msg :: 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 f :: 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 msg :: String
msg expr :: 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 msg :: String
msg expr :: 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 _ pat :: Pat X
pat _ _) = 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 _           = Bool
False

-- | Return formatter string if expression is a FFI call.
ffiExp :: Exp a -> Maybe String
ffiExp :: Exp a -> Maybe String
ffiExp (App _ (Var _ (UnQual _ (Ident _ "ffi"))) (Lit _ (String _ formatstr :: String
formatstr _))) = String -> Maybe String
forall a. a -> Maybe a
Just String
formatstr
ffiExp _ = 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 withName :: 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
$ \s :: CompileState
s -> CompileState
s { stateNameDepth :: Integer
stateNameDepth = Integer
depth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 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
$ \s :: 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 withName :: 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
$ \s :: CompileState
s -> CompileState
s { stateNameDepth :: Integer
stateNameDepth = Integer
depth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 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
$ "$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
$ \s :: 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 "" = () -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
warn w :: 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 _ "" = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ioWarn cfg :: Config
cfg w :: 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
$ "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{..} = String
srcFilename String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":" 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
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcColumn

printSrcSpanInfo :: SrcSpanInfo -> String
printSrcSpanInfo :: SrcSpanInfo -> String
printSrcSpanInfo (SrcSpanInfo a :: SrcSpan
a b :: [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{..} = String
srcSpanFilename String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": (" 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
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
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
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcSpanEndColumn String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"


-- | 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 con :: QName
con =
  case QName -> Maybe QName
forall l. Show l => QName (Scoped l) -> Maybe QName
tryResolveName QName
con of
    Nothing -> [Name ()] -> Compile [Name ()]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just c :: 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 "ghc" ["--version"] ""
  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 "7.6.0") of
          (v :: (Version, String)
v:_, Just min' :: (Version, String)
min') | (Version, String)
v (Version, String) -> (Version, String) -> Bool
forall a. Ord a => a -> a -> Bool
> (Version, String)
min' -> "-package-db"
          _ -> "-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 reader' :: CompileReader
reader' state' :: CompileState
state' m :: 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 reader' :: CompileReader
reader' state' :: CompileState
state' m :: 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 pragmas :: [String]
pragmas modulePragmas :: [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 _ q :: [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 _ = []

hasLanguagePragma :: String -> [ModulePragma l] -> Bool
hasLanguagePragma :: String -> [ModulePragma l] -> Bool
hasLanguagePragma pr :: 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 then' :: Compile a
then' else' :: 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'