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