{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Feldspar.Sugar where
import qualified Language.Haskell.TH as TH
import Language.Syntactic
import Language.Syntactic.TH
import Language.Syntactic.Functional
import Language.Syntactic.Functional.Tuple
import Language.Syntactic.Functional.Tuple.TH
import Feldspar.Representation
instance (Syntax a, Syntactic b, Domain b ~ FeldDomain) => Syntactic (a -> b)
where
type Domain (a -> b) = FeldDomain
type Internal (a -> b) = Internal a -> Internal b
desugar :: (a -> b) -> ASTF (Domain (a -> b)) (Internal (a -> b))
desugar a -> b
f = (Name -> (:&:) FeldConstructs TypeRepFun (Full (Internal a)))
-> (Name
-> ASTF FeldDomain (Internal b)
-> ASTF FeldDomain (Internal a -> Internal b))
-> (ASTF FeldDomain (Internal a) -> ASTF FeldDomain (Internal b))
-> ASTF FeldDomain (Internal a -> Internal b)
forall (sym :: * -> *) a b.
Project BindingT sym =>
(Name -> sym (Full a))
-> (Name -> ASTF sym b -> ASTF sym (a -> b))
-> (ASTF sym a -> ASTF sym b)
-> ASTF sym (a -> b)
lamT_template Name -> (:&:) FeldConstructs TypeRepFun (Full (Internal a))
forall (expr :: * -> *) a.
(BindingT :<: expr, Type a) =>
Name -> (:&:) expr TypeRepFun (Full a)
varSym Name
-> ASTF FeldDomain (Internal b)
-> ASTF FeldDomain (Internal a -> Internal b)
forall (expr :: * -> *) a a.
(BindingT :<: expr, Type a) =>
Name
-> AST (expr :&: TypeRepFun) (Full a)
-> AST (expr :&: TypeRepFun) (Full (a -> a))
lamSym (b -> ASTF FeldDomain (Internal b)
forall a. Syntactic a => a -> ASTF (Domain a) (Internal a)
desugar (b -> ASTF FeldDomain (Internal b))
-> (ASTF FeldDomain (Internal a) -> b)
-> ASTF FeldDomain (Internal a)
-> ASTF FeldDomain (Internal b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> b)
-> (ASTF FeldDomain (Internal a) -> a)
-> ASTF FeldDomain (Internal a)
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF FeldDomain (Internal a) -> a
forall a. Syntactic a => ASTF (Domain a) (Internal a) -> a
sugar)
where
varSym :: Name -> (:&:) expr TypeRepFun (Full a)
varSym Name
v = BindingT (Full a) -> expr (Full a)
forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj (Name -> BindingT (Full a)
forall a. Typeable a => Name -> BindingT (Full a)
VarT Name
v) expr (Full a)
-> TypeRepFun (DenResult (Full a))
-> (:&:) expr TypeRepFun (Full a)
forall (expr :: * -> *) sig (info :: * -> *).
expr sig -> info (DenResult sig) -> (:&:) expr info sig
:&: TypeRep a -> TypeRepFun a
forall a. TypeRep a -> TypeRepFun a
ValT TypeRep a
forall a. Type a => TypeRep a
typeRep
lamSym :: Name
-> AST (expr :&: TypeRepFun) (Full a)
-> AST (expr :&: TypeRepFun) (Full (a -> a))
lamSym Name
v AST (expr :&: TypeRepFun) (Full a)
b = (:&:) expr TypeRepFun (a :-> Full (a -> a))
-> AST (expr :&: TypeRepFun) (a :-> Full (a -> a))
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (BindingT (a :-> Full (a -> a)) -> expr (a :-> Full (a -> a))
forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj (Name -> BindingT (a :-> Full (a -> a))
forall a b. Typeable a => Name -> BindingT (b :-> Full (a -> b))
LamT Name
v) expr (a :-> Full (a -> a))
-> TypeRepFun (DenResult (a :-> Full (a -> a)))
-> (:&:) expr TypeRepFun (a :-> Full (a -> a))
forall (expr :: * -> *) sig (info :: * -> *).
expr sig -> info (DenResult sig) -> (:&:) expr info sig
:&: TypeRep a -> TypeRepFun a -> TypeRepFun (a -> a)
forall a b. TypeRep a -> TypeRepFun b -> TypeRepFun (a -> b)
FunT TypeRep a
forall a. Type a => TypeRep a
typeRep (AST (expr :&: TypeRepFun) (Full a)
-> TypeRepFun (DenResult (Full a))
forall (sym :: * -> *) (info :: * -> *) sig.
AST (sym :&: info) sig -> info (DenResult sig)
getDecor AST (expr :&: TypeRepFun) (Full a)
b)) AST (expr :&: TypeRepFun) (a :-> Full (a -> a))
-> AST (expr :&: TypeRepFun) (Full a)
-> AST (expr :&: TypeRepFun) (Full (a -> a))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST (expr :&: TypeRepFun) (Full a)
b
sugar :: ASTF (Domain (a -> b)) (Internal (a -> b)) -> a -> b
sugar = [Char] -> ASTF FeldDomain (Internal a -> Internal b) -> a -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"sugar not implemented for (a -> b)"
instance (Syntax a, Syntax b) => Syntactic (a,b)
where
type Domain (a,b) = FeldDomain
type Internal (a,b) = (Internal a, Internal b)
desugar :: (a, b) -> ASTF (Domain (a, b)) (Internal (a, b))
desugar (a
a,b
b) = Tuple
(Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> AST FeldDomain (Full (Internal a))
-> AST FeldDomain (Full (Internal b))
-> AST FeldDomain (Full (Internal a, Internal b))
forall sig fi f (sub :: * -> *).
(Signature sig, fi ~ SmartFun FeldDomain sig, sig ~ SmartSig fi,
FeldDomain ~ SmartSym fi, SyntacticN f fi, sub :<: FeldConstructs,
Type (DenResult sig)) =>
sub sig -> f
sugarSymFeld Tuple
(Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
forall a1 b. Tuple (a1 :-> (b :-> Full (a1, b)))
Pair (a -> ASTF (Domain a) (Internal a)
forall a. Syntactic a => a -> ASTF (Domain a) (Internal a)
desugar a
a) (b -> ASTF (Domain b) (Internal b)
forall a. Syntactic a => a -> ASTF (Domain a) (Internal a)
desugar b
b)
sugar :: ASTF (Domain (a, b)) (Internal (a, b)) -> (a, b)
sugar ASTF (Domain (a, b)) (Internal (a, b))
ab = (Tuple ((Internal a, Internal b) :-> Full (Internal a))
-> AST FeldDomain (Full (Internal a, Internal b)) -> a
forall sig fi f (sub :: * -> *).
(Signature sig, fi ~ SmartFun FeldDomain sig, sig ~ SmartSig fi,
FeldDomain ~ SmartSym fi, SyntacticN f fi, sub :<: FeldConstructs,
Type (DenResult sig)) =>
sub sig -> f
sugarSymFeld Tuple ((Internal a, Internal b) :-> Full (Internal a))
forall a1 b. Tuple ((a1, b) :-> Full a1)
Fst AST FeldDomain (Full (Internal a, Internal b))
ASTF (Domain (a, b)) (Internal (a, b))
ab, Tuple ((Internal a, Internal b) :-> Full (Internal b))
-> AST FeldDomain (Full (Internal a, Internal b)) -> b
forall sig fi f (sub :: * -> *).
(Signature sig, fi ~ SmartFun FeldDomain sig, sig ~ SmartSig fi,
FeldDomain ~ SmartSym fi, SyntacticN f fi, sub :<: FeldConstructs,
Type (DenResult sig)) =>
sub sig -> f
sugarSymFeld Tuple ((Internal a, Internal b) :-> Full (Internal b))
forall a1 b. Tuple ((a1, b) :-> Full b)
Snd AST FeldDomain (Full (Internal a, Internal b))
ASTF (Domain (a, b)) (Internal (a, b))
ab)
deriveSyntacticForTuples
(return . classPred ''Type TH.ConT . return)
(\sym -> foldl TH.AppT (TH.ConT ''(:&:)) [sym, TH.ConT ''TypeRepFun])
[foldl TH.AppT TH.EqualityT
[TH.VarT (TH.mkName "sym"), TH.ConT ''FeldConstructs]
]
15