{-# LANGUAGE PatternSynonyms, TypeApplications #-}
{-|
Module      : Parsley.Internal.Core.Defunc
Description : Combinator-level defunctionalisation
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

This module contains the infrastructure and definitions of defunctionalised
terms that can be used by the user and the frontend.

@since 1.0.0.0
-}
module Parsley.Internal.Core.Defunc (
    Defunc(..),
    pattern COMPOSE_H, pattern FLIP_H, pattern FLIP_CONST, pattern UNIT,
    lamTerm
  ) where

import Data.List                     (intercalate)
import Data.Typeable                 (Typeable, (:~:)(Refl), eqT)
import Language.Haskell.TH.Syntax    (Lift(..))
import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))
import Parsley.Internal.Core.Lam     (normaliseGen, Lam(..))

{-|
This datatype is useful for providing an /inspectable/ representation of common Haskell functions.
These can be provided in place of `WQ` to any combinator that requires it. The only difference is
that the Parsley compiler is able to manipulate and match on the constructors, which might lead to
optimisations. They can also be more convenient than constructing the `WQ` object itself:

> ID ~= WQ id [||id||]
> APP_H f x ~= WQ (f x) [||f x||]

@since 0.1.0.0
-}
data Defunc a where
  -- | Corresponds to the standard @id@ function
  ID      :: Defunc (a -> a)
  -- | Corresponds to the standard @(.)@ function applied to no arguments.
  COMPOSE :: Defunc ((b -> c) -> (a -> b) -> (a -> c))
  -- | Corresponds to the standard @flip@ function applied to no arguments.
  FLIP    :: Defunc ((a -> b -> c) -> b -> a -> c)
  -- | Corresponds to function application of two other `Defunc` values.
  APP_H   :: Defunc (a -> b) -> Defunc a -> Defunc b
  -- | Corresponds to the partially applied @(== x)@ for some `Defunc` value @x@.
  EQ_H    :: Eq a => Defunc a -> Defunc (a -> Bool)
  -- | Represents a liftable, showable, typable value.
  LIFTED  :: (Show a, Lift a, Typeable a) => a -> Defunc a
  -- | Represents the standard @(:)@ function applied to no arguments.
  CONS    :: Defunc (a -> [a] -> [a])
  -- | Represents the standard @const@ function applied to no arguments.
  CONST   :: Defunc (a -> b -> a)
  -- | Represents the empty list @[]@.
  EMPTY   :: Defunc [a]
  -- | Wraps up any value of type `WQ`.
  BLACK   :: WQ a -> Defunc a

  {-|
  Designed to be a specialised form of character predicate: is a character within some given ranges
  (which are inclusive at both ends).

  @since 2.0.0.0
  -}
  RANGES  :: Bool                  -- ^ Does the range test for membership (@True@) or /no/ membership (@False@).
          -> [(Char, Char)]        -- ^ List of ranges of the form @(l, u)@: @l@ and @u@ are inclusive to the range.
          -> Defunc (Char -> Bool)

  -- Syntax constructors
  {-|
  Represents the regular Haskell @if@ syntax.

  @since 0.1.1.0
  -}
  IF_S    :: Defunc Bool -> Defunc a -> Defunc a -> Defunc a
  {-|
  Represents a Haskell lambda abstraction.

  @since 0.1.1.0
  -}
  LAM_S   :: (Defunc a -> Defunc b) -> Defunc (a -> b)
  {-|
  Represents a Haskell let binding.

  @since 0.1.1.0
  -}
  LET_S   :: Defunc a -> (Defunc a -> Defunc b) -> Defunc b

{-|
This instance is used to manipulate values of `Defunc`.

@since 0.1.0.0
-}
instance Quapplicative Defunc where
  makeQ :: a -> Code a -> Defunc a
makeQ a
x Code a
qx               = WQ a -> Defunc a
forall a. WQ a -> Defunc a
BLACK (a -> Code a -> WQ a
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
x Code a
qx)
  _val :: Defunc a -> a
_val Defunc a
ID                  = a
forall a. a -> a
id
  _val Defunc a
COMPOSE             = a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
  _val Defunc a
FLIP                = a
forall a b c. (a -> b -> c) -> b -> a -> c
flip
  _val (APP_H Defunc (a -> a)
f Defunc a
x)         = Defunc (a -> a) -> a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc (a -> a)
f (Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x)
  _val (LIFTED a
x)          = a
x
  _val (EQ_H Defunc a
x)            = (Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)
  _val Defunc a
