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

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 = Lam c -> Defunc c
forall a. Lam a -> Defunc a
LAM (Lam (b -> c) -> Lam b -> Lam c
forall a b. Lam (a -> b) -> Lam a -> Lam b
Lam.App (Lam (a -> b -> c) -> Lam a -> Lam (b -> c)
forall a b. Lam (a -> b) -> Lam a -> Lam b
Lam.App (Defunc (a -> b -> c) -> Lam (a -> b -> c)
forall a. Defunc a -> Lam a
seal Defunc (a -> b -> c)
f) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
seal Defunc a
x)) (Defunc b -> Lam b
forall a. Defunc a -> Lam a
seal Defunc b
y))
  where
    seal :: Defunc a -> Lam a
    seal :: Defunc a -> Lam a
seal (LAM Lam a
x) = Lam a
x
    seal 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"

genDefunc1 :: Defunc (a -> b) -> Code a -> Code b
genDefunc1 :: Defunc (a -> b) -> Code a -> Code b
genDefunc1 (LAM Lam (a -> b)
f) Code a
qx = Lam b -> Code b
forall a. Lam a -> Code a
normaliseGen (Lam (a -> b) -> Lam a -> Lam b
forall a b. Lam (a -> b) -> Lam a -> Lam b
Lam.App Lam (a -> b)
f (Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Lam.Var Bool
True Code a
qx))
genDefunc1 Defunc (a -> b)
f Code a
qx       = [|| $$(genDefunc f) $$qx ||]

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"