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

This module contains the infrastructure and definitions of defunctionalised
terms used solely within the machine.

@since 1.0.0.0
-}
module Parsley.Internal.Backend.Machine.Defunc (
    Defunc(..),
    user, userBool,
    ap, ap2,
    _if,
    genDefunc,
    pattern NormLam, pattern FREEVAR
  ) where

import Parsley.Internal.Backend.Machine.Types.Offset (Offset)
import Parsley.Internal.Common.Utils                 (Code)
import Parsley.Internal.Core.Lam                     (Lam, normaliseGen, normalise)

import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm, lamTermBool)
import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))

{-|
Machine level defunctionalisation, for terms that can only be introduced by
the code generator, and that do not require value level representations.

@since 1.4.0.0
-}
data Defunc a where
  {-|
  Wraps `Lam` terms so that they can be used within the machine.

  @since 1.1.0.0
  -}
  LAM     :: Lam a -> Defunc a
  {-|
  Represents Haskell's @undefined@, which may be used by high-level
  optimisers to replace redundant values whilst preserving the types.

  @since 1.0.0.0
  -}
  BOTTOM  :: Defunc a
  {-|
  Allows the static `Offset`s to be pushed onto the operand stack, which
  is the easiest way to get them to persist as arguments to handlers, and
  interact with `Parsley.Internal.Backend.Machine.Instructions.Seek` and
  `Parsley.Internal.Backend.Machine.Instructions.Tell`.

  @since 1.4.0.0
  -}
  OFFSET  :: Offset o -> Defunc o

{-|
Promotes a @Defunc@ value from the Frontend API into a Backend one.

@since 1.1.0.0
-}
user :: Core.Defunc a -> Defunc a
user :: Defunc a -> Defunc a
user = Lam a -> Defunc a
forall a. Lam a -> Defunc a
LAM (Lam a -> Defunc a) -> (Defunc a -> Lam a) -> Defunc a -> Defunc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Lam a
forall a. Defunc a -> Lam a
Core.lamTerm

{-|
Promotes a @Defunc@ value from the Frontend API into a Backend one,
for values representing @a -> Bool@.

@since 1.3.0.0
-}
userBool :: Core.Defunc (a -> Bool) -> Defunc (a -> Bool)
userBool :: Defunc (a -> Bool) -> Defunc (a -> Bool)
userBool = Lam (a -> Bool) -> Defunc (a -> Bool)
forall a. Lam a -> Defunc a
LAM (Lam (a -> Bool) -> Defunc (a -> Bool))
-> (Defunc (a -> Bool) -> Lam (a -> Bool))
-> Defunc (a -> Bool)
-> Defunc (a -> Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc (a -> Bool) -> Lam (a -> Bool)
forall a. Defunc (a -> Bool) -> Lam (a -> Bool)
Core.lamTermBool

{-|
Applies a function to a value when both are `Defunc`.

@since 1.3.0.0
-}
ap :: Defunc (a -> b) -> Defunc a -> Defunc b
ap :: Defunc (a -> b) -> Defunc a -> Defunc b
ap Defunc (a -> b)
f Defunc a
x = Lam b -> Defunc b
forall a. Lam a -> Defunc a
LAM (Lam (a -> b) -> Lam a -> Lam b
forall a b. Lam (a -> b) -> Lam a -> Lam b
Lam.App (Defunc (a -> b) -> Lam (a -> b)
forall a. Defunc a -> Lam a
unliftDefunc Defunc (a -> b)
f) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
unliftDefunc Defunc a
x))

{-|
Applies a function to two values when all are `Defunc`.

@since 1.3.0.0
-}
ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c
ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c
ap2 Defunc (a -> b -> c)
f Defunc a
x = Defunc (b -> c) -> Defunc b -> Defunc c
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
ap (Defunc (a -> b -> c) -> Defunc a -> Defunc (b -> c)
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
ap Defunc (a -> b -> c)
f Defunc a
x)

{-|
Acts as an @if@-expression lifted to the `Defunc` level.

@since 1.3.0.0
-}
_if :: Defunc Bool -> Code a -> Code a -> Code a
_if :: Defunc Bool -> Code a -> Code a -> Code a
_if Defunc Bool
c Code a
t Code a
e = Lam a -> Code a
forall a. Lam a -> Code a
normaliseGen (Lam Bool -> Lam a -> Lam a -> Lam a
forall a. Lam Bool -> Lam a -> Lam a -> Lam a
Lam.If (Defunc Bool -> Lam Bool
forall a. Defunc a -> Lam a
unliftDefunc Defunc Bool
c) (Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Lam.Var Bool
False Code a
t) (Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Lam.Var Bool
False Code a
e))

unliftDefunc :: Defunc a -> Lam a
unliftDefunc :: Defunc a -> Lam a
unliftDefunc (LAM Lam a
x) = Lam a
x
unliftDefunc Defunc a
x       = Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Lam.Var Bool
False (Defunc a -> Code a
forall a. Defunc a -> Code a
genDefunc Defunc a
x)

{-|
Generate the Haskell code that represents this defunctionalised value.

@since 1.0.0.0
-}
genDefunc :: Defunc a -> Code a
genDefunc :: Defunc a -> Code a
genDefunc (LAM Lam a
x)    = Lam a -> Code a
forall a. Lam a -> Code a
normaliseGen Lam a
x
genDefunc Defunc a
BOTTOM      = [||undefined||]
genDefunc (OFFSET Offset a
_)  = [Char] -> Code a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot materialise an unboxed offset in the regular way"

{-|
Pattern that normalises a `Lam` before returning it.

@since 1.1.0.0
-}
pattern NormLam :: Lam a -> Defunc a
pattern $mNormLam :: forall r a. Defunc a -> (Lam a -> r) -> (Void# -> r) -> r
NormLam t <- LAM (normalise -> t)

{-|
Pattern that represents simple `Lam` variables,
post-normalisation.

@since 1.1.0.0
-}
pattern FREEVAR :: Code a -> Defunc a
pattern $bFREEVAR :: Code a -> Defunc a
$mFREEVAR :: forall r a. Defunc a -> (Code a -> r) -> (Void# -> r) -> r
FREEVAR v <- NormLam (Lam.Var True v)
  where
    FREEVAR Code a
v = Lam a -> Defunc a
forall a. Lam a -> Defunc a
LAM (Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Lam.Var Bool
True Code a
v)

instance Show (Defunc a) where
  show :: Defunc a -> [Char]
show (LAM Lam a
x) = Lam a -> [Char]
forall a. Show a => a -> [Char]
show Lam a
x
  show Defunc a
BOTTOM = [Char]
"[[irrelevant]]"
  show (FREEVAR Code a
_) = [Char]
"x"
  show (OFFSET Offset a
o)  = [Char]
"offset " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Offset a -> [Char]
forall a. Show a => a -> [Char]
show Offset a
o