{-# LANGUAGE PatternSynonyms, TypeApplications #-}
module Parsley.Internal.Core.Defunc (
Defunc(..),
pattern COMPOSE_H, pattern FLIP_H, pattern FLIP_CONST, pattern UNIT,
lamTerm, lamTermBool
) where
import Language.Haskell.TH.Syntax (Lift(..))
import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))
import Parsley.Internal.Core.Lam (normaliseGen, Lam(..))
data Defunc a where
ID :: Defunc (a -> a)
COMPOSE :: Defunc ((b -> c) -> (a -> b) -> (a -> c))
FLIP :: Defunc ((a -> b -> c) -> b -> a -> c)
APP_H :: Defunc (a -> b) -> Defunc a -> Defunc b
EQ_H :: Eq a => Defunc a -> Defunc (a -> Bool)
LIFTED :: (Show a, Lift a) => a -> Defunc a
CONS :: Defunc (a -> [a] -> [a])
CONST :: Defunc (a -> b -> a)
EMPTY :: Defunc [a]
BLACK :: WQ a -> Defunc a
IF_S :: Defunc Bool -> Defunc a -> Defunc a -> Defunc a
LAM_S :: (Defunc a -> Defunc b) -> Defunc (a -> b)
LET_S :: Defunc a -> (Defunc a -> Defunc b) -> Defunc b
instance Quapplicative Defunc where
makeQ :: a -> Code a -> Defunc a
makeQ a
x Code a
qx = WQ a -> Defunc a
forall a. WQ a -> Defunc a
BLACK (a -> Code a -> WQ a
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
x Code a
qx)
_val :: Defunc a -> a
_val Defunc a
ID = a
forall a. a -> a
id
_val Defunc a
COMPOSE = a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
_val Defunc a
FLIP = a
forall a b c. (a -> b -> c) -> b -> a -> c
flip
_val (APP_H Defunc (a -> a)
f Defunc a
x) = Defunc (a -> a) -> a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc (a -> a)
f (Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x)
_val (LIFTED a
x) = a
x
_val (EQ_H Defunc a
x) = (Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)
_val Defunc a
CONS = (:)
_val Defunc a
CONST = a
forall a b. a -> b -> a
const
_val Defunc a
EMPTY = []
_val (BLACK WQ a
f) = WQ a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val WQ a
f
_val (IF_S Defunc Bool
c Defunc a
t Defunc a
e) = if Defunc Bool -> Bool
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc Bool
c then Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
t else Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
e
_val (LAM_S Defunc a -> Defunc b
f) = \a
x -> Defunc b -> b
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val (Defunc a -> Defunc b
f (a -> Code a -> Defunc a
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
x Code a
forall a. HasCallStack => a
undefined))
_val (LET_S Defunc a
x Defunc a -> Defunc a
f) = let y :: a
y = Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x in Defunc a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val (Defunc a -> Defunc a
f (a -> Code a -> Defunc a
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
y Code a
forall a. HasCallStack => a
undefined))
_code :: Defunc a -> Code a
_code = Lam a -> Code a
forall a. Lam a -> Code a
normaliseGen (Lam a -> Code a) -> (Defunc a -> Lam a) -> Defunc a -> Code a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm
>*< :: Defunc (a -> b) -> Defunc a -> Defunc b
(>*<) = Defunc (a -> b) -> Defunc a -> Defunc b
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
APP_H
pattern COMPOSE_H :: () => ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) => Defunc x -> Defunc y -> Defunc z
pattern $bCOMPOSE_H :: Defunc x -> Defunc y -> Defunc z
$mCOMPOSE_H :: forall r z.
Defunc z
-> (forall x y b c a.
((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
Defunc x -> Defunc y -> r)
-> (Void# -> r)
-> r
COMPOSE_H f g = APP_H (APP_H COMPOSE f) g
pattern FLIP_H :: () => ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) => Defunc x -> Defunc y
pattern $bFLIP_H :: Defunc x -> Defunc y
$mFLIP_H :: forall r y.
Defunc y
-> (forall x a b c.
((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
Defunc x -> r)
-> (Void# -> r)
-> r
FLIP_H f = APP_H FLIP f
pattern FLIP_CONST :: () => (x ~ (a -> b -> b)) => Defunc x
pattern $bFLIP_CONST :: Defunc x
$mFLIP_CONST :: forall r x.
Defunc x
-> (forall a b. (x ~ (a -> b -> b)) => r) -> (Void# -> r) -> r
FLIP_CONST = FLIP_H CONST
pattern UNIT :: Defunc ()
pattern $bUNIT :: Defunc ()
$mUNIT :: forall r. Defunc () -> (Void# -> r) -> (Void# -> r) -> r
UNIT = LIFTED ()
lamTermBool :: Defunc (a -> Bool) -> Lam (a -> Bool)
lamTermBool :: Defunc (a -> Bool) -> Lam (a -> Bool)
lamTermBool (APP_H Defunc (a -> a -> Bool)
CONST (LIFTED a
True)) = (Lam a -> Lam Bool) -> Lam (a -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam Bool -> Lam a -> Lam Bool
forall a b. a -> b -> a
const Lam Bool
T)
lamTermBool (APP_H Defunc (a -> a -> Bool)
CONST (LIFTED a
False)) = (Lam a -> Lam Bool) -> Lam (a -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam Bool -> Lam a -> Lam Bool
forall a b. a -> b -> a
const Lam Bool
F)
lamTermBool Defunc (a -> Bool)
f = Defunc (a -> Bool) -> Lam (a -> Bool)
forall a. Defunc a -> Lam a
lamTerm Defunc (a -> Bool)
f
lamTerm :: Defunc a -> Lam a
lamTerm :: Defunc a -> Lam a
lamTerm Defunc a
ID = (Lam a -> Lam a) -> Lam (a -> a)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs Lam a -> Lam a
forall a. a -> a
id
lamTerm Defunc a
COMPOSE = (Lam (b -> c) -> Lam ((a -> b) -> a -> c))
-> Lam ((b -> c) -> (a -> b) -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam (b -> c)
f -> (Lam (a -> b) -> Lam (a -> c)) -> Lam ((a -> b) -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam (a -> b)
g -> (Lam a -> Lam c) -> Lam (a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam (b -> c) -> Lam b -> Lam c
forall a b. Lam (a -> b) -> Lam a -> Lam b
App Lam (b -> c)
f (Lam b -> Lam c) -> (Lam a -> Lam b) -> Lam a -> Lam c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam (a -> b) -> Lam a -> Lam b
forall a b. Lam (a -> b) -> Lam a -> Lam b
App Lam (a -> b)
g)))
lamTerm Defunc a
FLIP = (Lam (a -> b -> c) -> Lam (b -> a -> c))
-> Lam ((a -> b -> c) -> b -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam (a -> b -> c)
f -> (Lam b -> Lam (a -> c)) -> Lam (b -> a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam b
x -> (Lam a -> Lam c) -> Lam (a -> c)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (\Lam a
y -> Lam (b -> c) -> Lam b -> Lam c
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (a -> b -> c) -> Lam a -> Lam (b -> c)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App Lam (a -> b -> c)
f Lam a
y) Lam b
x)))
lamTerm (APP_H Defunc (a -> a)
f Defunc a
x) = Lam (a -> a) -> Lam a -> Lam a
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Defunc (a -> a) -> Lam (a -> a)
forall a. Defunc a -> Lam a
lamTerm Defunc (a -> a)
f) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
x)
lamTerm (LIFTED a
x) = Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Var Bool
True [||x||]
lamTerm (EQ_H Defunc a
x) = (Lam a -> Lam Bool) -> Lam (a -> Bool)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs (Lam (a -> Bool) -> Lam a -> Lam Bool
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Lam (a -> a -> Bool) -> Lam a -> Lam (a -> Bool)
forall a b. Lam (a -> b) -> Lam a -> Lam b
App (Bool -> Code (a -> a -> Bool) -> Lam (a -> a -> Bool)
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(==)||]) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
x)))
lamTerm Defunc a
CONS = Bool -> Code (a -> [a] -> [a]) -> Lam (a -> [a] -> [a])
forall a. Bool -> Code a -> Lam a
Var Bool
True [||(:)||]
lamTerm Defunc a
EMPTY = Bool -> Code [a] -> Lam [a]
forall a. Bool -> Code a -> Lam a
Var Bool
True [||[]||]
lamTerm Defunc a
CONST = (Lam a -> Lam (b -> a)) -> Lam (a -> b -> a)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs ((Lam b -> Lam a) -> Lam (b -> a)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs ((Lam b -> Lam a) -> Lam (b -> a))
-> (Lam a -> Lam b -> Lam a) -> Lam a -> Lam (b -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Lam b -> Lam a
forall a b. a -> b -> a
const)
lamTerm (BLACK WQ a
x) = Bool -> Code a -> Lam a
forall a. Bool -> Code a -> Lam a
Var Bool
False (WQ a -> Code a
forall (q :: Type -> Type) a. Quapplicative q => q a -> Code a
_code WQ a
x)
lamTerm (LAM_S Defunc a -> Defunc b
f) = (Lam a -> Lam b) -> Lam (a -> b)
forall a a. (Lam a -> Lam a) -> Lam (a -> a)
Abs ((Defunc a -> Defunc b) -> Lam a -> Lam b
forall a b. (Defunc a -> Defunc b) -> Lam a -> Lam b
adaptLam Defunc a -> Defunc b
f)
lamTerm (IF_S Defunc Bool
c Defunc a
t Defunc a
e) = Lam Bool -> Lam a -> Lam a -> Lam a
forall a. Lam Bool -> Lam a -> Lam a -> Lam a
If (Defunc Bool -> Lam Bool
forall a. Defunc a -> Lam a
lamTerm Defunc Bool
c) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
t) (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
e)
lamTerm (LET_S Defunc a
x Defunc a -> Defunc a
f) = Lam a -> (Lam a -> Lam a) -> Lam a
forall a b. Lam a -> (Lam a -> Lam b) -> Lam b
Let (Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm Defunc a
x) ((Defunc a -> Defunc a) -> Lam a -> Lam a
forall a b. (Defunc a -> Defunc b) -> Lam a -> Lam b
adaptLam Defunc a -> Defunc a
f)
adaptLam :: (Defunc a -> Defunc b) -> (Lam a -> Lam b)
adaptLam :: (Defunc a -> Defunc b) -> Lam a -> Lam b
adaptLam Defunc a -> Defunc b
f = Defunc b -> Lam b
forall a. Defunc a -> Lam a
lamTerm (Defunc b -> Lam b) -> (Lam a -> Defunc b) -> Lam a -> Lam b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Defunc b
f (Defunc a -> Defunc b) -> (Lam a -> Defunc a) -> Lam a -> Defunc b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm
where
defuncTerm :: Lam a -> Defunc a
defuncTerm :: Lam a -> Defunc a
defuncTerm (Abs Lam a -> Lam b
f) = (Defunc a -> Defunc b) -> Defunc (a -> b)
forall a a. (Defunc a -> Defunc a) -> Defunc (a -> a)
LAM_S (Lam b -> Defunc b
forall a. Lam a -> Defunc a
defuncTerm (Lam b -> Defunc b) -> (Defunc a -> Lam b) -> Defunc a -> Defunc b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Lam b
f (Lam a -> Lam b) -> (Defunc a -> Lam a) -> Defunc a -> Lam b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm)
defuncTerm (App Lam (a -> a)
f Lam a
x) = Defunc (a -> a) -> Defunc a -> Defunc a
forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
APP_H (Lam (a -> a) -> Defunc (a -> a)
forall a. Lam a -> Defunc a
defuncTerm Lam (a -> a)
f) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
x)
defuncTerm (Var Bool
_ Code a
x) = Code a -> Defunc a
forall a. Code a -> Defunc a
unsafeBLACK Code a
x
defuncTerm (If Lam Bool
c Lam a
t Lam a
e) = Defunc Bool -> Defunc a -> Defunc a -> Defunc a
forall a. Defunc Bool -> Defunc a -> Defunc a -> Defunc a
IF_S (Lam Bool -> Defunc Bool
forall a. Lam a -> Defunc a
defuncTerm Lam Bool
c) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
t) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
e)
defuncTerm (Let Lam a
x Lam a -> Lam a
f) = Defunc a -> (Defunc a -> Defunc a) -> Defunc a
forall a b. Defunc a -> (Defunc a -> Defunc b) -> Defunc b
LET_S (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm Lam a
x) (Lam a -> Defunc a
forall a. Lam a -> Defunc a
defuncTerm (Lam a -> Defunc a) -> (Defunc a -> Lam a) -> Defunc a -> Defunc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a -> Lam a
f (Lam a -> Lam a) -> (Defunc a -> Lam a) -> Defunc a -> Lam a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Lam a
forall a. Defunc a -> Lam a
lamTerm)
defuncTerm Lam a
T = Bool -> Defunc Bool
forall a. (Show a, Lift a) => a -> Defunc a
LIFTED Bool
True
defuncTerm Lam a
F = Bool -> Defunc Bool
forall a. (Show a, Lift a) => a -> Defunc a
LIFTED Bool
False
unsafeBLACK :: Code a -> Defunc a
unsafeBLACK :: Code a -> Defunc a
unsafeBLACK = WQ a -> Defunc a
forall a. WQ a -> Defunc a
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
instance Show (Defunc a) where
show :: Defunc a -> String
show Defunc a
COMPOSE = String
"(.)"
show Defunc a
FLIP = String
"flip"
show (FLIP_H Defunc x
f) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(flip ", Defunc x -> String
forall a. Show a => a -> String
show Defunc x
f, String
")"]
show (COMPOSE_H Defunc x
f Defunc y
g) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(", Defunc x -> String
forall a. Show a => a -> String
show Defunc x
f, String
" . ", Defunc y -> String
forall a. Show a => a -> String
show Defunc y
g, String
")"]
show (APP_H Defunc (a -> a)
f Defunc a
x) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(", Defunc (a -> a) -> String
forall a. Show a => a -> String
show Defunc (a -> a)
f, String
" ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
x, String
")"]
show (LIFTED a
x) = a -> String
forall a. Show a => a -> String
show a
x
show (EQ_H Defunc a
x) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(== ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
x, String
")"]
show Defunc a
ID = String
"id"
show Defunc a
EMPTY = String
"[]"
show Defunc a
CONS = String
"(:)"
show Defunc a
CONST = String
"const"
show (IF_S Defunc Bool
c Defunc a
b Defunc a
e) = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(if ", Defunc Bool -> String
forall a. Show a => a -> String
show Defunc Bool
c, String
" then ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
b, String
" else ", Defunc a -> String
forall a. Show a => a -> String
show Defunc a
e, String
")"]
show (LAM_S Defunc a -> Defunc b
_) = String
"f"
show Defunc a
_ = String
"x"