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

-- | Compile pattern matches.

module Fay.Compiler.Pattern where

import           Fay.Compiler.Prelude

import           Fay.Compiler.Misc
import           Fay.Compiler.QName
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            (throwError)
import           Control.Monad.Reader            (ask)
import           Language.Haskell.Exts hiding (name)
import           Language.Haskell.Names          (NameInfo (RecPatWildcard), Scoped (Scoped))

-- | Compile the given pattern against the given expression.
compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]
compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat JsExp
exp Pat
pat [JsStmt]
body = case Pat
pat of
  PVar X
_ Name X
name       -> Name X -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePVar Name X
name JsExp
exp [JsStmt]
body
  PApp X
_ QName X
cons [Pat]
pats  -> do
    Maybe (Maybe QName, Type)
newty <- QName X -> Compile (Maybe (Maybe QName, Type))
lookupNewtypeConst QName X
cons
    case Maybe (Maybe QName, Type)
newty of
      Maybe (Maybe QName, Type)
Nothing -> Pat -> QName X -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePApp Pat
pat QName X
cons [Pat]
pats JsExp
exp [JsStmt]
body
      Just (Maybe QName, Type)
_  -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compileNewtypePat [Pat]
pats JsExp
exp [JsStmt]
body
  PLit X
_ Sign X
sign Literal X
lit   -> JsExp -> Sign X -> Literal X -> [JsStmt] -> Compile [JsStmt]
compilePLit JsExp
exp Sign X
sign Literal X
lit [JsStmt]
body
  PWildCard X
_       -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt]
body
  PList X
_ [Pat]
pats      -> [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
compilePList [Pat]
pats [JsStmt]
body JsExp
exp
  PTuple X
_ Boxed
_bx [Pat]
pats -> [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
compilePList [Pat]
pats [JsStmt]
body JsExp
exp
  PAsPat X
_ Name X
name Pat
pt  -> JsExp -> Name X -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePAsPat JsExp
exp Name X
name Pat
pt [JsStmt]
body
  PRec X
_ QName X
name [PatField X]
pats  -> JsExp -> QName X -> [PatField X] -> [JsStmt] -> Compile [JsStmt]
compilePatFields JsExp
exp QName X
name [PatField X]
pats [JsStmt]
body
  PParen{}          -> Pat -> Compile [JsStmt]
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Pat
pat
  PInfixApp{}       -> Pat -> Compile [JsStmt]
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Pat
pat
  Pat
_                 -> CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Pat -> CompileError
UnsupportedPattern Pat
pat)

-- | Compile a pattern variable e.g. x.
compilePVar :: S.Name -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePVar :: Name X -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePVar (Name X -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) JsExp
exp [JsStmt]
body =
  [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 (() -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () Name ()
name)) JsExp
exp JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: [JsStmt]
body

-- | Compile a record field pattern.
compilePatFields :: JsExp -> S.QName -> [S.PatField] -> [JsStmt] -> Compile [JsStmt]
compilePatFields :: JsExp -> QName X -> [PatField X] -> [JsStmt] -> Compile [JsStmt]
compilePatFields JsExp
exp QName X
name [PatField X]
pats [JsStmt]
body = do
  [JsStmt]
c <- ([JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt]
body) ([JsStmt] -> [JsStmt]) -> Compile [JsStmt] -> Compile [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QName X] -> [PatField X] -> Compile [JsStmt]
compilePats' [] [PatField X]
pats
  QName
qname <- QName X -> Compile QName
unsafeResolveName QName X
name
  [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsExp
force JsExp
exp JsExp -> JsName -> JsExp
`JsInstanceOf` QName -> JsName
JsConstructor QName
qname) [JsStmt]
c []]
  where
    -- compilePats' collects field names that had already been matched so that
      -- wildcard generates code for the rest of the fields.
      compilePats' :: [S.QName] -> [S.PatField] -> Compile [JsStmt]
      compilePats' :: [QName X] -> [PatField X] -> Compile [JsStmt]
compilePats' [QName X]
_ (p :: PatField X
p@PFieldPun{}:[PatField X]
_) = PatField X -> Compile [JsStmt]
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared PatField X
p
      compilePats' [QName X]
names (PFieldPat X
_ QName X
fieldname (PVar X
_ (Name X -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
varName)):[PatField X]
xs) = do
        [JsStmt]
r <- [QName X] -> [PatField X] -> Compile [JsStmt]
compilePats' (QName X
fieldname QName X -> [QName X] -> [QName X]
forall a. a -> [a] -> [a]
: [QName X]
names) [PatField X]
xs
        [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 (() -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () Name ()
varName))
                       (JsExp -> JsName -> JsExp
JsGetProp (JsExp -> JsExp
force JsExp
exp) (QName -> JsName
JsNameVar (QName -> QName
forall a. QName a -> QName a
unQualify (QName -> QName) -> QName -> QName
forall a b. (a -> b) -> a -> b
$ QName X -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName X
fieldname)))
                 JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: [JsStmt]
r -- TODO: think about this force call

      compilePats' [QName X]
