{-# LANGUAGE ImplicitParams, 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 Data.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)
import qualified Parsley.Internal.Opt as Opt (Flags(termNormalisation), none)
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 :: forall a. a -> Code a -> Defunc a
makeQ a
x Code a
qx = forall a. WQ a -> Defunc a
BLACK (forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
x Code a
qx)
_val :: forall a. Defunc a -> a
_val Defunc a
ID = forall a. a -> a
id
_val Defunc a
COMPOSE = forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
_val Defunc a
FLIP = forall a b c. (a -> b -> c) -> b -> a -> c
flip
_val (APP_H Defunc (a -> a)
f Defunc a
x) = forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc (a -> a)
f (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) = (forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x forall a. Eq a => a -> a -> Bool
==)
_val Defunc a
CONS = (:)
_val Defunc a
CONST = forall a b. a -> b -> a
const
_val Defunc a
EMPTY = []
_val (BLACK WQ a
f) = 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 forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc Bool
c then forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
t else forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
e
_val (LAM_S Defunc a -> Defunc b
f) = \a
x -> forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val (Defunc a -> Defunc b
f (forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
x forall a. HasCallStack => a
undefined))
_val (LET_S Defunc a
x Defunc a -> Defunc a
f) = let y :: a
y = forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc a
x in forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val (Defunc a -> Defunc a
f (forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ a
y forall a. HasCallStack => a
undefined))
_val (RANGES Bool
True [(Char, Char)]
rngs) = \Char
c -> forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (\(Char
l, Char
u) -> Char
l forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
|| Char
c forall a. Ord a => a -> a -> Bool
<= Char
u) [(Char, Char)]
rngs
_val (RANGES Bool
False [(Char, Char)]
rngs) = \Char
c -> forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\(Char
l, Char
u) -> Char
l forall a. Ord a => a -> a -> Bool
>= Char
c Bool -> Bool -> Bool
|| Char
c forall a. Ord a => a -> a -> Bool
>= Char
u) [(Char, Char)]
rngs
_code :: forall a. Defunc a -> Code a
_code = let ?flags = Flags
Opt.none { termNormalisation :: Bool
Opt.termNormalisation = Bool
True } in forall a. (?flags::Flags) => Lam a -> Code a
normaliseGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Defunc a -> Lam a
lamTerm
>*< :: forall a 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 :: forall z x y b c a.
((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
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)
-> ((# #) -> 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 :: forall y x a b c.
((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
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)
-> ((# #) -> r)
-> r
FLIP_H f = APP_H FLIP f
pattern FLIP_CONST :: () => (x ~ (a -> b -> b)) => Defunc x
pattern $bFLIP_CONST :: forall x a b. (x ~ (a -> b -> b)) => Defunc x
$mFLIP_CONST :: forall {r} {x}.
Defunc x
-> (forall {a} {b}. (x ~ (a -> b -> b)) => r) -> ((# #) -> r) -> r
FLIP_CONST = FLIP_H CONST
pattern UNIT :: Defunc ()
pattern $bUNIT :: Defunc ()
$mUNIT :: forall {r}. Defunc () -> ((# #) -> r) -> ((# #) -> r) -> r
UNIT = LIFTED ()
lamTerm :: forall a. Defunc a -> Lam a
lamTerm :: forall a. Defunc a -> Lam a
lamTerm Defunc a
ID = forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs forall a. a -> a
id
lamTerm Defunc a
COMPOSE = forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (\Lam (b -> c)
f -> forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (\Lam (a -> b)
g -> forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (forall a1 a. Lam (a1 -> a) -> Lam a1 -> Lam a
App Lam (b -> c)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a1 a. Lam (a1 -> a) -> Lam a1 -> Lam a
App Lam (a -> b)
g)))
lamTerm Defunc a
FLIP = forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (\Lam (a -> b -> c)
f -> forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (\Lam b
x -> forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (\Lam a
y -> forall a1 a. Lam (a1 -> a) -> Lam a1 -> Lam a
App (forall a1 a. Lam (a1 -> a) -> Lam a1 -> Lam a
App Lam (a -> b -> c)
f Lam a
y) Lam b
x)))
lamTerm (APP_H Defunc (a -> a)
f Defunc a
x) = forall a1 a. Lam (a1 -> a) -> Lam a1 -> Lam a
App (forall a. Defunc a -> Lam a
lamTerm Defunc (a -> a)
f) (forall a. Defunc a -> Lam a
lamTerm Defunc a
x)
lamTerm (LIFTED a
b) | Just a :~: Bool
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @Bool = if a
b then Lam Bool
T else Lam Bool
F
lamTerm (LIFTED a
x) = forall a. Bool -> Code a -> Lam a
Var Bool
True [||x||]
lamTerm (EQ_H Defunc a
x) = forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (forall a1 a. Lam (a1 -> a) -> Lam a1 -> Lam a
App (forall a1 a. Lam (a1 -> a) -> Lam a1 -> Lam a
App (forall a. Bool -> Code a -> Lam a
Var Bool
True [||(==)||]) (forall a. Defunc a -> Lam a
lamTerm Defunc a
x)))
lamTerm Defunc a
CONS = forall a. Bool -> Code a -> Lam a
Var Bool
True [||(:)||]
lamTerm Defunc a
EMPTY = forall a. Bool -> Code a -> Lam a
Var Bool
True [||[]||]
lamTerm Defunc a
CONST = forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const)
lamTerm (BLACK WQ a
x) = forall a. Bool -> Code a -> Lam a
Var Bool
False (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
rngs)
lamTerm (LAM_S Defunc a -> Defunc b
f) = forall a1 b. (Lam a1 -> Lam b) -> Lam (a1 -> b)
Abs (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) = forall a. Lam Bool -> Lam a -> Lam a -> Lam a
If (forall a. Defunc a -> Lam a
lamTerm Defunc Bool
c) (forall a. Defunc a -> Lam a
lamTerm Defunc a
t) (forall a. Defunc a -> Lam a
lamTerm Defunc a
e)
lamTerm (LET_S Defunc a
x Defunc a -> Defunc a
f) = forall a1 a. Lam a1 -> (Lam a1 -> Lam a) -> Lam a
Let (forall a. Defunc a -> Lam a
lamTerm Defunc a
x) (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
c
charPred (RANGES Bool
False []) = CharPred
Item
charPred (RANGES Bool
True [(Char
l, Char
u)]) | Char
l forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound, Char
u forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound = CharPred
Item
charPred (RANGES Bool
True [(Char, Char)]
cs) = RangeSet Char -> CharPred
Ranges (forall a. Enum a => [(a, a)] -> RangeSet a
fromRanges [(Char, Char)]
cs)
charPred (RANGES Bool
False [(Char, Char)]
cs) = RangeSet Char -> CharPred
Ranges (forall a. (Bounded a, Enum a) => RangeSet a -> RangeSet a
complement (forall a. Enum a => [(a, a)] -> RangeSet a
fromRanges [(Char, Char)]
cs))
charPred (APP_H Defunc (a -> Char -> Bool)
CONST (LIFTED a
Bool
True)) = CharPred
Item
charPred (APP_H Defunc (a -> Char -> Bool)
CONST (LIFTED a
Bool
False)) = RangeSet Char -> CharPred
Ranges forall a. RangeSet a
empty
charPred Defunc (Char -> Bool)
p = (Char -> Bool) -> Lam (Char -> Bool) -> CharPred
UserPred (forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val Defunc (Char -> Bool)
p) (forall a. Defunc a -> Lam a
lamTerm Defunc (Char -> Bool)
p)
adaptLam :: (Defunc a -> Defunc b) -> (Lam a -> Lam b)
adaptLam :: forall a b. (Defunc a -> Defunc b) -> Lam a -> Lam b
adaptLam Defunc a -> Defunc b
f = forall a. Defunc a -> Lam a
lamTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defunc a -> Defunc b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lam a -> Defunc a
defuncTerm
where
defuncTerm :: Lam a -> Defunc a
defuncTerm :: forall a. Lam a -> Defunc a
defuncTerm (Abs Lam a1 -> Lam b
f) = forall a b. (Defunc a -> Defunc b) -> Defunc (a -> b)
LAM_S (forall a. Lam a -> Defunc a
defuncTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a1 -> Lam b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Defunc a -> Lam a
lamTerm)
defuncTerm (App Lam (a1 -> a)
f Lam a1
x) = forall a b. Defunc (a -> b) -> Defunc a -> Defunc b
APP_H (forall a. Lam a -> Defunc a
defuncTerm Lam (a1 -> a)
f) (forall a. Lam a -> Defunc a
defuncTerm Lam a1
x)
defuncTerm (Var Bool
_ Code a
x) = forall a. Code a -> Defunc a
unsafeBLACK Code a
x
defuncTerm (If Lam Bool
c Lam a
t Lam a
e) = forall a. Defunc Bool -> Defunc a -> Defunc a -> Defunc a
IF_S (forall a. Lam a -> Defunc a
defuncTerm Lam Bool
c) (forall a. Lam a -> Defunc a
defuncTerm Lam a
t) (forall a. Lam a -> Defunc a
defuncTerm Lam a
e)
defuncTerm (Let Lam a1
x Lam a1 -> Lam a
f) = forall a b. Defunc a -> (Defunc a -> Defunc b) -> Defunc b
LET_S (forall a. Lam a -> Defunc a
defuncTerm Lam a1
x) (forall a. Lam a -> Defunc a
defuncTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lam a1 -> Lam a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Defunc a -> Lam a
lamTerm)
defuncTerm Lam a
T = forall a. (Show a, Lift a, Typeable a) => a -> Defunc a
LIFTED Bool
True
defuncTerm Lam a
F = forall a. (Show a, Lift a, Typeable a) => a -> Defunc a
LIFTED Bool
False
unsafeBLACK :: Code a -> Defunc a
unsafeBLACK :: forall a. Code a -> Defunc a
unsafeBLACK = forall a. WQ a -> Defunc a
BLACK forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Code a -> WQ a
WQ 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) = forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(flip ", forall a. Show a => a -> String
show Defunc x
f, String
")"]
show (COMPOSE_H Defunc x
f Defunc y
g) = forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(", forall a. Show a => a -> String
show Defunc x
f, String
" . ", forall a. Show a => a -> String
show Defunc y
g, String
")"]
show (APP_H Defunc (a -> a)
f Defunc a
x) = forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(", forall a. Show a => a -> String
show Defunc (a -> a)
f, String
" ", forall a. Show a => a -> String
show Defunc a
x, String
")"]
show (LIFTED a
x) = forall a. Show a => a -> String
show a
x
show (EQ_H Defunc a
x) = forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [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) = forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [String
"(if ", forall a. Show a => a -> String
show Defunc Bool
c, String
" then ", forall a. Show a => a -> String
show Defunc a
b, String
" else ", 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{} = forall a. Show a => a -> String
show (Defunc (Char -> Bool) -> CharPred
charPred Defunc a
p)
show Defunc a
_ = String
"x"