-- |
-- CoreFn traversal helpers
--
module Language.PureScript.CoreFn.Traversals where

import Prelude

import Control.Arrow (second, (***), (+++))
import Data.Bitraversable (bitraverse)

import Language.PureScript.AST.Literals
import Language.PureScript.CoreFn.Binders
import Language.PureScript.CoreFn.Expr

everywhereOnValues :: (Bind a -> Bind a) ->
                      (Expr a -> Expr a) ->
                      (Binder a -> Binder a) ->
                      (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
everywhereOnValues :: forall a.
(Bind a -> Bind a)
-> (Expr a -> Expr a)
-> (Binder a -> Binder a)
-> (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
everywhereOnValues Bind a -> Bind a
f Expr a -> Expr a
g Binder a -> Binder a
h = (Bind a -> Bind a
f', Expr a -> Expr a
g', Binder a -> Binder a
h')
  where
  f' :: Bind a -> Bind a
f' (NonRec a
a Ident
name Expr a
e) = Bind a -> Bind a
f (forall a. a -> Ident -> Expr a -> Bind a
NonRec a
a Ident
name (Expr a -> Expr a
g' Expr a
e))
  f' (Rec [((a, Ident), Expr a)]
es) = Bind a -> Bind a
f (forall a. [((a, Ident), Expr a)] -> Bind a
Rec (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Expr a -> Expr a
g') [((a, Ident), Expr a)]
es))

  g' :: Expr a -> Expr a
g' (Literal a
ann Literal (Expr a)
e) = Expr a -> Expr a
g (forall a. a -> Literal (Expr a) -> Expr a
Literal a
ann (forall a. (a -> a) -> Literal a -> Literal a
handleLiteral Expr a -> Expr a
g' Literal (Expr a)
e))
  g' (Accessor a
ann PSString
prop Expr a
e) = Expr a -> Expr a
g (forall a. a -> PSString -> Expr a -> Expr a
Accessor a
ann PSString
prop (Expr a -> Expr a
g' Expr a
e))
  g' (ObjectUpdate a
ann Expr a
obj [(PSString, Expr a)]
vs) = Expr a -> Expr a
g (forall a. a -> Expr a -> [(PSString, Expr a)] -> Expr a
ObjectUpdate a
ann (Expr a -> Expr a
g' Expr a
obj) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr a -> Expr a
g') [(PSString, Expr a)]
vs))
  g' (Abs a
ann Ident
name Expr a
e) = Expr a -> Expr a
g (forall a. a -> Ident -> Expr a -> Expr a
Abs a
ann Ident
name (Expr a -> Expr a
g' Expr a
e))
  g' (App a
ann Expr a
v1 Expr a
v2) = Expr a -> Expr a
g (forall a. a -> Expr a -> Expr a -> Expr a
App a
ann (Expr a -> Expr a
g' Expr a
v1) (Expr a -> Expr a
g' Expr a
v2))
  g' (Case a
ann [Expr a]
vs [CaseAlternative a]
alts) = Expr a -> Expr a
g (forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case a
ann (forall a b. (a -> b) -> [a] -> [b]
map Expr a -> Expr a
g' [Expr a]
vs) (forall a b. (a -> b) -> [a] -> [b]
map CaseAlternative a -> CaseAlternative a
handleCaseAlternative [CaseAlternative a]
alts))
  g' (Let a
ann [Bind a]
ds Expr a
e) = Expr a -> Expr a
g (forall a. a -> [Bind a] -> Expr a -> Expr a
Let a
ann (forall a b. (a -> b) -> [a] -> [b]
map Bind a -> Bind a
f' [Bind a]
ds) (Expr a -> Expr a
g' Expr a
e))
  g' Expr a
e = Expr a -> Expr a
g Expr a
e

  h' :: Binder a -> Binder a
h' (LiteralBinder a
a Literal (Binder a)
b) = Binder a -> Binder a
h (forall a. a -> Literal (Binder a) -> Binder a
LiteralBinder a
a (forall a. (a -> a) -> Literal a -> Literal a
handleLiteral Binder a -> Binder a
h' Literal (Binder a)
b))
  h' (NamedBinder a