CONS                = (:)
  _val Defunc a
CONST               = a
forall a b. a -> b -> a
const
  _val Defunc a
EMPTY               = []
  _val (BLACK WQ a
f)           = WQ a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val WQ a
f
  -- Syntax
  _val (IF_S Defunc Bool
c Defunc a
t Defunc a
e)        = if Defunc Bool -> Bool
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc Bool
c then Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
t else Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
e
  _val (LAM_S Defunc a -> Defunc b
f)           = \a
x -> Defunc b -> b
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val (Defunc a -> Defunc b
f (a -> Code a -> Defunc a
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
x Code a
forall a. HasCallStack => a
undefined))
  _val (LET_S Defunc a
x Defunc a -> Defunc a
f)         = let y :: a
y = Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x in Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val (Defunc a -> Defunc a
f (a -> Code a -> Defunc a
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
y Code a
forall a. HasCallStack => a
undefined))
  _val (RANGES Bool
True [(Char, Char)]
rngs)  = \Char
c -> ((Char, Char) -> Bool) -> [(Char, Char)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (\(Char
l, Char
u) -> Char
l Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
u) [(Char, Char)]
rngs
  _val (RANGES Bool
False [(Char, Char)]
rngs) = \Char
c -> ((Char, Char) -> Bool) -> [(Char, Char)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\(Char
l, Char
u) -> Char
l Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
u) [(Char, Char)]
rngs
  _code :: Defunc a -> Code a
_code = Lam a -> Code a
forall a. Lam a -> Code a
normaliseGen (Lam a -> Code a) -> (Defunc a -> Lam a) -> Defunc a -> Code a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm
  >*< :: Defunc (a -> b) -> Defunc a -> Defunc b
(>*<) = Defunc (a -> b) -> Defunc a -> Defunc b
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
APP_H

{-|
This pattern represents fully applied composition of two `Defunc` values.

@since 0.1.0.0
-}
pattern COMPOSE_H     :: () => ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) => Defunc x -> Defunc y -> Defunc z
pattern $bCOMPOSE_H :: Defunc x -> Defunc y -> Defunc z
$mCOMPOSE_H :: forall r z.
Defunc z
-> (forall x y b c a.
    ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
    Defunc x -> Defunc y -> r)
-> (Void# -> r)
-> r
COMPOSE_H f g = APP_H (APP_H COMPOSE f) g
{-|
This pattern corresponds to the standard @flip@ function applied to a single argument.

@since 0.1.0.0
-}
pattern FLIP_H        :: () => ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) => Defunc x -> Defunc y
pattern $bFLIP_H :: Defunc x -> Defunc y
$mFLIP_H :: forall r y.
Defunc y
-> (forall x a b c.
    ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
    Defunc x -> r)
