{-# LANGUAGE PatternSynonyms, StandaloneKindSignatures, TypeApplications, ViewPatterns #-}
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(..))
data Defunc a where
LAM :: Lam a -> Defunc a
BOTTOM :: Defunc a
OFFSET :: Offset 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 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)
_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 (OFFSET Offset 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
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