{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- | 'Syntactic' instances for functions and tuples

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