{-# LANGUAGE PatternSynonyms #-}
module Parsley.Internal.Core.Defunc (module Parsley.Internal.Core.Defunc) where

import Language.Haskell.TH.Syntax (Lift(..))
import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))

{-|
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 value
  LIFTED  :: (Show a, Lift 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

  -- 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))
  _code :: Defunc a -> Code a
_code = Defunc a -> Code a
forall a. Defunc a -> Code a
genDefunc
  >*< :: 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 ()

ap :: Defunc (a -> b) -> Defunc a -> Defunc b
ap :: Defunc (a -> b) -> Defunc a -> Defunc b
ap Defunc (a -> b)
f Defunc a
x = Defunc (a -> b) -> Defunc a -> Defunc b
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
APP_H Defunc (a -> b)
f Defunc a
x

genDefunc :: Defunc a -> Code a
genDefunc :: Defunc a -> Code a
genDefunc Defunc a
ID                        = [|| \x -> x ||]
genDefunc Defunc a
COMPOSE                   = [|| \f g x -> f (g x) ||]
genDefunc Defunc a
FLIP                      = [|| \f x y -> f y x ||]
genDefunc (COMPOSE_H Defunc x
f Defunc y
g)           = [|| \x -> $$(genDefunc1 (COMPOSE_H f g) [||x||]) ||]
genDefunc Defunc a
CONST                     = [|| \x _ -> x ||]
genDefunc Defunc a
FLIP_CONST                = [|| \_ y -> y ||]
genDefunc (FLIP_H Defunc x
f)                = [|| \x -> $$(genDefunc1 (FLIP_H f) [||x||]) ||]
genDefunc (APP_H Defunc (a -> a)
f Defunc a
x)               = Defunc (a -> a) -> Code a -> Code a
forall a b. Defunc (a -> b) -> Code a -> Code b
genDefunc1 Defunc (a -> a)
f (Defunc a -> Code a
forall a. Defunc a -> Code a
genDefunc Defunc a
x)
genDefunc (LIFTED a
x)                = [|| x ||]
genDefunc (EQ_H Defunc a
x)                  = [|| \y -> $$(genDefunc1 (EQ_H x) [||y||]) ||]
genDefunc Defunc a
CONS                      = [|| \x xs -> x : xs ||]
genDefunc Defunc a
EMPTY                     = [|| [] ||]
genDefunc (IF_S (LIFTED Bool
True) Defunc a
t Defunc a
_)  = Defunc a -> Code a
forall a. Defunc a -> Code a
genDefunc Defunc a
t
genDefunc (IF_S (LIFTED Bool
False) Defunc a
_ Defunc a
e) = Defunc a -> Code a
forall a. Defunc a -> Code a
genDefunc Defunc a
e
genDefunc (IF_S Defunc Bool
c Defunc a
t Defunc a
e)              = [|| if $$(genDefunc c) then $$(genDefunc t) else $$(genDefunc e) ||]
genDefunc (LAM_S Defunc a -> Defunc b
f)                 = [|| \x -> $$(genDefunc1 (LAM_S f) [||x||]) ||]
genDefunc (LET_S Defunc a
x Defunc a -> Defunc a
f)               = [|| let y = $$(genDefunc x) in $$(genDefunc (f (makeQ undefined [||y||]))) ||]
genDefunc (BLACK WQ a
f)                 = WQ a -> Code a
forall (q :: Type -> Type) a. Quapplicative q => q a -> Code a
_code WQ a
f

