{-# LANGUAGE StandaloneKindSignatures, TypeApplications #-}
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, WQ(WQ))

import qualified Parsley.Internal.Core.Defunc as Core (Defunc(BLACK), ap, genDefunc, genDefunc1, genDefunc2)

data Defunc a where
  USER    :: Core.Defunc a -> Defunc a
  BOTTOM  :: Defunc a
  SAME    :: PositionOps o => Defunc (o -> o -> Bool)
  FREEVAR :: Code a -> Defunc a
  OFFSET  :: Code (Rep o) -> Defunc o

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) = Defunc Bool -> Defunc Bool
forall a. Defunc a -> Defunc a
USER (Code Bool -> Defunc Bool
forall a. Code a -> Defunc a
black (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 c -> Defunc c
forall a. Defunc a -> Defunc a
USER (Defunc (b -> c) -> Defunc b -> Defunc c
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
Core.ap (Defunc (a -> b -> c) -> Defunc a -> Defunc (b -> c)
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
Core.ap (Defunc (a -> b -> c) -> Defunc (a -> b -> c)
forall a. Defunc a -> Defunc a
seal Defunc (a -> b -> c)
f) (Defunc a -> Defunc a
forall a. Defunc a -> Defunc a
seal Defunc a
x)) (Defunc b -> Defunc b
forall a. Defunc a -> Defunc a
seal Defunc b
y))
  where
    seal :: Defunc a -> Core.Defunc a
    seal :: Defunc a -> Defunc a
seal (USER Defunc a
x) = Defunc a
x
    seal Defunc a
x        = Code a -> Defunc a
forall a. Code a -> Defunc a
black (Defunc a -> Code a
forall a. Defunc a -> Code a
genDefunc Defunc a
x)

black :: Code a -> Core.Defunc a
black :: Code a -> Defunc a
black = WQ a -> Defunc a
forall a. WQ a -> Defunc a
Core.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

genDefunc :: Defunc a -> Code a
genDefunc :: Defunc a -> Code a
genDefunc (USER Defunc a
x)    = Defunc a -> Code a
forall a. Defunc a -> Code a
Core.genDefunc Defunc a
x
genDefunc Defunc a
BOTTOM      = [||undefined||]
genDefunc (FREEVAR Code a
x) = Code a
x
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 (USER Defunc (a -> b)
f) Code a
qx = Defunc (a -> b) -> Code a -> Code b
forall a b. Defunc (a -> b) -> Code a -> Code b
Core.genDefunc1 Defunc (a -> b)
f 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 (USER Defunc (a -> b -> c)
f) Code a
qx Code b
qy = Defunc (a -> b -> c) -> Code a -> Code b -> Code c
forall a b c. Defunc (a -> b -> c) -> Code a -> Code b -> Code c
Core.genDefunc2 Defunc (a -> b -> c)
f Code a
qx Code b
qy
genDefunc2 Defunc (a -> b -> c)
f Code a
qx Code b
qy        = [|| $$(genDefunc f) $$qx $$qy ||]

instance Show (Defunc a) where
  show :: Defunc a -> [Char]
show (USER Defunc a
x) = Defunc a -> [Char]
forall a. Show a => a -> [Char]
show Defunc 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"