-> (Void# -> r)
-> r
FLIP_H f      = APP_H FLIP f
{-|
Represents the flipped standard @const@ function applied to no arguments.

@since 0.1.0.0
-}
pattern FLIP_CONST    :: () => (x ~ (a -> b -> b)) => Defunc x
pattern $bFLIP_CONST :: Defunc x
$mFLIP_CONST :: forall r x.
Defunc x
-> (forall a b. (x ~ (a -> b -> b)) => r) -> (Void# -> r) -> r
FLIP_CONST    = FLIP_H CONST
{-|
This pattern represents the unit value @()@.

@since 0.1.0.0
-}
pattern UNIT          :: Defunc ()
pattern $bUNIT :: Defunc ()
$mUNIT :: forall r. Defunc () -> (Void# -> r) -> (Void# -> r) -> r
UNIT          = LIFTED ()

{-|
Converts a `Defunc` value into an equivalent `Lam` value, discarding
the inspectivity of functions.

@since 1.0.1.0
-}
lamTerm :: forall a. Defunc a -> Lam a
lamTerm :: Defunc a -> Lam a
lamTerm Defunc a
ID = (Lam a -> Lam a) -> Lam (a -> a)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs Lam a -> Lam a
forall a. a -> a
id
lamTerm Defunc a
COMPOSE = (Lam (b -> c) -> Lam ((a -> b) -> a -> c))
-> Lam ((b -> c) -> (a -> b) -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam (b -> c)
f -> (Lam (a -> b) -> Lam (a -> c)) -> Lam ((a -> b) -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam (a -> b)
g -> (Lam a -> Lam c) -> Lam (a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam (b -> c) -> Lam b -> Lam c
forall a b. Lam (a -> b) -> Lam a -> Lam b
App Lam (b -> c)
f (Lam b -> Lam c) -> (Lam a -> Lam b) -> Lam a -> Lam c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam (a -> b) -> Lam a -> Lam b
forall a b. Lam (a -> b) -> Lam a -> Lam b
App Lam (a -> b)
g)))
lamTerm Defunc a
FLIP = (Lam (a -> b -> c) -> Lam (b -> a -> c))
-> Lam ((a -> b -> c) -> b -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam (a -> b -> c)
f -> (Lam b -> Lam (a -> c)) -> Lam (b -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam b
x -> (Lam a -> Lam c) -> Lam (a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam a
y -> Lam (b -> c) -> Lam b -> Lam c
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (a -> b -> c) -> Lam a -> Lam (b -> c)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App Lam (a -> b -> c)
f Lam a
y) Lam b
x)))
lamTerm (APP_H Defunc (a -> a)
f Defunc a
x) = Lam (a -> a) -> Lam a -> Lam a
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Defunc (a -> a) -> Lam (a -> a)
forall a. Defunc a -> Lam a
lamTerm Defunc (a -> a)
f) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
x)
lamTerm (LIFTED a
b) | Just a :~: Bool
Refl <- (Typeable a, Typeable Bool) => Maybe (a :~: Bool)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @Bool = if a
Bool
b then Lam a
Lam Bool
T else Lam a
Lam Bool
F
lamTerm (LIFTED a
x) = Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Var Bool
True [||x||]
lamTerm (EQ_H Defunc a
x) = (Lam a -> Lam Bool) -> Lam (a -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam (a -> Bool) -> Lam a -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (a -> a -> Bool) -> Lam a -> Lam (a -> Bool)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Bool -> Code (a -> a -> Bool) -> Lam (a -> a -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(==)||]) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
x)))
lamTerm Defunc a
CONS = Bool -> Code (a -> [a] -> [a]) -> Lam (a -> [a] -> [a])
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(:)||]
lamTerm Defunc a
EMPTY = Bool -> Code [a] -> Lam [a]
forall a. Bool -> Code a -> Lam a
Var Bool
True [||[]||]
lamTerm Defunc a
CONST = (Lam a -> Lam (b -> a)) -> Lam (a -> b -> a)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs ((Lam b -> Lam a) -> Lam (b -> a)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs ((Lam b -> Lam a) -> Lam (b -> a))
-> (Lam a -> Lam b -> Lam a) -> Lam a -> Lam (b -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Lam b -> Lam a
forall a b. a -> b -> a
const)
lamTerm (BLACK WQ a
x) = Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Var Bool
False (WQ a -> Code a
forall (q :: Type -> Type) a. Quapplicative q => q a -> Code a
_code WQ a
x)
lamTerm (RANGES Bool
incl []) = (Lam Char -> Lam Bool) -> Lam (Char -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam Bool -> Lam Char -> Lam Bool
forall a b. a -> b -> a
const (if Bool
incl then Lam Bool
F else Lam Bool
T))
lamTerm (RANGES Bool
incl [(Char
l, Char
u)]) | Char
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
minBound, Char
u Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
maxBound = (Lam Char -> Lam Bool) -> Lam (Char -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam Bool -> Lam Char -> Lam Bool
forall a b. a -> b -> a
const (if Bool
incl then Lam Bool
T else Lam Bool
F))
lamTerm (RANGES Bool
incl [(Char, Char)]
rngs) =
  (Lam Char -> Lam Bool) -> Lam (Char -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs ((Lam Char -> Lam Bool) -> Lam (Char -> Bool))
-> (Lam Char -> Lam Bool) -> Lam (Char -> Bool)
forall a b. (a -> b) -> a -> b
$ \Lam Char
c ->
    Lam (Bool -> Bool) -> Lam Bool -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (if Bool
incl then (Lam Bool -> Lam Bool) -> Lam (Bool -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs Lam Bool -> Lam Bool
forall a. a -> a
id else Bool -> Code (Bool -> Bool) -> Lam (Bool -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||not||])
        ((Lam Bool -> Lam Bool -> Lam Bool) -> [Lam Bool] -> Lam Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 (Lam (Bool -> Bool) -> Lam Bool -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (Bool -> Bool) -> Lam Bool -> Lam Bool)
-> (Lam Bool -> Lam (Bool -> Bool))
-> Lam Bool
-> Lam Bool
-> Lam Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam (Bool -> Bool -> Bool) -> Lam Bool -> Lam (Bool -> Bool)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Bool -> Code (Bool -> Bool -> Bool) -> Lam (Bool -> Bool -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(||)||]))
          (((Char, Char) -> Lam Bool) -> [(Char, Char)] -> [Lam Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(Char
l, Char
u) ->
            if Char
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
u then Lam (Char -> Bool) -> Lam Char -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (Char -> Char -> Bool) -> Lam Char -> Lam (Char -> Bool)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Bool -> Code (Char -> Char -> Bool) -> Lam (Char -> Char -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(==)||]) Lam Char
c) (Bool -> Code Char -> Lam Char
forall a. Bool -> Code a -> Lam a
Var Bool
True [||l||])
                      else Lam (Bool -> Bool) -> Lam Bool -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (Bool -> Bool -> Bool) -> Lam Bool -> Lam (Bool -> Bool)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Bool -> Code (Bool -> Bool -> Bool) -> Lam (Bool -> Bool -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(&&)||])
                               (Lam (Char -> Bool) -> Lam Char -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (Char -> Char -> Bool) -> Lam Char -> Lam (Char -> Bool)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Bool -> Code (Char -> Char -> Bool) -> Lam (Char -> Char -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(<=)||]) (Bool -> Code Char -> Lam Char
forall a. Bool -> Code a -> Lam a
Var Bool
True [||l||])) Lam Char
c))
                               (Lam (Char -> Bool) -> Lam Char -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (Char -> Char -> Bool) -> Lam Char -> Lam (Char -> Bool)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Bool -> Code (Char -> Char -> Bool) -> Lam (Char -> Char -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(<=)||]) Lam Char
