{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Fay.Compiler.Decl where
import Fay.Compiler.Prelude
import Fay.Compiler.Exp
import Fay.Compiler.FFI
import Fay.Compiler.GADT
import Fay.Compiler.Misc
import Fay.Compiler.Pattern
import Fay.Compiler.State
import Fay.Exts (convertFieldDecl, fieldDeclNames)
import Fay.Exts.NoAnnotation (unAnn)
import qualified Fay.Exts.Scoped as S
import Fay.Types
import Control.Monad.Except (throwError)
import Control.Monad.RWS (gets, modify)
import Language.Haskell.Exts hiding (binds, loc, name)
{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]
compileDecls :: Bool -> [Decl] -> Compile [JsStmt]
compileDecls toplevel :: Bool
toplevel = ([[JsStmt]] -> [JsStmt]) -> Compile [[JsStmt]] -> Compile [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Compile [[JsStmt]] -> Compile [JsStmt])
-> ([Decl] -> Compile [[JsStmt]]) -> [Decl] -> Compile [JsStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl -> Compile [JsStmt]) -> [Decl] -> Compile [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Decl -> Compile [JsStmt]
compileDecl Bool
toplevel)
compileDecl :: Bool -> S.Decl -> Compile [JsStmt]
compileDecl :: Bool -> Decl -> Compile [JsStmt]
compileDecl toplevel :: Bool
toplevel decl :: Decl
decl = case Decl
decl of
pat :: Decl
pat@PatBind{} -> Bool -> Decl -> Compile [JsStmt]
compilePatBind Bool
toplevel Decl
pat
FunBind _ matches :: [Match X]
matches -> Bool -> [Match X] -> Compile [JsStmt]
compileFunCase Bool
toplevel [Match X]
matches
DataDecl _ (DataType _ ) _ (DeclHead X -> [TyVarBind]
mkTyVars -> [TyVarBind]
tyvars) constructors :: [QualConDecl X]
constructors _ -> Bool -> [TyVarBind] -> [QualConDecl X] -> Compile [JsStmt]
compileDataDecl Bool
toplevel [TyVarBind]
tyvars [QualConDecl X]
constructors
GDataDecl _ (DataType _) _l :: Maybe (Context X)
_l (DeclHead X -> [TyVarBind]
mkTyVars -> [TyVarBind]
tyvars) _n :: Maybe (Kind X)
_n decls :: [GadtDecl X]
decls _ -> Bool -> [TyVarBind] -> [QualConDecl X] -> Compile [JsStmt]
compileDataDecl Bool
toplevel [TyVarBind]
tyvars ((GadtDecl X -> QualConDecl X) -> [GadtDecl X] -> [QualConDecl X]
forall a b. (a -> b) -> [a] -> [b]
map GadtDecl X -> QualConDecl X
forall a. GadtDecl a -> QualConDecl a
convertGADT [GadtDecl X]
decls)
DataDecl _ (NewType _) _ head' :: DeclHead X
head' constructors :: [QualConDecl X]
constructors _ ->
Compile [JsStmt] -> Compile [JsStmt] -> Compile [JsStmt]
forall a. Compile a -> Compile a -> Compile a
ifOptimizeNewtypes ([JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
(Bool -> [TyVarBind] -> [QualConDecl X] -> Compile [JsStmt]
compileDataDecl Bool
toplevel (DeclHead X -> [TyVarBind]
mkTyVars DeclHead X
head') [QualConDecl X]
constructors)
TypeDecl {} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
TypeSig {} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
InfixDecl{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
ClassDecl{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
InstDecl {} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
DerivDecl{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
DefaultDecl{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
RulePragmaDecl{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
DeprPragmaDecl{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
WarnPragmaDecl{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
InlineSig{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
InlineConlikeSig{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
SpecSig{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
SpecInlineSig{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
InstSig{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
AnnPragma{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
_ -> CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Decl -> CompileError
UnsupportedDeclaration Decl
decl)
mkTyVars :: S.DeclHead -> [S.TyVarBind]
mkTyVars :: DeclHead X -> [TyVarBind]
mkTyVars x :: DeclHead X
x = DeclHead X -> [TyVarBind] -> [TyVarBind]
forall l. DeclHead l -> [TyVarBind l] -> [TyVarBind l]
go DeclHead X
x []
where
go :: DeclHead l -> [TyVarBind l] -> [TyVarBind l]
go (DHead _ _) = [TyVarBind l] -> [TyVarBind l]
forall a. a -> a
id
go (DHInfix _ r :: TyVarBind l
r _) = (TyVarBind l
rTyVarBind l -> [TyVarBind l] -> [TyVarBind l]
forall a. a -> [a] -> [a]
:)
go (DHParen _ dh :: DeclHead l
dh) = DeclHead l -> [TyVarBind l] -> [TyVarBind l]
go DeclHead l
dh
go (DHApp _ dh :: DeclHead l
dh r :: TyVarBind l
r) = DeclHead l -> [TyVarBind l] -> [TyVarBind l]
go DeclHead l
dh ([TyVarBind l] -> [TyVarBind l])
-> ([TyVarBind l] -> [TyVarBind l])
-> [TyVarBind l]
-> [TyVarBind l]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBind l
rTyVarBind l -> [TyVarBind l] -> [TyVarBind l]
forall a. a -> [a] -> [a]
:)
compilePatBind :: Bool -> S.Decl -> Compile [JsStmt]
compilePatBind :: Bool -> Decl -> Compile [JsStmt]
compilePatBind toplevel :: Bool
toplevel patDecl :: Decl
patDecl = case Decl
patDecl of
PatBind _ (PVar _ name' :: Name X
name')
(UnGuardedRhs _
(ExpTypeSig _
(App _ (Var _ (UnQual _ (Ident _ "ffi")))
(Lit _ (String _ formatstr :: String
formatstr _)))
sig :: Kind X
sig)) Nothing ->
let name :: Name ()
name = Name X -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Name X
name'
loc :: SrcSpanInfo
loc = X -> SrcSpanInfo
S.srcSpanInfo (X -> SrcSpanInfo) -> X -> SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ Name X -> X
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name X
name'
in do
JsExp
fun <- SrcSpanInfo -> Maybe (Name ()) -> String -> Kind X -> Compile JsExp
forall a.
SrcSpanInfo -> Maybe (Name a) -> String -> Kind X -> Compile JsExp
compileFFIExp SrcSpanInfo
loc (Name () -> Maybe (Name ())
forall a. a -> Maybe a
Just Name ()
name) String
formatstr Kind X
sig
JsStmt
stmt <- Bool -> Maybe SrcSpan -> Name () -> JsExp -> Compile JsStmt
forall a.
Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt
bindToplevel Bool
toplevel (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpanInfo -> SrcSpan
srcInfoSpan SrcSpanInfo
loc)) Name ()
name JsExp
fun
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
stmt]
PatBind srcloc :: X
srcloc (PVar _ ident :: Name X
ident) (UnGuardedRhs _ rhs :: Exp X
rhs) Nothing ->
Bool -> X -> Name X -> Exp X -> Compile [JsStmt]
compileUnguardedRhs Bool
toplevel X
srcloc Name X
ident Exp X
rhs
PatBind srcloc :: X
srcloc (PVar _ ident :: Name X
ident) (UnGuardedRhs _ rhs :: Exp X
rhs) (Just bdecls :: Binds X
bdecls) ->
Bool -> X -> Name X -> Exp X -> Compile [JsStmt]
compileUnguardedRhs Bool
toplevel X
srcloc Name X
ident (X -> Binds X -> Exp X -> Exp X
forall l. l -> Binds l -> Exp l -> Exp l
Let X
S.noI Binds X
bdecls Exp X
rhs)
PatBind _ pat :: Pat X
pat (UnGuardedRhs _ rhs :: Exp X
rhs) _bdecls :: Maybe (Binds X)
_bdecls -> case Pat X
pat of
PList {} -> Pat X -> Exp X -> Compile [JsStmt]
compilePatBind' Pat X
pat Exp X
rhs
PTuple{} -> Pat X -> Exp X -> Compile [JsStmt]
compilePatBind' Pat X
pat Exp X
rhs
PApp {} -> Pat X -> Exp X -> Compile [JsStmt]
compilePatBind' Pat X
pat Exp X
rhs
_ -> CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile [JsStmt])
-> CompileError -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ Decl -> CompileError
UnsupportedDeclaration Decl
patDecl
_ -> CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile [JsStmt])
-> CompileError -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ Decl -> CompileError
UnsupportedDeclaration Decl
patDecl
where
compilePatBind' :: S.Pat -> S.Exp -> Compile [JsStmt]
compilePatBind' :: Pat X -> Exp X -> Compile [JsStmt]
compilePatBind' pat :: Pat X
pat rhs :: Exp X
rhs = do
JsExp
exp <- Exp X -> Compile JsExp
compileExp Exp X
rhs
JsName
name <- (JsName -> Compile JsName) -> Compile JsName
forall a. (JsName -> Compile a) -> Compile a
withScopedTmpJsName JsName -> Compile JsName
forall (m :: * -> *) a. Monad m => a -> m a
return
[JsStmt]
m <- JsExp -> Pat X -> [JsStmt] -> Compile [JsStmt]
compilePat (JsName -> JsExp
JsName JsName
name) Pat X
pat []
[JsStmt]
m2 <- [JsStmt] -> Pat X -> [JsStmt] -> Compile [JsStmt]
interleavePatternMatchFailures [JsStmt]
m Pat X
pat [JsStmt]
m
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return (JsName -> JsExp -> JsStmt
JsVar JsName
name JsExp
exp JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: [JsStmt]
m2)
interleavePatternMatchFailures :: [JsStmt] -> S.Pat -> [JsStmt] -> Compile [JsStmt]
interleavePatternMatchFailures :: [JsStmt] -> Pat X -> [JsStmt] -> Compile [JsStmt]
interleavePatternMatchFailures original :: [JsStmt]
original pat :: Pat X
pat = [JsStmt] -> Compile [JsStmt]
forall (f :: * -> *). Monad f => [JsStmt] -> f [JsStmt]
walk
where
walk :: [JsStmt] -> f [JsStmt]
walk m :: [JsStmt]
m = case [JsStmt]
m of
[JsIf t :: JsExp
t b1 :: [JsStmt]
b1 []] -> do
[JsStmt]
b2 <- [JsStmt] -> f [JsStmt]
walk [JsStmt]
b1
[JsStmt] -> f [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf JsExp
t [JsStmt]
b2 [JsStmt]
err]
[JsVar n :: JsName
n exp2 :: JsExp
exp2] -> [JsStmt] -> f [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsName -> JsExp -> JsStmt
JsVar JsName
n JsExp
exp2]
stmt :: JsStmt
stmt:stmts :: [JsStmt]
stmts -> (JsStmt
stmtJsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:) ([JsStmt] -> [JsStmt]) -> f [JsStmt] -> f [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JsStmt] -> f [JsStmt]
walk [JsStmt]
stmts
[] -> String -> f [JsStmt]
forall a. HasCallStack => String -> a
error (String -> f [JsStmt]) -> String -> f [JsStmt]
forall a b. (a -> b) -> a -> b
$ "Fay bug! Can't compile pat bind for pattern: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [JsStmt] -> String
forall a. Show a => a -> String
show [JsStmt]
original
err :: [JsStmt]
err = [String -> JsExp -> JsStmt
throw ("Irrefutable pattern failed for pattern: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pat X -> String
forall a. Pretty a => a -> String
prettyPrint Pat X
pat) ([JsExp] -> JsExp
JsList [])]
compileUnguardedRhs :: Bool -> S.X -> S.Name -> S.Exp -> Compile [JsStmt]
compileUnguardedRhs :: Bool -> X -> Name X -> Exp X -> Compile [JsStmt]
compileUnguardedRhs toplevel :: Bool
toplevel srcloc :: X
srcloc ident :: Name X
ident rhs :: Exp X
rhs = do
JsExp
body <- Exp X -> Compile JsExp
compileExp Exp X
rhs
JsStmt
bind <- Bool -> Maybe SrcSpan -> Name X -> JsExp -> Compile JsStmt
forall a.
Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt
bindToplevel Bool
toplevel (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpanInfo -> SrcSpan
srcInfoSpan (X -> SrcSpanInfo
S.srcSpanInfo X
srcloc))) Name X
ident (JsExp -> JsExp
thunk JsExp
body)
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
bind]
compileDataDecl :: Bool -> [S.TyVarBind] -> [S.QualConDecl] -> Compile [JsStmt]
compileDataDecl :: Bool -> [TyVarBind] -> [QualConDecl X] -> Compile [JsStmt]
compileDataDecl toplevel :: Bool
toplevel tyvars :: [TyVarBind]
tyvars constructors :: [QualConDecl X]
constructors =
([[JsStmt]] -> [JsStmt]) -> Compile [[JsStmt]] -> Compile [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Compile [[JsStmt]] -> Compile [JsStmt])
-> Compile [[JsStmt]] -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$
[QualConDecl X]
-> (QualConDecl X -> Compile [JsStmt]) -> Compile [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QualConDecl X]
constructors ((QualConDecl X -> Compile [JsStmt]) -> Compile [[JsStmt]])
-> (QualConDecl X -> Compile [JsStmt]) -> Compile [[JsStmt]]
forall a b. (a -> b) -> a -> b
$ \(QualConDecl _ _ _ condecl :: ConDecl X
condecl) ->
case ConDecl X
condecl of
ConDecl _ name :: Name X
name types :: [Kind X]
types -> do
let slots :: [Name ()]
slots = ((Int, Kind X) -> Name ()) -> [(Int, Kind X)] -> [Name ()]
forall a b. (a -> b) -> [a] -> [b]
map (() -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String -> Name ())
-> ((Int, Kind X) -> String) -> (Int, Kind X) -> Name ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("slot"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ((Int, Kind X) -> String) -> (Int, Kind X) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Int, Kind X) -> Int) -> (Int, Kind X) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Kind X) -> Int
forall a b. (a, b) -> a
fst) ([(Int, Kind X)] -> [Name ()]) -> [(Int, Kind X)] -> [Name ()]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Kind X] -> [(Int, Kind X)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1 :: Int ..] [Kind X]
types
fields :: [([Name ()], Kind X)]
fields = [[Name ()]] -> [Kind X] -> [([Name ()], Kind X)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Name () -> [Name ()]) -> [Name ()] -> [[Name ()]]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> [Name ()]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name ()]
slots) [Kind X]
types
JsStmt
cons <- Name X -> [Name ()] -> Compile JsStmt
forall a b. Name a -> [Name b] -> Compile JsStmt
makeConstructor Name X
name [Name ()]
slots
JsStmt
func <- Name X -> [Name ()] -> Compile JsStmt
forall a b. Name a -> [Name b] -> Compile JsStmt
makeFunc Name X
name [Name ()]
slots
Name X -> [TyVarBind] -> [([Name ()], Kind X)] -> Compile ()
forall a b c d.
Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitFayToJs Name X
name [TyVarBind]
tyvars [([Name ()], Kind X)]
fields
Name X -> [TyVarBind] -> [([Name ()], Kind X)] -> Compile ()
forall a b c d.
Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitJsToFay Name X
name [TyVarBind]
tyvars [([Name ()], Kind X)]
fields
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
cons, JsStmt
func]
InfixConDecl _ t1 :: Kind X
t1 name :: Name X
name t2 :: Kind X
t2 -> do
let slots :: [Name ()]
slots = [() -> String -> Name ()
forall l. l -> String -> Name l
Ident () "slot1",() -> String -> Name ()
forall l. l -> String -> Name l
Ident () "slot2"]
fields :: [([Name ()], Kind X)]
fields = [[Name ()]] -> [Kind X] -> [([Name ()], Kind X)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Name () -> [Name ()]) -> [Name ()] -> [[Name ()]]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> [Name ()]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name ()]
slots) [Kind X
t1, Kind X
t2]
JsStmt
cons <- Name X -> [Name ()] -> Compile JsStmt
forall a b. Name a -> [Name b] -> Compile JsStmt
makeConstructor Name X
name [Name ()]
slots
JsStmt
func <- Name X -> [Name ()] -> Compile JsStmt
forall a b. Name a -> [Name b] -> Compile JsStmt
makeFunc Name X
name [Name ()]
slots
Name X -> [TyVarBind] -> [([Name ()], Kind X)] -> Compile ()
forall a b c d.
Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitFayToJs Name X
name [TyVarBind]
tyvars [([Name ()], Kind X)]
fields
Name X -> [TyVarBind] -> [([Name ()], Kind X)] -> Compile ()
forall a b c d.
Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitJsToFay Name X
name [TyVarBind]
tyvars [([Name ()], Kind X)]
fields
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
cons, JsStmt
func]
RecDecl _ name :: Name X
name fields' :: [FieldDecl X]
fields' -> do
let fields :: [Name X]
fields = (FieldDecl X -> [Name X]) -> [FieldDecl X] -> [Name X]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FieldDecl X -> [Name X]
forall a. FieldDecl a -> [Name a]
fieldDeclNames [FieldDecl X]
fields'
JsStmt
cons <- Name X -> [Name X] -> Compile JsStmt
forall a b. Name a -> [Name b] -> Compile JsStmt
makeConstructor Name X
name [Name X]
fields
JsStmt
func <- Name X -> [Name X] -> Compile JsStmt
forall a b. Name a -> [Name b] -> Compile JsStmt
makeFunc Name X
name [Name X]
fields
[JsStmt]
funs <- [Name X] -> Compile [JsStmt]
makeAccessors [Name X]
fields
Name X -> [TyVarBind] -> [([Name X], Kind X)] -> Compile ()
forall a b c d.
Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitFayToJs Name X
name [TyVarBind]
tyvars ((FieldDecl X -> ([Name X], Kind X))
-> [FieldDecl X] -> [([Name X], Kind X)]
forall a b. (a -> b) -> [a] -> [b]
map FieldDecl X -> ([Name X], Kind X)
forall a. FieldDecl a -> ([Name a], Type a)
convertFieldDecl [FieldDecl X]
fields')
Name X -> [TyVarBind] -> [([Name X], Kind X)] -> Compile ()
forall a b c d.
Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitJsToFay Name X
name [TyVarBind]
tyvars ((FieldDecl X -> ([Name X], Kind X))
-> [FieldDecl X] -> [([Name X], Kind X)]
forall a b. (a -> b) -> [a] -> [b]
map FieldDecl X -> ([Name X], Kind X)
forall a. FieldDecl a -> ([Name a], Type a)
convertFieldDecl [FieldDecl X]
fields')
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return (JsStmt
cons JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: JsStmt
func JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: [JsStmt]
funs)
where
makeConstructor :: Name a -> [Name b] -> Compile JsStmt
makeConstructor :: Name a -> [Name b] -> Compile JsStmt
makeConstructor (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) ((Name b -> JsName) -> [Name b] -> [JsName]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> JsName
JsNameVar (QName -> JsName) -> (Name b -> QName) -> Name b -> JsName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () (Name () -> QName) -> (Name b -> Name ()) -> Name b -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name b -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn) -> [JsName]
fields) = do
QName
qname <- Name () -> Compile QName
forall a. Name a -> Compile QName
qualify Name ()
name
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
$
QName -> JsExp -> JsStmt
JsSetConstructor QName
qname (JsExp -> JsStmt) -> JsExp -> JsStmt
forall a b. (a -> b) -> a -> b
$
Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun (JsName -> Maybe JsName
forall a. a -> Maybe a
Just (JsName -> Maybe JsName) -> JsName -> Maybe JsName
forall a b. (a -> b) -> a -> b
$ QName -> JsName
JsConstructor QName
qname)
[JsName]
fields
(((JsName -> JsStmt) -> [JsName] -> [JsStmt])
-> [JsName] -> (JsName -> JsStmt) -> [JsStmt]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (JsName -> JsStmt) -> [JsName] -> [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [JsName]
fields ((JsName -> JsStmt) -> [JsStmt]) -> (JsName -> JsStmt) -> [JsStmt]
forall a b. (a -> b) -> a -> b
$ \field :: JsName
field -> JsName -> JsName -> JsExp -> JsStmt
JsSetProp JsName
JsThis JsName
field (JsName -> JsExp
JsName JsName
field))
Maybe JsExp
forall a. Maybe a
Nothing
makeFunc :: Name a -> [Name b] -> Compile JsStmt
makeFunc :: Name a -> [Name b] -> Compile JsStmt
makeFunc (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) ((Name b -> JsName) -> [Name b] -> [JsName]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> JsName
JsNameVar (QName -> JsName) -> (Name b -> QName) -> Name b -> JsName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () (Name () -> QName) -> (Name b -> Name ()) -> Name b -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name b -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn) -> [JsName]
fields) = do
let fieldExps :: [JsExp]
fieldExps = (JsName -> JsExp) -> [JsName] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map JsName -> JsExp
JsName [JsName]
fields
QName
qname <- Name () -> Compile QName
forall a. Name a -> Compile QName
qualify Name ()
name
let mp :: ModulePath
mp = QName -> ModulePath
forall a. QName a -> ModulePath
mkModulePathFromQName QName
qname
let func :: JsExp
func = (JsName -> JsExp -> JsExp) -> JsExp -> [JsName] -> JsExp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\slot :: JsName
slot inner :: JsExp
inner -> Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [JsName
slot] [] (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just JsExp
inner))
(JsExp -> JsExp
thunk (JsExp -> JsExp) -> JsExp -> JsExp
forall a b. (a -> b) -> a -> b
$ JsName -> [JsExp] -> JsExp
JsNew (QName -> JsName
JsConstructor QName
qname) [JsExp]
fieldExps)
[JsName]
fields
Bool
added <- (CompileState -> Bool) -> Compile Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ModulePath -> CompileState -> Bool
addedModulePath ModulePath
mp)
if Bool
added
then JsStmt -> Compile JsStmt
forall (m :: * -> *) a. Monad m => a -> m a
return (JsStmt -> Compile JsStmt)
-> (JsExp -> JsStmt) -> JsExp -> Compile JsStmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcSpan -> QName -> JsExp -> JsStmt
JsSetQName Maybe SrcSpan
forall a. Maybe a
Nothing QName
qname (JsExp -> Compile JsStmt) -> JsExp -> Compile JsStmt
forall a b. (a -> b) -> a -> b
$ JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name () -> JsName
JsBuiltIn "objConcat")
[JsExp
func, JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ QName -> JsName
JsNameVar QName
qname]
else do
(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
$ ModulePath -> CompileState -> CompileState
addModulePath ModulePath
mp
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
forall a. Maybe a
Nothing QName
qname JsExp
func
makeAccessors :: [S.Name] -> Compile [JsStmt]
makeAccessors :: [Name X] -> Compile [JsStmt]
makeAccessors fields :: [Name X]
fields =
[Name X] -> (Name X -> Compile JsStmt) -> Compile [JsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name X]
fields ((Name X -> Compile JsStmt) -> Compile [JsStmt])
-> (Name X -> Compile JsStmt) -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ \(Name X -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) ->
Bool -> Maybe SrcSpan -> Name () -> JsExp -> Compile JsStmt
forall a.
Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt
bindToplevel Bool
toplevel
Maybe SrcSpan
forall a. Maybe a
Nothing
Name ()
name
(Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing
[QName -> JsName
JsNameVar "x"]
[]
(JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> JsExp
thunk (JsExp -> JsName -> JsExp
JsGetProp (JsExp -> JsExp
force (JsName -> JsExp
JsName (QName -> JsName
JsNameVar "x")))
(QName -> JsName
JsNameVar (() -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () Name ()
name))))))
compileFunCase :: Bool -> [S.Match] -> Compile [JsStmt]
compileFunCase :: Bool -> [Match X] -> Compile [JsStmt]
compileFunCase _toplevel :: Bool
_toplevel [] = [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
compileFunCase toplevel :: Bool
toplevel (InfixMatch l :: X
l pat :: Pat X
pat name :: Name X
name pats :: [Pat X]
pats rhs :: Rhs X
rhs binds :: Maybe (Binds X)
binds : rest :: [Match X]
rest) =
Bool -> [Match X] -> Compile [JsStmt]
compileFunCase Bool
toplevel (X -> Name X -> [Pat X] -> Rhs X -> Maybe (Binds X) -> Match X
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match X
l Name X
name (Pat X
patPat X -> [Pat X] -> [Pat X]
forall a. a -> [a] -> [a]
:[Pat X]
pats) Rhs X
rhs Maybe (Binds X)
binds Match X -> [Match X] -> [Match X]
forall a. a -> [a] -> [a]
: [Match X]
rest)
compileFunCase toplevel :: Bool
toplevel matches :: [Match X]
matches@(Match srcloc :: X
srcloc name :: Name X
name argslen :: [Pat X]
argslen _ _:_) = do
[[JsStmt]]
pats <- ([[JsStmt]] -> [[JsStmt]])
-> Compile [[JsStmt]] -> Compile [[JsStmt]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[JsStmt]] -> [[JsStmt]]
optimizePatConditions ((Match X -> Compile [JsStmt]) -> [Match X] -> Compile [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Match X -> Compile [JsStmt]
compileCase [Match X]
matches)
JsStmt
bind <- Bool -> Maybe SrcSpan -> Name X -> JsExp -> Compile JsStmt
forall a.
Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt
bindToplevel Bool
toplevel
(SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpanInfo -> SrcSpan
srcInfoSpan (X -> SrcSpanInfo
S.srcSpanInfo X
srcloc)))
Name X
name
((JsName -> JsExp -> JsExp) -> JsExp -> [JsName] -> JsExp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\arg :: JsName
arg inner :: JsExp
inner -> Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [JsName
arg] [] (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just JsExp
inner))
([JsStmt] -> JsExp
stmtsThunk ([JsStmt] -> JsExp) -> [JsStmt] -> JsExp
forall a b. (a -> b) -> a -> b
$ [JsStmt] -> [JsStmt]
deleteAfterReturn ([[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JsStmt]]
pats [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt]
basecase))
[JsName]
args)
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
bind]
where
deleteAfterReturn :: [JsStmt] -> [JsStmt]
deleteAfterReturn :: [JsStmt] -> [JsStmt]
deleteAfterReturn [] = []
deleteAfterReturn (x :: JsStmt
x@(JsEarlyReturn _):_) = [JsStmt
x]
deleteAfterReturn (x :: JsStmt
x:xs :: [JsStmt]
xs) = JsStmt
xJsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:[JsStmt] -> [JsStmt]
deleteAfterReturn [JsStmt]
xs
args :: [JsName]
args = (JsName -> Pat X -> JsName) -> [JsName] -> [Pat X] -> [JsName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith JsName -> Pat X -> JsName
forall a b. a -> b -> a
const [JsName]
uniqueNames [Pat X]
argslen
isWildCardMatch :: Match X -> Bool
isWildCardMatch (Match _ _ pats :: [Pat X]
pats _ _) = (Pat X -> Bool) -> [Pat X] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pat X -> Bool
isWildCardPat [Pat X]
pats
isWildCardMatch (InfixMatch _ pat :: Pat X
pat _ pats :: [Pat X]
pats _ _) = (Pat X -> Bool) -> [Pat X] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pat X -> Bool
isWildCardPat (Pat X
patPat X -> [Pat X] -> [Pat X]
forall a. a -> [a] -> [a]
:[Pat X]
pats)
compileCase :: S.Match -> Compile [JsStmt]
compileCase :: Match X -> Compile [JsStmt]
compileCase (InfixMatch l :: X
l pat :: Pat X
pat nm :: Name X
nm pats :: [Pat X]
pats rhs :: Rhs X
rhs binds :: Maybe (Binds X)
binds) =
Match X -> Compile [JsStmt]
compileCase (Match X -> Compile [JsStmt]) -> Match X -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ X -> Name X -> [Pat X] -> Rhs X -> Maybe (Binds X) -> Match X
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match X
l Name X
nm (Pat X
patPat X -> [Pat X] -> [Pat X]
forall a. a -> [a] -> [a]
:[Pat X]
pats) Rhs X
rhs Maybe (Binds X)
binds
compileCase match :: Match X
match@(Match _ _ pats :: [Pat X]
pats rhs :: Rhs X
rhs _) = do
[Decl]
whereDecls' <- Match X -> Compile [Decl]
whereDecls Match X
match
Either JsStmt JsExp
rhsform <- Rhs X -> Compile (Either JsStmt JsExp)
compileRhs Rhs X
rhs
[JsStmt]
body <- if [Decl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Decl]
whereDecls'
then [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [(JsStmt -> JsStmt)
-> (JsExp -> JsStmt) -> Either JsStmt JsExp -> JsStmt
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either JsStmt -> JsStmt
forall a. a -> a
id JsExp -> JsStmt
JsEarlyReturn Either JsStmt JsExp
rhsform]
else do
[[JsStmt]]
binds <- (Decl -> Compile [JsStmt]) -> [Decl] -> Compile [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl -> Compile [JsStmt]
compileLetDecl [Decl]
whereDecls'
case Either JsStmt JsExp
rhsform of
Right exp :: JsExp
exp ->
[JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> JsStmt
JsEarlyReturn (JsExp -> JsStmt) -> JsExp -> JsStmt
forall a b. (a -> b) -> a -> b
$ JsExp -> [JsExp] -> JsExp
JsApp (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [] ([[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JsStmt]]
binds) (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just JsExp
exp)) []]
Left stmt :: JsStmt
stmt ->
(JsName -> Compile [JsStmt]) -> Compile [JsStmt]
forall a. (JsName -> Compile a) -> Compile a
withScopedTmpJsName ((JsName -> Compile [JsStmt]) -> Compile [JsStmt])
-> (JsName -> Compile [JsStmt]) -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ \n :: JsName
n -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ JsName -> JsExp -> JsStmt
JsVar JsName
n (JsExp -> [JsExp] -> JsExp
JsApp (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [] ([[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JsStmt]]
binds [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt
stmt]) Maybe JsExp
forall a. Maybe a
Nothing) [])
, JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsExp -> JsExp
JsNeq JsExp
JsUndefined (JsName -> JsExp
JsName JsName
n)) [JsExp -> JsStmt
JsEarlyReturn (JsName -> JsExp
JsName JsName
n)] []
]
([JsStmt] -> (JsName, Pat X) -> Compile [JsStmt])
-> [JsStmt] -> [(JsName, Pat X)] -> Compile [JsStmt]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\inner :: [JsStmt]
inner (arg :: JsName
arg,pat :: Pat X
pat) ->
JsExp -> Pat X -> [JsStmt] -> Compile [JsStmt]
compilePat (JsName -> JsExp
JsName JsName
arg) Pat X
pat [JsStmt]
inner)
[JsStmt]
body
([JsName] -> [Pat X] -> [(JsName, Pat X)]
forall a b. [a] -> [b] -> [(a, b)]
zip [JsName]
args [Pat X]
pats)
whereDecls :: S.Match -> Compile [S.Decl]
whereDecls :: Match X -> Compile [Decl]
whereDecls (Match _ _ _ _ (Just (BDecls _ decls :: [Decl]
decls))) = [Decl] -> Compile [Decl]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl]
decls
whereDecls (Match _ _ _ _ Nothing) = [Decl] -> Compile [Decl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
whereDecls match :: Match X
match = CompileError -> Compile [Decl]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Match X -> CompileError
UnsupportedWhereInMatch Match X
match)
basecase :: [JsStmt]
basecase :: [JsStmt]
basecase = if (Match X -> Bool) -> [Match X] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Match X -> Bool
isWildCardMatch [Match X]
matches
then []
else [String -> JsExp -> JsStmt
throw ("unhandled case in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name X -> String
forall a. Pretty a => a -> String
prettyPrint Name X
name)
([JsExp] -> JsExp
JsList ((JsName -> JsExp) -> [JsName] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map JsName -> JsExp
JsName [JsName]
args))]
compileRhs :: S.Rhs -> Compile (Either JsStmt JsExp)
compileRhs :: Rhs X -> Compile (Either JsStmt JsExp)
compileRhs (UnGuardedRhs _ exp :: Exp X
exp) = JsExp -> Either JsStmt JsExp
forall a b. b -> Either a b
Right (JsExp -> Either JsStmt JsExp)
-> Compile JsExp -> Compile (Either JsStmt JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp X -> Compile JsExp
compileExp Exp X
exp
compileRhs (GuardedRhss _ rhss :: [GuardedRhs X]
rhss) = JsStmt -> Either JsStmt JsExp
forall a b. a -> Either a b
Left (JsStmt -> Either JsStmt JsExp)
-> Compile JsStmt -> Compile (Either JsStmt JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedRhs X] -> Compile JsStmt
compileGuards [GuardedRhs X]
rhss