{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
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)
thunk :: JsExp -> JsExp
thunk :: JsExp -> JsExp
thunk expr :: JsExp
expr =
case JsExp
expr of
JsLit{} -> JsExp
expr
JsApp fun :: JsExp
fun@JsFun{} [] -> JsName -> [JsExp] -> JsExp
JsNew JsName
JsThunk [JsExp
fun]
_ -> 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)]
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]
uniqueNames :: [JsName]
uniqueNames :: [JsName]
uniqueNames = (Integer -> JsName) -> [Integer] -> [JsName]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> JsName
JsParam [1::Integer ..]
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
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
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
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)
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 :: 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))
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
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 :: 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]
isConstant :: JsExp -> Bool
isConstant :: JsExp -> Bool
isConstant JsLit{} = Bool
True
isConstant _ = Bool
False
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)
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)
optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]
optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]
optimizePatConditions = [[JsStmt]] -> [[JsStmt]]
forall a. a -> a
id
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])
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])
isWildCardAlt :: S.Alt -> Bool
isWildCardAlt :: Alt -> Bool
isWildCardAlt (Alt _ pat :: Pat X
pat _ _) = Pat X -> Bool
isWildCardPat Pat X
pat
isWildCardPat :: S.Pat -> Bool
isWildCardPat :: Pat X -> Bool
isWildCardPat PWildCard{} = Bool
True
isWildCardPat PVar{} = Bool
True
isWildCardPat _ = Bool
False
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
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
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
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
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]
++ ")"
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
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
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
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'))
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
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]
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'