{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ViewPatterns          #-}

-- | Compile declarations.

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) #-}

-- | Compile Haskell declaration.
compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]
compileDecls :: Bool -> [Decl] -> Compile [JsStmt]
compileDecls 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)

-- | Compile a declaration.
compileDecl :: Bool -> S.Decl -> Compile [JsStmt]
compileDecl :: Bool -> Decl -> Compile [JsStmt]
compileDecl Bool
toplevel Decl
decl = case Decl
decl of
  pat :: Decl
pat@PatBind{} -> Bool -> Decl -> Compile [JsStmt]
compilePatBind Bool
toplevel Decl
pat
  FunBind X
_ [Match X]
matches -> Bool -> [Match X] -> Compile [JsStmt]
compileFunCase Bool
toplevel [Match X]
matches
  DataDecl X
_ (DataType X
_ ) Maybe (Context X)
_ (DeclHead X -> [TyVarBind]
mkTyVars -> [TyVarBind]
tyvars) [QualConDecl X]
constructors [Deriving X]
_ -> Bool -> [TyVarBind] -> [QualConDecl X] -> Compile [JsStmt]
compileDataDecl Bool
toplevel [TyVarBind]
tyvars [QualConDecl X]
constructors
  GDataDecl X
_ (DataType X
_) Maybe (Context X)
_l (DeclHead X -> [TyVarBind]
mkTyVars -> [TyVarBind]
tyvars) Maybe (Kind X)
_n [GadtDecl X]
decls [Deriving X]
_ -> 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 X
_ (NewType X
_) Maybe (Context X)
_  DeclHead X
head' [QualConDecl X]
constructors [Deriving X]
_ ->
    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)
  -- Just ignore type aliases and signatures.
  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 [] -- FIXME: Ignore.
  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 []
  Decl
_ -> 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 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 l
_ Name l
_) = [TyVarBind l] -> [TyVarBind l]
forall a. a -> a
id
    go (DHInfix l
_ TyVarBind l
r Name l
_) = (TyVarBind l
rTyVarBind l -> [TyVarBind l] -> [TyVarBind l]
forall a. a -> [a] -> [a]
:)
    go (DHParen l
_ DeclHead l
dh) = DeclHead l -> [TyVarBind l] -> [TyVarBind l]
go DeclHead l
dh
    go (DHApp l
_ DeclHead l
dh 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]
:)

-- | Compile a top-level pattern bind.
compilePatBind :: Bool -> S.Decl -> Compile [JsStmt]
compilePatBind :: Bool -> Decl -> Compile [JsStmt]
compilePatBind Bool
toplevel Decl
patDecl = case Decl
patDecl of
  PatBind X
