-- |
-- Case binders
--
module Language.PureScript.AST.Binders where

import Prelude.Compat

import Language.PureScript.AST.SourcePos
import Language.PureScript.AST.Literals
import Language.PureScript.Names
import Language.PureScript.Comments
import Language.PureScript.Types

-- |
-- Data type for binders
--
data Binder
  -- |
  -- Wildcard binder
  --
  = NullBinder
  -- |
  -- A binder which matches a literal
  --
  | LiteralBinder SourceSpan (Literal Binder)
  -- |
  -- A binder which binds an identifier
  --
  | VarBinder SourceSpan Ident
  -- |
  -- A binder which matches a data constructor
  --
  | ConstructorBinder SourceSpan (Qualified (ProperName 'ConstructorName)) [Binder]
  -- |
  -- A operator alias binder. During the rebracketing phase of desugaring,
  -- this data constructor will be removed.
  --
  | OpBinder SourceSpan (Qualified (OpName 'ValueOpName))
  -- |
  -- Binary operator application. During the rebracketing phase of desugaring,
  -- this data constructor will be removed.
  --
  | BinaryNoParensBinder Binder Binder Binder
  -- |
  -- Explicit parentheses. During the rebracketing phase of desugaring, this
  -- data constructor will be removed.
  --
  -- Note: although it seems this constructor is not used, it _is_ useful,
  -- since it prevents certain traversals from matching.
  --
  | ParensInBinder Binder
  -- |
  -- A binder which binds its input to an identifier
  --
  | NamedBinder SourceSpan Ident Binder
  -- |
  -- A binder with source position information
  --
  | PositionedBinder SourceSpan [Comment] Binder
  -- |
  -- A binder with a type annotation
  --
  | TypedBinder SourceType Binder
  deriving (Int -> Binder -> ShowS
[Binder] -> ShowS
Binder -> String
(Int -> Binder -> ShowS)
-> (Binder -> String) -> ([Binder] -> ShowS) -> Show Binder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Binder] -> ShowS
$cshowList :: [Binder] -> ShowS
show :: Binder -> String
$cshow :: Binder -> String
showsPrec :: Int -> Binder -> ShowS
$cshowsPrec :: Int -> Binder -> ShowS
Show)

-- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
-- the `SourceSpan` values embedded in some of the data constructors of `Binder`
-- was expensive. This made exhaustiveness checking observably slow for code
-- such as the `explode` function in `test/purs/passing/LargeSumTypes.purs`.
-- Custom instances were written to skip comparing the `SourceSpan` values. Only
-- the `Ord` instance was needed for the speed-up, but I did not want the `Eq`
-- to have mismatched behavior.
instance Eq Binder where
  Binder
NullBinder == :: Binder -> Binder -> Bool
== Binder
NullBinder =
    Bool
True
  (LiteralBinder SourceSpan
_ Literal Binder
lb) == (LiteralBinder SourceSpan
_ Literal Binder
lb') =
    Literal Binder
lb Literal Binder -> Literal Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Literal Binder
lb'
  (VarBinder SourceSpan
_ Ident
ident) == (VarBinder SourceSpan
_ Ident
ident') =
    Ident
ident Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ident'
  (ConstructorBinder SourceSpan
_ Qualified (ProperName 'ConstructorName)
qpc [Binder]
bs) == (ConstructorBinder SourceSpan
_ Qualified (ProperName 'ConstructorName)
qpc' [Binder]
bs') =
    Qualified (ProperName 'ConstructorName)
qpc Qualified (ProperName 'ConstructorName)
-> Qualified (ProperName 'ConstructorName) -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified (ProperName 'ConstructorName)
qpc' Bool -> Bool -> Bool
&& [Binder]
bs [Binder] -> [Binder] -> Bool
forall a. Eq a => a -> a -> Bool
== [Binder]
bs'
  (OpBinder SourceSpan
_ Qualified (OpName 'ValueOpName)
qov) == (OpBinder SourceSpan
_ Qualified (OpName 'ValueOpName)
qov') =
    Qualified (OpName 'ValueOpName)
qov Qualified (OpName 'ValueOpName)
-> Qualified (OpName 'ValueOpName) -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified (OpName 'ValueOpName)
qov'
  (BinaryNoParensBinder Binder
b1 Binder
b2 Binder
b3) == (BinaryNoParensBinder Binder
b1' Binder
b2' Binder
b3') =
    Binder
b1 Binder -> Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Binder
b1' Bool -> Bool -> Bool
&& Binder
b2 Binder -> Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Binder
b2' Bool -> Bool -> Bool
&& Binder
b3 Binder -> Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Binder
b3'
  (ParensInBinder Binder
b) == (ParensInBinder Binder
b') =
    Binder
b Binder -> Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Binder
b'
  (NamedBinder SourceSpan
_ Ident
ident Binder
b) == (NamedBinder SourceSpan
_ Ident
ident' Binder
b') =
    Ident
ident Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ident' Bool -> Bool -> Bool
&& Binder
b Binder -> Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Binder
b'
  (PositionedBinder SourceSpan
_ [Comment]
comments Binder
b) == (PositionedBinder SourceSpan
_ [Comment]
comments' Binder
b') =
    [Comment]
comments [Comment] -> [Comment] -> Bool
forall a. Eq a => a -> a -> Bool
== [Comment]
comments' Bool -> Bool -> Bool
&& Binder
b Binder -> Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Binder
b'
  (TypedBinder SourceType
ty Binder
b) == (TypedBinder SourceType
ty' Binder
b') =
    SourceType
ty SourceType -> SourceType -> Bool
forall a. Eq a => a -> a -> Bool
== SourceType
ty' Bool -> Bool -> Bool
&& Binder
b Binder -> Binder -> Bool
forall a. Eq a => a -> a -> Bool
== Binder
b'
  Binder
_ == Binder
_ = Bool
False

instance Ord Binder where
  compare :: Binder -> Binder -> Ordering
compare Binder
NullBinder Binder
NullBinder = Ordering
EQ
  compare (LiteralBinder SourceSpan
_ Literal Binder
lb) (LiteralBinder SourceSpan
_ Literal Binder
lb') =
    Literal Binder -> Literal Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Literal Binder
lb Literal Binder
lb'
  compare (VarBinder SourceSpan
_ Ident
ident) (VarBinder SourceSpan
_ Ident
ident') =
    Ident -> Ident -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Ident
ident Ident
ident'
  compare (ConstructorBinder SourceSpan
_ Qualified (ProperName 'ConstructorName)
qpc [Binder]
bs) (ConstructorBinder SourceSpan
_ Qualified (ProperName 'ConstructorName)
qpc' [Binder]
bs') =
    Qualified (ProperName 'ConstructorName)
-> Qualified (ProperName 'ConstructorName) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Qualified (ProperName 'ConstructorName)
qpc Qualified (ProperName 'ConstructorName)
qpc' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> [Binder] -> [Binder] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Binder]
bs [Binder]
bs'
  compare (OpBinder SourceSpan
_ Qualified (OpName 'ValueOpName)
qov) (OpBinder SourceSpan
_ Qualified (OpName 'ValueOpName)
qov') =
    Qualified (OpName 'ValueOpName)
-> Qualified (OpName 'ValueOpName) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Qualified (OpName 'ValueOpName)
qov Qualified (OpName 'ValueOpName)
qov'
  compare (BinaryNoParensBinder Binder
b1 Binder
b2 Binder
b3) (BinaryNoParensBinder Binder
b1' Binder
b2' Binder
b3') =
    Binder -> Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Binder
b1 Binder
b1' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Binder -> Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Binder
b2 Binder
b2' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Binder -> Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Binder
b3 Binder
b3'
  compare (ParensInBinder Binder
b) (ParensInBinder Binder
b') =
    Binder -> Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Binder
b Binder
b'
  compare (NamedBinder SourceSpan
_ Ident
ident Binder
b) (NamedBinder SourceSpan
_ Ident
ident' Binder
b') =
    Ident -> Ident -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Ident
ident Ident
ident' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Binder -> Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Binder
b Binder
b'
  compare (PositionedBinder SourceSpan
_ [Comment]
comments Binder
b) (PositionedBinder SourceSpan
_ [Comment]
comments' Binder
b') =
    [Comment] -> [Comment] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Comment]
comments [Comment]
comments' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Binder -> Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Binder
b Binder
b'
  compare (TypedBinder SourceType
ty Binder
b) (TypedBinder SourceType
ty' Binder
b') =
    SourceType -> SourceType -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SourceType
ty SourceType
ty' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Binder -> Binder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Binder
b Binder
b'
  compare Binder
binder Binder
binder' =
    Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Binder -> Int
orderOf Binder
binder) (Binder -> Int
orderOf Binder
binder')
      where
        orderOf :: Binder -> Int
        orderOf :: Binder -> Int
orderOf Binder
NullBinder = Int
0
        orderOf LiteralBinder{} = Int
1
        orderOf VarBinder{} = Int
2
        orderOf ConstructorBinder{} = Int
3
        orderOf OpBinder{} = Int
4
        orderOf BinaryNoParensBinder{} = Int
5
        orderOf ParensInBinder{} = Int
6
        orderOf NamedBinder{} = Int
7
        orderOf PositionedBinder{} = Int
8
        orderOf TypedBinder{} = Int
9

-- |
-- Collect all names introduced in binders in an expression
--
binderNames :: Binder -> [Ident]
binderNames :: Binder -> [Ident]
binderNames = [Ident] -> Binder -> [Ident]
go []
  where
  go :: [Ident] -> Binder -> [Ident]
go [Ident]
ns (LiteralBinder SourceSpan
_ Literal Binder
b) = [Ident] -> Literal Binder -> [Ident]
lit [Ident]
ns Literal Binder
b
  go [Ident]
ns (VarBinder SourceSpan
_ Ident
name) = Ident
name Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: [Ident]
ns
  go [Ident]
ns (ConstructorBinder SourceSpan
_ Qualified (ProperName 'ConstructorName)
_ [Binder]
bs) = ([Ident] -> Binder -> [Ident]) -> [Ident] -> [Binder] -> [Ident]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Ident] -> Binder -> [Ident]
go [Ident]
ns [Binder]
bs
  go [Ident]
ns (BinaryNoParensBinder Binder
b1 Binder
b2 Binder
b3) = ([Ident] -> Binder -> [Ident]) -> [Ident] -> [Binder] -> [Ident]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Ident] -> Binder -> [Ident]
go [Ident]
ns [Binder
b1, Binder
b2, Binder
b3]
  go [Ident]
ns (ParensInBinder Binder
b) = [Ident] -> Binder -> [Ident]
go [Ident]
ns Binder
b
  go [Ident]
ns (NamedBinder SourceSpan
_ Ident
name Binder
b) = [Ident] -> Binder -> [Ident]
go (Ident
name Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: [Ident]
ns) Binder
b
  go [Ident]
ns (PositionedBinder SourceSpan
_ [Comment]
_ Binder
b) = [Ident] -> Binder -> [Ident]
go [Ident]
ns Binder
b
  go [Ident]
ns (TypedBinder SourceType
_ Binder
b) = [Ident] -> Binder -> [Ident]
go [Ident]
ns Binder
b
  go [Ident]
ns Binder
_ = [Ident]
ns
  lit :: [Ident] -> Literal Binder -> [Ident]
lit [Ident]
ns (ObjectLiteral [(PSString, Binder)]
bs) = ([Ident] -> Binder -> [Ident]) -> [Ident] -> [Binder] -> [Ident]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Ident] -> Binder -> [Ident]
go [Ident]
ns (((PSString, Binder) -> Binder) -> [(PSString, Binder)] -> [Binder]
forall a b. (a -> b) -> [a] -> [b]
map (PSString, Binder) -> Binder
forall a b. (a, b) -> b
snd [(PSString, Binder)]
bs)
  lit [Ident]
ns (ArrayLiteral [Binder]
bs) = ([Ident] -> Binder -> [Ident]) -> [Ident] -> [Binder] -> [Ident]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Ident] -> Binder -> [Ident]
go [Ident]
ns [Binder]
bs
  lit [Ident]
ns Literal Binder
_ = [Ident]
ns

isIrrefutable :: Binder -> Bool
isIrrefutable :: Binder -> Bool
isIrrefutable Binder
NullBinder = Bool
True
isIrrefutable (VarBinder SourceSpan
_ Ident
_) = Bool
True
isIrrefutable (PositionedBinder SourceSpan
_ [Comment]
_ Binder
b) = Binder -> Bool
isIrrefutable Binder
b
isIrrefutable (TypedBinder SourceType
_ Binder
b) = Binder -> Bool
isIrrefutable Binder
b
isIrrefutable Binder
_ = Bool
False