{-# 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 exp :: JsExp
exp pat :: Pat
pat body :: [JsStmt]
body = case Pat
pat of
  PVar _ name :: Name X
name       -> Name X -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePVar Name X
name JsExp
exp [JsStmt]
body
  PApp _ cons :: QName X
cons pats :: [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
      Nothing -> Pat -> QName X -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePApp Pat
pat QName X
cons [Pat]
pats JsExp
exp [JsStmt]
body
      Just _  -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compileNewtypePat [Pat]
pats JsExp
exp [JsStmt]
body
  PLit _ sign :: Sign X
sign lit :: Literal X
lit   -> JsExp -> Sign X -> Literal X -> [JsStmt] -> Compile [JsStmt]
compilePLit JsExp
exp Sign X
sign Literal X
lit [JsStmt]
body
  PWildCard _       -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt]
body
  PList _ pats :: [Pat]
pats      -> [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
compilePList [Pat]
pats [JsStmt]
body JsExp
exp
  PTuple _ _bx :: Boxed
_bx pats :: [Pat]
pats -> [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
compilePList [Pat]
pats [JsStmt]
body JsExp
exp
  PAsPat _ name :: Name X
name pt :: Pat
pt  -> JsExp -> Name X -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePAsPat JsExp
exp Name X
name Pat
pt [JsStmt]
body
  PRec _ name :: QName X
name pats :: [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
  _                 -> 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) exp :: JsExp
exp body :: [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 exp :: JsExp
exp name :: QName X
name pats :: [PatField X]
pats body :: [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' _ (p :: PatField X
p@PFieldPun{}:_) = PatField X -> Compile [JsStmt]
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared PatField X
p
      compilePats' names :: [QName X]
names (PFieldPat _ fieldname :: QName X
fieldname (PVar _ (Name X -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
varName)):xs :: [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' names :: [QName X]
names (PFieldWildcard (X -> [QName]
wildcardFields -> [QName]
fields):xs :: [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
$ \fieldName :: 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' _ [] = [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []

      compilePats' _ (pat :: PatField X
pat:_) = 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 l :: X
l = case X
l of
        Scoped (RecPatWildcard es :: [OrigName]
es) _ -> (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
        _ -> []

-- | 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 exp :: JsExp
exp sign :: Sign X
sign literal :: Literal X
literal body :: [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 a :: JsExp
a b :: 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 "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 exp :: JsExp
exp (Name X -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) pat :: Pat
pat body :: [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
pat] exp :: JsExp
exp body :: [JsStmt]
body = JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat JsExp
exp Pat
pat [JsStmt]
body
compileNewtypePat ps :: [Pat]
ps _ _ = [Char] -> Compile [JsStmt]
forall a. HasCallStack => [Char] -> a
error ([Char] -> Compile [JsStmt]) -> [Char] -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ "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 origPat :: Pat
origPat cons :: QName X
cons pats :: [Pat]
pats exp :: JsExp
exp body :: [JsStmt]
body = do
  let forcedExp :: JsExp
forcedExp = JsExp -> JsExp
force JsExp
exp
  let boolIf :: Bool -> m [JsStmt]
boolIf b :: 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 _ (UnitCon _) -> [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 _ Cons{} -> case [Pat]
pats of
      [left :: Pat
left, right :: 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
$ \tmpName :: JsName
tmpName -> do
          let forcedList :: JsExp
forcedList = JsName -> JsExp
JsName JsName
tmpName
              x :: JsExp
x = JsExp -> JsName -> JsExp
JsGetProp JsExp
forcedList (QName -> JsName
JsNameVar "car")
              xs :: JsExp
xs = JsExp -> JsName -> JsExp
JsGetProp JsExp
forcedList (QName -> JsName
JsNameVar "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 "Cons"))
                       [JsStmt]
leftMatch
                       []]
      _ -> 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 _ (Ident _ "True")   -> Bool -> Compile [JsStmt]
forall (m :: * -> *). Monad m => Bool -> m [JsStmt]
boolIf Bool
True
    UnQual _ (Ident _ "False")  -> Bool -> Compile [JsStmt]
forall (m :: * -> *). Monad m => Bool -> m [JsStmt]
boolIf Bool
False
    -- Everything else, generic:
    n :: 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
        Nothing -> [Char] -> Compile [JsStmt]
forall a. HasCallStack => [Char] -> a
error ([Char] -> Compile [JsStmt]) -> [Char] -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ "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]
++ "' could not be resolved"
        Just _ -> 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 (\bd :: [JsStmt]
bd (field :: QName
field,pat :: 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 [] body :: [JsStmt]
body exp :: 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 pats :: [Pat]
pats body :: [JsStmt]
body exp :: 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 (\bd :: [JsStmt]
bd (i :: Int
i,pat :: Pat
pat) -> JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (Name () -> JsName
JsBuiltIn "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 [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 "listLen")) [JsExp
forcedExp,JsExp
patsLen])
               [JsStmt]
stmts
               []]