c) (Bool -> Code Char -> Lam Char
forall a. Bool -> Code a -> Lam a
Var Bool
True [||u||])))
           [(Char, Char)]
rngs))
lamTerm (LAM_S Defunc a -> Defunc b
f) = (Lam a -> Lam b) -> Lam (a -> b)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs ((Defunc a -> Defunc b) -> Lam a -> Lam b
forall a b. (Defunc a -> Defunc b) -> Lam a -> Lam b
adaptLam Defunc a -> Defunc b
f)
lamTerm (IF_S Defunc Bool
c Defunc a
t Defunc a
e) = Lam Bool -> Lam a -> Lam a -> Lam a
forall a. Lam Bool -> Lam a -> Lam a -> Lam a
If (Defunc Bool -> Lam Bool
forall a. Defunc a -> Lam a
lamTerm Defunc Bool
c) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
t) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
e)
lamTerm (LET_S Defunc a
x Defunc a -> Defunc a
f) = Lam a -> (Lam a -> Lam a) -> Lam a
forall a b. Lam a -> (Lam a -> Lam b) -> Lam b
Let (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
x) ((Defunc a -> Defunc a) -> Lam a -> Lam a
forall a b. (Defunc a -> Defunc b) -> Lam a -> Lam b
adaptLam Defunc a -> Defunc a
f)

adaptLam :: (Defunc a -> Defunc b) -> (Lam a -> Lam b)
adaptLam :: (Defunc a -> Defunc b) -> Lam a -> Lam b
adaptLam Defunc a -> Defunc b
f = Defunc b -> Lam b
forall a. Defunc a -> Lam a
lamTerm (Defunc b -> Lam b) -> (Lam a -> Defunc b) -> Lam a -> Lam b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Defunc b
f (Defunc a -> Defunc b) -> (Lam a -> Defunc a) -> Lam a -> Defunc b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm
  where
    defuncTerm :: Lam a -> Defunc a
    defuncTerm :: Lam a -> Defunc a
