{-# LANGUAGE PatternSynonyms, TypeApplications #-}
module Parsley.Internal.Core.Defunc (
Defunc(..),
pattern COMPOSE_H, pattern FLIP_H, pattern FLIP_CONST, pattern UNIT,
lamTerm, charPred
) where
import Data.Typeable (Typeable, (:~:)(Refl), eqT)
import Language.Haskell.TH.Syntax (Lift(..))
import Parsley.Internal.Common.RangeSet (fromRanges, empty, complement)
import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))
import Parsley.Internal.Core.CharPred (CharPred(..), pattern Item, pattern Specific)
import Parsley.Internal.Core.Lam (normaliseGen, Lam(..))
import qualified Parsley.Internal.Core.CharPred as CharPred (lamTerm)
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, Typeable a) => a -> Defunc a
CONS :: Defunc (a -> [a] -> [a])
CONST :: Defunc (a -> b -> a)
EMPTY :: Defunc [a]
BLACK :: WQ a -> Defunc a
RANGES :: Bool
-> [(Char, Char)]
-> Defunc (Char -> Bool)
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))
_val (RANGES Bool
True [(Char, Char)]
rngs) = \Char
c -> ((Char, Char) -> Bool) -> [(Char, Char)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (\(Char
l, Char
u) -> Char
l Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
u) [(Char, Char)]
rngs
_val (RANGES Bool
False [(Char, Char)]
rngs) = \Char
c -> ((Char, Char) -> Bool) -> [(Char, Char)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\(Char
l, Char
u) -> Char
l Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
u) [(Char, Char)]
rngs
_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 ()
lamTerm :: forall a. 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
b) | Just a :~: Bool
Refl <- (Typeable a, Typeable Bool) => Maybe (a :~: Bool)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @Bool = if a
Bool
b then Lam a
Lam Bool
T else Lam a
Lam Bool
F
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 rngs :: Defunc a
rngs@(RANGES Bool
_ [(Char, Char)]
_) = CharPred -> Lam (Char -> Bool)
CharPred.lamTerm (Defunc (Char -> Bool) -> CharPred
charPred Defunc a
Defunc (Char -> Bool)
rngs)
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)
charPred :: Defunc (Char -> Bool) -> CharPred
charPred :: Defunc (Char -> Bool) -> CharPred
charPred (EQ_H (LIFTED a
c)) = Char -> CharPred
Specific a
Char
c
charPred (RANGES Bool
False []) = CharPred
Item
charPred (RANGES Bool
True [(Char
l, Char
u)]) | Char
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
minBound, Char
u Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
maxBound = CharPred
Item
charPred (RANGES Bool
True [(Char, Char)]
cs) = RangeSet Char -> CharPred
Ranges ([(Char, Char)] -> RangeSet Char
forall a. (Enum a, Ord a) => [(a, a)] -> RangeSet a
fromRanges [(Char, Char)]
cs)
charPred (RANGES Bool
False [(Char, Char)]
cs) = RangeSet Char -> CharPred
Ranges (RangeSet Char -> RangeSet Char
forall a. (Bounded a, Enum a, Eq a) => RangeSet a -> RangeSet a
complement ([(Char, Char)] -> RangeSet Char
forall a. (Enum a, Ord a) => [(a, a)] -> RangeSet a
fromRanges [(Char, Char)]
cs))
charPred (APP_H Defunc (a -> Char -> Bool)
CONST (LIFTED a
True)) = CharPred
Item
charPred (APP_H Defunc (a -> Char -> Bool)
CONST (LIFTED a
False)) = RangeSet Char -> CharPred
Ranges RangeSet Char
forall a. RangeSet a
empty
charPred Defunc (Char -> Bool)
p = (Char -> Bool) -> Lam (Char -> Bool) -> CharPred
UserPred (Defunc (Char -> Bool) -> Char -> Bool
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc (Char -> Bool)
p) (Defunc (Char -> Bool) -> Lam (Char -> Bool)
forall a. Defunc a -> Lam a
lamTerm Defunc (Char -> Bool)
p)
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, Typeable a) => a -> Defunc a
LIFTED Bool
True
defuncTerm Lam a
F = Bool -> Defunc Bool
forall a. (Show a, Lift a, Typeable 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 p :: Defunc a
p@RANGES{} = CharPred -> String
forall a. Show a => a -> String
show (Defunc (Char -> Bool) -> CharPred
charPred Defunc a
Defunc (Char -> Bool)
p)
show Defunc a
_ = String
"x"