names (PFieldWildcard (X -> [QName]
wildcardFields -> [QName]
fields):[PatField X]
xs) = do
        [JsStmt]
f <- [QName] -> (QName -> Compile JsStmt) -> Compile [JsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QName]
fields ((QName -> Compile JsStmt) -> Compile [JsStmt])
-> (QName -> Compile JsStmt) -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ \QName
fieldName ->
          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
fieldName)
                         (JsExp -> JsName -> JsExp
JsGetProp (JsExp -> JsExp
force JsExp
exp) (QName -> JsName
JsNameVar QName
fieldName))
        [JsStmt]
r <- [QName X] -> [PatField X] -> Compile [JsStmt]
compilePats' [QName X]
names [PatField X]
xs
        [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
$ [JsStmt]
f [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt]
r

      compilePats' [QName X]
_ [] = [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []

      compilePats' [QName X]
_ (PatField X
pat:[PatField X]
_) = CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PatField X -> CompileError
UnsupportedFieldPattern PatField X
pat)

      wildcardFields :: S.X -> [N.QName]
      wildcardFields :: X -> [QName]
wildcardFields X
l = case X
l of
        Scoped (RecPatWildcard [OrigName]
es) SrcSpanInfo
_ -> (OrigName -> QName) -> [OrigName] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> QName
forall a. QName a -> QName a
unQualify (QName -> QName) -> (OrigName -> QName) -> OrigName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> QName
origName2QName) [OrigName]
es
        X
_ -> []

-- | Compile a literal value from a pattern match.
compilePLit :: JsExp -> S.Sign -> S.Literal -> [JsStmt] -> Compile [JsStmt]
compilePLit :: JsExp -> Sign X -> Literal X -> [JsStmt] -> Compile [JsStmt]
compilePLit JsExp
exp Sign X
sign Literal X
literal [JsStmt]
body = do
  CompileReader
c <- Compile CompileReader
forall r (m :: * -> *). MonadReader r m => m r
ask
  JsExp
lit <- CompileReader -> Sign X -> Literal X -> Compile JsExp
readerCompileLit CompileReader
c Sign X
sign Literal X
literal
  [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsExp -> JsExp
equalExps JsExp
exp JsExp
lit)
               [JsStmt]
body
               []]

  where
    -- Equality test for two expressions, with some optimizations.
    equalExps :: JsExp -> JsExp -> JsExp
    equalExps :: JsExp -> JsExp -> JsExp
equalExps JsExp
a JsExp
b
      | JsExp -> Bool
isConstant JsExp
a Bool -> Bool -> Bool
&& JsExp -> Bool
isConstant JsExp
b = JsExp -> JsExp -> JsExp
JsEq JsExp
a JsExp
b
      | JsExp -> Bool
isConstant JsExp
a = JsExp -> JsExp -> JsExp
JsEq JsExp
a (JsExp -> JsExp
force JsExp
b)
      | JsExp -> Bool
isConstant JsExp
b = JsExp -> JsExp -> JsExp
JsEq (JsExp -> JsExp
force JsExp
a) JsExp
b
      | Bool
otherwise =
         JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (Name () -> JsName
JsBuiltIn Name ()
"equal")) [JsExp
a,JsExp
b]

-- | Compile as binding in pattern match
compilePAsPat :: JsExp -> S.Name -> S.Pat -> [JsStmt] -> Compile [JsStmt]
compilePAsPat :: JsExp -> Name X -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePAsPat JsExp
exp (Name X -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) Pat
pat [JsStmt]
body = do
  [JsStmt]