_ (PVar X
_ Name X
name')
    (UnGuardedRhs X
_
      (ExpTypeSig X
_
        (App X
_ (Var X
_ (UnQual X
_ (Ident X
_ String
"ffi")))
                (Lit X
_ (String X
_ String
formatstr String
_)))
      Kind X
sig)) Maybe (Binds X)
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 X
srcloc (PVar X
_ Name X
ident) (UnGuardedRhs X
_ Exp X
rhs) Maybe (Binds X)
Nothing ->
      Bool -> X -> Name X -> Exp X -> Compile [JsStmt]
compileUnguardedRhs Bool
toplevel X
srcloc Name X
ident Exp X
rhs
  -- TODO: Generalize to all patterns
  PatBind X
srcloc (PVar X
_ Name X
ident) (UnGuardedRhs X
_ Exp X
rhs) (Just 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 X
_ Pat X
pat (UnGuardedRhs X
_ Exp X
rhs) 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
    Pat X
_        -> 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
  Decl
_ -> 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 X
pat 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 [JsStmt]
original Pat X
pat = [JsStmt] -> Compile [JsStmt]
forall (f :: * -> *). Monad f => [JsStmt] -> f [JsStmt]
walk
      where
        walk :: [JsStmt] -> f [JsStmt]
walk [JsStmt]
m = case [JsStmt]
m of
          [JsIf JsExp
t [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 JsName
n JsExp
exp2] -> [JsStmt] -> f [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsName -> JsExp -> JsStmt
JsVar JsName
n JsExp
exp2]
          JsStmt
stmt:[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
$ String
"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 (String
"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 [])]

-- | Compile a normal simple pattern binding.
compileUnguardedRhs :: Bool -> S.X -> S.Name -> S.Exp -> Compile [JsStmt]
compileUnguardedRhs :: Bool -> X -> Name X -> Exp X -> Compile [JsStmt]
compileUnguardedRhs Bool
toplevel X
srcloc Name X
ident 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]

-- | Compile a data declaration (or a GADT, latter is converted to former).
compileDataDecl :: Bool -> [S.TyVarBind] -> [S.QualConDecl] -> Compile [JsStmt]
compileDataDecl :: Bool -> [TyVarBind] -> [QualConDecl X] -> Compile [JsStmt]
compileDataDecl Bool
toplevel [TyVarBind]
tyvars [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 X
_ Maybe [TyVarBind]
_ Maybe (Context X)
_ ConDecl X
condecl) ->
      case ConDecl X
condecl of
        ConDecl X
_ Name X
name [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
. (String
"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 [Int
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 X
_ Kind X
t1 Name X
name Kind X
t2 -> do
          let slots :: [Name ()]
slots = [() -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"slot1",() -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"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 X
_ Name X
name [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
    -- Creates a constructor _RecConstr for a Record
    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
$ \JsName
field -> JsName -> JsName -> JsExp -> JsStmt
JsSetProp JsName
JsThis JsName
field (JsName -> JsExp
JsName JsName
field))
                Maybe JsExp
forall a. Maybe a
Nothing

    -- Creates a function to initialize the record by regular application
    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 (\JsName
slot 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 Name ()
"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

    -- Creates getters for a RecDecl's values
    makeAccessors :: [S.Name] -> Compile [JsStmt]
    makeAccessors :: [Name X] -> Compile [JsStmt]
makeAccessors [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 QName
"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 QName
"x")))
                                                       (QName -> JsName
JsNameVar (() -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () Name ()
name))))))


-- | Compile a function which pattern matches (causing a case analysis).
compileFunCase :: Bool -> [S.Match] -> Compile [JsStmt]
compileFunCase :: Bool -> [Match X] -> Compile [JsStmt]
compileFunCase Bool
_toplevel [] = [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
compileFunCase Bool
toplevel (InfixMatch X
l Pat X
pat Name X
name [Pat X]
pats Rhs X
rhs Maybe (Binds X)
binds : [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 Bool
toplevel matches :: [Match X]
matches@(Match X
srcloc Name X
name [Pat X]
argslen Rhs X
_ Maybe (Binds X)
_:[Match X]
_) = 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 (\JsName
arg 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 JsExp
_):[JsStmt]
_) = [JsStmt
x]
    deleteAfterReturn (JsStmt
x:[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 X
_ Name X
_ [Pat X]
pats          Rhs X
_ Maybe (Binds X)
_) = (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 X
_ Pat X
pat Name X
_ [Pat X]
pats Rhs X
_ Maybe (Binds X)
_) = (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 X
l Pat X
pat Name X
nm [Pat X]
pats Rhs X
rhs 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 X
_ Name X
_ [Pat X]
pats Rhs X
rhs Maybe (Binds X)
_) = 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 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 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
$ \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 (\[JsStmt]
inner (JsName
arg,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 X
_ Name X
_ [Pat X]
_ Rhs X
_ (Just (BDecls X
_ [Decl]
decls))) = [Decl] -> Compile [Decl]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl]
decls
    whereDecls (Match X
_ Name X
_ [Pat X]
_ Rhs X
_ Maybe (Binds X)
Nothing) = [Decl] -> Compile [Decl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    whereDecls 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 (String
"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))]

-- | Compile a right-hand-side expression.
compileRhs :: S.Rhs -> Compile (Either JsStmt JsExp)
compileRhs :: Rhs X -> Compile (Either JsStmt JsExp)
compileRhs (UnGuardedRhs X
_ 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 X
_ [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