defuncTerm (Abs Lam a -> Lam b
f)    = (Defunc a -> Defunc b) -> Defunc (a -> b)
forall a a. (Defunc a -> Defunc a) -> Defunc (a -> a)
LAM_S (Lam b -> Defunc b
forall a. Lam a -> Defunc a
defuncTerm (Lam b -> Defunc b) -> (Defunc a -> Lam b) -> Defunc a -> Defunc b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Lam b
f (Lam a -> Lam b) -> (Defunc a -> Lam a) -> Defunc a -> Lam b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm)
    defuncTerm (App Lam (a -> a)
f Lam a
x)  = Defunc (a -> a) -> Defunc a -> Defunc a
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
APP_H (Lam (a -> a) -> Defunc (a -> a)
forall a. Lam a -> Defunc a
defuncTerm Lam (a -> a)
f) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
x)
    defuncTerm (Var Bool
_ Code a
x)  = Code a -> Defunc a
forall a. Code a -> Defunc a
unsafeBLACK Code a
x
    defuncTerm (If Lam Bool
c Lam a
t Lam a
e) = Defunc Bool -> Defunc a -> Defunc a -> Defunc a
forall a. Defunc Bool -> Defunc a -> Defunc a -> Defunc a
IF_S (Lam Bool -> Defunc Bool
forall a. Lam a -> Defunc a
defuncTerm Lam Bool
c) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
t) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
e)
    defuncTerm (Let Lam a
x Lam a -> Lam a
f)  = Defunc a -> (Defunc a -> Defunc a) -> Defunc a
forall a b. Defunc a -> (Defunc a -> Defunc b) -> Defunc b
LET_S (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
x) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm (Lam a -> Defunc a) -> (Defunc a -> Lam a) -> Defunc a -> Defunc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Lam a
f (Lam a -> Lam a) -> (Defunc a -> Lam a) -> Defunc a -> Lam a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm)
    defuncTerm Lam a
T          = Bool -> Defunc Bool
forall a. (Show a, Lift a, Typeable a) => a -> Defunc a
LIFTED Bool
True
    defuncTerm Lam a
F          = Bool -> Defunc Bool
forall a. (Show a, Lift a, Typeable a) => a -> Defunc a
LIFTED Bool
False

unsafeBLACK :: Code a -> Defunc a
unsafeBLACK :: Code a -> Defunc a
unsafeBLACK = WQ a -> Defunc a
forall a. WQ a -> Defunc a
BLACK (WQ a -> Defunc a) -> (Code a -> WQ a) -> Code a -> Defunc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Code a -> WQ a
forall a. a -> Code a -> WQ a
WQ a
forall a. HasCallStack => a
undefined

instance Show (Defunc a) where
  show :: Defunc a -> String
show Defunc a
COMPOSE = String
"(.)"
  show Defunc a
FLIP = String
"flip"
  show (FLIP_H Defunc x
f) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(flip ", Defunc x -> String
forall a. Show a => a -> String
show Defunc x
f, String
")"]
  show (COMPOSE_H Defunc x
f Defunc y
g) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(", Defunc x -> String
forall a. Show a => a -> String
show Defunc x
f, String
" . ", Defunc y -> String
forall a. Show a => a -> String
show Defunc y
g, String
")"]
  show (APP_H Defunc (a -> a)
f Defunc a
x) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(", Defunc (a -> a) -> String
forall a. Show a => a -> String
show Defunc (a -> a)
f, String
" ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
x, String
")"]
  show (LIFTED a
x) = a -> String
forall a. Show a => a -> String
show a
x
  show (EQ_H Defunc a
x) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(== ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
x, String
")"]
  show Defunc a
ID  = String
"id"
  show Defunc a
EMPTY = String
"[]"
  show Defunc a
CONS = String
"(:)"
  show Defunc a
CONST = String
"const"
  show (IF_S Defunc Bool
c Defunc a
b Defunc a
e) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(if ", Defunc Bool -> String
forall a. Show a => a -> String
show Defunc Bool
c, String
" then ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
b, String
" else ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
e, String
")"]
  show (LAM_S Defunc a -> Defunc b
_) = String
"f"
  show (RANGES Bool
incl [(Char, Char)]
rngs) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [if Bool
incl then String
"not " else String
"", String
"elem (", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" ++ " (((Char, Char) -> String) -> [(Char, Char)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Char
l, Char
u) -> [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"[", Char -> String
forall a. Show a => a -> String
show Char
l, String
"..", Char -> String
forall a. Show a => a -> String
show Char
u, String
"]"]) [(Char, Char)]
rngs), String
")"]
  show Defunc a
_ = String
"x"