p <- JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat JsExp
exp Pat
pat [JsStmt]
body
  [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
exp JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: [JsStmt]
p

-- | Compile a pattern match on a newtype.
compileNewtypePat :: [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compileNewtypePat :: [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compileNewtypePat [Pat
pat] JsExp
exp [JsStmt]
body = JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat JsExp
exp Pat
pat [JsStmt]
body
compileNewtypePat [Pat]
ps JsExp
_ [JsStmt]
_ = [Char] -> Compile [JsStmt]
forall a. HasCallStack => [Char] -> a
error ([Char] -> Compile [JsStmt]) -> [Char] -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ [Char]
"compileNewtypePat: Should be impossible (this is a bug). Got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Pat] -> [Char]
forall a. Show a => a -> [Char]
show [Pat]
ps

-- | Compile a pattern application.
compilePApp :: S.Pat -> S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePApp :: Pat -> QName X -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePApp Pat
origPat QName X
cons [Pat]
pats JsExp
exp [JsStmt]
body = do
  let forcedExp :: JsExp
forcedExp = JsExp -> JsExp
force JsExp
exp
  let boolIf :: Bool -> m [JsStmt]
boolIf Bool
b = [JsStmt] -> m [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsExp -> JsExp
JsEq JsExp
forcedExp (JsLit -> JsExp
JsLit (Bool -> JsLit
JsBool Bool
b))) [JsStmt]
body []]
  case QName X
cons of
    -- Special-casing on the booleans.
    Special X
_ (UnitCon X
_) -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> JsStmt
JsExpStmt JsExp
forcedExp JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: [JsStmt]
body)
    Special X
_ Cons{} -> case [Pat]
pats of
      [Pat
left, Pat
right] ->
        (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
tmpName -> do
          let forcedList :: JsExp
forcedList = JsName -> JsExp
JsName JsName
tmpName
              x :: JsExp
x = JsExp -> JsName -> JsExp
JsGetProp JsExp
forcedList (QName -> JsName
JsNameVar QName
"car")
              xs :: JsExp
xs = JsExp -> JsName -> JsExp
JsGetProp JsExp
forcedList (QName -> JsName
JsNameVar QName
"cdr")
          [JsStmt]
rightMatch <- JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat JsExp
xs Pat
right [JsStmt]
body
          [JsStmt]
leftMatch <- JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat JsExp
x Pat
left [JsStmt]
rightMatch
          [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsName -> JsExp -> JsStmt
JsVar JsName
tmpName (JsExp -> JsExp
force JsExp
exp)
                 ,JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsName -> JsExp
JsInstanceOf JsExp
forcedList (Name () -> JsName
JsBuiltIn Name ()
"Cons"))
                       [JsStmt]
leftMatch
                       []]
      [Pat]
_ -> 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
$ Pat -> CompileError
UnsupportedPattern Pat
origPat
    UnQual X
_ (Ident X
_ [Char]
"True")   -> Bool -> Compile [JsStmt]
forall (m :: * -> *). Monad m => Bool -> m [JsStmt]
boolIf Bool
True
    UnQual X
_ (Ident X
_ [Char]
"False")  -> Bool -> Compile [JsStmt]
forall (m :: * -> *). Monad m => Bool -> m [JsStmt]
boolIf Bool
False
    -- Everything else, generic:
    QName X
n -> do
      let n' :: Maybe QName
n' = QName X -> Maybe QName
forall l. Show l => QName (Scoped l) -> Maybe QName
tryResolveName QName X
n
      case Maybe QName
n' of
        Maybe QName
Nothing -> [Char] -> Compile [JsStmt]
forall a. HasCallStack => [Char] -> a
error ([Char] -> Compile [JsStmt]) -> [Char] -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ [Char]
"Constructor '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName X -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint QName X
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' could not be resolved"
        Just QName
_ -> do
          [QName]
recordFields <- (Name () -> QName) -> [Name ()] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map (() -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual ()) ([Name ()] -> [QName]) -> Compile [Name ()] -> Compile [QName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName X -> Compile [Name ()]
recToFields QName X
n
          [JsStmt]
substmts <- ([JsStmt] -> (QName, Pat) -> Compile [JsStmt])
-> [JsStmt] -> [(QName, Pat)] -> Compile [JsStmt]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[JsStmt]
bd (QName
field,Pat
pat) ->
                                 JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat (JsExp -> JsName -> JsExp
JsGetProp JsExp
forcedExp (QName -> JsName
JsNameVar QName
field)) Pat
pat [JsStmt]
bd)
                      [JsStmt]
body
                      ([(QName, Pat)] -> [(QName, Pat)]
forall a. [a] -> [a]
reverse ([QName] -> [Pat] -> [(QName, Pat)]
forall a b. [a] -> [b] -> [(a, b)]
zip [QName]
recordFields [Pat]
pats))
          QName
qcons <- QName X -> Compile QName
unsafeResolveName QName X
cons
          [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp
forcedExp JsExp -> JsName -> JsExp
`JsInstanceOf` QName -> JsName
JsConstructor QName
qcons)
                       [JsStmt]
substmts
                       []]

-- | Compile a pattern list.
compilePList :: [S.Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
compilePList [] [JsStmt]
body JsExp
exp =
  [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsExp -> JsExp
JsEq (JsExp -> JsExp
force JsExp
exp) JsExp
JsNull) [JsStmt]
body []]
compilePList [Pat]
pats [JsStmt]
body JsExp
exp = do
  let forcedExp :: JsExp
forcedExp = JsExp -> JsExp
force JsExp
exp
  [JsStmt]
stmts <- ([JsStmt] -> (Int, Pat) -> Compile [JsStmt])
-> [JsStmt] -> [(Int, Pat)] -> Compile [JsStmt]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[JsStmt]
bd (Int
i,Pat
pat) -> JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (Name () -> JsName
JsBuiltIn Name ()
"index"))
                                                   [JsLit -> JsExp
JsLit (Int -> JsLit
JsInt Int
i),JsExp
forcedExp])
                                            Pat
pat
                                            [JsStmt]
bd)
        [JsStmt]
body
        ([(Int, Pat)] -> [(Int, Pat)]
forall a. [a] -> [a]
reverse ([Int] -> [Pat] -> [(Int, Pat)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Pat]
pats))
  let patsLen :: JsExp
patsLen = JsLit -> JsExp
JsLit (Int -> JsLit
JsInt ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats))
  [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (Name () -> JsName
JsBuiltIn Name ()
"listLen")) [JsExp
forcedExp,JsExp
patsLen])
               [JsStmt]
stmts
               []]