a Ident
name Binder a
b) = Binder a -> Binder a
h (forall a. a -> Ident -> Binder a -> Binder a
NamedBinder a
a Ident
name (Binder a -> Binder a
h' Binder a
b))
  h' (ConstructorBinder a
a Qualified (ProperName 'TypeName)
q1 Qualified (ProperName 'ConstructorName)
q2 [Binder a]
bs) = Binder a -> Binder a
h (forall a.
a
-> Qualified (ProperName 'TypeName)
-> Qualified (ProperName 'ConstructorName)
-> [Binder a]
-> Binder a
ConstructorBinder a
a Qualified (ProperName 'TypeName)
q1 Qualified (ProperName 'ConstructorName)
q2 (forall a b. (a -> b) -> [a] -> [b]
map Binder a -> Binder a
h' [Binder a]
bs))
  h' Binder a
b = Binder a -> Binder a
h Binder a
b

  handleCaseAlternative :: CaseAlternative a -> CaseAlternative a
handleCaseAlternative CaseAlternative a
ca =
    CaseAlternative a
ca { caseAlternativeBinders :: [Binder a]
caseAlternativeBinders = forall a b. (a -> b) -> [a] -> [b]
map Binder a -> Binder a
h' (forall a. CaseAlternative a -> [Binder a]
caseAlternativeBinders CaseAlternative a
ca)
       , caseAlternativeResult :: Either [(Expr a, Expr a)] (Expr a)
caseAlternativeResult = (forall a b. (a -> b) -> [a] -> [b]
map (Expr a -> Expr a
g' forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Expr a -> Expr a
g') forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ Expr a -> Expr a
g') (forall a.
CaseAlternative a -> Either [(Guard a, Guard a)] (Guard a)
caseAlternativeResult CaseAlternative a
ca)
       }

  handleLiteral :: (a -> a) -> Literal a -> Literal a
  handleLiteral :: forall a. (a -> a) -> Literal a -> Literal a
handleLiteral a -> a
i (ArrayLiteral [a]
ls) = forall a. [a] -> Literal a
ArrayLiteral (forall a b. (a -> b) -> [a] -> [b]
map a -> a
i [a]
ls)
  handleLiteral a -> a
i (ObjectLiteral [(PSString, a)]
ls) = forall a. [(PSString, a)] -> Literal a
ObjectLiteral (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
i) [(PSString, a)]
ls)
  handleLiteral a -> a
_ Literal a
other = Literal a
other

-- |
-- Apply the provided functions to the top level of AST nodes.
--
-- This function is useful as a building block for recursive functions, but
-- doesn't actually recurse itself.
--
traverseCoreFn
  :: forall f a
   . Applicative f
  => (Bind a -> f (Bind a))
  -> (Expr a -> f (Expr a))
  -> (Binder a -> f (Binder a))
  -> (CaseAlternative a -> f (CaseAlternative a))
  -> (Bind a -> f (Bind a), Expr a -> f (Expr a), Binder a -> f (Binder a), CaseAlternative a -> f (CaseAlternative a))
traverseCoreFn :: forall (f :: * -> *) a.
Applicative f =>
(Bind a -> f (Bind a))
-> (Expr a -> f (Expr a))
-> (Binder a -> f (Binder a))
-> (CaseAlternative a -> f (CaseAlternative a))
-> (Bind a -> f (Bind a), Expr a -> f (Expr a),
    Binder a -> f (Binder a),
    CaseAlternative a -> f (CaseAlternative a))
traverseCoreFn Bind a -> f (Bind a)
f Expr a -> f (Expr a)
g Binder a -> f (Binder a)
h CaseAlternative a -> f (CaseAlternative a)
i = (Bind a -> f (Bind a)
f', Expr a -> f (Expr a)
g', Binder a -> f (Binder a)
h', CaseAlternative a -> f (CaseAlternative a)
i')
  where
  f' :: Bind a -> f (Bind a)
f' (NonRec a
a Ident
name Expr a
e) = forall a. a -> Ident -> Expr a -> Bind a
NonRec a
a Ident
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> f (Expr a)
g Expr a
e
  f' (Rec [((a, Ident), Expr a)]
es) = forall a. [((a, Ident), Expr a)] -> Bind a
Rec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr a -> f (Expr a)
g) [((a, Ident), Expr a)]
es

  g' :: Expr a -> f (Expr a)
g' (Literal a
ann Literal (Expr a)
e) = forall a. a -> Literal (Expr a) -> Expr a
Literal a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {a}.
Applicative f =>
(a -> f a) -> Literal a -> f (Literal a)
handleLiteral Expr a -> f (Expr a)
g Literal (Expr a)
e
  g' (Accessor a
ann PSString
prop Expr a
e) = forall a. a -> PSString -> Expr a -> Expr a
Accessor a
ann PSString
prop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> f (Expr a)
g Expr a
e
  g' (ObjectUpdate a
