{-# LANGUAGE PatternSynonyms, StandaloneKindSignatures, TypeApplications, ViewPatterns #-}
module Parsley.Internal.Backend.Machine.Defunc (module Parsley.Internal.Backend.Machine.Defunc) where

import Data.Proxy                                (Proxy(Proxy))
import Parsley.Internal.Backend.Machine.InputOps (PositionOps(same))
import Parsley.Internal.Backend.Machine.InputRep (Rep)
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(..))

data Defunc a where
  LAM     :: Lam a -> Defunc a
  BOTTOM  :: Defunc a
  SAME    :: PositionOps o => Defunc (o -> o -> Bool)
  OFFSET  :: Code (Rep o) -> Defunc o

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

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

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))

ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c
ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c
ap2 f :: Defunc (a -> b -> c)
f@Defunc (a -> b -> c)
SAME (OFFSET Code (Rep a)
o1) (OFFSET Code (Rep b)
o2) = Lam Bool -> Defunc Bool
forall a. Lam a -> Defunc a
LAM (Bool -> Code Bool -> Lam Bool
forall a. Bool -> Code a -> Lam a
Lam.Var Bool
False (Defunc (a -> a -> Bool)
-> Code (Rep a) -> Code (Rep a) -> Code Bool
forall o.
Defunc (o -> o -> Bool)
-> Code (Rep o) -> Code (Rep o) -> Code Bool
apSame Defunc (a -> a -> Bool)
Defunc (a -> b -> c)
f Code (Rep a)
o1 Code (Rep a)
Code (Rep b)
o2))
  where
    apSame :: forall o. Defunc (o -> o -> Bool) -> Code (Rep o) -> Code (Rep o) -> Code Bool
    apSame :: Defunc (o -> o -> Bool)
-> Code (Rep o) -> Code (Rep o) -> Code Bool
apSame Defunc (o -> o -> Bool)
SAME = Proxy o -> Code (Rep o) -> Code (Rep o) -> Code Bool
forall input (rep :: TYPE (RepKind input)).
(PositionOps input, rep ~ Rep input) =>
Proxy input -> Code rep -> Code rep -> Code Bool
same (Proxy o
forall k (t :: k). Proxy t
Proxy @o)
    apSame Defunc (o -> o -> Bool)
_    = Code (Rep o) -> Code (Rep o) -> Code Bool
forall a. HasCallStack => a
undefined
ap2 Defunc (a -> b -> c)
f Defunc a
x Defunc b
y = 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) Defunc b
y

_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)

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 Defunc a
SAME        = [Char] -> Code a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot materialise the same function in the regular way"
genDefunc (OFFSET Code (Rep a)
_)  = [Char] -> Code a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot materialise an unboxed offset in the regular way"

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 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
SAME = [Char]
"same"
  show Defunc a
BOTTOM = [Char]
"[[irrelevant]]"
  show (FREEVAR Code a
_) = [Char]
"x"
  show (OFFSET Code (Rep a)
_)  = [Char]
"an offset"