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