ann Expr a
obj [(PSString, Expr a)]
vs) = forall a. a -> Expr a -> [(PSString, Expr a)] -> Expr a
ObjectUpdate a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> f (Expr a)
g Expr a
obj forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr a -> f (Expr a)
g) [(PSString, Expr a)]
vs
  g' (Abs a
ann Ident
name Expr a
e) = forall a. a -> Ident -> Expr a -> Expr a
Abs a
ann Ident
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> f (Expr a)
g Expr a
e
  g' (App a
ann Expr a
v1 Expr a
v2) = forall a. a -> Expr a -> Expr a -> Expr a
App a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> f (Expr a)
g Expr a
v1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr a -> f (Expr a)
g Expr a
v2
  g' (Case a
ann [Expr a]
vs [CaseAlternative a]
alts) = forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr a -> f (Expr a)
g [Expr a]
vs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CaseAlternative a -> f (CaseAlternative a)
i [CaseAlternative a]
alts
  g' (Let a
ann [Bind a]
ds Expr a
e) = forall a. a -> [Bind a] -> Expr a -> Expr a
Let a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Bind a -> f (Bind a)
f [Bind a]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr a -> f (Expr a)
g' Expr a
e
  g' Expr a
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr a
e

  h' :: Binder a -> f (Binder a)
h' (LiteralBinder a
a Literal (Binder a)
b) = forall a. a -> Literal (Binder a) -> Binder a
LiteralBinder a
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {a}.
Applicative f =>
(a -> f a) -> Literal a -> f (Literal a)
handleLiteral Binder a -> f (Binder a)
h Literal (Binder a)
b
  h' (NamedBinder a
a Ident
name Binder a
b) = forall a. a -> Ident -> Binder a -> Binder a
NamedBinder a
a Ident
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Binder a -> f (Binder a)
h Binder a
b
  h' (ConstructorBinder a
a Qualified (ProperName 'TypeName)
q1 Qualified (ProperName 'ConstructorName)
q2 [Binder a]
bs) = forall a.
a
-> Qualified (ProperName 'TypeName)
-> Qualified (ProperName 'ConstructorName)
-> [Binder a]
-> Binder a
ConstructorBinder a
a Qualified (ProperName 'TypeName)
q1 Qualified (ProperName 'ConstructorName)
q2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Binder a -> f (Binder a)
h [Binder a]
bs
  h' Binder a
b = forall (f :: * -> *) a. Applicative f => a -> f a
pure Binder a
b

  i' :: CaseAlternative a -> f (CaseAlternative a)
i' CaseAlternative a
ca = forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Binder a -> f (Binder a)
h (forall a. CaseAlternative a -> [Binder a]
caseAlternativeBinders CaseAlternative a
ca) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Expr a -> f (Expr a)
g Expr a -> f (Expr a)
g) Expr a -> f (Expr a)
g (forall a.
CaseAlternative a -> Either [(Guard a, Guard a)] (Guard a)
caseAlternativeResult CaseAlternative a
ca)

  handleLiteral :: (a -> f a) -> Literal a -> f (Literal a)
handleLiteral a -> f a
withItem = \case
    ArrayLiteral [a]
ls -> forall a. [a] -> Literal a
ArrayLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f a
withItem [a]
ls
    ObjectLiteral [(PSString, a)]
ls -> forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f a
withItem) [(PSString, a)]
ls
    Literal a
other -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Literal a
other