genDefunc1 :: Defunc (a -> b) -> Code a -> Code b
genDefunc1 :: Defunc (a -> b) -> Code a -> Code b
genDefunc1 Defunc (a -> b)
ID              Code a
qx = Code a
Code b
qx
genDefunc1 Defunc (a -> b)
COMPOSE         Code a
qf = [|| \g x -> $$qf (g x) ||]
genDefunc1 Defunc (a -> b)
FLIP            Code a
qf = [|| \x y -> $$qf y x ||]
genDefunc1 (COMPOSE_H Defunc x
f Defunc y
g) Code a
qx = Defunc (b -> b) -> Code b -> Code b
forall a b. Defunc (a -> b) -> Code a -> Code b
genDefunc1 Defunc x
Defunc (b -> b)
f (Defunc (a -> b) -> Code a -> Code b
forall a b. Defunc (a -> b) -> Code a -> Code b
genDefunc1 Defunc y
Defunc (a -> b)
g Code a
qx)
genDefunc1 (APP_H Defunc (a -> a -> b)
ID Defunc a
f)    Code a
qx = Defunc (a -> b) -> Code a -> Code b
forall a b. Defunc (a -> b) -> Code a -> Code b
genDefunc1 Defunc a
Defunc (a -> b)
f Code a
qx
genDefunc1 (APP_H Defunc (a -> a -> b)
f Defunc a
x)     Code a
qy = Defunc (a -> a -> b) -> Code a -> Code a -> Code b
forall a b c. Defunc (a -> b -> c) -> Code a -> Code b -> Code c
genDefunc2 Defunc (a -> a -> b)
f (Defunc a -> Code a
forall a. Defunc a -> Code a
genDefunc Defunc a
x) Code a
qy
genDefunc1 Defunc (a -> b)
CONST           Code a
qx = [|| \_ -> $$qx ||]
genDefunc1 Defunc (a -> b)
FLIP_CONST      Code a
_  = Defunc (b -> b) -> Code (b -> b)
forall a. Defunc a -> Code a
genDefunc Defunc (b -> b)
forall a. Defunc (a -> a)
ID
genDefunc1 (FLIP_H Defunc x
f)      Code a
qx = [|| \y -> $$(genDefunc2 (FLIP_H f) qx [||y||]) ||]
genDefunc1 (EQ_H Defunc a
x)        Code a
qy = [|| $$(genDefunc x)  == $$qy ||]
genDefunc1 (LAM_S Defunc a -> Defunc b
f)       Code a
qx = Defunc b -> Code b
forall a. Defunc a -> Code a
genDefunc (Defunc a -> Defunc b
f (a -> Code a -> Defunc a
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
forall a. HasCallStack => a
undefined Code a
qx))
genDefunc1 Defunc (a -> b)
f               Code a
qx = [|| $$(genDefunc f) $$qx ||]

genDefunc2 :: Defunc (a -> b -> c) -> Code a -> Code b -> Code c
genDefunc2 :: Defunc (a -> b -> c) -> Code a -> Code b -> Code c
genDefunc2 Defunc (a -> b -> c)
ID              Code a
qf Code b
qx  = [|| $$qf $$qx ||]
genDefunc2 Defunc (a -> b -> c)
COMPOSE         Code a
qf Code b
qg  = [|| \x -> $$qf ($$qg x) ||]
genDefunc2 Defunc (a -> b -> c)
FLIP            Code a
qf Code b
qx  = [|| \y -> $$qf y $$qx ||]
genDefunc2 (COMPOSE_H Defunc x
f Defunc y
g) Code a
qx Code b
qy  = Defunc (b -> b -> c) -> Code b -> Code b -> Code c
forall a b c. Defunc (a -> b -> c) -> Code a -> Code b -> Code c
genDefunc2 Defunc x
Defunc (b -> b -> c)
f (Defunc (a -> b) -> Code a -> Code b
forall a b. Defunc (a -> b) -> Code a -> Code b
genDefunc1 Defunc y
Defunc (a -> b)
g Code a
qx) Code b
qy
genDefunc2 Defunc (a -> b -> c)
CONST           Code a
qx Code b
_   = Code a
Code c
qx
genDefunc2 Defunc (a -> b -> c)
FLIP_CONST      Code a
_  Code b
qy  = Code b
Code c
qy
genDefunc2 (FLIP_H Defunc x
f)      Code a
qx Code b
qy  = Defunc (b -> a -> c) -> Code b -> Code a -> Code c
forall a b c. Defunc (a -> b -> c) -> Code a -> Code b -> Code c
genDefunc2 Defunc x
Defunc (b -> a -> c)
f Code b
qy Code a
qx
genDefunc2 Defunc (a -> b -> c)
CONS            Code a
qx Code b
qxs = [|| $$qx : $$qxs ||]
genDefunc2 Defunc (a -> b -> c)
f               Code a
qx Code b
qy  = [|| $$(genDefunc1 f qx) $$qy ||]

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 Defunc a
_ = String
"x"