packages feed

syntactic 1.17 → 2.0

raw patch · 77 files changed

+3072/−8726 lines, 77 filesdep +criteriondep +safedep +taggeddep −arraydep −bytestringdep −ghc-primdep ~QuickCheckdep ~basedep ~tree-view

Dependencies added: criterion, safe, tagged

Dependencies removed: array, bytestring, ghc-prim, transformers, tuple

Dependency ranges changed: QuickCheck, base, tree-view

Files

CONTRIBUTORS view
@@ -3,5 +3,3 @@   * Anders Persson   * Daniel Schoepe   * Dmytro Lypai-  * Johan Ankner-  * Peter Jonsson
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2011, Emil Axelsson+Copyright (c) 2011-2014, Emil Axelsson  All rights reserved.
+ benchmarks/JoiningTypes.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE TemplateHaskell #-}++module JoiningTypes (main) where++import Criterion.Main+import Criterion.Config+import Data.Monoid+import Data.Syntactic+import Data.Syntactic.Functional++-- Normal DSL, not joined types.+data Expr1 t where+  EI    :: Int  -> Expr1 (Full Int)+  EB    :: Bool -> Expr1 (Full Bool)+  EAdd  :: Expr1 (Int :-> Int :-> Full Int)+  EEq   :: (Eq t) => Expr1 (t   :-> t   :-> Full Bool)+  EIf   :: Expr1 (Bool :-> a :-> a :-> Full a)++type Expr1' a = AST Expr1 (Full a)++int  :: Int -> Expr1' Int+int = Sym . EI++bool :: Bool -> Expr1' Bool+bool = Sym . EB++add  :: Expr1' Int -> Expr1' Int -> Expr1' Int+add a b = Sym EAdd :$ a :$ b++eq   :: (Eq a) => Expr1' a -> Expr1' a -> Expr1' Bool+eq a b = Sym EEq :$ a :$ b++if'  :: Expr1' Bool -> Expr1' a -> Expr1' a -> Expr1' a+if' c a b = Sym EIf :$ c :$ a :$ b++instance Render Expr1 where+  renderSym (EI n)  = "EI"+  renderSym (EB b)  = "EB"+  renderSym (EAdd)  = "EAdd"+  renderSym (EEq)   = "EEq"+  renderSym (EIf)   = "EIf"++interpretationInstances ''Expr1++instance Eval Expr1 where+  evalSym (EI n)  = n+  evalSym (EB b)  = b+  evalSym EAdd    = (+)+  evalSym EEq     = (==)+  evalSym EIf     = \c a b -> if c then a else b++instance EvalEnv Expr1 env where+  compileSym p (EI n) = compileSymDefault p (EI n)+  compileSym p (EB b) = compileSymDefault p (EB b)+  compileSym p EAdd   = compileSymDefault p EAdd+  compileSym p EEq    = compileSymDefault p EEq+  compileSym p EIf    = compileSymDefault p EIf++-- Joined types+data ExprI t where+  EIJ    :: Int  -> ExprI (Full Int)+  EAddJ  :: ExprI (Int :-> Int :-> Full Int)++data ExprB t where+  EBJ    :: Bool -> ExprB (Full Bool)+  EEqJ   :: (Eq t) => ExprB (t   :-> t   :-> Full Bool)+  EIfJ   :: ExprB (Bool :-> a :-> a :-> Full a)++type ExprJ = ExprI :+: ExprB+type ExprJ' a = AST ExprJ (Full a)++intJ  :: Int -> ExprJ' Int+intJ = Sym . inj . EIJ++boolJ :: Bool -> ExprJ' Bool+boolJ = Sym . inj . EBJ++addJ  :: ExprJ' Int -> ExprJ' Int -> ExprJ' Int+addJ a b = Sym (inj EAddJ) :$ a :$ b++eqJ   :: (Eq a) => ExprJ' a -> ExprJ' a -> ExprJ' Bool+eqJ a b = Sym (inj EEqJ) :$ a :$ b++ifJ  :: ExprJ' Bool -> ExprJ' a -> ExprJ' a -> ExprJ' a+ifJ c a b = Sym (inj EIfJ) :$ c :$ a :$ b++instance Render ExprI where+  renderSym (EIJ n)  = "EI"+  renderSym (EAddJ)  = "EAdd"+instance Render ExprB where+  renderSym (EBJ b)  = "EB"+  renderSym (EEqJ)   = "EEq"+  renderSym (EIfJ)   = "EIf"++interpretationInstances ''ExprI+interpretationInstances ''ExprB++instance Eval ExprI where+  evalSym (EIJ n) = n+  evalSym EAddJ   = (+)++instance Eval ExprB where+  evalSym (EBJ b) = b+  evalSym EEqJ    = (==)+  evalSym EIfJ    = \c a b -> if c then a else b++instance EvalEnv ExprI env where+  compileSym p (EIJ n) = compileSymDefault p (EIJ n)+  compileSym p EAddJ   = compileSymDefault p EAddJ++instance EvalEnv ExprB env where+  compileSym p (EBJ b) = compileSymDefault p (EBJ b)+  compileSym p EEqJ    = compileSymDefault p EEqJ+  compileSym p EIfJ    = compileSymDefault p EIfJ++-- Joined types (4 joins)++data Expr4J1 t where+  E4JI    :: Int  -> Expr4J1 (Full Int)+data Expr4J2 t where+  E4JB    :: Bool -> Expr4J2 (Full Bool)+data Expr4J3 t where+  E4JAdd  :: Expr4J3 (Int :-> Int :-> Full Int)+data Expr4J4 t where+  E4JEq   :: (Eq t) => Expr4J4 (t   :-> t   :-> Full Bool)+data Expr4J5 t where+  E4JIf   :: Expr4J5 (Bool :-> a :-> a :-> Full a)++type Expr4J = Expr4J1 :+: Expr4J2 :+: Expr4J3 :+: Expr4J4 :+: Expr4J5+type Expr4J' a = AST Expr4J (Full a)++int4  :: Int -> Expr4J' Int+int4 = Sym . inj . E4JI++bool4 :: Bool -> Expr4J' Bool+bool4 = Sym . inj . E4JB++add4  :: Expr4J' Int -> Expr4J' Int -> Expr4J' Int+add4 a b = Sym (inj E4JAdd) :$ a :$ b++eq4   :: (Eq a) => Expr4J' a -> Expr4J' a -> Expr4J' Bool+eq4 a b = Sym (inj E4JEq) :$ a :$ b++if4  :: Expr4J' Bool -> Expr4J' a -> Expr4J' a -> Expr4J' a+if4 c a b = Sym (inj E4JIf) :$ c :$ a :$ b++instance Render Expr4J1 where+  renderSym (E4JI n)  = "EI"++instance Render Expr4J2 where+  renderSym (E4JB b)  = "EB"++instance Render Expr4J3 where+  renderSym (E4JAdd)  = "EAdd"++instance Render Expr4J4 where+  renderSym (E4JEq)   = "EEq"++instance Render Expr4J5 where+  renderSym (E4JIf)   = "EIf"++interpretationInstances ''Expr4J1+interpretationInstances ''Expr4J2+interpretationInstances ''Expr4J3+interpretationInstances ''Expr4J4+interpretationInstances ''Expr4J5++instance Eval Expr4J1 where+  evalSym (E4JI n)  = n++instance Eval Expr4J2 where+  evalSym (E4JB b)  = b++instance Eval Expr4J3 where+  evalSym E4JAdd    = (+)++instance Eval Expr4J4 where+  evalSym E4JEq     = (==)++instance Eval Expr4J5 where+  evalSym E4JIf     = \c a b -> if c then a else b++instance EvalEnv Expr4J1 env where+  compileSym p (E4JI n)  = compileSymDefault p (E4JI n)++instance EvalEnv Expr4J2 env where+  compileSym p (E4JB b)  = compileSymDefault p (E4JB b)++instance EvalEnv Expr4J3 env where+  compileSym p E4JAdd    = compileSymDefault p E4JAdd++instance EvalEnv Expr4J4 env where+  compileSym p E4JEq     = compileSymDefault p E4JEq++instance EvalEnv Expr4J5 env where+  compileSym p E4JIf     = compileSymDefault p E4JIf++-- Expressions+syntacticExpr :: Int -> Expr1' Int+syntacticExpr 0 = if' (eq (int 5) (int 4)) (int 5) (int 0)+syntacticExpr n = (add (syntacticExpr (n-1)) (syntacticExpr (n-1)))++syntacticExprJ :: Int -> ExprJ' Int+syntacticExprJ 0 = ifJ (eqJ (intJ 5) (intJ 4)) (intJ 5) (intJ 0)+syntacticExprJ n = (addJ (syntacticExprJ (n-1)) (syntacticExprJ (n-1)))++syntacticExpr4J :: Int -> Expr4J' Int+syntacticExpr4J 0 = if4 (eq4 (int4 5) (int4 4)) (int4 5) (int4 0)+syntacticExpr4J n = (add4 (syntacticExpr4J (n-1)) (syntacticExpr4J (n-1)))++main :: IO ()+main = defaultMainWith (defaultConfig {cfgSummaryFile = Last $ Just "bench-results/joiningTypes.csv"}) (return ())+         [ bgroup "eval 10" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 10)+                            , bench "syntactic 1 join"  $ nf evalDen (syntacticExprJ 10)+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 10)]+         , bgroup "eval 15" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 15)+                            , bench "syntactic 1 join"  $ nf evalDen (syntacticExprJ 15)+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 15)]+         , bgroup "eval 20" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 20)+                            , bench "syntactic 1 join"  $ nf evalDen (syntacticExprJ 20)+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 20)]+         , bgroup "size 10" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 10)+                            , bench "syntactic 1 join"  $ nf size (syntacticExprJ 10)+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 10)]+         , bgroup "size 15" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 15)+                            , bench "syntactic 1 join"  $ nf size (syntacticExprJ 15)+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 15)]+         , bgroup "size 20" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 20)+                            , bench "syntactic 1 join"  $ nf size (syntacticExprJ 20)+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 20)]]+
+ benchmarks/MainBenchmark.hs view
@@ -0,0 +1,11 @@+module Main where++import qualified Normal+import qualified WithArity+import qualified JoiningTypes++main :: IO ()+main = do+  Normal.main+  WithArity.main+  JoiningTypes.main
+ benchmarks/Normal.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TemplateHaskell #-}++module Normal (main) where++import Criterion.Main+import Criterion.Config+import Data.Monoid+import Data.Syntactic+import Data.Syntactic.Functional++main :: IO ()+main = defaultMainWith (defaultConfig {cfgSummaryFile = Last $ Just "bench-results/normal.csv"}) (return ())+         [ bgroup "Eval Tree 10"   [ bench "gadt"      $ nf evl (gadtExpr 10)+                                   , bench "syntactic" $ nf evalDen (syntacticExpr 10)]+         , bgroup "Eval Tree 15"   [ bench "gadt"      $ nf evl (gadtExpr 15)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 15)]+         , bgroup "Eval Tree 20"   [ bench "gadt"      $ nf evl (gadtExpr 20)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 20) ]+         , bgroup "Size Tree 10"   [ bench "gadt"      $ nf gSize (gadtExpr 10)+                                   , bench "syntactic" $ nf size (syntacticExpr 10)]+         , bgroup "Size Tree 15"   [ bench "gadt"      $ nf gSize (gadtExpr 15)+                                   , bench "syntactic" $ nf size (syntacticExpr 15)]+         , bgroup "Size Tree 20"   [ bench "gadt"      $ nf gSize (gadtExpr 20)+                                   , bench "syntactic" $ nf size (syntacticExpr 20)]+         , bgroup "Eval IFTree 10" [ bench "if gadt"   $ nf evl (gadtExpr 10)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 10)]+         , bgroup "Eval IFTree 15" [ bench "gadt"      $ nf evl (gadtExpr 15)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 15)]+         , bgroup "Eval IFTree 20" [ bench "gadt"      $ nf evl (gadtExpr 20)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 20) ]+         , bgroup "Size IFTree 10" [ bench "gadt"      $ nf gSize (gadtExpr 10)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 10)]+         , bgroup "Size IFTree 15" [ bench "gadt"      $ nf gSize (gadtExpr 15)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 15)]+         , bgroup "Size IFTree 20" [ bench "gadt"      $ nf gSize (gadtExpr 20)+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 20) ]]++-- Expressions+gadtExpr :: Int -> Expr Int+gadtExpr 0 = (If ((LitI 5) :== (LitI 4)) (LitI 5) (LitI 0))+gadtExpr n = gadtExpr (n-1) :+ gadtExpr (n-1)++gadtExprIf :: Int -> Expr Int+gadtExprIf 0 = (If ((LitI 5) :== (LitI 4)) (LitI 5) (LitI 0))+gadtExprIf n = (If (gadtExprIf (n-1) :== (LitI 0)) (gadtExprIf (n-1)) (gadtExprIf (n-1)))++syntacticExpr :: Int -> ExprS' Int+syntacticExpr 0 = if' (eq (int 5) (int 4)) (int 5) (int 0)+syntacticExpr n = (add (syntacticExpr (n-1)) (syntacticExpr (n-1)))++-- We also test an expression with several ifs so the tree has higher width.+syntacticExprIf :: Int -> ExprS' Int+syntacticExprIf 0 = if' (eq (int 5) (int 4)) (int 5) (int 0)+syntacticExprIf n = if' (eq (syntacticExprIf(n-1)) (int 0)) (syntacticExprIf (n-1)) (syntacticExprIf (n-1))+++-- Comparing Syntactic with GADTs+-- GADTs+data Expr t where+  LitI  :: Int                           -> Expr Int+  LitB  :: Bool                          -> Expr Bool+  (:+)  ::         Expr Int -> Expr Int  -> Expr Int+  (:==) :: Eq t => Expr t   -> Expr t    -> Expr Bool+  If    :: Expr Bool -> Expr t -> Expr t -> Expr t++evl :: Expr t -> t+evl (LitI n)     =  n+evl (LitB b)     =  b+evl (e1 :+ e2)   =  evl e1 +  evl e2+evl (e1 :== e2)  =  evl e1 == evl e2+evl (If b t e)   =  if evl b then evl t else evl e++gSize :: Expr t ->  Int+gSize (LitI n)     =  1+gSize (LitB b)     =  1+gSize (e1 :+ e2)   =  gSize e1 +  gSize e2+gSize (e1 :== e2)  =  gSize e1 + gSize e2+gSize (If b t e)   =  gSize b + gSize t +  gSize e++-- Syntactic++data ExprS t where+  EI    :: Int  -> ExprS (Full Int)+  EB    :: Bool -> ExprS (Full Bool)+  EAdd  :: ExprS (Int :-> Int :-> Full Int)+  EEq   :: (Eq t) => ExprS (t   :-> t   :-> Full Bool)+  EIf   :: ExprS (Bool :-> a :-> a :-> Full a)++type ExprS' a = AST ExprS (Full a)++-- Smart constructors+int  :: Int -> ExprS' Int+int = Sym . EI++bool :: Bool -> ExprS' Bool+bool = Sym . EB++add  :: ExprS' Int -> ExprS' Int -> ExprS' Int+add a b = Sym EAdd :$ a :$ b++eq   :: (Eq a) => ExprS' a -> ExprS' a -> ExprS' Bool+eq a b = Sym EEq :$ a :$ b++if'  :: ExprS' Bool -> ExprS' a -> ExprS' a -> ExprS' a+if' c a b = Sym EIf :$ c :$ a :$ b++instance Render ExprS where+  renderSym (EI n) = "EI"+  renderSym (EB b) = "EB"+  renderSym EAdd   = "EAdd"+  renderSym EEq    = "EEq"+  renderSym EIf    = "EIf"++interpretationInstances ''ExprS++instance Eval ExprS where+  evalSym (EI n) = n+  evalSym (EB b) = b+  evalSym EAdd   = (+)+  evalSym EEq    = (==)+  evalSym EIf    = \c a b -> if c then a else b++instance EvalEnv ExprS env where+  compileSym p (EI n) = compileSymDefault p (EI n)+  compileSym p (EB b) = compileSymDefault p (EB b)+  compileSym p EAdd   = compileSymDefault p EAdd+  compileSym p EEq    = compileSymDefault p EEq+  compileSym p EIf    = compileSymDefault p EIf+
+ benchmarks/WithArity.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell #-}++module WithArity (main) where++import Criterion.Main+import Criterion.Config+import Data.Monoid+import Data.Syntactic hiding (E)+import Data.Syntactic.Functional++main :: IO ()+main = defaultMainWith (defaultConfig {cfgSummaryFile = Last $ Just "bench-results/withArity.csv"}) (return ())+         [ bgroup "eval 5"  [ bench "gadt"      $ nf evl (gExpr 5)+                            , bench "Syntactic" $ nf evalDen (sExpr 5) ]+         , bgroup "eval 6"  [ bench "gadt"      $ nf evl (gExpr 6)+                            , bench "Syntactic" $ nf evalDen (sExpr 6) ]+         , bgroup "eval 7"  [ bench "gadt"      $ nf evl (gExpr 7)+                            , bench "Syntactic" $ nf evalDen (sExpr 7) ]+         , bgroup "size 5"  [ bench "gadt"      $ nf gSize (gExpr 5)+                            , bench "Syntactic" $ nf size (sExpr 5) ]+         , bgroup "size 6"  [ bench "gadt"      $ nf gSize (gExpr 6)+                            , bench "Syntactic" $ nf size (sExpr 6) ]+         , bgroup "size 7"  [ bench "gadt"      $ nf gSize (gExpr 7)+                            , bench "Syntactic" $ nf size (sExpr 7) ]]++-- Expressions+gExpr :: Int -> E Int+gExpr 0  = E0 1+gExpr 1  = E2 (E2 (E0 1) (E0 1)) (E1 (E0 1))+gExpr n  = E10 (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1))+           (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1))++sExpr :: Int -> T' Int+sExpr 0  = t0 1+sExpr 1  = t2 (t2 (t0 1) (t0 1)) (t1 (t0 1))+sExpr n  = t10 (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1))+           (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1))++gSize :: E a -> Int+gSize (E0 _) = 1+gSize (E1 a)   = gSize a+gSize (E2 a b) = gSize a + gSize b+gSize (E3 a b c) = gSize a + gSize b + gSize c+gSize (E5 a b c d e) = gSize a + gSize b + gSize c + gSize d + gSize e+gSize (E10 a b c d e f g h i j) = gSize a + gSize b + gSize c + gSize d + gSize e ++                                  gSize f + gSize g + gSize h + gSize i + gSize j+++-- Comparing Syntactic with GADTs+-- GADTs+data E a where+  E0    :: a  -> E a+  E1    :: E a -> E a+  E2    :: E a -> E a -> E a+  E3    :: E a -> E a -> E a -> E a+  E5    :: E a -> E a -> E a -> E a -> E a -> E a+  E10   :: E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a+++evl :: E Int -> Int+evl (E0 n)         =  n+evl (E1 a)         =  evl a+evl (E2 a b)       =  evl a + evl b+evl (E3 a b c)     =  evl a + evl b + evl c+evl (E5 a b c d e) =  evl a + evl b + evl c + evl d + evl e+evl (E10 a b c d e f g h i j) =+    evl a + evl b + evl c + evl d + evl e + evl f + evl g + evl h + evl i + evl j++-- Syntactic++data T a where+  T0    :: Num a =>  a  -> T (Full a)+  T1    :: Num a =>  T (a :-> Full a)+  T2    :: Num a =>  T (a :-> a :-> Full a)+  T3    :: Num a =>  T (a :-> a :-> a :-> Full a)+  T5    :: Num a =>  T (a :-> a :-> a :-> a :-> a :-> Full a)+  T10   :: Num a =>  T (a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> Full a)++type T' a = AST T (Full a)++t0  :: Num a =>  a -> T' a+t0 = Sym . T0++t1 :: Num a =>  T' a -> T' a+t1 a = Sym T1 :$ a++t2    :: Num a =>  T' a -> T' a -> T' a+t2 a b = Sym T2 :$ a :$ b++t3    :: Num a =>  T' a -> T' a -> T' a -> T' a+t3 a b c = Sym T3 :$ a :$ b :$ c++t5    :: Num a =>  T' a -> T' a -> T' a -> T' a -> T' a -> T' a+t5 a b c d e = Sym T5 :$ a :$ b :$ c :$ d :$ e++t10   :: Num a => T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a+t10 a b c d e f g h i j = Sym T10 :$ a :$ b :$ c :$ d :$ e :$ f :$ g :$ h :$ i:$ j++instance Render T+  where+    renderSym (T0 a) = "T0"+    renderSym T1     = "T1"+    renderSym T2     = "T2"+    renderSym T3     = "T3"+    renderSym T5     = "T5"+    renderSym T10    = "T10"++interpretationInstances ''T++instance Eval T+  where+    evalSym (T0 a) = a+    evalSym T1     = id+    evalSym T2     = (+)+    evalSym T3     = \a b c -> a + b + c+    evalSym T5     = \a b c d e -> a + b + c + d + e+    evalSym T10    = \a b c d e f g h i j -> a + b + c + d + e + f + g + h + i + j++instance EvalEnv T env+  where+    compileSym p (T0 a) = compileSymDefault p (T0 a)+    compileSym p T1     = compileSymDefault p T1+    compileSym p T2     = compileSymDefault p T2+    compileSym p T3     = compileSymDefault p T3+    compileSym p T5     = compileSymDefault p T5+    compileSym p T10    = compileSymDefault p T10+
+ examples/Monad.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}++-- | This module demonstrates monad reification.+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011+-- <http://www.cse.chalmers.se/~emax/documents/persson2011generic.pdf>) for details.++module Monad where++++import Control.Monad (replicateM_)+import Data.Char (isDigit)+import Data.Typeable (Typeable)++import Data.Syntactic+import Data.Syntactic.Functional+import Data.Syntactic.Sugar.MonadT++import NanoFeldspar (Type, Arithmetic (..))++++type Dom = BindingT :+: MONAD IO :+: Construct :+: Arithmetic++type Exp a = ASTF Dom a++type IO' a = Remon Dom IO (Exp a)++getDigit :: IO' Int+getDigit = sugarSym $ Construct "getDigit" get+  where+    get = do+        c <- getChar+        if isDigit c then return (fromEnum c - fromEnum '0') else get++putDigit :: Exp Int -> IO' ()+putDigit = sugarSym $ Construct "putDigit" print++iter :: Typeable a => Exp Int -> IO' a -> IO' ()+iter = sugarSym $ Construct "iter" replicateM_++-- | Literal+value :: Show a => a -> Exp a+value a = sugar $ inj $ Construct (show a) a++instance (Num a, Type a) => Num (Exp a)+  where+    fromInteger = value . fromInteger+    (+)         = sugarSym Add+    (-)         = sugarSym Sub+    (*)         = sugarSym Mul++ex1 :: Exp Int -> IO' ()+ex1 n = iter n $ do+    d <- getDigit+    putDigit (d+d)++test1 = evalClosed (desugar ex1) 5+test2 = drawAST $ desugar ex1+
+ examples/NanoFeldspar.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}++-- | A minimal Feldspar core language implementation. The intention of this module is to demonstrate+-- how to quickly make a language prototype using Syntactic.++module NanoFeldspar where++++import Prelude hiding (max, min, not, (==), length, map, sum, zip, zipWith)+import qualified Prelude++import Data.Tree+import Data.Typeable++import Data.Syntactic hiding (fold, printExpr, showAST, drawAST, writeHtmlAST)+import qualified Data.Syntactic as Syntactic+import Data.Syntactic.Functional+import Data.Syntactic.Sugar.BindingT++++--------------------------------------------------------------------------------+-- * Types+--------------------------------------------------------------------------------++-- | Convenient class alias+class    (Typeable a, Show a, Eq a, Ord a) => Type a+instance (Typeable a, Show a, Eq a, Ord a) => Type a++type Length = Int+type Index  = Int++++--------------------------------------------------------------------------------+-- * Abstract syntax+--------------------------------------------------------------------------------++data Arithmetic a+  where+    Add :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a)+    Sub :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a)+    Mul :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a)++instance Render Arithmetic+  where+    renderSym Add = "(+)"+    renderSym Sub = "(-)"+    renderSym Mul = "(*)"+    renderArgs = renderArgsSmart++interpretationInstances ''Arithmetic++instance Eval Arithmetic+  where+    evalSym Add = (+)+    evalSym Sub = (-)+    evalSym Mul = (*)++instance EvalEnv Arithmetic env+  where+    compileSym p Add = compileSymDefault p Add+    compileSym p Sub = compileSymDefault p Sub+    compileSym p Mul = compileSymDefault p Mul+      -- Pattern matching on the individual constructors is needed in order to fulfill the+      -- 'Signature' constraint required by the right-hand side.++data Let a+  where+    Let :: Let (a :-> (a -> b) :-> Full b)++instance Equality Let+  where+    equal = equalDefault+    hash  = hashDefault++instance Render Let+  where+    renderSym Let = "letBind"++instance StringTree Let+  where+    stringTreeSym [a, Node lam [body]] Let+        | ("Lam",v) <- splitAt 3 lam = Node ("Let" ++ v) [a,body]+    stringTreeSym [a,f] Let = Node "Let" [a,f]++instance Eval Let+  where+    evalSym Let = flip ($)++instance EvalEnv Let env+  where+    compileSym p Let = compileSymDefault p Let++data Parallel a+  where+    Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a])++instance Render Parallel+  where+    renderSym Parallel = "parallel"++interpretationInstances ''Parallel++instance Eval Parallel+  where+    evalSym Parallel = \len ixf -> Prelude.map ixf [0 .. len-1]++instance EvalEnv Parallel env+  where+    compileSym p Parallel = compileSymDefault p Parallel++data ForLoop a+  where+    ForLoop :: Type st => ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st)++instance Render ForLoop+  where+    renderSym ForLoop = "forLoop"++interpretationInstances ''ForLoop++instance Eval ForLoop+  where+    evalSym ForLoop = \len init body -> foldl (flip body) init [0 .. len-1]++instance EvalEnv ForLoop env+  where+    compileSym p ForLoop = compileSymDefault p ForLoop++type FeldDomain+    =   Arithmetic+    :+: BindingT+    :+: Let+    :+: Parallel+    :+: ForLoop+    :+: Construct++newtype Data a = Data { unData :: ASTF FeldDomain a }++-- | Declaring 'Data' as syntactic sugar+instance Type a => Syntactic (Data a)+  where+    type Domain (Data a)   = FeldDomain+    type Internal (Data a) = a+    desugar = unData+    sugar   = Data++-- | Specialization of the 'Syntactic' class for the Feldspar domain+class    (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a+instance (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a++instance Type a => Show (Data a)+  where+    show = render . unData++++--------------------------------------------------------------------------------+-- * "Backends"+--------------------------------------------------------------------------------++-- | Show the expression+showExpr :: (Syntactic a, Domain a ~ FeldDomain) => a -> String+showExpr = render . desugar++-- | Print the expression+printExpr :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()+printExpr = putStrLn . showExpr++-- | Show the syntax tree using unicode art+showAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> String+showAST = Syntactic.showAST . desugar++-- | Draw the syntax tree on the terminal using unicode art+drawAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()+drawAST = putStrLn . showAST++-- | Write the syntax tree to an HTML file with foldable nodes+writeHtmlAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()+writeHtmlAST = Syntactic.writeHtmlAST "tree.html" . desugar++eval :: (Syntactic a, Domain a ~ FeldDomain) => a -> Internal a+eval = evalClosed . desugar++++--------------------------------------------------------------------------------+-- * Front end+--------------------------------------------------------------------------------++-- | Literal+value :: Syntax a => Internal a -> a+value a = sugar $ inj $ Construct (show a) a++false :: Data Bool+false = value False++true :: Data Bool+true = value True++-- | For types containing some kind of \"thunk\", this function can be used to+-- force computation+force :: Syntax a => a -> a+force = resugar++instance (Type a, Num a) => Num (Data a)+  where+    fromInteger = value . fromInteger+    (+)         = sugarSym Add+    (-)         = sugarSym Sub+    (*)         = sugarSym Mul++share :: (Syntax a, Syntactic b, Domain b ~ FeldDomain) => a -> (a -> b) -> b+share = sugarSym Let++-- | Parallel array+parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]+parallel = sugarSym Parallel++-- | For loop+forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st+forLoop = sugarSym ForLoop++(?) :: forall a . Syntax a => Data Bool -> (a,a) -> a+c ? (t,f) = sugarSym sym c t f+  where+    sym :: Construct (Bool :-> Internal a :-> Internal a :-> Full (Internal a))+    sym = Construct "cond" (\c t f -> if c then t else f)++arrLength :: Type a => Data [a] -> Data Length+arrLength = sugarSym $ Construct "arrLength" Prelude.length++-- | Array indexing+getIx :: Type a => Data [a] -> Data Index -> Data a+getIx = sugarSym $ Construct "getIx" eval+  where+    eval as i+        | i >= len || i < 0 = error "getIx: index out of bounds"+        | otherwise         = as !! i+      where+        len = Prelude.length as++not :: Data Bool -> Data Bool+not = sugarSym $ Construct "not" Prelude.not++(==) :: Type a => Data a -> Data a -> Data Bool+(==) = sugarSym $ Construct "(==)" (Prelude.==)++max :: Type a => Data a -> Data a -> Data a+max = sugarSym $ Construct "max" Prelude.max++min :: Type a => Data a -> Data a -> Data a+min = sugarSym $ Construct "min" Prelude.min++++--------------------------------------------------------------------------------+-- * Vector library+--------------------------------------------------------------------------------++data Vector a+  where+    Indexed :: Data Length -> (Data Index -> a) -> Vector a++instance Syntax a => Syntactic (Vector a)+  where+    type Domain (Vector a)   = FeldDomain+    type Internal (Vector a) = [Internal a]+    desugar = desugar . freezeVector . map resugar+    sugar   = map resugar . thawVector . sugar++length :: Vector a -> Data Length+length (Indexed len _) = len++indexed :: Data Length -> (Data Index -> a) -> Vector a+indexed = Indexed++index :: Vector a -> Data Index -> a+index (Indexed _ ixf) = ixf++(!) :: Vector a -> Data Index -> a+Indexed _ ixf ! i = ixf i++infixl 9 !++freezeVector :: Type a => Vector (Data a) -> Data [a]+freezeVector vec = parallel (length vec) (index vec)++thawVector :: Type a => Data [a] -> Vector (Data a)+thawVector arr = Indexed (arrLength arr) (getIx arr)++zip :: Vector a -> Vector b -> Vector (a,b)+zip a b = indexed (length a `min` length b) (\i -> (index a i, index b i))++unzip :: Vector (a,b) -> (Vector a, Vector b)+unzip ab = (indexed len (fst . index ab), indexed len (snd . index ab))+  where+    len = length ab++permute :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)+permute perm vec = indexed len (index vec . perm len)+  where+    len = length vec++reverse :: Vector a -> Vector a+reverse = permute $ \len i -> len-i-1++(...) :: Data Index -> Data Index -> Vector (Data Index)+l ... h = indexed (h-l+1) (+l)++map :: (a -> b) -> Vector a -> Vector b+map f (Indexed len ixf) = Indexed len (f . ixf)++zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWith f a b = map (uncurry f) $ zip a b++fold :: Syntax b => (a -> b -> b) -> b -> Vector a -> b+fold f b (Indexed len ixf) = forLoop len b (\i st -> f (ixf i) st)++sum :: (Num a, Syntax a) => Vector a -> a+sum = fold (+) 0++type Matrix a = Vector (Vector (Data a))++-- | Transpose of a matrix. Assumes that the number of rows is > 0.+transpose :: Type a => Matrix a -> Matrix a+transpose a = indexed (length (a!0)) $ \k -> indexed (length a) $ \l -> a ! l ! k++++--------------------------------------------------------------------------------+-- * Examples+--------------------------------------------------------------------------------++-- | Scalar product+scProd :: Vector (Data Float) -> Vector (Data Float) -> Data Float+scProd a b = sum (zipWith (*) a b)++forEach = flip map++-- | Matrix multiplication+matMul :: Matrix Float -> Matrix Float -> Matrix Float+matMul a b = forEach a $ \a' ->+               forEach (transpose b) $ \b' ->+                 scProd a' b'+
− examples/NanoFeldspar/Core.hs 
@@ -1,283 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}---- | A minimal Feldspar core language implementation. The intention of this--- module is to demonstrate how to quickly make a language prototype using--- syntactic.------ A more realistic implementation would use custom contexts to restrict the--- types at which constructors operate. Currently, all general constructs (such--- as 'Literal' and 'Tuple') use a 'SimpleCtx' context, which means that the--- types are quite unrestricted. A real implementation would also probably use--- custom types for primitive functions, since 'Construct' is quite unsafe (uses--- only a 'String' to distinguish between functions).--module NanoFeldspar.Core where----import Data.Typeable--import Language.Syntactic as Syntactic-import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Constructs.Binding.HigherOrder-import Language.Syntactic.Constructs.Condition-import Language.Syntactic.Constructs.Construct-import Language.Syntactic.Constructs.Literal-import Language.Syntactic.Constructs.Tuple-import Language.Syntactic.Frontend.Tuple-import Language.Syntactic.Sharing.SimpleCodeMotion-import Language.Syntactic.Sharing.CodeMotion2--------------------------------------------------------------------------------------- * Types------------------------------------------------------------------------------------- | Convenient class alias-class    (Ord a, Show a, Typeable a) => Type a-instance (Ord a, Show a, Typeable a) => Type a where-  {-# SPECIALIZE instance (Ord a, Show a, Typeable a) => Type a #-}--type Length = Int-type Index  = Int--------------------------------------------------------------------------------------- * Parallel arrays-----------------------------------------------------------------------------------data Parallel a-  where-    Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a])--instance Constrained Parallel-  where-    {-# SPECIALIZE instance Constrained Parallel #-}-    {-# INLINABLE exprDict #-}-    type Sat Parallel = Type-    exprDict Parallel = Dict--instance Semantic Parallel-  where-    {-# SPECIALIZE instance Semantic Parallel #-}-    {-# INLINABLE semantics #-}-    semantics Parallel = Sem-        { semanticName = "parallel"-        , semanticEval = \len ixf -> map ixf [0 .. len-1]-        }--semanticInstances ''Parallel--instance EvalBind Parallel where-  {-# SPECIALIZE instance EvalBind Parallel #-}--instance AlphaEq dom dom dom env => AlphaEq Parallel Parallel dom env-  where-    {-# SPECIALIZE instance AlphaEq dom dom dom env =>-          AlphaEq Parallel Parallel dom env #-}--------------------------------------------------------------------------------------- * For loops-----------------------------------------------------------------------------------data ForLoop a-  where-    ForLoop :: Type st =>-        ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st)--instance Constrained ForLoop-  where-    type Sat ForLoop = Type-    exprDict ForLoop = Dict--instance Semantic ForLoop-  where-    semantics ForLoop = Sem-        { semanticName = "forLoop"-        , semanticEval = \len init body -> foldl (flip body) init [0 .. len-1]-        }--semanticInstances ''ForLoop--instance EvalBind ForLoop where evalBindSym = evalBindSymDefault--instance AlphaEq dom dom dom env => AlphaEq ForLoop ForLoop dom env-  where-    alphaEqSym = alphaEqSymDefault--------------------------------------------------------------------------------------- * Feldspar domain------------------------------------------------------------------------------------- | The Feldspar domain-type FeldDomain-    =   Construct-    :+: Literal-    :+: Condition-    :+: Tuple-    :+: Select-    :+: Parallel-    :+: ForLoop--type FeldSyms      = Let :+: (FeldDomain :|| Eq :| Show)-type FeldDomainAll = HODomain FeldSyms Typeable Top--newtype Data a = Data { unData :: ASTF FeldDomainAll a }---- | Declaring 'Data' as syntactic sugar-instance Type a => Syntactic (Data a)-  where-    type Domain (Data a)   = FeldDomainAll-    type Internal (Data a) = a-    desugar = unData-    sugar   = Data---- | Specialization of the 'Syntactic' class for the Feldspar domain-class    (Syntactic a, Domain a ~ FeldDomainAll, Type (Internal a)) => Syntax a-instance (Syntactic a, Domain a ~ FeldDomainAll, Type (Internal a)) => Syntax a---- | A predicate deciding which constructs can be shared. Lambdas and literals are not shared.-canShare :: ASTF (FODomain FeldSyms Typeable Top) a -> Maybe (Dict (Top a))-canShare (lam :$ _)-    | Just _ <- prjP (P::P (CLambda Top)) lam = Nothing-canShare (prj -> Just (Literal _)) = Nothing-canShare _  = Just Dict--canShareIn :: ASTF (FODomain FeldSyms Typeable Top) a -> Bool-canShareIn (lam :$ _)-    | Just _ <- prjP (P::P (CLambda Top)) lam = False-canShareIn _ = True--canShareDict :: MkInjDict (FODomain FeldSyms Typeable Top)-canShareDict = mkInjDictFO canShare canShareIn--canShareDict2 :: MkInjDict (FODomain FeldSyms Typeable Top)-canShareDict2 = mkInjDictFO canShare (const True)--------------------------------------------------------------------------------------- * Back ends------------------------------------------------------------------------------------- | Show the expression-showExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String-showExpr = render . reifySmart (const True) canShareDict---- | Print the expression-printExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-printExpr = print . reifySmart (const True) canShareDict---- | Show the syntax tree using Unicode art-showAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String-showAST = Syntactic.showAST . reifySmart (const True) canShareDict--showAST2 :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String-showAST2 = Syntactic.showAST . reifySmart2 (const True) canShareDict---- | Draw the syntax tree on the terminal using Unicode art-drawAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-drawAST = Syntactic.drawAST . reifySmart (const True) canShareDict---- | Write the syntax tree to an HTML file with foldable nodes-writeHtmlAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()-writeHtmlAST = Syntactic.writeHtmlAST "tree.html" . desugar---- | Evaluation-eval :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> Internal a-eval = evalBind . reifySmart (const True) canShareDict--eval2 :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> Internal a-eval2 = evalBind . reifySmart2 (const True) canShareDict2--------------------------------------------------------------------------------------- * Core library------------------------------------------------------------------------------------- | Literal-value :: Syntax a => Internal a -> a-value = sugarSymC . Literal--false :: Data Bool-false = value False--true :: Data Bool-true = value True---- | For types containing some kind of \"thunk\", this function can be used to--- force computation-force :: Syntax a => a -> a-force = resugar---- | Share a value using let binding-share :: (Syntax a, Syntax b) => a -> (a -> b) -> b-share = sugarSymC Let---- | Alpha equivalence-instance Type a => Eq (Data a)-  where-    Data a == Data b = alphaEq (reify a) (reify b)--instance Type a => Show (Data a)-  where-    show (Data a) = render $ reify a--instance (Type a, Num a) => Num (Data a)-  where-    fromInteger = value . fromInteger-    abs         = sugarSymC $ Construct "abs" abs-    signum      = sugarSymC $ Construct "signum" signum-    (+)         = sugarSymC $ Construct "(+)" (+)-    (-)         = sugarSymC $ Construct "(-)" (-)-    (*)         = sugarSymC $ Construct "(*)" (*)--(?) :: Syntax a => Data Bool -> (a,a) -> a-cond ? (t,e) = sugarSymC Condition cond t e---- | Parallel array-parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]-parallel = sugarSymC Parallel--forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st-forLoop = sugarSymC ForLoop--arrLength :: Type a => Data [a] -> Data Length-arrLength = sugarSymC $ Construct "arrLength" Prelude.length---- | Array indexing-getIx :: Type a => Data [a] -> Data Index -> Data a-getIx = sugarSymC $ Construct "getIx" eval-  where-    eval as i-        | i >= len || i < 0 = error "getIx: index out of bounds"-        | otherwise         = as !! i-      where-        len = Prelude.length as--not :: Data Bool -> Data Bool-not = sugarSymC $ Construct "not" Prelude.not--(==) :: Type a => Data a -> Data a -> Data Bool-(==) = sugarSymC $ Construct "(==)" (Prelude.==)--max :: Type a => Data a -> Data a -> Data a-max = sugarSymC $ Construct "max" Prelude.max--min :: Type a => Data a -> Data a -> Data a-min = sugarSymC $ Construct "min" Prelude.min
− examples/NanoFeldspar/Extra.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}--module NanoFeldspar.Extra where----import Control.Monad.State-import Data.Typeable--import Language.Syntactic as Syntactic-import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Constructs.Binding.HigherOrder-import Language.Syntactic.Constructs.Binding.Optimize-import Language.Syntactic.Constructs.Construct-import Language.Syntactic.Constructs.Literal-import Language.Syntactic.Sharing.SimpleCodeMotion-import Language.Syntactic.Sharing.Graph-import Language.Syntactic.Sharing.ReifyHO--import NanoFeldspar.Core--------------------------------------------------------------------------------------- * Graph reification------------------------------------------------------------------------------------- | A predicate deciding which constructs can be shared. Variables, lambdas and literals are not--- shared.-canShare2 :: ASTF (HODomain FeldSyms Typeable Top) a -> Bool-canShare2 (prjP (P::P (Variable :|| Top))               -> Just _) = False-canShare2 (prjP (P::P (HOLambda FeldSyms Typeable Top)) -> Just _) = False-canShare2 (prj -> Just (Literal _)) = False-canShare2 _  = True---- | Draw the syntax graph after common sub-expression elimination-drawCSE :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-drawCSE a = do-    (g,_) <- reifyGraph canShare2 a-    drawASG-      $ reindexNodesFrom0-      $ inlineSingle-      $ cse-      $ g---- | Draw the syntax graph after observing sharing-drawObs :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-drawObs a = do-    (g,_) <- reifyGraph canShare2 a-    drawASG-      $ reindexNodesFrom0-      $ inlineSingle-      $ g--------------------------------------------------------------------------------------- * Simplification/constant folding-----------------------------------------------------------------------------------instance Optimize ForLoop-  where-    {-# SPECIALIZE instance Optimize ForLoop #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym = optimizeSymDefault--instance Optimize Parallel-  where-    {-# SPECIALIZE instance Optimize Parallel #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym = optimizeSymDefault--constFold :: forall a-    .  ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) a-    -> a-    -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) a-constFold expr a = match (\sym _ -> case sym of-      C' (InjR (InjR (InjR (C (C' _))))) -> injC (Literal a)-      _ -> expr-    ) expr--reifySimp :: (Syntactic a, Domain a ~ FeldDomainAll) =>-    a -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) (Internal a)-reifySimp = flip evalState 0 .-    (   codeMotion (const True) prjDictFO canShareDict-    .   optimize constFold-    <=< reifyM-    .   desugar-    )--drawSimp :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-drawSimp = Syntactic.drawAST . reifySimp
− examples/NanoFeldspar/Test.hs 
@@ -1,98 +0,0 @@-module NanoFeldspar.Test where----import Prelude hiding (length, map, (==), max, min, reverse, sum, unzip, zip, zipWith)--import NanoFeldspar.Core-import NanoFeldspar.Extra-import NanoFeldspar.Vector--------------------------------------------------------------------------------------- Basic examples------------------------------------------------------------------------------------- Scalar product-scProd :: Vector (Data Float) -> Vector (Data Float) -> Data Float-scProd a b = sum (zipWith (*) a b)--forEach = flip map---- Matrix multiplication-matMul :: Matrix Float -> Matrix Float -> Matrix Float-matMul a b = forEach a $ \a' ->-               forEach (transpose b) $ \b' ->-                 scProd a' b'---- Note that------   * `transpose` is fused with `scProd`---   * some invariant expressions have been hoisted out of `parallel` and `forLoop` (see the---     `Let` nodes)-test_matMul = drawAST matMul---- Parallel array-prog1 :: Data Int -> Data Int -> Data [Int]-prog1 a b = parallel a (\i -> min (i+3) b)---- Common sub-expressions-prog2 :: Data Int -> Data Int-prog2 a = max (min a a) (min a a)--prog3 :: Data Index -> Data Index -> Data Index-prog3 a b = sum $ reverse (l ... u)-  where-    l = min a b-    u = max a b---- Invariant code hoisting-prog4 :: Data Int -> Data [Int]-prog4 a = parallel a (\i -> (a+a)*i)---- Explicit sharing-prog5 :: Data Index -> Data Index-prog5 a = share (a*2,a*3) $ \(b,c) -> (b-c)*(c-b)--------------------------------------------------------------------------------------- Common sub-expression elimination and observable sharing-----------------------------------------------------------------------------------prog6 = index as 1 + sum as + sum as-  where-    as = map (*2) $ force (1...20)--test6_1 = drawAST prog6-  -- Draws a tree with no duplication--test6_2 = drawCSE prog6-  -- Draws a graph with no duplication--test6_3 = drawObs prog6-  -- Draws a graph with some duplication. The 'forLoop' introduced by 'sum' is-  -- not shared, because 'sum as' is repeated twice in source code. But the-  -- 'parallel' introduced by 'force' is shared, because 'force' only appears-  -- once.--------------------------------------------------------------------------------------- Optimizations-----------------------------------------------------------------------------------prog7 :: Data Int -> Data Int-prog7 a = (a==10) ? (max 5 (6+7), max 5 (6+7))--test7 = drawSimp prog7-  -- Reduced to the literal 13--prog8 a = c ? (parallel 10 (+a), parallel 10 (+a))-  where-    c = (a*a*a*a) == 23--test8 = drawSimp prog8-  -- The condition gets pruned away-
− examples/NanoFeldspar/Vector.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}---- | A simple vector library for NanoFeldspar. The intention of this module is--- to demonstrate how to add language features without extending the underlying--- core language. By declaring 'Vector' as syntactic sugar, vector operations--- can work seamlessly with the functions of the core language.------ An interesting aspect of the 'Vector' interface is that the only operation--- that produces a core language array (i.e. allocates memory) is 'freezeVector'--- (which uses 'parallel'). This means that expressions not involving--- 'freezeVector' are guaranteed to be fused. (Note, however, that--- 'freezeVector' is introduced by 'desugar', which in turn is used by many--- other functions.)--module NanoFeldspar.Vector where----import Prelude hiding (length, map, (==), max, min, reverse, sum, unzip, zip, zipWith)--import Language.Syntactic (Syntactic (..), resugar)--import NanoFeldspar.Core----data Vector a-  where-    Indexed :: Data Length -> (Data Index -> a) -> Vector a--instance Syntax a => Syntactic (Vector a)-  where-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (Vector a)   = FeldDomainAll-    type Internal (Vector a) = [Internal a]-    desugar = desugar . freezeVector . map resugar-    sugar   = map resugar . unfreezeVector . sugar----length :: Vector a -> Data Length-length (Indexed len _) = len--indexed :: Data Length -> (Data Index -> a) -> Vector a-indexed = Indexed--index :: Vector a -> Data Index -> a-index (Indexed _ ixf) = ixf--(!) :: Vector a -> Data Index -> a-Indexed _ ixf ! i = ixf i--infixl 9 !--freezeVector :: Type a => Vector (Data a) -> Data [a]-freezeVector vec = parallel (length vec) (index vec)--unfreezeVector :: Type a => Data [a] -> Vector (Data a)-unfreezeVector arr = Indexed (arrLength arr) (getIx arr)--zip :: Vector a -> Vector b -> Vector (a,b)-zip a b = indexed (length a `min` length b) (\i -> (index a i, index b i))--unzip :: Vector (a,b) -> (Vector a, Vector b)-unzip ab = (indexed len (fst . index ab), indexed len (snd . index ab))-  where-    len = length ab--permute :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)-permute perm vec = indexed len (index vec . perm len)-  where-    len = length vec--reverse :: Vector a -> Vector a-reverse = permute $ \len i -> len-i-1--(...) :: Data Index -> Data Index -> Vector (Data Index)-l ... h = indexed (h-l+1) (+l)--map :: (a -> b) -> Vector a -> Vector b-map f (Indexed len ixf) = Indexed len (f . ixf)--zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c-zipWith f a b = map (uncurry f) $ zip a b--fold :: Syntax b => (a -> b -> b) -> b -> Vector a -> b-fold f b (Indexed len ixf) = forLoop len b (\i st -> f (ixf i) st)--sum :: (Num a, Syntax a) => Vector a -> a-sum = fold (+) 0--type Matrix a = Vector (Vector (Data a))---- | Transpose of a matrix. Assumes that the number of rows is > 0.-transpose :: Type a => Matrix a -> Matrix a-transpose a = indexed (length (a!0)) $ \k -> indexed (length a) $ \l -> a ! l ! k
+ examples/WellScoped.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}++-- | This module demonstrates the use of 'WS' terms. In particular, note that 'share' has no+-- constraints on the type @a@ in contrast to the corresponding function in NanoFeldspar.+--+-- 'WS' terms can be evaluated directly using 'evalClosedWS' and they can be examined by first+-- converting them using the function 'fromWS'.++module WellScoped where++++import Data.Proxy++import Data.Syntactic+import Data.Syntactic.Functional++import NanoFeldspar (Arithmetic (..), Let (..))++++type Exp e a = WS (Let :+: Construct) e a++instance (Num a, Show a) => Num (Exp e a)+  where+    fromInteger i = smartWS $ Construct (show i') i'+      where i' = fromInteger i+    (+) = smartWS $ Construct "(+)" (+)++share :: forall e a b .+    Exp e a -> ((forall e' . Ext e' (a,e) => Exp e' a) -> Exp (a,e) b) -> Exp e b+share a f = smartWS Let a $ lamWS f++ex1 :: Exp e (Int -> Int)+ex1 = lamWS $ \a -> share (a + 4) $ \b -> share (a+b) $ \c -> a+b+c++test1 = evalClosedWS ex1 5+test2 = drawAST $ fromWS ex1+
+ extras/TypeUniverseClosed.hs view
@@ -0,0 +1,93 @@+-- | Typed type reification, type-level reasoning and dynamic types+--+-- This module is meant as a reference for understanding the "Data.Syntactic.TypeUniverse" module.++module TypeUniverseClosed where++++import Data.Constraint++++-- | Typed representation of types (reification of type @a@)+data TypeRep a+  where+    BoolType  :: TypeRep Bool+    IntType   :: TypeRep Int+    FloatType :: TypeRep Float+    ListType  :: TypeRep a -> TypeRep [a]++-- | Type reification+class Typeable a+  where+    -- | Reifies type @a@+    typeRep :: TypeRep a++instance Typeable Bool              where typeRep = BoolType+instance Typeable Int               where typeRep = IntType+instance Typeable Float             where typeRep = FloatType+instance Typeable a => Typeable [a] where typeRep = ListType typeRep++typeEq :: TypeRep a -> TypeRep b -> Maybe (Dict (a ~ b))+typeEq BoolType      BoolType      = Just Dict+typeEq IntType       IntType       = Just Dict+typeEq FloatType     FloatType     = Just Dict+typeEq (ListType t1) (ListType t2) = do Dict <- typeEq t1 t2; return Dict+typeEq _ _ = Nothing++hasTypeable :: TypeRep a -> Dict (Typeable a)+hasTypeable BoolType  = Dict+hasTypeable IntType   = Dict+hasTypeable FloatType = Dict+hasTypeable (ListType t) | Dict <- hasTypeable t = Dict++hasEq :: TypeRep a -> Dict (Eq a)+hasEq BoolType  = Dict+hasEq IntType   = Dict+hasEq FloatType = Dict+hasEq (ListType t) | Dict <- hasEq t = Dict++hasShow :: TypeRep a -> Dict (Show a)+hasShow BoolType  = Dict+hasShow IntType   = Dict+hasShow FloatType = Dict+hasShow (ListType t) | Dict <- hasShow t = Dict++hasNum :: TypeRep a -> Maybe (Dict (Num a))+hasNum BoolType     = Nothing+hasNum IntType      = Just Dict+hasNum FloatType    = Just Dict+hasNum (ListType t) = Nothing++-- | Safe cast (does not use @unsafeCoerce@ underneath)+cast :: forall a b . (Typeable a, Typeable b) => a -> Maybe b+cast a = do+    Dict <- typeEq (typeRep :: TypeRep a) (typeRep :: TypeRep b)+    return a++typeOf :: Typeable a => a -> TypeRep a+typeOf _ = typeRep++data Dynamic+  where+    Dyn :: TypeRep a -> a -> Dynamic++toDyn :: Typeable a => a -> Dynamic+toDyn = Dyn typeRep++fromDyn :: Typeable a => Dynamic -> Maybe a+fromDyn (Dyn t a) | Dict <- hasTypeable t = cast a++instance Eq Dynamic+  where+    Dyn ta a == Dyn tb b+        | Just Dict <- typeEq ta tb+        , Dict      <- hasEq ta+        = a == b+    _ == _ = False++instance Show Dynamic+  where+    show (Dyn t a) | Dict <- hasShow t = show a+
− src/Data/DynamicAlt.hs 
@@ -1,28 +0,0 @@--- | An alternative to "Data.Dynamic" with a different constraint on 'toDyn'--module Data.DynamicAlt where----import Data.Dynamic ()-import Data.Typeable-import GHC.Exts-import Unsafe.Coerce--import Data.PolyProxy----data Dynamic = Dynamic TypeRep Any--toDyn :: forall a b . Typeable (a -> b) => P (a -> b) -> a -> Dynamic-toDyn _ a = case splitTyConApp $ typeOf (undefined :: a -> b) of-    (_,[ta,_]) -> Dynamic ta (unsafeCoerce a)--fromDyn :: Typeable a => Dynamic -> Maybe a-fromDyn (Dynamic t a)-    | b <- unsafeCoerce a-    , t == typeOf b-    = Just b-fromDyn _ = Nothing-
− src/Data/PolyProxy.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE PolyKinds #-}---- TODO PolyKinds can be enabled globally in GHC 7.6. In 7.4, additional annotations are needed.--module Data.PolyProxy where------ | Kind-polymorphic proxy type-data P a where P :: P a-  -- Using one letter to remove line noise-
+ src/Data/Syntactic.hs view
@@ -0,0 +1,18 @@+-- | The basic parts of the syntactic library++module Data.Syntactic+    ( module Data.Syntactic.Syntax+    , module Data.Syntactic.Traversal+    , module Data.Syntactic.Interpretation+    , module Data.Syntactic.Sugar+    , module Data.Syntactic.Decoration+    ) where++++import Data.Syntactic.Syntax+import Data.Syntactic.Traversal+import Data.Syntactic.Interpretation+import Data.Syntactic.Sugar+import Data.Syntactic.Decoration+
+ src/Data/Syntactic/Decoration.hs view
@@ -0,0 +1,110 @@+-- | Construct for decorating symbols or expressions with additional information++module Data.Syntactic.Decoration where++++import Data.Tree (Tree (..))++import Data.Tree.View++import Data.Syntactic.Syntax+import Data.Syntactic.Traversal+import Data.Syntactic.Interpretation++++-- | Decorating symbols or expressions with additional information+--+-- One usage of ':&:' is to decorate every node of a syntax tree. This is done+-- simply by changing+--+-- > AST sym sig+--+-- to+--+-- > AST (sym :&: info) sig+data (expr :&: info) sig+  where+    (:&:)+        :: { decorExpr :: expr sig+           , decorInfo :: info (DenResult sig)+           }+        -> (expr :&: info) sig++instance Project sub sup => Project sub (sup :&: info)+  where+    prj = prj . decorExpr++instance Equality expr => Equality (expr :&: info)+  where+    equal a b = decorExpr a `equal` decorExpr b+    hash      = hash . decorExpr++instance Render expr => Render (expr :&: info)+  where+    renderSym       = renderSym . decorExpr+    renderArgs args = renderArgs args . decorExpr++instance StringTree expr => StringTree (expr :&: info)+  where+    stringTreeSym args = stringTreeSym args . decorExpr++++-- | Map over a decoration+mapDecor+    :: (sym1 sig -> sym2 sig)+    -> (info1 (DenResult sig) -> info2 (DenResult sig))+    -> ((sym1 :&: info1) sig -> (sym2 :&: info2) sig)+mapDecor fs fi (s :&: i) = fs s :&: fi i++-- | Get the decoration of the top-level node+getDecor :: AST (sym :&: info) sig -> info (DenResult sig)+getDecor (Sym (_ :&: info)) = info+getDecor (f :$ _)           = getDecor f++-- | Update the decoration of the top-level node+updateDecor :: forall info sym a .+    (info a -> info a) -> ASTF (sym :&: info) a -> ASTF (sym :&: info) a+updateDecor f = match update+  where+    update+        :: (a ~ DenResult sig)+        => (sym :&: info) sig+        -> Args (AST (sym :&: info)) sig+        -> ASTF (sym :&: info) a+    update (a :&: info) args = appArgs (Sym sym) args+      where+        sym = a :&: (f info)++-- | Lift a function that operates on expressions with associated information to+-- operate on a ':&:' expression. This function is convenient to use together+-- with e.g. 'queryNodeSimple' when the domain has the form @(sym `:&:` info)@.+liftDecor :: (expr s -> info (DenResult s) -> b) -> ((expr :&: info) s -> b)+liftDecor f (a :&: info) = f a info++-- | Strip decorations from an 'AST'+stripDecor :: AST (sym :&: info) sig -> AST sym sig+stripDecor (Sym (a :&: _)) = Sym a+stripDecor (f :$ a)        = stripDecor f :$ stripDecor a++-- | Rendering of decorated syntax trees+stringTreeDecor :: forall info sym a . StringTree sym =>+    (forall a . info a -> String) -> ASTF (sym :&: info) a -> Tree String+stringTreeDecor showInfo a = mkTree [] a+  where+    mkTree :: [Tree String] -> AST (sym :&: info) sig -> Tree String+    mkTree args (Sym (expr :&: info)) = Node infoStr [stringTreeSym args expr]+      where+        infoStr = "<<" ++ showInfo info ++ ">>"+    mkTree args (f :$ a) = mkTree (mkTree [] a : args) f++-- | Show an decorated syntax tree using ASCII art+showDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> String+showDecorWith showInfo = showTree . stringTreeDecor showInfo++-- | Print an decorated syntax tree using ASCII art+drawDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> IO ()+drawDecorWith showInfo = putStrLn . showDecorWith showInfo+
+ src/Data/Syntactic/Functional.hs view
@@ -0,0 +1,666 @@+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Basics for implementing functional EDSLs++module Data.Syntactic.Functional+    ( -- * Syntactic constructs+      Name (..)+    , Construct (..)+    , Binding (..)+    , maxLam+    , lam+    , fromDeBruijn+    , BindingT (..)+    , maxLamT+    , lamT+    , BindingDomain (..)+    , MONAD (..)+    , Remon (..)+    , desugarMonad+      -- * Alpha-equivalence+    , AlphaEnv+    , alphaEq'+    , alphaEq+      -- * Evaluation+    , Denotation+    , Eval (..)+    , evalDen+    , DenotationM+    , liftDenotationM+    , RunEnv+    , EvalEnv (..)+    , compileSymDefault+    , evalOpen+    , evalClosed+      -- * Well-scoped terms+    , Ext (..)+    , lookEnv+    , BindingWS (..)+    , lamWS+    , evalOpenWS+    , evalClosedWS+    , LiftReader+    , UnReader+    , LowerReader+    , ReaderSym (..)+    , WS+    , fromWS+    , smartWS+    ) where++++import Control.Applicative+import Control.Monad.Cont+import Control.Monad.Reader+import Data.Dynamic+import Data.List (genericIndex)+import Data.Tree++import Data.Hash (hashInt)+import Data.Proxy+import Safe++import Data.Syntactic++++----------------------------------------------------------------------------------------------------+-- * Syntactic constructs+----------------------------------------------------------------------------------------------------++-- | Generic N-ary syntactic construct+--+-- 'Construct' gives a quick way to introduce a syntactic construct by giving its name and semantic+-- function.+data Construct a+  where+    Construct :: Signature sig => String -> Denotation sig -> Construct sig++instance Render Construct+  where+    renderSym (Construct name _) = name+    renderArgs = renderArgsSmart++instance Equality Construct+  where+    equal = equalDefault+    hash  = hashDefault++instance StringTree Construct++-- | Variable name+newtype Name = Name Integer+  deriving (Eq, Ord, Num, Enum, Real, Integral)++instance Show Name+  where+    show (Name n) = show n++-- | Variables and binders+data Binding a+  where+    Var :: Name -> Binding (Full a)+    Lam :: Name -> Binding (b :-> Full (a -> b))++-- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.+--+-- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation+-- that enables the following property:+--+-- @`alphaEq` a b ==> `hash` a == `hash` b@+instance Equality Binding+  where+    equal (Var v1) (Var v2) = v1==v2+    equal (Lam v1) (Lam v2) = v1==v2+    equal _ _ = False++    hash (Var _) = hashInt 0+    hash (Lam _) = hashInt 0++instance Render Binding+  where+    renderSym (Var v) = 'v' : show v+    renderSym (Lam v) = "Lam v" ++ show v+    renderArgs []     (Var v) = 'v' : show v+    renderArgs [body] (Lam v) = "(\\" ++ ('v':show v) ++ " -> " ++ body ++ ")"++instance StringTree Binding+  where+    stringTreeSym []     (Var v) = Node ('v' : show v) []+    stringTreeSym [body] (Lam v) = Node ("Lam " ++ 'v' : show v) [body]++-- | Get the highest name bound by the first 'Lam' binders at every path from the root. If the term+-- has /ordered binders/ \[1\], 'maxLam' returns the highest name introduced in the whole term.+--+-- \[1\] Ordered binders means that the names of 'Lam' nodes are decreasing along every path from+-- the root.+maxLam :: (Binding :<: s) => AST s a -> Name+maxLam (Sym lam :$ _) | Just (Lam v) <- prj lam = v+maxLam (s :$ a) = maxLam s `Prelude.max` maxLam a+maxLam _ = 0++-- | Higher-order interface for variable binding+--+-- Assumptions:+--+--   * The body @f@ does not inspect its argument.+--+--   * Applying @f@ to a term with ordered binders results in a term with /ordered binders/ \[1\].+--+-- \[1\] Ordered binders means that the names of 'Lam' nodes are decreasing along every path from+-- the root.+--+-- See \"Using Circular Programs for Higher-Order Syntax\"+-- (ICFP 2013, <http://www.cse.chalmers.se/~emax/documents/axelsson2013using.pdf>).+lam :: (Binding :<: s) => (ASTF s a -> ASTF s b) -> ASTF s (a -> b)+lam f = smartSym (Lam v) body+  where+    body = f (smartSym (Var v))+    v    = succ $ maxLam body++-- | Convert from a term with De Bruijn indexes to one with explicit names+--+-- In the argument term, variable 'Name's are treated as De Bruijn indexes, and lambda 'Name's are+-- ignored. (Ideally, one should use a different type for De Bruijn terms.)+fromDeBruijn :: (Binding :<: sym) => ASTF sym a -> ASTF sym a+fromDeBruijn = go []+  where+    go :: (Binding :<: sym) => [Name] -> ASTF sym a -> (ASTF sym a)+    go vs var           | Just (Var i) <- prj var = inj $ Var $ genericIndex vs i+    go vs (lam :$ body) | Just (Lam _) <- prj lam = inj (Lam v) :$ body'+      where+        body' = go (v:vs) body+        v     = succ $ maxLam body'+          -- Same trick as in `lam`+    go vs a = gmapT (go vs) a++-- | Typed variables and binders+data BindingT a+  where+    VarT :: Typeable a => Name -> BindingT (Full a)+    LamT :: Typeable a => Name -> BindingT (b :-> Full (a -> b))++-- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.+--+-- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation+-- that enables the following property:+--+-- @`alphaEq` a b ==> `hash` a == `hash` b@+instance Equality BindingT+  where+    equal (VarT v1) (VarT v2) = v1==v2+    equal (LamT v1) (LamT v2) = v1==v2+    equal _ _ = False++    hash (VarT _) = hashInt 0+    hash (LamT _) = hashInt 0++instance Render BindingT+  where+    renderSym (VarT v) = renderSym (Var v)+    renderSym (LamT v) = renderSym (Lam v)+    renderArgs args (VarT v) = renderArgs args (Var v)+    renderArgs args (LamT v) = renderArgs args (Lam v)++instance StringTree BindingT+  where+    stringTreeSym args (VarT v) = stringTreeSym args (Var v)+    stringTreeSym args (LamT v) = stringTreeSym args (Lam v)++-- | Get the highest name bound by the first 'LamT' binders at every path from the root. If the term+-- has /ordered binders/ \[1\], 'maxLamT' returns the highest name introduced in the whole term.+--+-- \[1\] Ordered binders means that the names of 'LamT' nodes are decreasing along every path from+-- the root.+maxLamT :: (BindingT :<: s) => AST s a -> Name+maxLamT (Sym lam :$ _) | Just (LamT n :: BindingT (b :-> a)) <- prj lam = n+maxLamT (s :$ a) = maxLamT s `Prelude.max` maxLamT a+maxLamT _ = 0++-- | Higher-order interface for typed variable binding+--+-- Assumptions:+--+--   * The body @f@ does not inspect its argument.+--+--   * Applying @f@ to a term with ordered binders results in a term with /ordered binders/ \[1\].+--+-- \[1\] Ordered binders means that the names of 'LamT' nodes are decreasing along every path from+-- the root.+--+-- See \"Using Circular Programs for Higher-Order Syntax\"+-- (ICFP 2013, <http://www.cse.chalmers.se/~emax/documents/axelsson2013using.pdf>).+lamT :: forall s a b . (BindingT :<: s, Typeable a) => (ASTF s a -> ASTF s b) -> ASTF s (a -> b)+lamT f = smartSym (LamT v :: BindingT (b :-> Full (a -> b))) body+  where+    body = f (smartSym (VarT v))+    v    = succ $ maxLamT body++-- | Domains that \"might\" include variables and binders+class BindingDomain sym+  where+    prVar :: sym sig -> Maybe Name+    prLam :: sym sig -> Maybe Name+  -- It is in principle possible to replace a constraint `BindingDomain s` by+  -- `(Project Binding s, Project BindingT s)`. However, the problem is that one then has to+  -- specify the type `t` through a `Proxy`. The `BindingDomain` class gets around this problem.++instance (BindingDomain sym1, BindingDomain sym2) => BindingDomain (sym1 :+: sym2)+  where+    prVar (InjL s) = prVar s+    prVar (InjR s) = prVar s+    prLam (InjL s) = prLam s+    prLam (InjR s) = prLam s++instance BindingDomain sym => BindingDomain (sym :&: i)+  where+    prVar = prVar . decorExpr+    prLam = prLam . decorExpr++instance BindingDomain sym => BindingDomain (AST sym)+  where+    prVar (Sym s) = prVar s+    prVar _       = Nothing+    prLam (Sym s) = prLam s+    prLam _       = Nothing++instance BindingDomain Binding+  where+    prVar (Var v) = Just v+    prVar _       = Nothing+    prLam (Lam v) = Just v+    prLam _       = Nothing++instance BindingDomain BindingT+  where+    prVar (VarT v) = Just v+    prVar _        = Nothing+    prLam (LamT v) = Just v+    prLam _        = Nothing++instance BindingDomain sym+  where+    prVar _ = Nothing+    prLam _ = Nothing++-- | Monadic constructs+--+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011+-- <http://www.cse.chalmers.se/~emax/documents/persson2011generic.pdf>).+data MONAD m sig+  where+    Return :: MONAD m (a :-> Full (m a))+    Bind   :: MONAD m (m a :-> (a -> m b) :-> Full (m b))++instance Render (MONAD m)+  where+    renderSym Return = "return"+    renderSym Bind   = "(>>=)"+    renderArgs = renderArgsSmart++instance Equality (MONAD m)+  where+    equal = equalDefault+    hash  = hashDefault++instance StringTree (MONAD m)++-- | Reifiable monad+--+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011+-- <http://www.cse.chalmers.se/~emax/documents/persson2011generic.pdf>).+--+-- It is advised to convert to/from 'Mon' using the 'Syntactic' instance provided in the modules+-- @Data.Syntactic.Sugar.Monad@ or @Data.Syntactic.Sugar.MonadT@.+newtype Remon sym m a+  where+    Remon+        :: { unRemon :: forall r . (Monad m, MONAD m :<: sym) => Cont (ASTF sym (m r)) a }+        -> Remon sym m a+  deriving (Functor)++instance (Applicative m) => Applicative (Remon sym m)+  where+    pure a  = Remon $ pure a+    f <*> a = Remon $ unRemon f <*> unRemon a++instance (Monad m) => Monad (Remon dom m)+  where+    return a = Remon $ return a+    ma >>= f = Remon $ unRemon ma >>= unRemon . f++-- | One-layer desugaring of monadic actions+desugarMonad :: (MONAD m :<: sym, Monad m) => Remon sym m (ASTF sym a) -> ASTF sym (m a)+desugarMonad = flip runCont (sugarSym Return) . unRemon++++----------------------------------------------------------------------------------------------------+-- * Alpha-equivalence+----------------------------------------------------------------------------------------------------++-- | Environment used by 'alphaEq''+type AlphaEnv = [(Name,Name)]++alphaEq' :: (Equality sym, BindingDomain sym) => AlphaEnv -> ASTF sym a -> ASTF sym b -> Bool+alphaEq' env var1 var2+    | Just v1 <- prVar var1+    , Just v2 <- prVar var2+    = case lookup v1 env of+        Nothing  -> v1==v2   -- Free variables+        Just v2' -> v2==v2'+alphaEq' env (lam1 :$ body1) (lam2 :$ body2)+    | Just v1 <- prLam lam1+    , Just v2 <- prLam lam2+    = alphaEq' ((v1,v2):env) body1 body2+alphaEq' env a b = simpleMatch (alphaEq'' env b) a++alphaEq'' :: (Equality sym, BindingDomain sym) =>+    AlphaEnv -> ASTF sym b -> sym a -> Args (AST sym) a -> Bool+alphaEq'' env b a aArgs = simpleMatch (alphaEq''' env a aArgs) b++alphaEq''' :: (Equality sym, BindingDomain sym) =>+    AlphaEnv -> sym a -> Args (AST sym) a -> sym b -> Args (AST sym) b -> Bool+alphaEq''' env a aArgs b bArgs+    | equal a b = alphaEqChildren env a' b'+    | otherwise = False+  where+    a' = appArgs (Sym undefined) aArgs+    b' = appArgs (Sym undefined) bArgs++alphaEqChildren :: (Equality sym, BindingDomain sym) => AlphaEnv -> AST sym a -> AST sym b -> Bool+alphaEqChildren _ (Sym _) (Sym _) = True+alphaEqChildren env (s :$ a) (t :$ b) = alphaEqChildren env s t && alphaEq' env a b+alphaEqChildren _ _ _ = False++-- | Alpha-equivalence+alphaEq :: (Equality sym, BindingDomain sym) => ASTF sym a -> ASTF sym b -> Bool+alphaEq = alphaEq' []++++----------------------------------------------------------------------------------------------------+-- * Evaluation+----------------------------------------------------------------------------------------------------++-- | Semantic function type of the given symbol signature+type family   Denotation sig+type instance Denotation (Full a)    = a+type instance Denotation (a :-> sig) = a -> Denotation sig++class Eval s+  where+    evalSym :: s sig -> Denotation sig++instance (Eval s, Eval t) => Eval (s :+: t)+  where+    evalSym (InjL s) = evalSym s+    evalSym (InjR s) = evalSym s++instance Eval Empty+  where+    evalSym = error "evalSym: Empty"++instance Eval sym => Eval (sym :&: info)+  where+    evalSym = evalSym . decorExpr++instance Eval Construct+  where+    evalSym (Construct _ d) = d++instance Monad m => Eval (MONAD m)+  where+    evalSym Return = return+    evalSym Bind   = (>>=)++-- | Evaluation+evalDen :: Eval s => AST s sig -> Denotation sig+evalDen = go+  where+    go :: Eval s => AST s sig -> Denotation sig+    go (Sym s)  = evalSym s+    go (s :$ a) = go s $ go a++-- | Monadic denotation; mapping from a symbol signature+--+-- > a :-> b :-> Full c+--+-- to+--+-- > m a -> m b -> m c+type family   DenotationM (m :: * -> *) sig+type instance DenotationM m (Full a)    = m a+type instance DenotationM m (a :-> sig) = m a -> DenotationM m sig++-- | Lift a 'Denotation' to 'DenotationM'+liftDenotationM :: forall m sig proxy1 proxy2 . (Monad m, Signature sig) =>+    proxy1 m -> proxy2 sig -> Denotation sig -> DenotationM m sig+liftDenotationM _ _ = help2 sig . help1 sig+  where+    sig = signature :: SigRep sig++    help1 :: Monad m =>+        SigRep sig' -> Denotation sig' -> Args (WrapFull m) sig' -> m (DenResult sig')+    help1 SigFull f _ = return f+    help1 (SigMore sig) f (WrapFull ma :* as) = do+        a <- ma+        help1 sig (f a) as++    help2 :: SigRep sig' -> (Args (WrapFull m) sig' -> m (DenResult sig')) -> DenotationM m sig'+    help2 SigFull f = f Nil+    help2 (SigMore sig) f = \a -> help2 sig (\as -> f (WrapFull a :* as))++-- | Runtime environment+type RunEnv = [(Name, Dynamic)]+  -- TODO Use a more efficient data structure?++-- | Evaluation+class EvalEnv sym env+  where+    compileSym :: proxy env -> sym sig -> DenotationM (Reader env) sig++instance (EvalEnv sym1 env, EvalEnv sym2 env) => EvalEnv (sym1 :+: sym2) env+  where+    compileSym p (InjL s) = compileSym p s+    compileSym p (InjR s) = compileSym p s++instance EvalEnv Empty env+  where+    compileSym = error "compileSym: Empty"++instance EvalEnv sym env => EvalEnv (sym :&: info) env+  where+    compileSym p = compileSym p . decorExpr++instance EvalEnv Construct env+  where+    compileSym _ s@(Construct _ d :: Construct sig) = liftDenotationM p s d+      where+        p = Proxy :: Proxy (Reader env)++instance Monad m => EvalEnv (MONAD m) env+  where+    compileSym p Return = compileSymDefault p Return+    compileSym p Bind   = compileSymDefault p Bind+      -- Pattern matching on the individual constructors is needed in order to fulfill the+      -- 'Signature' constraint required by the right-hand side.++instance EvalEnv BindingT RunEnv+  where+    compileSym _ (VarT v) = reader $ \env -> case fromJustNote (msgVar v) $ lookup v env of+        d -> fromJustNote msgType $ fromDynamic d+      where+        msgVar v = "compileSym: Variable " ++ show v ++ " not in scope"+        msgType  = "compileSym: type error"  -- TODO Print types+    compileSym _ (LamT v) = \body -> reader $ \env a -> runReader body ((v, toDyn a) : env)++-- | Simple implementation of `compileSym` from a 'Denotation'+compileSymDefault :: forall proxy env sym sig . (Eval sym, Signature sig) =>+    proxy env -> sym sig -> DenotationM (Reader env) sig+compileSymDefault p s = liftDenotationM (Proxy :: Proxy (Reader env)) s (evalSym s)++-- | \"Compile\" a term to a Haskell function+compile :: EvalEnv sym env => proxy env -> AST sym sig -> DenotationM (Reader env) sig+compile p (Sym s)  = compileSym p s+compile p (s :$ a) = compile p s $ compile p a+  -- This use of the term \"compile\" comes from \"Typing Dynamic Typing\" (Baars and Swierstra,+  -- ICFP 2002, <http://doi.acm.org/10.1145/581478.581494>)++-- | Evaluation of open terms+evalOpen :: EvalEnv sym env => env -> ASTF sym a -> a+evalOpen env a = runReader (compile Proxy a) env++-- | Evaluation of closed terms where 'RunEnv' is used as the internal environment+--+-- (Note that there is no guarantee that the term is actually closed.)+evalClosed :: EvalEnv sym RunEnv => ASTF sym a -> a+evalClosed a = runReader (compile (Proxy :: Proxy RunEnv) a) []++++----------------------------------------------------------------------------------------------------+-- * Well-scoped terms+----------------------------------------------------------------------------------------------------++-- | Environment extension+class Ext ext orig+  where+    -- | Remove the extension of an environment+    unext :: ext -> orig+    -- | Return the amount by which an environment has been extended+    diff :: Num a => Proxy ext -> Proxy orig -> a++instance Ext env env+  where+    unext = id+    diff _ _ = 0++instance (Ext env e, ext ~ (a,env)) => Ext ext e+  where+    unext = unext . snd+    diff m n = diff (fmap snd m) n + 1++-- | Lookup in an extended environment+lookEnv :: forall env a e . Ext env (a,e) => Proxy e -> Reader env a+lookEnv _ = reader $ \env -> let (a, e :: e) = unext env in a++-- | Well-scoped variable binding+--+-- Well-scoped terms are introduced to be able to evaluate without type casting. The implementation+-- is inspired by \"Typing Dynamic Typing\" (Baars and Swierstra, ICFP 2002,+-- <http://doi.acm.org/10.1145/581478.581494>) where expressions are represented as (essentially)+-- @`Reader` env a@ after \"compilation\". However, a major difference is that+-- \"Typing Dynamic Typing\" starts from an untyped term, and thus needs (safe) dynamic type casting+-- during compilation. In contrast, the denotational semantics of 'BindingWS' (the 'Eval' instance)+-- uses no type casting.+data BindingWS a+  where+    VarWS :: Ext env (a,e) => Proxy e -> BindingWS (Full (Reader env a))+    LamWS :: BindingWS (Reader (a,e) b :-> Full (Reader e (a -> b)))++instance Eval BindingWS+  where+    evalSym (VarWS p) = lookEnv p+    evalSym LamWS     = \f -> reader $ \e -> \a -> runReader f (a,e)++-- | Higher-order interface for well-scoped variable binding+--+-- Inspired by Conor McBride's "I am not a number, I am a classy hack"+-- (<http://mazzo.li/epilogue/index.html%3Fp=773.html>).+lamWS :: forall a e sym b . (BindingWS :<: sym)+    => ((forall env . (Ext env (a,e)) => ASTF sym (Reader env a)) -> ASTF sym (Reader (a,e) b))+    -> ASTF sym (Reader e (a -> b))+lamWS f = smartSym LamWS $ f $ smartSym (VarWS (Proxy :: Proxy e))++-- | Evaluation of open well-scoped terms+evalOpenWS :: Eval s => env -> ASTF s (Reader env a) -> a+evalOpenWS e = ($ e) . runReader . evalDen++-- | Evaluation of closed well-scoped terms+evalClosedWS :: Eval s => ASTF s (Reader () a) -> a+evalClosedWS = evalOpenWS ()++-- | Mapping from a symbol signature+--+-- > a :-> b :-> Full c+--+-- to+--+-- > Reader env a :-> Reader env b :-> Full (Reader env c)+type family   LiftReader env sig+type instance LiftReader env (Full a)    = Full (Reader env a)+type instance LiftReader env (a :-> sig) = Reader env a :-> LiftReader env sig++type family UnReader a+type instance UnReader (Reader e a) = a++-- | Mapping from a symbol signature+--+-- > Reader e a :-> Reader e b :-> Full (Reader e c)+--+-- to+--+-- > a :-> b :-> Full c+type family   LowerReader sig+type instance LowerReader (Full a)    = Full (UnReader a)+type instance LowerReader (a :-> sig) = UnReader a :-> LowerReader sig++-- | Wrap a symbol to give it a 'LiftReader' signature+data ReaderSym sym a+  where+    ReaderSym+        :: ( Signature sig+           , Denotation (LiftReader env sig) ~ DenotationM (Reader env) sig+           , LowerReader (LiftReader env sig) ~ sig+           )+        => Proxy env+        -> sym sig+        -> ReaderSym sym (LiftReader env sig)++instance Eval sym => Eval (ReaderSym sym)+  where+    evalSym (ReaderSym (_ :: Proxy env) s) = liftDenotationM p s $ evalSym s+      where+        p = Proxy :: Proxy (Reader env)++-- | Well-scoped 'AST'+type WS sym env a = ASTF (BindingWS :+: ReaderSym sym) (Reader env a)++-- | Convert the representation of variables and binders from 'BindingWS' to 'Binding'. The latter+-- is easier to analyze, has a 'Render' instance, etc.+fromWS :: WS sym env a -> ASTF (Binding :+: sym) a+fromWS = fromDeBruijn . go+  where+    go :: AST (BindingWS :+: ReaderSym sym) sig -> AST (Binding :+: sym) (LowerReader sig)+    go (Sym (InjL s@(VarWS p)))     = Sym (InjL (Var (diff (mkProxy2 s) (mkProxy1 s p))))+      where+        mkProxy1 = (\_ _ -> Proxy) :: BindingWS (Full (Reader e' a)) -> Proxy e -> Proxy (a,e)+        mkProxy2 = (\_ -> Proxy)   :: BindingWS (Full (Reader e' a)) -> Proxy e'+    go (Sym (InjL LamWS))           = Sym $ InjL $ Lam (-1) -- -1 since we're using De Bruijn+    go (s :$ a)                     = go s :$ go a+    go (Sym (InjR (ReaderSym _ s))) = Sym $ InjR s++-- | Make a smart constructor for well-scoped terms. 'smartWS' has any type of the form:+--+-- > smartWS :: (sub :<: sup, bsym ~ (BindingWS :+: ReaderSym sup))+-- >     => sub (a :-> b :-> ... :-> Full x)+-- >     -> ASTF bsym (Reader env a) -> ASTF bsym (Reader env b) -> ... -> ASTF bsym (Reader env x)+smartWS :: forall sig sig' bsym f sub sup env a+    .  ( Signature sig+       , Signature sig'+       , sub :<: sup+       , bsym ~ (BindingWS :+: ReaderSym sup)+       , f    ~ SmartFun bsym sig'+       , sig' ~ SmartSig f+       , bsym ~ SmartSym f+       , sig' ~ LiftReader env sig+       , Denotation (LiftReader env sig) ~ DenotationM (Reader env) sig+       , LowerReader (LiftReader env sig) ~ sig+       , Reader env a ~ DenResult sig'+       )+    => sub sig -> f+smartWS s = smartSym' $ InjR $ ReaderSym (Proxy :: Proxy env) $ inj s+
+ src/Data/Syntactic/Interpretation.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Equality and rendering of 'AST's++module Data.Syntactic.Interpretation+    ( -- * Equality+      Equality (..)+      -- * Rendering+    , Render (..)+    , renderArgsSmart+    , render+    , StringTree (..)+    , stringTree+    , showAST+    , drawAST+    , writeHtmlAST+      -- * Default interpretation+    , equalDefault+    , hashDefault+    , interpretationInstances+    ) where++++import Data.Tree (Tree (..))+import Language.Haskell.TH++import Data.Hash (Hash, combine, hashInt)+import qualified Data.Hash as Hash+import Data.Tree.View++import Data.Syntactic.Syntax++++----------------------------------------------------------------------------------------------------+-- * Equality+----------------------------------------------------------------------------------------------------++-- | Higher-kinded equality+class Equality e+  where+    -- | Higher-kinded equality+    --+    -- Comparing elements of different types is often needed when dealing with expressions with+    -- existentially quantified sub-terms.+    equal :: e a -> e b -> Bool++    -- | Higher-kinded hashing. Elements that are equal according to 'equal' must result in the same+    -- hash:+    --+    -- @equal a b  ==>  hash a == hash b@+    hash :: e a -> Hash++instance Equality sym => Equality (AST sym)+  where+    equal (Sym s1)   (Sym s2)   = equal s1 s2+    equal (s1 :$ a1) (s2 :$ a2) = equal s1 s2 && equal a1 a2+    equal _ _                   = False++    hash (Sym s)  = hashInt 0 `combine` hash s+    hash (s :$ a) = hashInt 1 `combine` hash s `combine` hash a++instance Equality sym => Eq (AST sym a)+  where+    (==) = equal++instance (Equality sym1, Equality sym2) => Equality (sym1 :+: sym2)+  where+    equal (InjL a) (InjL b) = equal a b+    equal (InjR a) (InjR b) = equal a b+    equal _ _               = False++    hash (InjL a) = hashInt 0 `combine` hash a+    hash (InjR a) = hashInt 1 `combine` hash a++instance (Equality sym1, Equality sym2) => Eq ((sym1 :+: sym2) a)+  where+    (==) = equal++instance Equality Empty+  where+    equal = error "equal: Empty"+    hash  = error "hash: Empty"++++----------------------------------------------------------------------------------------------------+-- * Rendering+----------------------------------------------------------------------------------------------------++-- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym'+-- method.+class Render sym+  where+    -- | Show a symbol as a 'String'+    renderSym :: sym sig -> String++    -- | Render a symbol given a list of rendered arguments+    renderArgs :: [String] -> sym sig -> String+    renderArgs []   s = renderSym s+    renderArgs args s = "(" ++ unwords (renderSym s : args) ++ ")"++instance (Render sym1, Render sym2) => Render (sym1 :+: sym2)+  where+    renderSym (InjL s) = renderSym s+    renderSym (InjR s) = renderSym s+    renderArgs args (InjL s) = renderArgs args s+    renderArgs args (InjR s) = renderArgs args s++-- | Implementation of 'renderArgs' that handles infix operators+renderArgsSmart :: Render sym => [String] -> sym a -> String+renderArgsSmart []   sym = renderSym sym+renderArgsSmart args sym+    | isInfix   = "(" ++ unwords [a,op,b] ++ ")"+    | otherwise = "(" ++ unwords (name : args) ++ ")"+  where+    name  = renderSym sym+    [a,b] = args+    op    = init $ tail name+    isInfix+      =  not (null name)+      && head name == '('+      && last name == ')'+      && length args == 2++-- | Render an 'AST' as concrete syntax+render :: forall sym a. Render sym => ASTF sym a -> String+render = go []+  where+    go :: [String] -> AST sym sig -> String+    go args (Sym s)  = renderArgs args s+    go args (s :$ a) = go (render a : args) s++instance Render Empty+  where+    renderSym  = error "renderSym: Empty"+    renderArgs = error "renderArgs: Empty"++instance Render sym => Show (ASTF sym a)+  where+    show = render++++-- | Convert a symbol to a 'Tree' of strings+class Render sym => StringTree sym+  where+    -- | Convert a symbol to a 'Tree' given a list of argument trees+    stringTreeSym :: [Tree String] -> sym a -> Tree String+    stringTreeSym args s = Node (renderSym s) args++instance (StringTree sym1, StringTree sym2) => StringTree (sym1 :+: sym2)+  where+    stringTreeSym args (InjL s) = stringTreeSym args s+    stringTreeSym args (InjR s) = stringTreeSym args s++instance StringTree Empty++-- | Convert an 'AST' to a 'Tree' of strings+stringTree :: forall sym a . StringTree sym => ASTF sym a -> Tree String+stringTree = go []+  where+    go :: [Tree String] -> AST sym sig -> Tree String+    go args (Sym s)  = stringTreeSym args s+    go args (s :$ a) = go (stringTree a : args) s++-- | Show a syntax tree using ASCII art+showAST :: StringTree sym => ASTF sym a -> String+showAST = showTree . stringTree++-- | Print a syntax tree using ASCII art+drawAST :: StringTree sym => ASTF sym a -> IO ()+drawAST = putStrLn . showAST++-- | Write a syntax tree to an HTML file with foldable nodes+writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO ()+writeHtmlAST file = writeHtmlTree file . fmap (\n -> NodeInfo n "") . stringTree++++----------------------------------------------------------------------------------------------------+-- * Default interpretation+----------------------------------------------------------------------------------------------------++-- | Default implementation of 'equal'+equalDefault :: Render sym => sym a -> sym b -> Bool+equalDefault a b = renderSym a == renderSym b++-- | Default implementation of 'hash'+hashDefault :: Render sym => sym a -> Hash+hashDefault = Hash.hash . renderSym++-- | Derive instances for 'Equality' and 'StringTree'+interpretationInstances :: Name -> DecsQ+interpretationInstances n =+    [d|+        instance Equality $(typ) where+          equal = equalDefault+          hash  = hashDefault+        instance StringTree $(typ)+    |]+  where+    typ = conT n+
+ src/Data/Syntactic/Sugar.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | \"Syntactic sugar\"+--+-- For details, see "Combining Deep and Shallow Embedding for EDSL"+-- (TFP 2013, <http://www.cse.chalmers.se/~emax/documents/svenningsson2013combining.pdf>).++module Data.Syntactic.Sugar where++++import Data.Syntactic.Syntax++++-- | It is usually assumed that @(`desugar` (`sugar` a))@ has the same meaning+-- as @a@.+class Syntactic a+  where+    type Domain a :: * -> *+    type Internal a+    desugar :: a -> ASTF (Domain a) (Internal a)+    sugar   :: ASTF (Domain a) (Internal a) -> a++instance Syntactic (ASTF sym a)+  where+    type Domain (ASTF sym a)   = sym+    type Internal (ASTF sym a) = a+    desugar = id+    sugar   = id++-- | Syntactic type casting+resugar :: (Syntactic a, Syntactic b, Domain a ~ Domain b, Internal a ~ Internal b) => a -> b+resugar = sugar . desugar++-- | N-ary syntactic functions+--+-- 'desugarN' has any type of the form:+--+-- > desugarN ::+-- >     ( Syntactic a+-- >     , Syntactic b+-- >     , ...+-- >     , Syntactic x+-- >     , Domain a ~ sym+-- >     , Domain b ~ sym+-- >     , ...+-- >     , Domain x ~ sym+-- >     ) => (a -> b -> ... -> x)+-- >       -> (  ASTF sym (Internal a)+-- >          -> ASTF sym (Internal b)+-- >          -> ...+-- >          -> ASTF sym (Internal x)+-- >          )+--+-- ...and vice versa for 'sugarN'.+class SyntacticN f internal | f -> internal+  where+    desugarN :: f -> internal+    sugarN   :: internal -> f++instance (Syntactic f, Domain f ~ sym, fi ~ AST sym (Full (Internal f))) => SyntacticN f fi+  where+    desugarN = desugar+    sugarN   = sugar++instance+    ( Syntactic a+    , Domain a ~ sym+    , ia ~ Internal a+    , SyntacticN f fi+    ) =>+      SyntacticN (a -> f) (AST sym (Full ia) -> fi)+  where+    desugarN f = desugarN . f . sugar+    sugarN f   = sugarN . f . desugar++-- | \"Sugared\" symbol application+--+-- 'sugarSym' has any type of the form:+--+-- > sugarSym ::+-- >     ( sub :<: AST sup+-- >     , Syntactic a+-- >     , Syntactic b+-- >     , ...+-- >     , Syntactic x+-- >     , Domain a ~ Domain b ~ ... ~ Domain x+-- >     ) => sub (Internal a :-> Internal b :-> ... :-> Full (Internal x))+-- >       -> (a -> b -> ... -> x)+sugarSym+    :: ( Signature sig+       , fi  ~ SmartFun sup sig+       , sig ~ SmartSig fi+       , sup ~ SmartSym fi+       , SyntacticN f fi+       , sub :<: sup+       )+    => sub sig -> f+sugarSym = sugarN . smartSym+
+ src/Data/Syntactic/Sugar/Binding.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instance for functions+--+-- This module is based on having 'Binding' in the domain. For 'BindingT' import module+-- "Data.Syntactic.Sugar.BindingT" instead++module Data.Syntactic.Sugar.Binding where++++import Data.Syntactic+import Data.Syntactic.Functional++++instance+    ( Syntactic a, Domain a ~ dom+    , Syntactic b, Domain b ~ dom+    , Binding :<: dom+    ) =>+      Syntactic (a -> b)+  where+    type Domain (a -> b)   = Domain a+    type Internal (a -> b) = Internal a -> Internal b+    desugar f = lam (desugar . f . sugar)+    sugar     = error "sugar not implemented for (a -> b)"+
+ src/Data/Syntactic/Sugar/BindingT.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instance for functions+--+-- This module is based on having 'BindingT' in the domain. For 'Binding' import module+-- "Data.Syntactic.Sugar.Binding" instead++module Data.Syntactic.Sugar.BindingT where++++import Data.Typeable++import Data.Syntactic+import Data.Syntactic.Functional++++instance+    ( Syntactic a, Domain a ~ dom+    , Syntactic b, Domain b ~ dom+    , BindingT :<: dom+    , Typeable (Internal a)+    ) =>+      Syntactic (a -> b)+  where+    type Domain (a -> b)   = Domain a+    type Internal (a -> b) = Internal a -> Internal b+    desugar f = lamT (desugar . f . sugar)+    sugar     = error "sugar not implemented for (a -> b)"+
+ src/Data/Syntactic/Sugar/Monad.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instance for 'Remon' using 'Binding' to handle variable binding++module Data.Syntactic.Sugar.Monad where++++import Control.Monad.Cont++import Data.Syntactic+import Data.Syntactic.Functional+import Data.Syntactic.Sugar.Binding++++-- | One-layer sugaring of monadic actions+sugarMonad :: (Binding :<: sym) => ASTF sym (m a) -> Remon sym m (ASTF sym a)+sugarMonad ma = Remon $ cont $ sugarSym Bind ma++instance+    ( Syntactic a+    , Domain a ~ sym+    , Binding :<: sym+    , MONAD m :<: sym+    , Monad m+    ) =>+      Syntactic (Remon sym m a)+  where+    type Domain (Remon sym m a)   = sym+    type Internal (Remon sym m a) = m (Internal a)+    desugar = desugarMonad . fmap desugar+    sugar   = fmap sugar   . sugarMonad+
+ src/Data/Syntactic/Sugar/MonadT.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instance for 'Remon' using 'BindingT' to handle variable binding++module Data.Syntactic.Sugar.MonadT where++++import Control.Monad.Cont+import Data.Typeable++import Data.Syntactic+import Data.Syntactic.Functional+import Data.Syntactic.Sugar.BindingT++++-- | One-layer sugaring of monadic actions+sugarMonad :: (BindingT :<: sym, Typeable a) => ASTF sym (m a) -> Remon sym m (ASTF sym a)+sugarMonad ma = Remon $ cont $ sugarSym Bind ma++instance+    ( Syntactic a+    , Domain a ~ sym+    , BindingT :<: sym+    , MONAD m  :<: sym+    , Monad m+    , Typeable (Internal a)+    ) =>+      Syntactic (Remon sym m a)+  where+    type Domain (Remon sym m a)   = sym+    type Internal (Remon sym m a) = m (Internal a)+    desugar = desugarMonad . fmap desugar+    sugar   = fmap sugar   . sugarMonad+
+ src/Data/Syntactic/Syntax.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Generic representation of typed syntax trees+--+-- For details, see: A Generic Abstract Syntax Model for Embedded Languages+-- (ICFP 2012, <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic.pdf>).++module Data.Syntactic.Syntax+    ( -- * Syntax trees+      AST (..)+    , ASTF+    , Full (..)+    , (:->) (..)+    , size+    , DenResult+      -- Smart constructors+    , SigRep (..)+    , Signature (..)+    , SmartFun+    , SmartSig+    , SmartSym+    , smartSym'+      -- * Open symbol domains+    , (:+:) (..)+    , Project (..)+    , (:<:) (..)+    , smartSym+    , Empty+      -- * Existential quantification+    , E (..)+    , liftE+    , liftE2+    , EF (..)+    , liftEF+    , liftEF2+      -- * Type inference+    , symType+    , prjP+    ) where++++import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+import Data.Typeable++import Data.Proxy++++--------------------------------------------------------------------------------+-- * Syntax trees+--------------------------------------------------------------------------------++-- | Generic abstract syntax tree, parameterized by a symbol domain+--+-- @(`AST` sym (a `:->` b))@ represents a partially applied (or unapplied)+-- symbol, missing at least one argument, while @(`AST` sym (`Full` a))@+-- represents a fully applied symbol, i.e. a complete syntax tree.+data AST sym sig+  where+    Sym  :: sym sig -> AST sym sig+    (:$) :: AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig++infixl 1 :$++-- | Fully applied abstract syntax tree+type ASTF sym a = AST sym (Full a)++instance Functor sym => Functor (AST sym)+  where+    fmap f (Sym s)  = Sym (fmap f s)+    fmap f (s :$ a) = fmap (fmap f) s :$ a++-- | Signature of a fully applied symbol+newtype Full a = Full { result :: a }+  deriving (Eq, Show, Typeable, Functor)++-- | Signature of a partially applied (or unapplied) symbol+newtype a :-> sig = Partial (a -> sig)+  deriving (Typeable, Functor)++infixr :->++-- | Count the number of symbols in an 'AST'+size :: AST sym sig -> Int+size (Sym _)  = 1+size (s :$ a) = size s + size a++-- | The result type of a symbol with the given signature+type family   DenResult sig+type instance DenResult (Full a)    = a+type instance DenResult (a :-> sig) = DenResult sig++++--------------------------------------------------------------------------------+-- * Smart constructors+--------------------------------------------------------------------------------++-- | Witness of the arity of a symbol signature+data SigRep sig+  where+    SigFull :: SigRep (Full a)+    SigMore :: SigRep sig -> SigRep (a :-> sig)++-- | Symbol signatures+class Signature sig+  where+    signature :: SigRep sig++instance Signature (Full a)+  where+    signature = SigFull++instance Signature sig => Signature (a :-> sig)+  where+    signature = SigMore signature++-- | Maps a symbol signature to the type of the corresponding smart constructor:+--+-- > SmartFun sym (a :-> b :-> ... :-> Full x) = ASTF sym a -> ASTF sym b -> ... -> ASTF sym x+type family   SmartFun (sym :: * -> *) sig+type instance SmartFun sym (Full a)    = ASTF sym a+type instance SmartFun sym (a :-> sig) = ASTF sym a -> SmartFun sym sig++-- | Maps a smart constructor type to the corresponding symbol signature:+--+-- > SmartSig (ASTF sym a -> ASTF sym b -> ... -> ASTF sym x) = a :-> b :-> ... :-> Full x+type family   SmartSig f+type instance SmartSig (AST sym sig)     = sig+type instance SmartSig (ASTF sym a -> f) = a :-> SmartSig f++-- | Returns the symbol in the result of a smart constructor+type family   SmartSym f :: * -> *+type instance SmartSym (AST sym sig) = sym+type instance SmartSym (a -> f)      = SmartSym f++-- | Make a smart constructor of a symbol. 'smartSym' has any type of the form:+--+-- > smartSym+-- >     :: sym (a :-> b :-> ... :-> Full x)+-- >     -> (ASTF sym a -> ASTF sym b -> ... -> ASTF sym x)+smartSym' :: forall sig f sym+    .  ( Signature sig+       , f   ~ SmartFun sym sig+       , sig ~ SmartSig f+       , sym ~ SmartSym f+       )+    => sym sig -> f+smartSym' s = go (signature :: SigRep sig) (Sym s)+  where+    go :: forall sig . SigRep sig -> AST sym sig -> SmartFun sym sig+    go SigFull s       = s+    go (SigMore sig) s = \a -> go sig (s :$ a)++++--------------------------------------------------------------------------------+-- * Open symbol domains+--------------------------------------------------------------------------------++-- | Direct sum of two symbol domains+data (sym1 :+: sym2) a+  where+    InjL :: sym1 a -> (sym1 :+: sym2) a+    InjR :: sym2 a -> (sym1 :+: sym2) a+  deriving (Functor, Foldable, Traversable)++infixr :+:++-- | Symbol projection+--+-- The class is defined for /all pairs of types/, but 'prj' can only succeed if @sup@ is of the form+-- @(... `:+:` sub `:+:` ...)@.+class Project sub sup+  where+    -- | Partial projection from @sup@ to @sub@+    prj :: sup a -> Maybe (sub a)++instance Project sub sup => Project sub (AST sup)+  where+    prj (Sym s) = prj s+    prj _       = Nothing++instance Project sym sym+  where+    prj = Just++instance Project sym1 (sym1 :+: sym2)+  where+    prj (InjL a) = Just a+    prj _        = Nothing++instance Project sym1 sym3 => Project sym1 (sym2 :+: sym3)+  where+    prj (InjR a) = prj a+    prj _        = Nothing++-- | If @sub@ is not in @sup@, 'prj' always returns 'Nothing'.+instance Project sub sup+  where+    prj _ = Nothing++-- | Symbol injection+--+-- The class includes types @sub@ and @sup@ where @sup@ is of the form @(... `:+:` sub `:+:` ...)@.+class Project sub sup => sub :<: sup+  where+    -- | Injection from @sub@ to @sup@+    inj :: sub a -> sup a++instance (sub :<: sup) => (sub :<: AST sup)+  where+    inj = Sym . inj++instance (sym :<: sym)+  where+    inj = id++instance (sym1 :<: (sym1 :+: sym2))+  where+    inj = InjL++instance (sym1 :<: sym3) => (sym1 :<: (sym2 :+: sym3))+  where+    inj = InjR . inj++-- The reason for separating the `Project` and `(:<:)` classes is that there are+-- types that can be instances of the former but not the latter due to type+-- constraints on the `a` type.++-- | Make a smart constructor of a symbol. 'smartSym' has any type of the form:+--+-- > smartSym :: (sub :<: AST sup)+-- >     => sub (a :-> b :-> ... :-> Full x)+-- >     -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x)+smartSym+    :: ( Signature sig+       , f   ~ SmartFun sup sig+       , sig ~ SmartSig f+       , sup ~ SmartSym f+       , sub :<: sup+       )+    => sub sig -> f+smartSym = smartSym' . inj++-- | Empty symbol type+--+-- Can be used to make uninhabited 'AST' types. It can also be used as a terminator in co-product+-- lists (e.g. to avoid overlapping instances):+--+-- > (A :+: B :+: Empty)+data Empty :: * -> *++++--------------------------------------------------------------------------------+-- * Existential quantification+--------------------------------------------------------------------------------++-- | Existential quantification+data E e+  where+    E :: e a -> E e++liftE :: (forall a . e a -> b) -> E e -> b+liftE f (E a) = f a++liftE2 :: (forall a b . e a -> e b -> c) -> E e -> E e -> c+liftE2 f (E a) (E b) = f a b++-- | Existential quantification of 'Full'-indexed type+data EF e+  where+    EF :: e (Full a) -> EF e++liftEF :: (forall a . e (Full a) -> b) -> EF e -> b+liftEF f (EF a) = f a++liftEF2 :: (forall a b . e (Full a) -> e (Full b) -> c) -> EF e -> EF e -> c+liftEF2 f (EF a) (EF b) = f a b++++--------------------------------------------------------------------------------+-- * Type inference+--------------------------------------------------------------------------------++-- | Constrain a symbol to a specific type+symType :: Proxy sym -> sym sig -> sym sig+symType _ = id++-- | Projection to a specific symbol type+prjP :: Project sub sup => Proxy sub -> sup sig -> Maybe (sub sig)+prjP _ = prj+
+ src/Data/Syntactic/Traversal.hs view
@@ -0,0 +1,202 @@+-- | Generic traversals of 'AST' terms++module Data.Syntactic.Traversal+    ( gmapQ+    , gmapT+    , everywhereUp+    , everywhereDown+    , universe+    , Args (..)+    , listArgs+    , mapArgs+    , mapArgsA+    , mapArgsM+    , foldrArgs+    , appArgs+    , listFold+    , match+    , simpleMatch+    , fold+    , simpleFold+    , matchTrans+    , mapAST+    , WrapFull (..)+    , toTree+    ) where++++import Control.Applicative+import Data.Tree++import Data.Syntactic.Syntax++++-- | Map a function over all immediate sub-terms (corresponds to the function+-- with the same name in Scrap Your Boilerplate)+gmapT :: forall sym+      .  (forall a . ASTF sym a -> ASTF sym a)+      -> (forall a . ASTF sym a -> ASTF sym a)+gmapT f a = go a+  where+    go :: AST sym a -> AST sym a+    go (s :$ a) = go s :$ f a+    go s        = s++-- | Map a function over all immediate sub-terms, collecting the results in a+-- list (corresponds to the function with the same name in Scrap Your+-- Boilerplate)+gmapQ :: forall sym b+      .  (forall a . ASTF sym a -> b)+      -> (forall a . ASTF sym a -> [b])+gmapQ f a = go a+  where+    go :: AST sym a -> [b]+    go (s :$ a) = f a : go s+    go _        = []++-- | Apply a transformation bottom-up over an 'AST' (corresponds to @everywhere@ in Scrap Your+-- Boilerplate)+everywhereUp+    :: (forall a . ASTF sym a -> ASTF sym a)+    -> (forall a . ASTF sym a -> ASTF sym a)+everywhereUp f = f . gmapT (everywhereUp f)++-- | Apply a transformation top-down over an 'AST' (corresponds to @everywhere'@ in Scrap Your+-- Boilerplate)+everywhereDown+    :: (forall a . ASTF sym a -> ASTF sym a)+    -> (forall a . ASTF sym a -> ASTF sym a)+everywhereDown f = gmapT (everywhereDown f) . f++-- | List all sub-terms (corresponds to @universe@ in Uniplate)+universe :: ASTF sym a -> [EF (AST sym)]+universe a = EF a : go a+  where+    go :: AST sym a -> [EF (AST sym)]+    go (Sym s)  = []+    go (s :$ a) = go s ++ universe a++-- | List of symbol arguments+data Args c sig+  where+    Nil  :: Args c (Full a)+    (:*) :: c (Full a) -> Args c sig -> Args c (a :-> sig)++infixr :*++-- | Map a function over an 'Args' list and collect the results in an ordinary list+listArgs :: (forall a . c (Full a) -> b) -> Args c sig -> [b]+listArgs f Nil       = []+listArgs f (a :* as) = f a : listArgs f as++-- | Map a function over an 'Args' list+mapArgs+    :: (forall a   . c1 (Full a) -> c2 (Full a))+    -> (forall sig . Args c1 sig -> Args c2 sig)+mapArgs f Nil       = Nil+mapArgs f (a :* as) = f a :* mapArgs f as++-- | Map an applicative function over an 'Args' list+mapArgsA :: Applicative f+    => (forall a   . c1 (Full a) -> f (c2 (Full a)))+    -> (forall sig . Args c1 sig -> f (Args c2 sig))+mapArgsA f Nil       = pure Nil+mapArgsA f (a :* as) = (:*) <$> f a <*> mapArgsA f as++-- | Map a monadic function over an 'Args' list+mapArgsM :: Monad m+    => (forall a   . c1 (Full a) -> m (c2 (Full a)))+    -> (forall sig . Args c1 sig -> m (Args c2 sig))+mapArgsM f = unwrapMonad . mapArgsA (WrapMonad . f)++-- | Right fold for an 'Args' list+foldrArgs+    :: (forall a . c (Full a) -> b -> b)+    -> b+    -> (forall sig . Args c sig -> b)+foldrArgs f b Nil       = b+foldrArgs f b (a :* as) = f a (foldrArgs f b as)++-- | Apply a (partially applied) symbol to a list of argument terms+appArgs :: AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)+appArgs a Nil       = a+appArgs s (a :* as) = appArgs (s :$ a) as++-- | \"Pattern match\" on an 'AST' using a function that gets direct access to+-- the top-most symbol and its sub-trees+match :: forall sym a c+    .  ( forall sig . (a ~ DenResult sig) =>+           sym sig -> Args (AST sym) sig -> c (Full a)+       )+    -> ASTF sym a+    -> c (Full a)+match f a = go a Nil+  where+    go :: (a ~ DenResult sig) => AST sym sig -> Args (AST sym) sig -> c (Full a)+    go (Sym a)  as = f a as+    go (s :$ a) as = go s (a :* as)++-- | A version of 'match' with a simpler result type+simpleMatch :: forall sym a b+    .  (forall sig . (a ~ DenResult sig) => sym sig -> Args (AST sym) sig -> b)+    -> ASTF sym a+    -> b+simpleMatch f = getConst . match (\s -> Const . f s)++-- | Fold an 'AST' using an 'Args' list to hold the results of sub-terms+fold :: forall sym c+    .  (forall sig . sym sig -> Args c sig -> c (Full (DenResult sig)))+    -> (forall a   . ASTF sym a -> c (Full a))+fold f = match (\s -> f s . mapArgs (fold f))++-- | Simplified version of 'fold' for situations where all intermediate results+-- have the same type+simpleFold :: forall sym b+    .  (forall sig . sym sig -> Args (Const b) sig -> b)+    -> (forall a   . ASTF sym a                    -> b)+simpleFold f = getConst . fold (\s -> Const . f s)++-- | Fold an 'AST' using a list to hold the results of sub-terms+listFold :: forall sym b+    .  (forall sig . sym sig -> [b] -> b)+    -> (forall a   . ASTF sym a     -> b)+listFold f = simpleFold (\s -> f s . listArgs getConst)++newtype WrapAST c sym sig = WrapAST { unWrapAST :: c (AST sym sig) }+  -- Only used in the definition of 'matchTrans'++-- | A version of 'match' where the result is a transformed syntax tree,+-- wrapped in a type constructor @c@+matchTrans :: forall sym sym' c a+    .  ( forall sig . (a ~ DenResult sig) =>+           sym sig -> Args (AST sym) sig -> c (ASTF sym' a)+       )+    -> ASTF sym a+    -> c (ASTF sym' a)+matchTrans f = unWrapAST . match (\s -> WrapAST . f s)++-- | Update the symbols in an AST+mapAST :: (forall sig' . sym1 sig' -> sym2 sig') -> AST sym1 sig -> AST sym2 sig+mapAST f (Sym s)  = Sym (f s)+mapAST f (s :$ a) = mapAST f s :$ mapAST f a++-- | Can be used to make an arbitrary type constructor indexed by @(`Full` a)@.+-- This is useful as the type constructor parameter of 'Args'. That is, use+--+-- > Args (WrapFull c) ...+--+-- instead of+--+-- > Args c ...+--+-- if @c@ is not indexed by @(`Full` a)@.+data WrapFull c a+  where+    WrapFull :: { unwrapFull :: c a } -> WrapFull c (Full a)++-- | Convert an 'AST' to a 'Tree'+toTree :: forall dom a b . (forall sig . dom sig -> b) -> ASTF dom a -> Tree b+toTree f = listFold (Node . f)+
− src/Language/Syntactic.hs 
@@ -1,30 +0,0 @@--- | The basic parts of the syntactic library--module Language.Syntactic-    ( module Data.PolyProxy-    , module Language.Syntactic.Syntax-    , module Language.Syntactic.Traversal-    , module Language.Syntactic.Constraint-    , module Language.Syntactic.Sugar-    , module Language.Syntactic.Interpretation-    , module Language.Syntactic.Interpretation.Equality-    , module Language.Syntactic.Interpretation.Render-    , module Language.Syntactic.Interpretation.Evaluation-    , module Language.Syntactic.Interpretation.Semantics-    , module Data.Constraint-    ) where----import Data.PolyProxy-import Language.Syntactic.Syntax-import Language.Syntactic.Traversal-import Language.Syntactic.Constraint-import Language.Syntactic.Sugar-import Language.Syntactic.Interpretation-import Language.Syntactic.Interpretation.Equality-import Language.Syntactic.Interpretation.Render-import Language.Syntactic.Interpretation.Evaluation-import Language.Syntactic.Interpretation.Semantics--import Data.Constraint (Constraint, Dict (..))
− src/Language/Syntactic/Constraint.hs 
@@ -1,517 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ <= 708)-{-# LANGUAGE OverlappingInstances #-}-#endif-{-# LANGUAGE UndecidableInstances #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 800)-{-# LANGUAGE UndecidableSuperClasses #-}-#endif----- | Type-constrained syntax trees--module Language.Syntactic.Constraint where----import Data.Typeable--import Data.Constraint--import Data.PolyProxy-import Language.Syntactic.Syntax-import Language.Syntactic.Interpretation.Equality-import Language.Syntactic.Interpretation.Render-import Language.Syntactic.Interpretation.Evaluation--------------------------------------------------------------------------------------- * Type predicates------------------------------------------------------------------------------------- | Intersection of type predicates-class    (c1 a, c2 a) => (c1 :/\: c2) a-instance (c1 a, c2 a) => (c1 :/\: c2) a-  where-    {-# SPECIALIZE instance (c1 a, c2 a) => (c1 :/\: c2) a #-}--infixr 5 :/\:---- | Universal type predicate-class    Top a-instance Top a where-  {-# SPECIALIZE instance Top a #-}--pTop :: P Top-pTop = P-{-# INLINABLE pTop #-}--pTypeable :: P Typeable-pTypeable = P-{-# INLINABLE pTypeable #-}---- | Evidence that the predicate @sub@ is a subset of @sup@-type Sub sub sup = forall a . Dict (sub a) -> Dict (sup a)---- | Weaken an intersection-weakL :: Sub (c1 :/\: c2) c1-weakL Dict = Dict-{-# INLINABLE weakL #-}---- | Weaken an intersection-weakR :: Sub (c1 :/\: c2) c2-weakR Dict = Dict-{-# INLINABLE weakR #-}---- | Subset relation on type predicates-class (sub :: * -> Constraint) :< (sup :: * -> Constraint)-  where-    -- | Compute evidence that @sub@ is a subset of @sup@ (i.e. that @(sup a)@-    -- implies @(sub a)@)-    sub :: Sub sub sup--instance p :< p-  where-    {-# SPECIALIZE instance p :< p #-}-    {-# INLINABLE sub #-}-    sub = id--instance (p :/\: ps) :< p-  where-    {-# SPECIALIZE instance (p :/\: ps) :< p #-}-    {-# INLINABLE sub #-}-    sub = weakL--instance (ps :< q) => ((p :/\: ps) :< q)-  where-    {-# SPECIALIZE instance (ps :< q) => ((p :/\: ps) :< q) #-}-    {-# INLINABLE sub #-}-    sub = sub . weakR--------------------------------------------------------------------------------------- * Constrained syntax------------------------------------------------------------------------------------- | Constrain the result type of the expression by the given predicate-data (:|) :: (* -> *) -> (* -> Constraint) -> (* -> *)-  where-    C :: pred (DenResult sig) => expr sig -> (expr :| pred) sig--infixl 4 :|--instance Project sub sup => Project sub (sup :| pred)-  where-    {-# SPECIALIZE instance (Project sub sup) => Project sub (sup :| pred) #-}-    {-# INLINABLE prj #-}-    prj (C s) = prj s--instance Equality dom => Equality (dom :| pred)-  where-    {-# SPECIALIZE instance (Equality dom) => Equality (dom :| pred) #-}-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (C a) (C b) = equal a b-    exprHash (C a)    = exprHash a--instance Render dom => Render (dom :| pred)-  where-    {-# SPECIALIZE instance (Render dom) => Render (dom :| pred) #-}-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym (C a) = renderSym a-    renderArgs args (C a) = renderArgs args a--instance Eval dom => Eval (dom :| pred)-  where-    {-# SPECIALIZE instance (Eval dom) => Eval (dom :| pred) #-}-    {-# INLINABLE evaluate #-}-    evaluate (C a) = evaluate a--instance StringTree dom => StringTree (dom :| pred)-  where-    {-# SPECIALIZE instance (StringTree dom) => StringTree (dom :| pred) #-}-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym args (C a) = stringTreeSym args a------ | Constrain the result type of the expression by the given predicate------ The difference between ':||' and ':|' is seen in the instances of the 'Sat'--- type:------ > type Sat (dom :|  pred) = pred :/\: Sat dom--- > type Sat (dom :|| pred) = pred-data (:||) :: (* -> *) -> (* -> Constraint) -> (* -> *)-  where-    C' :: pred (DenResult sig) => expr sig -> (expr :|| pred) sig--infixl 4 :||--instance Project sub sup => Project sub (sup :|| pred)-  where-    {-# SPECIALIZE instance (Project sub sup) => Project sub (sup :|| pred) #-}-    {-# INLINABLE prj #-}-    prj (C' s) = prj s--instance Equality dom => Equality (dom :|| pred)-  where-    {-# SPECIALIZE instance (Equality dom) => Equality (dom :|| pred) #-}-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (C' a) (C' b) = equal a b-    exprHash (C' a)     = exprHash a--instance Render dom => Render (dom :|| pred)-  where-    {-# SPECIALIZE instance (Render dom) => Render (dom :|| pred) #-}-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym (C' a) = renderSym a-    renderArgs args (C' a) = renderArgs args a--instance Eval dom => Eval (dom :|| pred)-  where-    {-# SPECIALIZE instance (Eval dom) => Eval (dom :|| pred) #-}-    {-# INLINABLE evaluate #-}-    evaluate (C' a) = evaluate a--instance StringTree dom => StringTree (dom :|| pred)-  where-    {-# SPECIALIZE instance (StringTree dom) => StringTree (dom :|| pred) #-}-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym args (C' a) = stringTreeSym args a------ | Expressions that constrain their result types-class Constrained expr-  where-    -- | Returns a predicate that is satisfied by the result type of all-    -- expressions of the given type (see 'exprDict').-    type Sat expr :: * -> Constraint--    -- | Compute a constraint on the result type of an expression-    exprDict :: expr a -> Dict (Sat expr (DenResult a))--instance Constrained dom => Constrained (AST dom)-  where-    {-# SPECIALIZE instance (Constrained dom) => Constrained (AST dom) #-}-    {-# INLINABLE exprDict #-}-    type Sat (AST dom) = Sat dom-    exprDict (Sym s)  = exprDict s-    exprDict (s :$ _) = exprDict s--instance Constrained (sub1 :+: sub2)-  where-    {-# SPECIALIZE instance (Constrained (sub1 :+: sub2)) #-}-    {-# INLINABLE exprDict #-}-    -- | An over-approximation of the union of @Sat sub1@ and @Sat sub2@-    type Sat (sub1 :+: sub2) = Top-    exprDict (InjL _) = Dict-    exprDict (InjR _) = Dict--instance Constrained dom => Constrained (dom :| pred)-  where-    {-# SPECIALIZE instance (Constrained dom) => Constrained (dom :| pred) #-}-    {-# INLINABLE exprDict #-}-    type Sat (dom :| pred) = pred :/\: Sat dom-    exprDict (C s) = case exprDict s of Dict -> Dict--instance Constrained (dom :|| pred)-  where-    {-# SPECIALIZE instance Constrained (dom :|| pred) #-}-    {-# INLINABLE exprDict #-}-    type Sat (dom :|| pred) = pred-    exprDict (C' _) = Dict--type ConstrainedBy expr p = (Constrained expr, Sat expr :< p)---- | A version of 'exprDict' that returns a constraint for a particular--- predicate @p@ as long as @(p :< Sat dom)@ holds-exprDictSub :: ConstrainedBy expr p => P p -> expr a -> Dict (p (DenResult a))-{-# SPECIALIZE INLINE exprDictSub :: (ConstrainedBy expr p) => P p -> expr a -> Dict (p (DenResult a)) #-}-exprDictSub = const $ sub . exprDict---- | A version of 'exprDict' that works for domains of the form--- @(dom1 :+: dom2)@ as long as @(Sat dom1 ~ Sat dom2)@ holds-exprDictPlus :: (Constrained dom1, Constrained dom2, Sat dom1 ~ Sat dom2) =>-    AST (dom1 :+: dom2) a -> Dict (Sat dom1 (DenResult a))-{-# SPECIALIZE INLINE-      exprDictPlus :: (Constrained dom1, Constrained dom2, Sat dom1 ~ Sat dom2)-                   => AST (dom1 :+: dom2) a -> Dict (Sat dom1 (DenResult a)) #-}-exprDictPlus (s :$ _)       = exprDictPlus s-exprDictPlus (Sym (InjL a)) = exprDict a-exprDictPlus (Sym (InjR a)) = exprDict a------ | Symbol injection (like ':<:') with constrained result types-class (Project sub sup, Sat sup a) => InjectC sub sup a-  where-    injC :: (DenResult sig ~ a) => sub sig -> sup sig--instance (InjectC sub sup a, Sat (AST sup) a) =>-    InjectC sub (AST sup) a-  where-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)-    {-# SPECIALIZE instance (InjectC sub sup a, Sat (AST sup) a) => InjectC sub (AST sup) a #-}-#endif-#endif-    {-# INLINABLE injC #-}-    injC = Sym . injC--instance (InjectC sub sup a, Sat (sup :| pred) a) =>-    InjectC sub (sup :| pred) a-  where-    {-# SPECIALIZE instance (InjectC sub sup a, Sat (sup :| pred) a) => InjectC sub (sup :| pred) a #-}-    {-# INLINABLE injC #-}-    injC = C . injC--instance (InjectC sub sup a, Sat (sup :|| pred) a) =>-    InjectC sub (sup :|| pred) a-  where-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)-    {-# SPECIALIZE instance (InjectC sub sup a, Sat (sup :|| pred) a) => InjectC sub (sup :|| pred) a #-}-#endif-#endif-    {-# INLINABLE injC #-}-    injC = C' . injC--instance (Sat expr a) => InjectC expr expr a-  where-    {-# SPECIALIZE instance (Sat expr a) => InjectC expr expr a #-}-    {-# INLINABLE injC #-}-    injC = id--instance {-# OVERLAPPABLE #-} InjectC expr1 (expr1 :+: expr2) a-  where-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)-    {-# SPECIALIZE instance InjectC expr1 (expr1 :+: expr2) a #-}-#endif-#endif-    {-# INLINABLE injC #-}-    injC = InjL--instance {-# OVERLAPPABLE #-} InjectC expr1 expr3 a =>-    InjectC expr1 (expr2 :+: expr3) a-  where-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)-    {-# SPECIALIZE instance InjectC expr1 expr3 a => InjectC expr1 (expr2 :+: expr3) a #-}-#endif-#endif-    {-# INLINABLE injC #-}-    injC = InjR . injC------ | Generic symbol application------ 'appSymC' has any type of the form:------ > appSymC :: InjectC expr (AST dom) x--- >     => expr (a :-> b :-> ... :-> Full x)--- >     -> (ASTF dom a -> ASTF dom b -> ... -> ASTF dom x)-appSymC :: (ApplySym sig f dom, InjectC sym (AST dom) (DenResult sig)) => sym sig -> f-appSymC = appSym' . injC-{-# INLINABLE appSymC #-}------ | Similar to ':||', but rather than constraining the whole result type, it assumes a result--- type of the form @c a@ and constrains the @a@.-data SubConstr1 :: (* -> *) -> (* -> *) -> (* -> Constraint) -> (* -> *)-  where-    SubConstr1 :: (p a, DenResult sig ~ c a) => dom sig -> SubConstr1 c dom p sig--instance Constrained dom => Constrained (SubConstr1 c dom p)-  where-    {-# SPECIALIZE instance Constrained dom => Constrained (SubConstr1 c dom p) #-}-    {-# INLINABLE exprDict #-}-    type Sat (SubConstr1 c dom p) = Sat dom-    exprDict (SubConstr1 s) = exprDict s--instance Project sub sup => Project sub (SubConstr1 c sup p)-  where-    {-# SPECIALIZE instance Project sub sup => Project sub (SubConstr1 c sup p) #-}-    {-# INLINABLE prj #-}-    prj (SubConstr1 s) = prj s--instance Equality dom => Equality (SubConstr1 c dom p)-  where-    {-# SPECIALIZE instance Equality dom => Equality (SubConstr1 c dom p) #-}-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (SubConstr1 a) (SubConstr1 b) = equal a b-    exprHash (SubConstr1 s) = exprHash s--instance Render dom => Render (SubConstr1 c dom p)-  where-    {-# SPECIALIZE instance Render dom => Render (SubConstr1 c dom p) #-}-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym (SubConstr1 s) = renderSym s-    renderArgs args (SubConstr1 s) = renderArgs args s--instance StringTree dom => StringTree (SubConstr1 c dom p)-  where-    {-# SPECIALIZE instance StringTree dom => StringTree (SubConstr1 c dom p) #-}-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym args (SubConstr1 a) = stringTreeSym args a--instance Eval dom => Eval (SubConstr1 c dom p)-  where-    {-# SPECIALIZE instance Eval dom => Eval (SubConstr1 c dom p) #-}-    {-# INLINABLE evaluate #-}-    evaluate (SubConstr1 a) = evaluate a------ | Similar to 'SubConstr1', but assumes a result type of the form @c a b@ and constrains both @a@--- and @b@.-data SubConstr2 :: (* -> * -> *) -> (* -> *) -> (* -> Constraint) -> (* -> Constraint) -> (* -> *)-  where-    SubConstr2 :: (DenResult sig ~ c a b, pa a, pb b) => dom sig -> SubConstr2 c dom pa pb sig--instance Constrained dom => Constrained (SubConstr2 c dom pa pb)-  where-    {-# SPECIALIZE instance Constrained dom => Constrained (SubConstr2 c dom pa pb) #-}-    {-# INLINABLE exprDict #-}-    type Sat (SubConstr2 c dom pa pb) = Sat dom-    exprDict (SubConstr2 s) = exprDict s--instance Project sub sup => Project sub (SubConstr2 c sup pa pb)-  where-    {-# SPECIALIZE instance Project sub sup => Project sub (SubConstr2 c sup pa pb) #-}-    {-# INLINABLE prj #-}-    prj (SubConstr2 s) = prj s--instance Equality dom => Equality (SubConstr2 c dom pa pb)-  where-    {-# SPECIALIZE instance Equality dom => Equality (SubConstr2 c dom pa pb) #-}-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (SubConstr2 a) (SubConstr2 b) = equal a b-    exprHash (SubConstr2 s) = exprHash s--instance Render dom => Render (SubConstr2 c dom pa pb)-  where-    {-# SPECIALIZE instance Render dom => Render (SubConstr2 c dom pa pb) #-}-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym (SubConstr2 s) = renderSym s-    renderArgs args (SubConstr2 s) = renderArgs args s--instance StringTree dom => StringTree (SubConstr2 c dom pa pb)-  where-    {-# SPECIALIZE instance StringTree dom => StringTree (SubConstr2 c dom pa pb) #-}-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym args (SubConstr2 a) = stringTreeSym args a--instance Eval dom => Eval (SubConstr2 c dom pa pb)-  where-    {-# SPECIALIZE instance Eval dom => Eval (SubConstr2 c dom pa pb) #-}-    {-# INLINABLE evaluate #-}-    evaluate (SubConstr2 a) = evaluate a--------------------------------------------------------------------------------------- * Existential quantification------------------------------------------------------------------------------------- | 'AST' with existentially quantified result type-data ASTE :: (* -> *) -> *-  where-    ASTE :: ASTF dom a -> ASTE dom--liftASTE-    :: (forall a . ASTF dom a -> b)-    -> ASTE dom-    -> b-liftASTE f (ASTE a) = f a-{-# INLINABLE liftASTE #-}--liftASTE2-    :: (forall a b . ASTF dom a -> ASTF dom b -> c)-    -> ASTE dom -> ASTE dom -> c-liftASTE2 f (ASTE a) (ASTE b) = f a b-{-# INLINABLE liftASTE2 #-}------ | 'AST' with bounded existentially quantified result type-data ASTB :: (* -> *) -> (* -> Constraint) -> *-  where-    ASTB :: p a => ASTF dom a -> ASTB dom p--liftASTB-    :: (forall a . p a => ASTF dom a -> b)-    -> ASTB dom p-    -> b-liftASTB f (ASTB a) = f a-{-# INLINABLE liftASTB #-}--liftASTB2-    :: (forall a b . (p a, p b) => ASTF dom a -> ASTF dom b -> c)-    -> ASTB dom p -> ASTB dom p -> c-liftASTB2 f (ASTB a) (ASTB b) = f a b-{-# INLINABLE liftASTB2 #-}--type ASTSAT dom = ASTB dom (Sat dom)--------------------------------------------------------------------------------------- * Misc.------------------------------------------------------------------------------------- | Empty symbol type------ Use-case:------ > data A a--- > data B a--- >--- > test :: AST (A :+: (B:||Eq) :+: Empty) a--- > test = injC (undefined :: (B :|| Eq) a)------ Without 'Empty', this would lead to an overlapping instance error due to the instances------ > InjectC (B :|| Eq) (B :|| Eq) (DenResult a)------ and------ > InjectC sub sup a, pred a) => InjectC sub (sup :|| pred) a-data Empty :: * -> *--instance Constrained Empty-  where-    type Sat Empty = Top-    exprDict = error "Not implemented: exprDict for Empty"--instance Equality Empty where-  equal      = error "Not implemented: equal for Empty"-  exprHash   = error "Not implemented: exprHash for Empty"-instance Eval Empty where-  evaluate   = error "Not implemented: equal for Empty"-instance Render Empty where-  renderSym  = error "Not implemented: renderSym for Empty"-  renderArgs = error "Not implemented: renderArgs for Empty"-instance StringTree Empty----universe :: ASTF dom a -> [ASTE dom]-universe a = ASTE a : go a-  where-    go :: AST dom a -> [ASTE dom]-    go (Sym _)  = []-    go (s :$ b) = go s ++ universe b
− src/Language/Syntactic/Constructs/Binding.hs 
@@ -1,539 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE UndecidableInstances #-}---- | General binding constructs--module Language.Syntactic.Constructs.Binding where----import qualified Control.Monad.Identity as Monad-import Control.Monad.Reader-import Data.Ix-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Tree-import Data.Typeable--import Data.Hash--import Data.PolyProxy-import Data.DynamicAlt-import Language.Syntactic-import Language.Syntactic.Constructs.Condition-import Language.Syntactic.Constructs.Construct-import Language.Syntactic.Constructs.Decoration-import Language.Syntactic.Constructs.Identity-import Language.Syntactic.Constructs.Literal-import Language.Syntactic.Constructs.Monad-import Language.Syntactic.Constructs.Tuple--------------------------------------------------------------------------------------- * Variables------------------------------------------------------------------------------------- | Variable identifier-newtype VarId = VarId { varInteger :: Integer }-  deriving (Eq, Ord, Num, Real, Integral, Enum, Ix)--instance Show VarId-  where-    show (VarId i) = show i--showVar :: VarId -> String-showVar v = "var" ++ show v------ | Variables-data Variable a-  where-    Variable :: VarId -> Variable (Full a)--instance Constrained Variable-  where-    {-# SPECIALIZE instance Constrained Variable #-}-    {-# INLINABLE exprDict #-}-    type Sat Variable = Top-    exprDict = const Dict---- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.------ 'exprHash' assigns the same hash to all variables. This is a valid--- over-approximation that enables the following property:------ @`alphaEq` a b  ==>  `exprHash` a == `exprHash` b@-instance Equality Variable-  where-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (Variable v1) (Variable v2) = v1==v2-    exprHash (Variable _)             = hashInt 0--instance Render Variable-  where-    {-# INLINABLE renderSym #-}-    renderSym (Variable v) = showVar v--instance StringTree Variable-  where-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym [] (Variable v) = Node ("var:" ++ show v) []--------------------------------------------------------------------------------------- * Lambda binding------------------------------------------------------------------------------------- | Lambda binding-data Lambda a-  where-    Lambda :: VarId -> Lambda (b :-> Full (a -> b))--instance Constrained Lambda-  where-    {-# INLINABLE exprDict #-}-    type Sat Lambda = Top-    exprDict = const Dict---- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.------ 'exprHash' assigns the same hash to all 'Lambda' bindings. This is a valid--- over-approximation that enables the following property:------ @`alphaEq` a b  ==>  `exprHash` a == `exprHash` b@-instance Equality Lambda-  where-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (Lambda v1) (Lambda v2) = v1==v2-    exprHash (Lambda _)           = hashInt 0--instance Render Lambda-  where-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym (Lambda v) = "Lambda " ++ show v-    renderArgs [body] (Lambda v) = "(\\" ++ showVar v ++ " -> "  ++ body ++ ")"--instance StringTree Lambda-  where-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym [body] (Lambda v) = Node ("Lambda " ++ show v) [body]---- | Allow an existing binding to be used with a body of a different type-reuseLambda :: Lambda (b :-> Full (a -> b)) -> Lambda (c :-> Full (a -> c))-reuseLambda (Lambda v) = Lambda v-{-# INLINABLE reuseLambda #-}--------------------------------------------------------------------------------------- * Let binding------------------------------------------------------------------------------------- | Let binding------ 'Let' is just an application operator with flipped argument order. The argument--- @(a -> b)@ is preferably constructed by 'Lambda'.-data Let a-  where-    Let :: Let (a :-> (a -> b) :-> Full b)--instance Constrained Let-  where-    {-# INLINABLE exprDict #-}-    type Sat Let = Top-    exprDict = const Dict--instance Equality Let-  where-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal Let Let = True-    exprHash Let  = hashInt 0--instance Render Let-  where-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym Let = "Let"-    renderArgs []    Let = "Let"-    renderArgs [f,a] Let = "(" ++ unwords ["letBind",f,a] ++ ")"--instance StringTree Let-  where-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym [a,body] Let = case splitAt 7 node of-        ("Lambda ", var) -> Node ("Let " ++ var) [a,body']-        _                -> Node "Let" [a,body]-      where-        Node node ~[body'] = body--instance Eval Let-  where-    {-# INLINABLE evaluate #-}-    evaluate Let = flip ($)--------------------------------------------------------------------------------------- * Interpretation------------------------------------------------------------------------------------- | Should be a capture-avoiding substitution, but it is currently not correct.------ Note: Variables with a different type than the new expression will be--- silently ignored.-subst :: forall dom a b-    .  ( ConstrainedBy dom Typeable-       , Project Lambda dom-       , Project Variable dom-       )-    => VarId       -- ^ Variable to be substituted-    -> ASTF dom a  -- ^ Expression to substitute for-    -> ASTF dom b  -- ^ Expression to substitute in-    -> ASTF dom b-subst v new = go-  where-    go :: AST dom c -> AST dom c-    go a@((prj -> Just (Lambda w)) :$ _)-        | v==w = a  -- Capture-    go (f :$ a) = go f :$ go a-    go var-        | Just (Variable w) <- prj var-        , v==w-        , Dict <- exprDictSub pTypeable new-        , Dict <- exprDictSub pTypeable var-        , Just new' <- gcast new-        = new'-    go a = a-  -- TODO Make it correct (may need to alpha-convert `new` before inserting it)-  -- TODO Should there be an error if `gcast` fails? (See note in Haddock-  --      comment.)---- | Beta-reduction of an expression. The expression to be reduced is assumed to--- be a `Lambda`.-betaReduce-    :: ( ConstrainedBy dom Typeable-       , Project Lambda dom-       , Project Variable dom-       )-    => ASTF dom a         -- ^ Argument-    -> ASTF dom (a -> b)  -- ^ Function to be reduced-    -> ASTF dom b-betaReduce new (lam :$ body)-    | Just (Lambda v) <- prj lam = subst v new body-{-# INLINABLE betaReduce #-}------ | Evaluation of expressions with variables-class EvalBind sub-  where-    evalBindSym-        :: (EvalBind dom, ConstrainedBy dom Typeable, Typeable (DenResult sig))-        => sub sig-        -> Args (AST dom) sig-        -> Reader [(VarId,Dynamic)] (DenResult sig)-    default evalBindSym-        :: (Eval sub, EvalBind dom, ConstrainedBy dom Typeable, Typeable (DenResult sig))-        => sub sig-        -> Args (AST dom) sig-        -> Reader [(VarId,Dynamic)] (DenResult sig)-    evalBindSym = evalBindSymDefault-    {-# INLINABLE evalBindSym #-}-  -- `(Typeable (DenResult sig))` is required because this dictionary cannot (in-  -- general) be obtained from `sub`. It can only be obtained from `dom`, and-  -- this is what `evalBindM` does.--instance (EvalBind sub1, EvalBind sub2) => EvalBind (sub1 :+: sub2)-  where-    {-# SPECIALIZE instance (EvalBind sub1, EvalBind sub2) => EvalBind (sub1 :+: sub2) #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym (InjL a) = evalBindSym a-    evalBindSym (InjR a) = evalBindSym a---- | Evaluation of possibly open expressions-evalBindM :: (EvalBind dom, ConstrainedBy dom Typeable) =>-    ASTF dom a -> Reader [(VarId,Dynamic)] a-evalBindM a-    | Dict <- exprDictSub pTypeable a-    = liftM result $ match (\s -> liftM Full . evalBindSym s) a-{-# INLINABLE evalBindM #-}---- | Evaluation of closed expressions-evalBind :: (EvalBind dom, ConstrainedBy dom Typeable) => ASTF dom a -> a-evalBind = flip runReader [] . evalBindM-{-# INLINABLE evalBind #-}---- | Apply a symbol denotation to a list of arguments-appDen :: Denotation sig -> Args Monad.Identity sig -> DenResult sig-appDen a Nil       = a-appDen f (a :* as) = appDen (f $ result $ Monad.runIdentity a) as-{-# INLINABLE appDen #-}---- | Convenient default implementation of 'evalBindSym'-evalBindSymDefault-    :: (Eval sub, EvalBind dom, ConstrainedBy dom Typeable)-    => sub sig-    -> Args (AST dom) sig-    -> Reader [(VarId,Dynamic)] (DenResult sig)-evalBindSymDefault sym args = do-    args' <- mapArgsM (liftM (Monad.Identity . Full) . evalBindM) args-    return $ appDen (evaluate sym) args'-{-# INLINABLE evalBindSymDefault #-}--instance EvalBind dom => EvalBind (dom :| pred)-  where-    {-# SPECIALIZE instance (EvalBind dom) => EvalBind (dom :| pred) #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym (C a) = evalBindSym a--instance EvalBind dom => EvalBind (dom :|| pred)-  where-    {-# SPECIALIZE instance (EvalBind dom) => EvalBind (dom :|| pred) #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym (C' a) = evalBindSym a--instance EvalBind dom => EvalBind (SubConstr1 c dom p)-  where-    {-# SPECIALIZE instance (EvalBind dom) => EvalBind (SubConstr1 c dom p) #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym (SubConstr1 a) = evalBindSym a--instance EvalBind dom => EvalBind (SubConstr2 c dom pa pb)-  where-    {-# SPECIALIZE instance (EvalBind dom) => EvalBind (SubConstr2 c dom pa pb) #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym (SubConstr2 a) = evalBindSym a--instance EvalBind Empty-  where-    {-# SPECIALIZE instance EvalBind Empty #-}-    evalBindSym = error "Not implemented: evalBindSym for Empty"--instance EvalBind dom => EvalBind (Decor info dom)-  where-    {-# SPECIALIZE instance (EvalBind dom) => EvalBind (Decor info dom) #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym = evalBindSym . decorExpr--instance EvalBind Identity where {-# SPECIALIZE instance EvalBind Identity #-}-instance EvalBind Construct where {-# SPECIALIZE instance EvalBind Construct #-}-instance EvalBind Literal where {-# SPECIALIZE instance EvalBind Literal #-}-instance EvalBind Condition where {-# SPECIALIZE instance EvalBind Condition #-}-instance EvalBind Tuple where {-# SPECIALIZE instance EvalBind Tuple #-}-instance EvalBind Select where {-# SPECIALIZE instance EvalBind Select #-}-instance EvalBind Let where {-# SPECIALIZE instance EvalBind Let #-}--instance Monad m => EvalBind (MONAD m) where-  {-# SPECIALIZE instance Monad m => EvalBind (MONAD m) #-}--instance EvalBind Variable-  where-    {-# SPECIALIZE instance EvalBind Variable #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym (Variable v) _ = do-        env <- ask-        case lookup v env of-            Nothing -> return $ error "evalBind: evaluating free variable"-            Just a  -> case fromDyn a of-              Just b -> return b-              _      -> return $ error "evalBind: internal type error"--instance EvalBind Lambda-  where-    {-# SPECIALIZE instance EvalBind Lambda #-}-    {-# INLINABLE evalBindSym #-}-    evalBindSym lam@(Lambda v) (body :* Nil) = do-        env <- ask-        return-            $ \a -> flip runReader ((v, toDyn (funType lam) a):env)-            $ evalBindM body-      where-        funType :: Lambda (b :-> Full (a -> b)) -> P (a -> b)-        funType = const P--------------------------------------------------------------------------------------- * Alpha equivalence------------------------------------------------------------------------------------- | Environments containing a list of variable equivalences-class VarEqEnv a-  where-    prjVarEqEnv :: a -> [(VarId,VarId)]-    modVarEqEnv :: ([(VarId,VarId)] -> [(VarId,VarId)]) -> (a -> a)--instance VarEqEnv [(VarId,VarId)]-  where-    {-# INLINABLE prjVarEqEnv #-}-    {-# INLINABLE modVarEqEnv #-}-    prjVarEqEnv = id-    modVarEqEnv = id---- | Alpha-equivalence-class AlphaEq sub1 sub2 dom env-  where-    alphaEqSym-        :: sub1 a-        -> Args (AST dom) a-        -> sub2 b-        -> Args (AST dom) b-        -> Reader env Bool-    default alphaEqSym-        :: (AlphaEq dom dom dom env, Equality sub2, sub1 ~ sub2)-        => sub1 a-        -> Args (AST dom) a-        -> sub2 b-        -> Args (AST dom) b-        -> Reader env Bool-    alphaEqSym = alphaEqSymDefault-    {-# INLINABLE alphaEqSym #-}--instance (AlphaEq subA1 subB1 dom env, AlphaEq subA2 subB2 dom env) =>-    AlphaEq (subA1 :+: subA2) (subB1 :+: subB2) dom env-  where-    {-# SPECIALIZE instance-          (AlphaEq subA1 subB1 dom env, AlphaEq subA2 subB2 dom env) =>-            AlphaEq (subA1 :+: subA2) (subB1 :+: subB2) dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (InjL a) aArgs (InjL b) bArgs = alphaEqSym a aArgs b bArgs-    alphaEqSym (InjR a) aArgs (InjR b) bArgs = alphaEqSym a aArgs b bArgs-    alphaEqSym _ _ _ _ = return False--alphaEqM :: AlphaEq dom dom dom env =>-    ASTF dom a -> ASTF dom b -> Reader env Bool-alphaEqM a b = simpleMatch (alphaEqM2 b) a-{-# INLINABLE alphaEqM #-}--alphaEqM2 :: AlphaEq dom dom dom env =>-    ASTF dom b -> dom a -> Args (AST dom) a -> Reader env Bool-alphaEqM2 b a aArgs = simpleMatch (alphaEqSym a aArgs) b-{-# INLINABLE alphaEqM2 #-}---- | Alpha-equivalence on lambda expressions. Free variables are taken to be--- equivalent if they have the same identifier.-alphaEq :: AlphaEq dom dom dom [(VarId,VarId)] =>-    ASTF dom a -> ASTF dom b -> Bool-alphaEq a b = flip runReader ([] :: [(VarId,VarId)]) $ alphaEqM a b-{-# INLINABLE alphaEq #-}--alphaEqSymDefault :: (Equality sub, AlphaEq dom dom dom env)-    => sub a-    -> Args (AST dom) a-    -> sub b-    -> Args (AST dom) b-    -> Reader env Bool-alphaEqSymDefault a aArgs b bArgs-    | equal a b = alphaEqChildren a' b'-    | otherwise = return False-  where-    a' = appArgs (Sym (undefined :: dom a)) aArgs-    b' = appArgs (Sym (undefined :: dom b)) bArgs-{-# INLINABLE alphaEqSymDefault #-}--alphaEqChildren :: AlphaEq dom dom dom env =>-    AST dom a -> AST dom b -> Reader env Bool-alphaEqChildren (Sym _)  (Sym _)  = return True-alphaEqChildren (f :$ a) (g :$ b) = liftM2 (&&)-    (alphaEqChildren f g)-    (alphaEqM a b)-alphaEqChildren _ _ = return False-{-# INLINABLE alphaEqChildren #-}--instance AlphaEq sub sub dom env => AlphaEq (sub :| pred) (sub :| pred) dom env-  where-    {-# SPECIALIZE instance (AlphaEq sub sub dom env) =>-          AlphaEq (sub :| pred) (sub :| pred) dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (C a) aArgs (C b) bArgs = alphaEqSym a aArgs b bArgs--instance AlphaEq sub sub dom env => AlphaEq (sub :|| pred) (sub :|| pred) dom env-  where-    {-# SPECIALIZE instance (AlphaEq sub sub dom env) =>-          AlphaEq (sub :|| pred) (sub :|| pred) dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (C' a) aArgs (C' b) bArgs = alphaEqSym a aArgs b bArgs--instance AlphaEq sub sub dom env => AlphaEq (SubConstr1 c sub p) (SubConstr1 c sub p) dom env-  where-    {-# SPECIALIZE instance (AlphaEq sub sub dom env) =>-          AlphaEq (SubConstr1 c sub p) (SubConstr1 c sub p) dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (SubConstr1 a) aArgs (SubConstr1 b) bArgs = alphaEqSym a aArgs b bArgs--instance AlphaEq sub sub dom env =>-    AlphaEq (SubConstr2 c sub pa pb) (SubConstr2 c sub pa pb) dom env-  where-    {-# SPECIALIZE instance (AlphaEq sub sub dom env) =>-          AlphaEq (SubConstr2 c sub pa pb) (SubConstr2 c sub pa pb) dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (SubConstr2 a) aArgs (SubConstr2 b) bArgs = alphaEqSym a aArgs b bArgs--instance AlphaEq Empty Empty dom env-  where-    {-# SPECIALIZE instance AlphaEq Empty Empty dom env #-}-    alphaEqSym = error "Not implemented: alphaEqSym for Empty"--instance AlphaEq dom dom dom env => AlphaEq Condition Condition dom env where-  {-# SPECIALIZE instance AlphaEq dom dom dom env =>-        AlphaEq Condition Condition dom env #-}-instance AlphaEq dom dom dom env => AlphaEq Construct Construct dom env where-  {-# SPECIALIZE instance AlphaEq dom dom dom env =>-        AlphaEq Construct Construct dom env #-}-instance AlphaEq dom dom dom env => AlphaEq Identity  Identity  dom env where-  {-# SPECIALIZE instance AlphaEq dom dom dom env =>-        AlphaEq Identity Identity dom env #-}-instance AlphaEq dom dom dom env => AlphaEq Let       Let       dom env where-  {-# SPECIALIZE instance AlphaEq dom dom dom env =>-        AlphaEq Let Let dom env #-}-instance AlphaEq dom dom dom env => AlphaEq Literal   Literal   dom env where-  {-# SPECIALIZE instance AlphaEq dom dom dom env =>-        AlphaEq Literal Literal dom env #-}-instance AlphaEq dom dom dom env => AlphaEq Select    Select    dom env where-  {-# SPECIALIZE instance AlphaEq dom dom dom env =>-        AlphaEq Select Select dom env #-}-instance AlphaEq dom dom dom env => AlphaEq Tuple     Tuple     dom env where-  {-# SPECIALIZE instance AlphaEq dom dom dom env =>-        AlphaEq Tuple Tuple dom env #-}--instance AlphaEq sub sub dom env =>-    AlphaEq (Decor info sub) (Decor info sub) dom env-  where-    {-# SPECIALIZE instance (AlphaEq sub sub dom env) =>-          AlphaEq (Decor info sub) (Decor info sub) dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym a aArgs b bArgs =-        alphaEqSym (decorExpr a) aArgs (decorExpr b) bArgs--instance (AlphaEq dom dom dom env, Monad m) => AlphaEq (MONAD m) (MONAD m) dom env-  where-    {-# SPECIALIZE instance (AlphaEq dom dom dom env, Monad m) =>-          AlphaEq (MONAD m) (MONAD m) dom env #-}--instance (AlphaEq dom dom dom env, VarEqEnv env) =>-    AlphaEq Variable Variable dom env-  where-    {-# SPECIALIZE instance (AlphaEq dom dom dom env, VarEqEnv env) =>-          AlphaEq Variable Variable dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (Variable v1) _ (Variable v2) _ = do-        env <- asks prjVarEqEnv-        case lookup v1 env of-          Nothing  -> return (v1==v2)   -- Free variables-          Just v2' -> return (v2==v2')--instance (AlphaEq dom dom dom env, VarEqEnv env) =>-    AlphaEq Lambda Lambda dom env-  where-    {-# SPECIALIZE instance (AlphaEq dom dom dom env, VarEqEnv env) =>-          AlphaEq Lambda Lambda dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (Lambda v1) (body1 :* Nil) (Lambda v2) (body2 :* Nil) =-        local (modVarEqEnv ((v1,v2):)) $ alphaEqM body1 body2
− src/Language/Syntactic/Constructs/Binding/HigherOrder.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}---- | This module provides binding constructs using higher-order syntax and a--- function ('reify') for translating to first-order syntax. Expressions--- constructed using the exported interface (specifically, not introducing--- 'Variable's explicitly) are guaranteed to have well-behaved translation.--module Language.Syntactic.Constructs.Binding.HigherOrder-    ( Variable-    , Let (..)-    , HOLambda (..)-    , HODomain-    , FODomain-    , CLambda-    , IsHODomain (..)-    , reifyM-    , reifyTop-    , reify-    ) where----import Control.Monad.State--import Language.Syntactic-import Language.Syntactic.Constructs.Binding------ | Higher-order lambda binding-data HOLambda dom p pVar a-  where-    HOLambda-        :: (p a, pVar a)-        => (ASTF (HODomain dom p pVar) a -> ASTF (HODomain dom p pVar) b)-        -> HOLambda dom p pVar (Full (a -> b))---- | Adding support for higher-order abstract syntax to a domain-type HODomain dom p pVar = (HOLambda dom p pVar :+: (Variable :|| pVar) :+: dom) :|| p---- | Equivalent to 'HODomain' (including type constraints), but using a first-order representation--- of binding-type FODomain dom p pVar = (CLambda pVar :+: (Variable :|| pVar) :+: dom) :|| p---- | 'Lambda' with a constraint on the bound variable type-type CLambda pVar = SubConstr2 (->) Lambda pVar Top------ | An abstraction of 'HODomain'-class IsHODomain dom p pVar | dom -> p pVar-  where-    lambda :: (p (a -> b), p a, pVar a) => (ASTF dom a -> ASTF dom b) -> ASTF dom (a -> b)--instance IsHODomain (HODomain dom p pVar) p pVar-  where-    {-# SPECIALIZE instance IsHODomain (HODomain dom p pVar) p pVar #-}-    {-# INLINABLE lambda #-}-    lambda = injC . HOLambda--instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , IsHODomain dom p pVar-    , p (Internal a -> Internal b)-    , p (Internal a)-    , pVar (Internal a)-    ) =>-      Syntactic (a -> b)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , IsHODomain dom p pVar-                            , p (Internal a -> Internal b)-                            , p (Internal a)-                            , pVar (Internal a)-                            ) => Syntactic (a -> b) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a -> b)   = Domain a-    type Internal (a -> b) = Internal a -> Internal b-    desugar f = lambda (desugar . f . sugar)-    sugar     = error "sugar not implemented for (a -> b)"-      -- TODO An implementation of sugar would require dom to have some kind of-      --      application. Perhaps use `Let` for this?----reifyM :: forall dom p pVar m a-       .  MonadState VarId m-       => AST (HODomain dom p pVar) a -> m (AST (FODomain dom p pVar) a)-reifyM (f :$ a)            = liftM2 (:$) (reifyM f) (reifyM a)-reifyM (Sym (C' (InjR a))) = return $ Sym $ C' $ InjR a-reifyM (Sym (C' (InjL (HOLambda f)))) = do-    v    <- get; put (v+1)-    body <- reifyM $ f $ injC $ symType pVar $ C' (Variable v)-    return $ injC (symType pLam $ SubConstr2 (Lambda v)) :$ body-  where-    pVar = P::P (Variable :|| pVar)-    pLam = P::P (CLambda pVar)---- | Translating expressions with higher-order binding to corresponding--- expressions using first-order binding-reifyTop :: AST (HODomain dom p pVar) a -> AST (FODomain dom p pVar) a-reifyTop = flip evalState 0 . reifyM-  -- It is assumed that there are no 'Variable' constructors (i.e. no free-  -- variables) in the argument. This is guaranteed by the exported interface.---- | Reify an n-ary syntactic function-reify :: (Syntactic a, Domain a ~ HODomain dom p pVar) =>-    a -> ASTF (FODomain dom p pVar) (Internal a)-reify = reifyTop . desugar
− src/Language/Syntactic/Constructs/Binding/Optimize.hs 
@@ -1,165 +0,0 @@--- | Basic optimization-module Language.Syntactic.Constructs.Binding.Optimize where---- TODO This module should live somewhere else.----import Control.Monad.Writer-import Data.Set as Set-import Data.Typeable--import Language.Syntactic-import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Constructs.Binding.HigherOrder-import Language.Syntactic.Constructs.Condition-import Language.Syntactic.Constructs.Construct-import Language.Syntactic.Constructs.Identity-import Language.Syntactic.Constructs.Literal-import Language.Syntactic.Constructs.Tuple------ | Constant folder------ Given an expression and the statically known value of that expression,--- returns a (possibly) new expression with the same meaning as the original.--- Typically, the result will be a 'Literal', if the relevant type constraints--- are satisfied.-type ConstFolder dom = forall a . ASTF dom a -> a -> ASTF dom a---- | Basic optimization-class Optimize sym-  where-    -- | Bottom-up optimization of an expression. The optimization performed is-    -- up to each instance, but the intention is to provide a sensible set of-    -- \"always-appropriate\" optimizations. The default implementation-    -- 'optimizeSymDefault' does only constant folding. This constant folding-    -- uses the set of free variables to know when it's static evaluation is-    -- possible. Thus it is possible to help constant folding of other-    -- constructs by pruning away parts of the syntax tree that are known not to-    -- be needed. For example, by replacing (using ordinary Haskell as an-    -- example)-    ---    -- > if True then a else b-    ---    -- with @a@, we don't need to report the free variables in @b@. This, in-    -- turn, can lead to more constant folding higher up in the expression.-    optimizeSym-        :: Optimize' dom-        => ConstFolder dom-        -> (sym sig -> AST dom sig)-        -> sym sig-        -> Args (AST dom) sig-        -> Writer (Set VarId) (ASTF dom (DenResult sig))-    optimizeSym = optimizeSymDefault-    {-# INLINABLE optimizeSym #-}--  -- The reason for having @dom@ as a class parameter is that many instances-  -- need to put additional constraints on @dom@.--type Optimize' dom =-    ( Optimize dom-    , EvalBind dom-    , AlphaEq dom dom dom [(VarId,VarId)]-    , ConstrainedBy dom Typeable-    )--instance (Optimize sub1, Optimize sub2) => Optimize (sub1 :+: sub2)-  where-    {-# SPECIALIZE instance (Optimize sub1, Optimize sub2) =>-          Optimize (sub1 :+: sub2) #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym constFold injecter (InjL a) = optimizeSym constFold (injecter . InjL) a-    optimizeSym constFold injecter (InjR a) = optimizeSym constFold (injecter . InjR) a--optimizeM :: Optimize' dom-    => ConstFolder dom-    -> ASTF dom a-    -> Writer (Set VarId) (ASTF dom a)-optimizeM constFold = matchTrans (optimizeSym constFold Sym)---- | Optimize an expression-optimize :: Optimize' dom => ConstFolder dom -> ASTF dom a -> ASTF dom a-optimize constFold = fst . runWriter . optimizeM constFold---- | Convenient default implementation of 'optimizeSym' (uses 'evalBind' to--- partially evaluate)-optimizeSymDefault :: Optimize' dom-    => ConstFolder dom-    -> (sym sig -> AST dom sig)-    -> sym sig-    -> Args (AST dom) sig-    -> Writer (Set VarId) (ASTF dom (DenResult sig))-optimizeSymDefault constFold injecter sym args = do-    (args',vars) <- listen $ mapArgsM (optimizeM constFold) args-    let result = appArgs (injecter sym) args'-        value  = evalBind result-    if Set.null vars-      then return $ constFold result value-      else return result--instance Optimize dom => Optimize (dom :| p)-  where-    {-# SPECIALIZE instance Optimize dom => Optimize (dom :| p) #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym cf i (C s) args = optimizeSym cf (i . C) s args--instance Optimize dom => Optimize (dom :|| p)-  where-    {-# SPECIALIZE instance Optimize dom => Optimize (dom :|| p) #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym cf i (C' s) args = optimizeSym cf (i . C') s args--instance Optimize Empty-  where-    {-# SPECIALIZE instance Optimize Empty #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym _ _ _ _ = error "Not implemented: optimizeSym for Empty"--instance Optimize dom => Optimize (SubConstr1 c dom p)-  where-    {-# SPECIALIZE instance Optimize dom => Optimize (SubConstr1 c dom p) #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym cf i (SubConstr1 s) args = optimizeSym cf (i . SubConstr1) s args--instance Optimize dom => Optimize (SubConstr2 c dom pa pb)-  where-    {-# SPECIALIZE instance Optimize dom => Optimize (SubConstr2 c dom pa pb) #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym cf i (SubConstr2 s) args = optimizeSym cf (i . SubConstr2) s args--instance Optimize Identity  where {-# SPECIALIZE instance Optimize Identity #-}-instance Optimize Construct where {-# SPECIALIZE instance Optimize Construct #-}-instance Optimize Literal   where {-# SPECIALIZE instance Optimize Literal #-}-instance Optimize Tuple     where {-# SPECIALIZE instance Optimize Tuple #-}-instance Optimize Select    where {-# SPECIALIZE instance Optimize Select #-}-instance Optimize Let       where {-# SPECIALIZE instance Optimize Let #-}--instance Optimize Condition-  where-    {-# SPECIALIZE instance Optimize Condition #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym constFold injecter cond@Condition args@(c :* t :* e :* Nil)-        | Set.null cVars = optimizeM constFold t_or_e-        | alphaEq t e    = optimizeM constFold t-        | otherwise      = optimizeSymDefault constFold injecter cond args-      where-        (c',cVars) = runWriter $ optimizeM constFold c-        t_or_e     = if evalBind c' then t else e--instance Optimize Variable-  where-    {-# SPECIALIZE instance Optimize Variable #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym _ injecter var@(Variable v) Nil = do-        tell (singleton v)-        return (injecter var)--instance Optimize Lambda-  where-    {-# SPECIALIZE instance Optimize Lambda #-}-    {-# INLINABLE optimizeSym #-}-    optimizeSym constFold injecter lam@(Lambda v) (body :* Nil) = do-        body' <- censor (delete v) $ optimizeM constFold body-        return $ injecter lam :$ body'
− src/Language/Syntactic/Constructs/Condition.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Conditional expressions--module Language.Syntactic.Constructs.Condition where----import Language.Syntactic----data Condition sig-  where-    Condition :: Condition (Bool :-> a :-> a :-> Full a)--instance Constrained Condition-  where-    {-# SPECIALIZE instance Constrained Condition #-}-    {-# INLINABLE exprDict #-}-    type Sat Condition = Top-    exprDict = const Dict--instance Semantic Condition-  where-    {-# SPECIALIZE instance Semantic Condition #-}-    {-# INLINABLE semantics #-}-    semantics Condition = Sem "condition" (\c t e -> if c then t else e)--semanticInstances ''Condition
− src/Language/Syntactic/Constructs/Construct.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Provides a simple way to make syntactic constructs for prototyping. Note--- that 'Construct' is quite unsafe as it only uses 'String' to distinguish--- between different constructs. Also, 'Construct' has a very free type that--- allows any number of arguments.--module Language.Syntactic.Constructs.Construct where----import Language.Syntactic----data Construct sig-  where-    Construct :: String -> Denotation sig -> Construct sig--instance Constrained Construct-  where-    {-# SPECIALIZE instance Constrained Construct #-}-    {-# INLINABLE exprDict #-}-    type Sat Construct = Top-    exprDict = const Dict--instance Semantic Construct-  where-    {-# SPECIALIZE instance Semantic Construct #-}-    {-# INLINABLE semantics #-}-    semantics (Construct name den) = Sem name den--semanticInstances ''Construct
− src/Language/Syntactic/Constructs/Decoration.hs 
@@ -1,149 +0,0 @@--- | Construct for decorating expressions with additional information--module Language.Syntactic.Constructs.Decoration where----import Data.Tree (Tree (..))--import Data.Tree.View--import Language.Syntactic--------------------------------------------------------------------------------------- * Decoration------------------------------------------------------------------------------------- | Decorating symbols with additional information------ One usage of 'Decor' is to decorate every node of a syntax tree. This is done--- simply by changing------ > AST dom sig------ to------ > AST (Decor info dom) sig-data Decor info expr sig-  where-    Decor-        :: { decorInfo :: info (DenResult sig)-           , decorExpr :: expr sig-           }-        -> Decor info expr sig--instance Constrained expr => Constrained (Decor info expr)-  where-    {-# SPECIALIZE instance (Constrained expr) => Constrained (Decor info expr) #-}-    {-# INLINABLE exprDict #-}-    type Sat (Decor info expr) = Sat expr-    exprDict (Decor _ a) = exprDict a--instance Project sub sup => Project sub (Decor info sup)-  where-    {-# SPECIALIZE instance (Project sub sup) => Project sub (Decor info sup) #-}-    {-# INLINABLE prj #-}-    prj = prj . decorExpr--instance Equality expr => Equality (Decor info expr)-  where-    {-# SPECIALIZE instance (Equality expr) => Equality (Decor info expr) #-}-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal a b = decorExpr a `equal` decorExpr b-    exprHash  = exprHash . decorExpr--instance Render expr => Render (Decor info expr)-  where-    {-# SPECIALIZE instance (Render expr) => Render (Decor info expr) #-}-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym = renderSym . decorExpr-    renderArgs args = renderArgs args . decorExpr--instance StringTree expr => StringTree (Decor info expr)-  where-    {-# SPECIALIZE instance (StringTree expr) => StringTree (Decor info expr) #-}-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym args = stringTreeSym args . decorExpr--instance Eval expr => Eval (Decor info expr)-  where-    {-# SPECIALIZE instance (Eval expr) => Eval (Decor info expr) #-}-    {-# INLINABLE evaluate #-}-    evaluate = evaluate . decorExpr------ | Get the decoration of the top-level node-getInfo :: AST (Decor info dom) sig -> info (DenResult sig)-getInfo (Sym (Decor info _)) = info-getInfo (f :$ _)             = getInfo f-{-# INLINABLE getInfo #-}---- | Update the decoration of the top-level node-updateDecor :: forall info dom a .-    (info a -> info a) -> ASTF (Decor info dom) a -> ASTF (Decor info dom) a-updateDecor f = match update-  where-    update-        :: (a ~ DenResult sig)-        => Decor info dom sig-        -> Args (AST (Decor info dom)) sig-        -> ASTF (Decor info dom) a-    update (Decor info a) args = appArgs (Sym sym) args-      where-        sym = Decor (f info) a---- | Lift a function that operates on expressions with associated information to--- operate on an 'Decor' expression. This function is convenient to use together--- with e.g. 'queryNodeSimple' when the domain has the form--- @(`Decor` info dom)@.-liftDecor :: (expr s -> info (DenResult s) -> b) -> (Decor info expr s -> b)-liftDecor f (Decor info a) = f a info-{-# INLINABLE liftDecor #-}---- | Collect the decorations of all nodes-collectInfo :: (forall sig . info sig -> b) -> AST (Decor info dom) a -> [b]-collectInfo coll (Sym (Decor info _)) = [coll info]-collectInfo coll (f :$ a) = collectInfo coll f ++ collectInfo coll a---- | Rendering of decorated syntax trees-stringTreeDecor :: forall info dom a . (StringTree dom) =>-    (forall sig. info sig -> String) -> ASTF (Decor info dom) a -> Tree String-stringTreeDecor showInfo = mkTree []-  where-    mkTree :: [Tree String] -> AST (Decor info dom) sig -> Tree String-    mkTree args (Sym (Decor info expr)) = Node infoStr [stringTreeSym args expr]-      where-        infoStr = "<<" ++ showInfo info ++ ">>"-    mkTree args (f :$ a) = mkTree (mkTree [] a : args) f---- | Show an decorated syntax tree using ASCII art-showDecorWith :: StringTree dom-              => (forall sig. info sig -> String)-              -> ASTF (Decor info dom) a -> String-showDecorWith showInfo = showTree . stringTreeDecor showInfo---- | Print an decorated syntax tree using ASCII art-drawDecorWith :: StringTree dom-              => (forall sig. info sig -> String)-              -> ASTF (Decor info dom) a -> IO ()-drawDecorWith showInfo = putStrLn . showDecorWith showInfo--writeHtmlDecorWith :: forall info sym a. (StringTree sym)-                   => (forall sig. info sig -> String)-                   -> FilePath -> ASTF (Decor info sym) a -> IO ()-writeHtmlDecorWith showInfo file = writeHtmlTree Nothing file . mkTree []-  where-    mkTree :: [Tree NodeInfo] -> AST (Decor info sym) sig -> Tree NodeInfo-    mkTree args (f :$ a) = mkTree (mkTree [] a : args) f-    mkTree args (Sym (Decor info expr)) = Node (NodeInfo InitiallyExpanded (renderSym expr) (showInfo info)) args---- | Strip decorations from an 'AST'-stripDecor :: AST (Decor info dom) sig -> AST dom sig-stripDecor (Sym (Decor _ a)) = Sym a-stripDecor (f :$ a)          = stripDecor f :$ stripDecor a-{-# INLINABLE stripDecor #-}
− src/Language/Syntactic/Constructs/Identity.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Identity function--module Language.Syntactic.Constructs.Identity where----import Language.Syntactic------ | Identity function-data Identity sig-  where-    Id :: Identity (a :-> Full a)--instance Constrained Identity-  where-    {-# SPECIALIZE instance Constrained Identity #-}-    {-# INLINABLE exprDict #-}-    type Sat Identity = Top-    exprDict = const Dict--instance Semantic Identity-  where-    {-# SPECIALIZE instance Semantic Identity #-}-    {-# INLINABLE semantics #-}-    semantics Id = Sem "id" id--semanticInstances ''Identity
− src/Language/Syntactic/Constructs/Literal.hs 
@@ -1,47 +0,0 @@--- | Literal expressions--module Language.Syntactic.Constructs.Literal where----import Data.Typeable--import Data.Hash--import Language.Syntactic----data Literal sig-  where-    Literal :: (Eq a, Show a, Typeable a) => a -> Literal (Full a)--instance Constrained Literal-  where-    {-# SPECIALIZE instance Constrained Literal #-}-    {-# INLINABLE exprDict #-}-    type Sat Literal = Eq :/\: Show :/\: Typeable :/\: Top-    exprDict (Literal _) = Dict--instance Equality Literal-  where-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    Literal a `equal` Literal b = case cast a of-        Just a' -> a'==b-        Nothing -> False--    exprHash (Literal a) = hash (show a)--instance Render Literal-  where-    {-# INLINABLE renderSym #-}-    renderSym (Literal a) = show a--instance StringTree Literal--instance Eval Literal-  where-    {-# SPECIALIZE instance Eval Literal #-}-    {-# INLINABLE evaluate #-}-    evaluate (Literal a) = a
− src/Language/Syntactic/Constructs/Monad.hs 
@@ -1,60 +0,0 @@--- | Monadic constructs------ This module is based on the paper--- /Generic Monadic Constructs for Embedded Languages/ (Persson et al., IFL 2011--- <http://www.cse.chalmers.se/~emax/documents/persson2011generic.pdf>).--module Language.Syntactic.Constructs.Monad where----import Control.Monad--import Language.Syntactic----data MONAD m sig-  where-    Return :: MONAD m (a    :-> Full (m a))-    Bind   :: MONAD m (m a  :-> (a -> m b) :-> Full (m b))-    Then   :: MONAD m (m a  :-> m b        :-> Full (m b))-    When   :: MONAD m (Bool :-> m ()       :-> Full (m ()))--instance Constrained (MONAD m)-  where-    {-# SPECIALIZE instance Constrained (MONAD m) #-}-    {-# INLINABLE exprDict #-}-    type Sat (MONAD m) = Top-    exprDict = const Dict--instance Monad m => Semantic (MONAD m)-  where-    {-# SPECIALIZE instance (Monad m) => Semantic (MONAD m) #-}-    {-# INLINABLE semantics #-}-    semantics Return = Sem "return" return-    semantics Bind   = Sem "bind"   (>>=)-    semantics Then   = Sem "then"   (>>)-    semantics When   = Sem "when"   when--instance Monad m => Equality   (MONAD m) where-  {-# SPECIALIZE instance (Monad m) => Equality (MONAD m) #-}-  {-# INLINABLE equal #-}-  {-# INLINABLE exprHash #-}-  equal = equalDefault-  exprHash = exprHashDefault-instance Monad m => Render     (MONAD m) where-  {-# SPECIALIZE instance (Monad m) => Render (MONAD m) #-}-  {-# INLINABLE renderSym #-}-  renderSym = renderSymDefault-instance Monad m => Eval       (MONAD m) where-  {-# SPECIALIZE instance (Monad m) => Eval (MONAD m) #-}-  {-# INLINABLE evaluate #-}-  evaluate = evaluateDefault-instance Monad m => StringTree (MONAD m) where-  {-# SPECIALIZE instance (Monad m) => StringTree (MONAD m) #-}---- | Projection with explicit monad type-prjMonad :: Project (MONAD m) sup => P m -> sup sig -> Maybe (MONAD m sig)-prjMonad _ = prj-{-# INLINABLE prjMonad #-}
− src/Language/Syntactic/Constructs/Tuple.hs 
@@ -1,286 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Construction and elimination of tuples in the object language--module Language.Syntactic.Constructs.Tuple where----import Data.Tuple.Select--import Language.Syntactic--------------------------------------------------------------------------------------- * Construction------------------------------------------------------------------------------------- | Expressions for constructing tuples-data Tuple sig-  where-    Tup2 :: Tuple (a :-> b :-> Full (a,b))-    Tup3 :: Tuple (a :-> b :-> c :-> Full (a,b,c))-    Tup4 :: Tuple (a :-> b :-> c :-> d :-> Full (a,b,c,d))-    Tup5 :: Tuple (a :-> b :-> c :-> d :-> e :-> Full (a,b,c,d,e))-    Tup6 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> Full (a,b,c,d,e,f))-    Tup7 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> Full (a,b,c,d,e,f,g))-    Tup8 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> Full (a,b,c,d,e,f,g,h))-    Tup9 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> Full (a,b,c,d,e,f,g,h,i))-    Tup10 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> Full (a,b,c,d,e,f,g,h,i,j))-    Tup11 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> Full (a,b,c,d,e,f,g,h,i,j,k))-    Tup12 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> Full (a,b,c,d,e,f,g,h,i,j,k,l))-    Tup13 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> m :-> Full (a,b,c,d,e,f,g,h,i,j,k,l,m))-    Tup14 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> m :-> n :-> Full (a,b,c,d,e,f,g,h,i,j,k,l,m,n))-    Tup15 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> m :-> n :-> o :-> Full (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o))--instance Constrained Tuple-  where-    {-# INLINABLE exprDict #-}-    type Sat Tuple = Top-    exprDict = const Dict--instance Semantic Tuple-  where-    {-# INLINABLE semantics #-}-    semantics Tup2  = Sem "tup2"  (,)-    semantics Tup3  = Sem "tup3"  (,,)-    semantics Tup4  = Sem "tup4"  (,,,)-    semantics Tup5  = Sem "tup5"  (,,,,)-    semantics Tup6  = Sem "tup6"  (,,,,,)-    semantics Tup7  = Sem "tup7"  (,,,,,,)-    semantics Tup8  = Sem "tup8"  (,,,,,,,)-    semantics Tup9  = Sem "tup9"  (,,,,,,,,)-    semantics Tup10 = Sem "tup10" (,,,,,,,,,)-    semantics Tup11 = Sem "tup11" (,,,,,,,,,,)-    semantics Tup12 = Sem "tup12" (,,,,,,,,,,,)-    semantics Tup13 = Sem "tup13" (,,,,,,,,,,,,)-    semantics Tup14 = Sem "tup14" (,,,,,,,,,,,,,)-    semantics Tup15 = Sem "tup15" (,,,,,,,,,,,,,,)--semanticInstances ''Tuple--------------------------------------------------------------------------------------- * Projection------------------------------------------------------------------------------------- | These families ('Sel1'' - 'Sel15'') are needed because of the problem--- described in:------ <http://emil-fp.blogspot.com/2011/08/fundeps-weaker-than-type-families.html>-type family Sel1' a-type instance Sel1' (a,b)                           = a-type instance Sel1' (a,b,c)                         = a-type instance Sel1' (a,b,c,d)                       = a-type instance Sel1' (a,b,c,d,e)                     = a-type instance Sel1' (a,b,c,d,e,f)                   = a-type instance Sel1' (a,b,c,d,e,f,g)                 = a-type instance Sel1' (a,b,c,d,e,f,g,h)               = a-type instance Sel1' (a,b,c,d,e,f,g,h,i)             = a-type instance Sel1' (a,b,c,d,e,f,g,h,i,j)           = a-type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k)         = a-type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l)       = a-type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = a-type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = a-type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = a--type family Sel2' a-type instance Sel2' (a,b)                           = b-type instance Sel2' (a,b,c)                         = b-type instance Sel2' (a,b,c,d)                       = b-type instance Sel2' (a,b,c,d,e)                     = b-type instance Sel2' (a,b,c,d,e,f)                   = b-type instance Sel2' (a,b,c,d,e,f,g)                 = b-type instance Sel2' (a,b,c,d,e,f,g,h)               = b-type instance Sel2' (a,b,c,d,e,f,g,h,i)             = b-type instance Sel2' (a,b,c,d,e,f,g,h,i,j)           = b-type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k)         = b-type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l)       = b-type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = b-type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = b-type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = b--type family Sel3' a-type instance Sel3' (a,b,c)                         = c-type instance Sel3' (a,b,c,d)                       = c-type instance Sel3' (a,b,c,d,e)                     = c-type instance Sel3' (a,b,c,d,e,f)                   = c-type instance Sel3' (a,b,c,d,e,f,g)                 = c-type instance Sel3' (a,b,c,d,e,f,g,h)               = c-type instance Sel3' (a,b,c,d,e,f,g,h,i)             = c-type instance Sel3' (a,b,c,d,e,f,g,h,i,j)           = c-type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k)         = c-type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l)       = c-type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = c-type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = c-type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = c--type family Sel4' a-type instance Sel4' (a,b,c,d)                       = d-type instance Sel4' (a,b,c,d,e)                     = d-type instance Sel4' (a,b,c,d,e,f)                   = d-type instance Sel4' (a,b,c,d,e,f,g)                 = d-type instance Sel4' (a,b,c,d,e,f,g,h)               = d-type instance Sel4' (a,b,c,d,e,f,g,h,i)             = d-type instance Sel4' (a,b,c,d,e,f,g,h,i,j)           = d-type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k)         = d-type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l)       = d-type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = d-type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = d-type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = d--type family Sel5' a-type instance Sel5' (a,b,c,d,e)                     = e-type instance Sel5' (a,b,c,d,e,f)                   = e-type instance Sel5' (a,b,c,d,e,f,g)                 = e-type instance Sel5' (a,b,c,d,e,f,g,h)               = e-type instance Sel5' (a,b,c,d,e,f,g,h,i)             = e-type instance Sel5' (a,b,c,d,e,f,g,h,i,j)           = e-type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k)         = e-type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l)       = e-type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = e-type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = e-type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = e--type family Sel6' a-type instance Sel6' (a,b,c,d,e,f)                   = f-type instance Sel6' (a,b,c,d,e,f,g)                 = f-type instance Sel6' (a,b,c,d,e,f,g,h)               = f-type instance Sel6' (a,b,c,d,e,f,g,h,i)             = f-type instance Sel6' (a,b,c,d,e,f,g,h,i,j)           = f-type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k)         = f-type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l)       = f-type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = f-type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = f-type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = f--type family Sel7' a-type instance Sel7' (a,b,c,d,e,f,g)                 = g-type instance Sel7' (a,b,c,d,e,f,g,h)               = g-type instance Sel7' (a,b,c,d,e,f,g,h,i)             = g-type instance Sel7' (a,b,c,d,e,f,g,h,i,j)           = g-type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k)         = g-type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l)       = g-type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = g-type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = g-type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = g--type family Sel8' a-type instance Sel8' (a,b,c,d,e,f,g,h)               = h-type instance Sel8' (a,b,c,d,e,f,g,h,i)             = h-type instance Sel8' (a,b,c,d,e,f,g,h,i,j)           = h-type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k)         = h-type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l)       = h-type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = h-type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = h-type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = h--type family Sel9' a-type instance Sel9' (a,b,c,d,e,f,g,h,i)             = i-type instance Sel9' (a,b,c,d,e,f,g,h,i,j)           = i-type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k)         = i-type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l)       = i-type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = i-type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = i-type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = i--type family Sel10' a-type instance Sel10' (a,b,c,d,e,f,g,h,i,j)           = j-type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k)         = j-type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l)       = j-type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = j-type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = j-type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = j--type family Sel11' a-type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k)         = k-type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l)       = k-type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = k-type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = k-type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = k--type family Sel12' a-type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l)       = l-type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = l-type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = l-type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = l--type family Sel13' a-type instance Sel13' (a,b,c,d,e,f,g,h,i,j,k,l,m)     = m-type instance Sel13' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = m-type instance Sel13' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = m--type family Sel14' a-type instance Sel14' (a,b,c,d,e,f,g,h,i,j,k,l,m,n)   = n-type instance Sel14' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = n--type family Sel15' a-type instance Sel15' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = o---- | Expressions for selecting elements of a tuple-data Select a-  where-    Sel1 :: (Sel1 a b, Sel1' a ~ b) => Select (a :-> Full b)-    Sel2 :: (Sel2 a b, Sel2' a ~ b) => Select (a :-> Full b)-    Sel3 :: (Sel3 a b, Sel3' a ~ b) => Select (a :-> Full b)-    Sel4 :: (Sel4 a b, Sel4' a ~ b) => Select (a :-> Full b)-    Sel5 :: (Sel5 a b, Sel5' a ~ b) => Select (a :-> Full b)-    Sel6 :: (Sel6 a b, Sel6' a ~ b) => Select (a :-> Full b)-    Sel7 :: (Sel7 a b, Sel7' a ~ b) => Select (a :-> Full b)-    Sel8 :: (Sel8 a b, Sel8' a ~ b) => Select (a :-> Full b)-    Sel9 :: (Sel9 a b, Sel9' a ~ b) => Select (a :-> Full b)-    Sel10 :: (Sel10 a b, Sel10' a ~ b) => Select (a :-> Full b)-    Sel11 :: (Sel11 a b, Sel11' a ~ b) => Select (a :-> Full b)-    Sel12 :: (Sel12 a b, Sel12' a ~ b) => Select (a :-> Full b)-    Sel13 :: (Sel13 a b, Sel13' a ~ b) => Select (a :-> Full b)-    Sel14 :: (Sel14 a b, Sel14' a ~ b) => Select (a :-> Full b)-    Sel15 :: (Sel15 a b, Sel15' a ~ b) => Select (a :-> Full b)--instance Constrained Select-  where-    {-# INLINABLE exprDict #-}-    type Sat Select = Top-    exprDict = const Dict--instance Semantic Select-  where-    {-# INLINABLE semantics #-}-    semantics Sel1 = Sem "sel1" sel1-    semantics Sel2 = Sem "sel2" sel2-    semantics Sel3 = Sem "sel3" sel3-    semantics Sel4 = Sem "sel4" sel4-    semantics Sel5 = Sem "sel5" sel5-    semantics Sel6 = Sem "sel6" sel6-    semantics Sel7 = Sem "sel7" sel7-    semantics Sel8 = Sem "sel8" sel8-    semantics Sel9 = Sem "sel9" sel9-    semantics Sel10 = Sem "sel10" sel10-    semantics Sel11 = Sem "sel11" sel11-    semantics Sel12 = Sem "sel12" sel12-    semantics Sel13 = Sem "sel13" sel13-    semantics Sel14 = Sem "sel14" sel14-    semantics Sel15 = Sem "sel15" sel15--semanticInstances ''Select---- | Return the selected position, e.g.------ > selectPos (Sel3 poly :: Select Poly ((Int,Int,Int,Int) :-> Full Int)) = 3-selectPos :: Select a -> Int-selectPos Sel1 = 1-selectPos Sel2 = 2-selectPos Sel3 = 3-selectPos Sel4 = 4-selectPos Sel5 = 5-selectPos Sel6 = 6-selectPos Sel7 = 7-selectPos Sel8 = 8-selectPos Sel9 = 9-selectPos Sel10 = 10-selectPos Sel11 = 11-selectPos Sel12 = 12-selectPos Sel13 = 13-selectPos Sel14 = 14-selectPos Sel15 = 15
− src/Language/Syntactic/Frontend/Monad.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}---- | Monadic constructs------ This module is based on the paper--- /Generic Monadic Constructs for Embedded Languages/ (Persson et al., IFL 2011--- <http://www.cse.chalmers.se/~emax/documents/persson2011generic.pdf>).--module Language.Syntactic.Frontend.Monad where----import Control.Applicative-import Control.Monad.Cont-import Data.Typeable--import Language.Syntactic-import Language.Syntactic.Constructs.Binding.HigherOrder-import Language.Syntactic.Constructs.Monad------ TODO Unfortunately, this module hard-codes the use of `Typeable`. The problem is this: Say we---      replace `Typeable` in the definition of `Mon` by a parameter `p`. Then `sugarMonad` will get---      a constraint `p (a -> m r)`. But `r` existentially quantified and can only be constrained in---      the definition of `Mon`. With `Typeable` this works because---      `(Typeable1 m, Typeable a, Typeable r)` implies `Typeable (a -> m r)`.---- | User interface to embedded monadic programs-newtype Mon dom m a-  where-    Mon-        :: { unMon-              :: forall r . (Monad m, Typeable r, InjectC (MONAD m) dom (m r))-              => Cont (ASTF dom (m r)) a-           }-        -> Mon dom m a--deriving instance Functor (Mon dom m)--instance (Monad m) => Monad (Mon dom m)-  where-    return a = Mon $ return a-    ma >>= f = Mon $ unMon ma >>= unMon . f--instance (Monad m, Applicative m) => Applicative (Mon dom m)-  where-    pure  = return-    (<*>) = ap---- | One-layer desugaring of monadic actions-desugarMonad-    :: ( IsHODomain dom Typeable pVar-       , InjectC (MONAD m) dom (m a)-       , Monad m-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-       , Typeable m-#else-       , Typeable1 m-#endif-       , Typeable a-       )-    => Mon dom m (ASTF dom a) -> ASTF dom (m a)-desugarMonad = flip runCont (sugarSymC Return) . unMon---- | One-layer sugaring of monadic actions-sugarMonad-    :: ( IsHODomain dom Typeable pVar-       , Monad m-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-       , Typeable m-#else-       , Typeable1 m-#endif-       , Typeable a-       , pVar a-       )-    => ASTF dom (m a) -> Mon dom m (ASTF dom a)-sugarMonad ma = Mon $ cont $ sugarSymC Bind ma--instance ( Syntactic a, Domain a ~ dom-         , IsHODomain dom Typeable pVar-         , InjectC (MONAD m) dom (m (Internal a))-         , Monad m-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-         , Typeable m-#else-         , Typeable1 m-#endif-         , Typeable (Internal a)-         , pVar (Internal a)-         ) =>-           Syntactic (Mon dom m a)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , IsHODomain dom Typeable pVar-                            , InjectC (MONAD m) dom (m (Internal a))-                            , Monad m-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-                            , Typeable m-#else-                            , Typeable1 m-#endif-                            , Typeable (Internal a)-                            , pVar (Internal a)-                            ) => Syntactic (Mon dom m a) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (Mon dom m a)   = dom-    type Internal (Mon dom m a) = m (Internal a)-    desugar = desugarMonad . fmap desugar-    sugar   = fmap sugar   . sugarMonad
− src/Language/Syntactic/Frontend/Tuple.hs 
@@ -1,1239 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}---- | 'Syntactic' instances for Haskell tuples--module Language.Syntactic.Frontend.Tuple where----import Language.Syntactic-import Language.Syntactic.Constructs.Tuple-import Data.Tuple.Curry----instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , InjectC Tuple dom-        ( Internal a-        , Internal b-        )-    , InjectC Select dom (Internal a)-    , InjectC Select dom (Internal b)-    ) =>-      Syntactic (a,b)-  where-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , InjectC Tuple dom-                                ( Internal a-                                , Internal b-                                )-                            , InjectC Select dom (Internal a)-                            , InjectC Select dom (Internal b)-                            ) => Syntactic (a,b) #-}-#endif-#endif-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b) = Domain a-    type Internal (a,b) =-        ( Internal a-        , Internal b-        )--    -- desugar = uncurryN $ sugarSymC Tup2-    desugar (a,b) = sugarSymC Tup2 a b-    sugar a =-        ( sugarSymC Sel1 a-        , sugarSymC Sel2 a-        )---- instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     ) =>---       Syntactic (a,b,c)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             ) => Syntactic (a,b,c) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c) = Domain a---     type Internal (a,b,c) =---         ( Internal a---         , Internal b---         , Internal c---         )------     desugar = uncurryN $ sugarSymC Tup3---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     ) =>---       Syntactic (a,b,c,d)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             ) => Syntactic (a,b,c,d) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d) = Domain a---     type Internal (a,b,c,d) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         )------     desugar = uncurryN $ sugarSymC Tup4---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     ) =>---       Syntactic (a,b,c,d,e)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             ) => Syntactic (a,b,c,d,e) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e) = Domain a---     type Internal (a,b,c,d,e) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         )------     desugar = uncurryN $ sugarSymC Tup5---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     ) =>---       Syntactic (a,b,c,d,e,f)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             ) => Syntactic (a,b,c,d,e,f) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f) = Domain a---     type Internal (a,b,c,d,e,f) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         )------     desugar = uncurryN $ sugarSymC Tup6---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     ) =>---       Syntactic (a,b,c,d,e,f,g)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             ) => Syntactic (a,b,c,d,e,f,g) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g) = Domain a---     type Internal (a,b,c,d,e,f,g) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         )------     desugar = uncurryN $ sugarSymC Tup7---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             ) => Syntactic (a,b,c,d,e,f,g,h) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h) = Domain a---     type Internal (a,b,c,d,e,f,g,h) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         )------     desugar = uncurryN $ sugarSymC Tup8---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , Syntactic i, Domain i ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     , InjectC Select dom (Internal i)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h,i)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , Syntactic i, Domain i ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 , Internal i---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             , InjectC Select dom (Internal i)---                             ) => Syntactic (a,b,c,d,e,f,g,h,i) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h,i) = Domain a---     type Internal (a,b,c,d,e,f,g,h,i) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         )------     desugar = uncurryN $ sugarSymC Tup9---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         , sugarSymC Sel9 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , Syntactic i, Domain i ~ dom---     , Syntactic j, Domain j ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     , InjectC Select dom (Internal i)---     , InjectC Select dom (Internal j)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h,i,j)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , Syntactic i, Domain i ~ dom---                             , Syntactic j, Domain j ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 , Internal i---                                 , Internal j---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             , InjectC Select dom (Internal i)---                             , InjectC Select dom (Internal j)---                             ) =>---                               Syntactic (a,b,c,d,e,f,g,h,i,j) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h,i,j) = Domain a---     type Internal (a,b,c,d,e,f,g,h,i,j) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         )------     desugar = uncurryN $ sugarSymC Tup10---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         , sugarSymC Sel9 a---         , sugarSymC Sel10 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , Syntactic i, Domain i ~ dom---     , Syntactic j, Domain j ~ dom---     , Syntactic k, Domain k ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     , InjectC Select dom (Internal i)---     , InjectC Select dom (Internal j)---     , InjectC Select dom (Internal k)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h,i,j,k)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , Syntactic i, Domain i ~ dom---                             , Syntactic j, Domain j ~ dom---                             , Syntactic k, Domain k ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 , Internal i---                                 , Internal j---                                 , Internal k---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             , InjectC Select dom (Internal i)---                             , InjectC Select dom (Internal j)---                             , InjectC Select dom (Internal k)---                             ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h,i,j,k) = Domain a---     type Internal (a,b,c,d,e,f,g,h,i,j,k) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         )------     desugar = uncurryN $ sugarSymC Tup11---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         , sugarSymC Sel9 a---         , sugarSymC Sel10 a---         , sugarSymC Sel11 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , Syntactic i, Domain i ~ dom---     , Syntactic j, Domain j ~ dom---     , Syntactic k, Domain k ~ dom---     , Syntactic l, Domain l ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     , InjectC Select dom (Internal i)---     , InjectC Select dom (Internal j)---     , InjectC Select dom (Internal k)---     , InjectC Select dom (Internal l)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h,i,j,k,l)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , Syntactic i, Domain i ~ dom---                             , Syntactic j, Domain j ~ dom---                             , Syntactic k, Domain k ~ dom---                             , Syntactic l, Domain l ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 , Internal i---                                 , Internal j---                                 , Internal k---                                 , Internal l---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             , InjectC Select dom (Internal i)---                             , InjectC Select dom (Internal j)---                             , InjectC Select dom (Internal k)---                             , InjectC Select dom (Internal l)---                             ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h,i,j,k,l) = Domain a---     type Internal (a,b,c,d,e,f,g,h,i,j,k,l) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         )------     desugar = uncurryN $ sugarSymC Tup12---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         , sugarSymC Sel9 a---         , sugarSymC Sel10 a---         , sugarSymC Sel11 a---         , sugarSymC Sel12 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , Syntactic i, Domain i ~ dom---     , Syntactic j, Domain j ~ dom---     , Syntactic k, Domain k ~ dom---     , Syntactic l, Domain l ~ dom---     , Syntactic m, Domain m ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         , Internal m---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     , InjectC Select dom (Internal i)---     , InjectC Select dom (Internal j)---     , InjectC Select dom (Internal k)---     , InjectC Select dom (Internal l)---     , InjectC Select dom (Internal m)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , Syntactic i, Domain i ~ dom---                             , Syntactic j, Domain j ~ dom---                             , Syntactic k, Domain k ~ dom---                             , Syntactic l, Domain l ~ dom---                             , Syntactic m, Domain m ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 , Internal i---                                 , Internal j---                                 , Internal k---                                 , Internal l---                                 , Internal m---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             , InjectC Select dom (Internal i)---                             , InjectC Select dom (Internal j)---                             , InjectC Select dom (Internal k)---                             , InjectC Select dom (Internal l)---                             , InjectC Select dom (Internal m)---                             ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m) = Domain a---     type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         , Internal m---         )------     desugar = uncurryN $ sugarSymC Tup13---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         , sugarSymC Sel9 a---         , sugarSymC Sel10 a---         , sugarSymC Sel11 a---         , sugarSymC Sel12 a---         , sugarSymC Sel13 a---         )------ instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , Syntactic i, Domain i ~ dom---     , Syntactic j, Domain j ~ dom---     , Syntactic k, Domain k ~ dom---     , Syntactic l, Domain l ~ dom---     , Syntactic m, Domain m ~ dom---     , Syntactic n, Domain n ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         , Internal m---         , Internal n---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     , InjectC Select dom (Internal i)---     , InjectC Select dom (Internal j)---     , InjectC Select dom (Internal k)---     , InjectC Select dom (Internal l)---     , InjectC Select dom (Internal m)---     , InjectC Select dom (Internal n)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , Syntactic i, Domain i ~ dom---                             , Syntactic j, Domain j ~ dom---                             , Syntactic k, Domain k ~ dom---                             , Syntactic l, Domain l ~ dom---                             , Syntactic m, Domain m ~ dom---                             , Syntactic n, Domain n ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 , Internal i---                                 , Internal j---                                 , Internal k---                                 , Internal l---                                 , Internal m---                                 , Internal n---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             , InjectC Select dom (Internal i)---                             , InjectC Select dom (Internal j)---                             , InjectC Select dom (Internal k)---                             , InjectC Select dom (Internal l)---                             , InjectC Select dom (Internal m)---                             , InjectC Select dom (Internal n)---                             ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = Domain a---     type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         , Internal m---         , Internal n---         )------     desugar = uncurryN $ sugarSymC Tup14---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         , sugarSymC Sel9 a---         , sugarSymC Sel10 a---         , sugarSymC Sel11 a---         , sugarSymC Sel12 a---         , sugarSymC Sel13 a---         , sugarSymC Sel14 a---         )--------- instance---     ( Syntactic a, Domain a ~ dom---     , Syntactic b, Domain b ~ dom---     , Syntactic c, Domain c ~ dom---     , Syntactic d, Domain d ~ dom---     , Syntactic e, Domain e ~ dom---     , Syntactic f, Domain f ~ dom---     , Syntactic g, Domain g ~ dom---     , Syntactic h, Domain h ~ dom---     , Syntactic i, Domain i ~ dom---     , Syntactic j, Domain j ~ dom---     , Syntactic k, Domain k ~ dom---     , Syntactic l, Domain l ~ dom---     , Syntactic m, Domain m ~ dom---     , Syntactic n, Domain n ~ dom---     , Syntactic o, Domain o ~ dom---     , InjectC Tuple dom---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         , Internal m---         , Internal n---         , Internal o---         )---     , InjectC Select dom (Internal a)---     , InjectC Select dom (Internal b)---     , InjectC Select dom (Internal c)---     , InjectC Select dom (Internal d)---     , InjectC Select dom (Internal e)---     , InjectC Select dom (Internal f)---     , InjectC Select dom (Internal g)---     , InjectC Select dom (Internal h)---     , InjectC Select dom (Internal i)---     , InjectC Select dom (Internal j)---     , InjectC Select dom (Internal k)---     , InjectC Select dom (Internal l)---     , InjectC Select dom (Internal m)---     , InjectC Select dom (Internal n)---     , InjectC Select dom (Internal o)---     ) =>---       Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)---   where---     {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom---                             , Syntactic b, Domain b ~ dom---                             , Syntactic c, Domain c ~ dom---                             , Syntactic d, Domain d ~ dom---                             , Syntactic e, Domain e ~ dom---                             , Syntactic f, Domain f ~ dom---                             , Syntactic g, Domain g ~ dom---                             , Syntactic h, Domain h ~ dom---                             , Syntactic i, Domain i ~ dom---                             , Syntactic j, Domain j ~ dom---                             , Syntactic k, Domain k ~ dom---                             , Syntactic l, Domain l ~ dom---                             , Syntactic m, Domain m ~ dom---                             , Syntactic n, Domain n ~ dom---                             , Syntactic o, Domain o ~ dom---                             , InjectC Tuple dom---                                 ( Internal a---                                 , Internal b---                                 , Internal c---                                 , Internal d---                                 , Internal e---                                 , Internal f---                                 , Internal g---                                 , Internal h---                                 , Internal i---                                 , Internal j---                                 , Internal k---                                 , Internal l---                                 , Internal m---                                 , Internal n---                                 , Internal o---                                 )---                             , InjectC Select dom (Internal a)---                             , InjectC Select dom (Internal b)---                             , InjectC Select dom (Internal c)---                             , InjectC Select dom (Internal d)---                             , InjectC Select dom (Internal e)---                             , InjectC Select dom (Internal f)---                             , InjectC Select dom (Internal g)---                             , InjectC Select dom (Internal h)---                             , InjectC Select dom (Internal i)---                             , InjectC Select dom (Internal j)---                             , InjectC Select dom (Internal k)---                             , InjectC Select dom (Internal l)---                             , InjectC Select dom (Internal m)---                             , InjectC Select dom (Internal n)---                             , InjectC Select dom (Internal o)---                             ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) #-}---     {-# INLINABLE desugar #-}---     {-# INLINABLE sugar #-}---     type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = Domain a---     type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) =---         ( Internal a---         , Internal b---         , Internal c---         , Internal d---         , Internal e---         , Internal f---         , Internal g---         , Internal h---         , Internal i---         , Internal j---         , Internal k---         , Internal l---         , Internal m---         , Internal n---         , Internal o---         )------     desugar = uncurryN $ sugarSymC Tup15---     sugar a =---         ( sugarSymC Sel1 a---         , sugarSymC Sel2 a---         , sugarSymC Sel3 a---         , sugarSymC Sel4 a---         , sugarSymC Sel5 a---         , sugarSymC Sel6 a---         , sugarSymC Sel7 a---         , sugarSymC Sel8 a---         , sugarSymC Sel9 a---         , sugarSymC Sel10 a---         , sugarSymC Sel11 a---         , sugarSymC Sel12 a---         , sugarSymC Sel13 a---         , sugarSymC Sel14 a---         , sugarSymC Sel15 a---         )
− src/Language/Syntactic/Frontend/TupleConstrained.hs 
@@ -1,1812 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif---- | Constrained 'Syntactic' instances for Haskell tuples--module Language.Syntactic.Frontend.TupleConstrained-    ( TupleSat-    ) where----import Data.Constraint-import Data.Tuple.Curry--import Language.Syntactic-import Language.Syntactic.Constructs.Tuple------ | Type-level function computing the predicate attached to 'Tuple' or 'Select'--- (whichever appears first) in a domain.-class TupleSat (dom :: * -> *) (p :: * -> Constraint) | dom -> p--instance TupleSat (Tuple :|| p) p where-  {-# SPECIALIZE instance TupleSat (Tuple :|| p) p #-}-instance TupleSat ((Tuple :|| p) :+: dom2) p where-  {-# SPECIALIZE instance TupleSat ((Tuple :|| p) :+: dom2) p #-}--instance TupleSat (Select :|| p) p where-  {-# SPECIALIZE instance TupleSat (Select :|| p) p #-}-instance TupleSat ((Select :|| p) :+: dom2) p where-  {-# SPECIALIZE instance TupleSat ((Select :|| p) :+: dom2) p #-}--instance TupleSat dom p => TupleSat (dom :| q) p where-  {-# SPECIALIZE instance TupleSat dom p => TupleSat (dom :| q) p #-}-instance TupleSat dom p => TupleSat (dom :|| q) p where-  {-# SPECIALIZE instance TupleSat dom p => TupleSat (dom :|| q) p #-}-instance TupleSat dom2 p => TupleSat (dom1 :+: dom2) p where-  {-# SPECIALIZE instance TupleSat dom2 p => TupleSat (dom1 :+: dom2) p #-}----sugarSymC' :: forall sym dom sig b c p-    .  ( TupleSat dom p-       , p (DenResult sig)-       , InjectC (sym :|| p) (AST dom) (DenResult sig)-       , ApplySym sig b dom-       , SyntacticN c b-       )-    => sym sig -> c-sugarSymC' s = sugarSymC (C' s :: (sym :|| p) sig)-{-# INLINABLE sugarSymC' #-}----instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , TupleSat dom p-    , p (Internal a, Internal b)-    , p (Internal a)-    , p (Internal b)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    ) =>-      Syntactic (a,b)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , TupleSat dom p-                            , p (Internal a, Internal b)-                            , p (Internal a)-                            , p (Internal b)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            ) => Syntactic (a,b) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b) = Domain a-    type Internal (a,b) =-        ( Internal a-        , Internal b-        )--    desugar = uncurryN $ sugarSymC' Tup2-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        )--instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    ) =>-      Syntactic (a,b,c)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            ) => Syntactic (a,b,c) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c) = Domain a-    type Internal (a,b,c) =-        ( Internal a-        , Internal b-        , Internal c-        )--    desugar = uncurryN $ sugarSymC' Tup3-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        )--instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    ) =>-      Syntactic (a,b,c,d)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            ) => Syntactic (a,b,c,d) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d) = Domain a-    type Internal (a,b,c,d) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        )--    desugar = uncurryN $ sugarSymC' Tup4-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        )--instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    ) =>-      Syntactic (a,b,c,d,e)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            ) => Syntactic (a,b,c,d,e) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e) = Domain a-    type Internal (a,b,c,d,e) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        )--    desugar = uncurryN $ sugarSymC' Tup5-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        )--instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    ) =>-      Syntactic (a,b,c,d,e,f)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            ) => Syntactic (a,b,c,d,e,f) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f) = Domain a-    type Internal (a,b,c,d,e,f) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        )--    desugar = uncurryN $ sugarSymC' Tup6-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        )--instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    ) =>-      Syntactic (a,b,c,d,e,f,g)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            ) => Syntactic (a,b,c,d,e,f,g) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g) = Domain a-    type Internal (a,b,c,d,e,f,g) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        )--    desugar = uncurryN $ sugarSymC' Tup7-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            ) => Syntactic (a,b,c,d,e,f,g,h) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h) = Domain a-    type Internal (a,b,c,d,e,f,g,h) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        )--    desugar = uncurryN $ sugarSymC' Tup8-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , Syntactic i, Domain i ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , p (Internal i)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    , InjectC (Select :|| p) dom (Internal i)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h,i)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , Syntactic i, Domain i ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , p (Internal i)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            , InjectC (Select :|| p) dom (Internal i)-                            ) => Syntactic (a,b,c,d,e,f,g,h,i) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h,i) = Domain a-    type Internal (a,b,c,d,e,f,g,h,i) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        )--    desugar = uncurryN $ sugarSymC' Tup9-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        , sugarSymC' Sel9 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , Syntactic i, Domain i ~ dom-    , Syntactic j, Domain j ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , p (Internal i)-    , p (Internal j)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    , InjectC (Select :|| p) dom (Internal i)-    , InjectC (Select :|| p) dom (Internal j)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h,i,j)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , Syntactic i, Domain i ~ dom-                            , Syntactic j, Domain j ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , p (Internal i)-                            , p (Internal j)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            , InjectC (Select :|| p) dom (Internal i)-                            , InjectC (Select :|| p) dom (Internal j)-                            ) => Syntactic (a,b,c,d,e,f,g,h,i,j) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h,i,j) = Domain a-    type Internal (a,b,c,d,e,f,g,h,i,j) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        )--    desugar = uncurryN $ sugarSymC' Tup10-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        , sugarSymC' Sel9 a-        , sugarSymC' Sel10 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , Syntactic i, Domain i ~ dom-    , Syntactic j, Domain j ~ dom-    , Syntactic k, Domain k ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , p (Internal i)-    , p (Internal j)-    , p (Internal k)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    , InjectC (Select :|| p) dom (Internal i)-    , InjectC (Select :|| p) dom (Internal j)-    , InjectC (Select :|| p) dom (Internal k)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h,i,j,k)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , Syntactic i, Domain i ~ dom-                            , Syntactic j, Domain j ~ dom-                            , Syntactic k, Domain k ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , p (Internal i)-                            , p (Internal j)-                            , p (Internal k)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            , InjectC (Select :|| p) dom (Internal i)-                            , InjectC (Select :|| p) dom (Internal j)-                            , InjectC (Select :|| p) dom (Internal k)-                            ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h,i,j,k) = Domain a-    type Internal (a,b,c,d,e,f,g,h,i,j,k) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        )--    desugar = uncurryN $ sugarSymC' Tup11-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        , sugarSymC' Sel9 a-        , sugarSymC' Sel10 a-        , sugarSymC' Sel11 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , Syntactic i, Domain i ~ dom-    , Syntactic j, Domain j ~ dom-    , Syntactic k, Domain k ~ dom-    , Syntactic l, Domain l ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , p (Internal i)-    , p (Internal j)-    , p (Internal k)-    , p (Internal l)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    , InjectC (Select :|| p) dom (Internal i)-    , InjectC (Select :|| p) dom (Internal j)-    , InjectC (Select :|| p) dom (Internal k)-    , InjectC (Select :|| p) dom (Internal l)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h,i,j,k,l)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , Syntactic i, Domain i ~ dom-                            , Syntactic j, Domain j ~ dom-                            , Syntactic k, Domain k ~ dom-                            , Syntactic l, Domain l ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , p (Internal i)-                            , p (Internal j)-                            , p (Internal k)-                            , p (Internal l)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            , InjectC (Select :|| p) dom (Internal i)-                            , InjectC (Select :|| p) dom (Internal j)-                            , InjectC (Select :|| p) dom (Internal k)-                            , InjectC (Select :|| p) dom (Internal l)-                            ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h,i,j,k,l) = Domain a-    type Internal (a,b,c,d,e,f,g,h,i,j,k,l) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        )--    desugar = uncurryN $ sugarSymC' Tup12-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        , sugarSymC' Sel9 a-        , sugarSymC' Sel10 a-        , sugarSymC' Sel11 a-        , sugarSymC' Sel12 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , Syntactic i, Domain i ~ dom-    , Syntactic j, Domain j ~ dom-    , Syntactic k, Domain k ~ dom-    , Syntactic l, Domain l ~ dom-    , Syntactic m, Domain m ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , p (Internal i)-    , p (Internal j)-    , p (Internal k)-    , p (Internal l)-    , p (Internal m)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    , InjectC (Select :|| p) dom (Internal i)-    , InjectC (Select :|| p) dom (Internal j)-    , InjectC (Select :|| p) dom (Internal k)-    , InjectC (Select :|| p) dom (Internal l)-    , InjectC (Select :|| p) dom (Internal m)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , Syntactic i, Domain i ~ dom-                            , Syntactic j, Domain j ~ dom-                            , Syntactic k, Domain k ~ dom-                            , Syntactic l, Domain l ~ dom-                            , Syntactic m, Domain m ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                , Internal m-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , p (Internal i)-                            , p (Internal j)-                            , p (Internal k)-                            , p (Internal l)-                            , p (Internal m)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                , Internal m-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            , InjectC (Select :|| p) dom (Internal i)-                            , InjectC (Select :|| p) dom (Internal j)-                            , InjectC (Select :|| p) dom (Internal k)-                            , InjectC (Select :|| p) dom (Internal l)-                            , InjectC (Select :|| p) dom (Internal m)-                            ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m) = Domain a-    type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        )--    desugar = uncurryN $ sugarSymC' Tup13-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        , sugarSymC' Sel9 a-        , sugarSymC' Sel10 a-        , sugarSymC' Sel11 a-        , sugarSymC' Sel12 a-        , sugarSymC' Sel13 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , Syntactic i, Domain i ~ dom-    , Syntactic j, Domain j ~ dom-    , Syntactic k, Domain k ~ dom-    , Syntactic l, Domain l ~ dom-    , Syntactic m, Domain m ~ dom-    , Syntactic n, Domain n ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        , Internal n-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , p (Internal i)-    , p (Internal j)-    , p (Internal k)-    , p (Internal l)-    , p (Internal m)-    , p (Internal n)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        , Internal n-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    , InjectC (Select :|| p) dom (Internal i)-    , InjectC (Select :|| p) dom (Internal j)-    , InjectC (Select :|| p) dom (Internal k)-    , InjectC (Select :|| p) dom (Internal l)-    , InjectC (Select :|| p) dom (Internal m)-    , InjectC (Select :|| p) dom (Internal n)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , Syntactic i, Domain i ~ dom-                            , Syntactic j, Domain j ~ dom-                            , Syntactic k, Domain k ~ dom-                            , Syntactic l, Domain l ~ dom-                            , Syntactic m, Domain m ~ dom-                            , Syntactic n, Domain n ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                , Internal m-                                , Internal n-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , p (Internal i)-                            , p (Internal j)-                            , p (Internal k)-                            , p (Internal l)-                            , p (Internal m)-                            , p (Internal n)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                , Internal m-                                , Internal n-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            , InjectC (Select :|| p) dom (Internal i)-                            , InjectC (Select :|| p) dom (Internal j)-                            , InjectC (Select :|| p) dom (Internal k)-                            , InjectC (Select :|| p) dom (Internal l)-                            , InjectC (Select :|| p) dom (Internal m)-                            , InjectC (Select :|| p) dom (Internal n)-                            ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = Domain a-    type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        , Internal n-        )--    desugar = uncurryN $ sugarSymC' Tup14-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        , sugarSymC' Sel9 a-        , sugarSymC' Sel10 a-        , sugarSymC' Sel11 a-        , sugarSymC' Sel12 a-        , sugarSymC' Sel13 a-        , sugarSymC' Sel14 a-        )---instance-    ( Syntactic a, Domain a ~ dom-    , Syntactic b, Domain b ~ dom-    , Syntactic c, Domain c ~ dom-    , Syntactic d, Domain d ~ dom-    , Syntactic e, Domain e ~ dom-    , Syntactic f, Domain f ~ dom-    , Syntactic g, Domain g ~ dom-    , Syntactic h, Domain h ~ dom-    , Syntactic i, Domain i ~ dom-    , Syntactic j, Domain j ~ dom-    , Syntactic k, Domain k ~ dom-    , Syntactic l, Domain l ~ dom-    , Syntactic m, Domain m ~ dom-    , Syntactic n, Domain n ~ dom-    , Syntactic o, Domain o ~ dom-    , TupleSat dom p-    , p ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        , Internal n-        , Internal o-        )-    , p (Internal a)-    , p (Internal b)-    , p (Internal c)-    , p (Internal d)-    , p (Internal e)-    , p (Internal f)-    , p (Internal g)-    , p (Internal h)-    , p (Internal i)-    , p (Internal j)-    , p (Internal k)-    , p (Internal l)-    , p (Internal m)-    , p (Internal n)-    , p (Internal o)-    , InjectC (Tuple :|| p) dom-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        , Internal n-        , Internal o-        )-    , InjectC (Select :|| p) dom (Internal a)-    , InjectC (Select :|| p) dom (Internal b)-    , InjectC (Select :|| p) dom (Internal c)-    , InjectC (Select :|| p) dom (Internal d)-    , InjectC (Select :|| p) dom (Internal e)-    , InjectC (Select :|| p) dom (Internal f)-    , InjectC (Select :|| p) dom (Internal g)-    , InjectC (Select :|| p) dom (Internal h)-    , InjectC (Select :|| p) dom (Internal i)-    , InjectC (Select :|| p) dom (Internal j)-    , InjectC (Select :|| p) dom (Internal k)-    , InjectC (Select :|| p) dom (Internal l)-    , InjectC (Select :|| p) dom (Internal m)-    , InjectC (Select :|| p) dom (Internal n)-    , InjectC (Select :|| p) dom (Internal o)-    ) =>-      Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , Syntactic b, Domain b ~ dom-                            , Syntactic c, Domain c ~ dom-                            , Syntactic d, Domain d ~ dom-                            , Syntactic e, Domain e ~ dom-                            , Syntactic f, Domain f ~ dom-                            , Syntactic g, Domain g ~ dom-                            , Syntactic h, Domain h ~ dom-                            , Syntactic i, Domain i ~ dom-                            , Syntactic j, Domain j ~ dom-                            , Syntactic k, Domain k ~ dom-                            , Syntactic l, Domain l ~ dom-                            , Syntactic m, Domain m ~ dom-                            , Syntactic n, Domain n ~ dom-                            , Syntactic o, Domain o ~ dom-                            , TupleSat dom p-                            , p ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                , Internal m-                                , Internal n-                                , Internal o-                                )-                            , p (Internal a)-                            , p (Internal b)-                            , p (Internal c)-                            , p (Internal d)-                            , p (Internal e)-                            , p (Internal f)-                            , p (Internal g)-                            , p (Internal h)-                            , p (Internal i)-                            , p (Internal j)-                            , p (Internal k)-                            , p (Internal l)-                            , p (Internal m)-                            , p (Internal n)-                            , p (Internal o)-                            , InjectC (Tuple :|| p) dom-                                ( Internal a-                                , Internal b-                                , Internal c-                                , Internal d-                                , Internal e-                                , Internal f-                                , Internal g-                                , Internal h-                                , Internal i-                                , Internal j-                                , Internal k-                                , Internal l-                                , Internal m-                                , Internal n-                                , Internal o-                                )-                            , InjectC (Select :|| p) dom (Internal a)-                            , InjectC (Select :|| p) dom (Internal b)-                            , InjectC (Select :|| p) dom (Internal c)-                            , InjectC (Select :|| p) dom (Internal d)-                            , InjectC (Select :|| p) dom (Internal e)-                            , InjectC (Select :|| p) dom (Internal f)-                            , InjectC (Select :|| p) dom (Internal g)-                            , InjectC (Select :|| p) dom (Internal h)-                            , InjectC (Select :|| p) dom (Internal i)-                            , InjectC (Select :|| p) dom (Internal j)-                            , InjectC (Select :|| p) dom (Internal k)-                            , InjectC (Select :|| p) dom (Internal l)-                            , InjectC (Select :|| p) dom (Internal m)-                            , InjectC (Select :|| p) dom (Internal n)-                            , InjectC (Select :|| p) dom (Internal o)-                            ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) #-}-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}-    type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = Domain a-    type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        , Internal h-        , Internal i-        , Internal j-        , Internal k-        , Internal l-        , Internal m-        , Internal n-        , Internal o-        )--    desugar = uncurryN $ sugarSymC' Tup15-    sugar a =-        ( sugarSymC' Sel1 a-        , sugarSymC' Sel2 a-        , sugarSymC' Sel3 a-        , sugarSymC' Sel4 a-        , sugarSymC' Sel5 a-        , sugarSymC' Sel6 a-        , sugarSymC' Sel7 a-        , sugarSymC' Sel8 a-        , sugarSymC' Sel9 a-        , sugarSymC' Sel10 a-        , sugarSymC' Sel11 a-        , sugarSymC' Sel12 a-        , sugarSymC' Sel13 a-        , sugarSymC' Sel14 a-        , sugarSymC' Sel15 a-        )
− src/Language/Syntactic/Interpretation.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Language.Syntactic.Interpretation where--import Language.Haskell.TH-import Language.Haskell.TH.Quote--import Language.Syntactic.Interpretation.Equality-import Language.Syntactic.Interpretation.Render-import Language.Syntactic.Interpretation.Evaluation---- | Derive instances for 'Semantic' related classes--- ('Equality', 'Render', 'StringTree', 'Eval')-semanticInstances :: Name -> DecsQ-semanticInstances n =-    [d|-        instance Equality $(typ)-        instance Render $(typ)-        instance StringTree $(typ)-        instance Eval $(typ) where-          {-# SPECIALIZE instance Eval $(typ) #-}-    |]-  where-    typ = conT n
− src/Language/Syntactic/Interpretation/Equality.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}--module Language.Syntactic.Interpretation.Equality where----import Data.Hash--import Language.Syntactic.Syntax-import Language.Syntactic.Interpretation.Semantics------ | Equality for expressions-class Equality expr-  where-    -- | Equality for expressions-    ---    -- Comparing expressions of different types is often needed when dealing-    -- with expressions with existentially quantified sub-terms.-    equal :: expr a -> expr b -> Bool--    -- | Computes a 'Hash' for an expression. Expressions that are equal-    -- according to 'equal' must result in the same hash:-    ---    -- @equal a b  ==>  exprHash a == exprHash b@-    exprHash :: expr a -> Hash--    default equal :: Semantic expr => expr a -> expr b -> Bool-    equal = equalDefault-    {-# INLINABLE equal #-}--    default exprHash :: Semantic expr => expr a -> Hash-    exprHash = exprHashDefault-    {-# INLINABLE exprHash #-}----- | Default implementation of 'equal'-equalDefault :: Semantic expr => expr a -> expr b -> Bool-equalDefault a b = equal (semantics a) (semantics b)-{-# INLINABLE equalDefault #-}---- | Default implementation of 'exprHash'-exprHashDefault :: Semantic expr => expr a -> Hash-exprHashDefault = exprHash . semantics-{-# INLINABLE exprHashDefault #-}---instance Equality Semantics-  where-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (Sem a _) (Sem b _) = a==b-    exprHash (Sem name _)     = hash name--instance Equality dom => Equality (AST dom)-  where-    {-# SPECIALIZE instance (Equality dom) => Equality (AST dom) #-}-    {-# INLINABLE equal #-}-    equal (Sym a)    (Sym b)    = equal a b-    equal (s1 :$ a1) (s2 :$ a2) = equal s1 s2 && equal a1 a2-    equal _ _                   = False--    {-# INLINABLE exprHash #-}-    exprHash (Sym a)  = hashInt 0 `combine` exprHash a-    exprHash (s :$ a) = hashInt 1 `combine` exprHash s `combine` exprHash a--instance Equality dom => Eq (AST dom a)-  where-    {-# SPECIALIZE instance (Equality dom) => Eq (AST dom a) #-}-    {-# INLINABLE (==) #-}-    (==) = equal--instance (Equality expr1, Equality expr2) => Equality (expr1 :+: expr2)-  where-    {-# SPECIALIZE instance (Equality expr1, Equality expr2) => Equality (expr1 :+: expr2) #-}-    {-# INLINABLE equal #-}-    equal (InjL a) (InjL b) = equal a b-    equal (InjR a) (InjR b) = equal a b-    equal _ _               = False--    {-# INLINABLE exprHash #-}-    exprHash (InjL a) = hashInt 0 `combine` exprHash a-    exprHash (InjR a) = hashInt 1 `combine` exprHash a--instance (Equality expr1, Equality expr2) => Eq ((expr1 :+: expr2) a)-  where-    {-# SPECIALIZE instance (Equality expr1, Equality expr2) => Eq ((expr1 :+: expr2) a)#-}-    (==) = equal
− src/Language/Syntactic/Interpretation/Evaluation.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}--module Language.Syntactic.Interpretation.Evaluation where----import Language.Syntactic.Syntax-import Language.Syntactic.Interpretation.Semantics----class Eval expr-  where-    -- | Evaluation of expressions-    evaluate :: expr a -> Denotation a--    default evaluate :: Semantic expr => expr a -> Denotation a-    evaluate = evaluateDefault-    {-# INLINABLE evaluate #-}---- | Default implementation of 'evaluate'-evaluateDefault :: Semantic expr => expr a -> Denotation a-evaluateDefault = evaluate . semantics-{-# INLINABLE evaluateDefault #-}--instance Eval Semantics-  where-    {-# INLINABLE evaluate #-}-    evaluate (Sem _ a) = a---instance Eval dom => Eval (AST dom)-  where-    {-# SPECIALIZE instance (Eval dom) => Eval (AST dom) #-}-    {-# INLINABLE evaluate #-}-    evaluate (Sym a)  = evaluate a-    evaluate (s :$ a) = evaluate s $ evaluate a--instance (Eval expr1, Eval expr2) => Eval (expr1 :+: expr2)-  where-    {-# SPECIALIZE instance (Eval expr1, Eval expr2) => Eval (expr1 :+: expr2) #-}-    {-# INLINABLE evaluate #-}-    evaluate (InjL a) = evaluate a-    evaluate (InjR a) = evaluate a
− src/Language/Syntactic/Interpretation/Render.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}--module Language.Syntactic.Interpretation.Render-    ( Render (..)-    , renderSymDefault-    , renderArgsDefault-    , render-    , StringTree (..)-    , stringTree-    , showAST-    , drawAST-    , writeHtmlAST-    ) where----import Data.Tree (Tree (..))--import Data.Tree.View--import Language.Syntactic.Syntax-import Language.Syntactic.Interpretation.Semantics----- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym'--- method.-class Render dom-  where-    -- | Show a symbol as a 'String'-    renderSym :: dom sig -> String--    -- | Render a symbol given a list of rendered arguments-    renderArgs :: [String] -> dom sig -> String-    renderArgs []   a = renderSym a-    renderArgs args a = "(" ++ unwords (renderSym a : args) ++ ")"-    {-# INLINABLE renderArgs #-}--    default renderSym :: Semantic dom => dom sig -> String-    renderSym = renderSymDefault-    {-# INLINABLE renderSym #-}---- | Default implementation of 'renderSym'-renderSymDefault :: Semantic expr => expr a -> String-renderSymDefault = renderSym . semantics-{-# INLINABLE renderSymDefault #-}---- | Default implementation of 'renderArgs'-renderArgsDefault :: Semantic expr => [String] -> expr a -> String-renderArgsDefault args = renderArgs args . semantics-{-# INLINABLE renderArgsDefault #-}--instance Render Semantics-  where-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym (Sem name _) = name-    renderArgs [] (Sem name _) = name-    renderArgs args (Sem name _)-        | isInfix   = "(" ++ unwords [a,op,b] ++ ")"-        | otherwise = "(" ++ unwords (name : args) ++ ")"-      where-        [a,b] = args-        op    = init $ tail name-        isInfix-          =  not (null name)-          && head name == '('-          && last name == ')'-          && length args == 2--instance (Render expr1, Render expr2) => Render (expr1 :+: expr2)-  where-    {-# SPECIALIZE instance (Render expr1, Render expr2) => Render (expr1 :+: expr2) #-}-    {-# INLINABLE renderSym #-}-    {-# INLINABLE renderArgs #-}-    renderSym (InjL a) = renderSym a-    renderSym (InjR a) = renderSym a-    renderArgs args (InjL a) = renderArgs args a-    renderArgs args (InjR a) = renderArgs args a---- | Render an expression as concrete syntax-render :: forall dom a. Render dom => ASTF dom a -> String-render = go []-  where-    go :: [String] -> AST dom sig -> String-    go args (Sym a)  = renderArgs args a-    go args (s :$ a) = go (render a : args) s-{-# INLINABLE render #-}--instance Render dom => Show (ASTF dom a)-  where-    {-# SPECIALIZE instance Render dom => Show (ASTF dom a) #-}-    show = render------ | Convert a symbol to a 'Tree' of strings-class Render dom => StringTree dom-  where-    -- | Convert a symbol to a 'Tree' given a list of argument trees-    stringTreeSym :: [Tree String] -> dom a -> Tree String-    stringTreeSym args a = Node (renderSym a) args-    {-# INLINABLE stringTreeSym #-}--instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2)-  where-    {-# SPECIALIZE instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2) #-}-    {-# INLINABLE stringTreeSym #-}-    stringTreeSym args (InjL a) = stringTreeSym args a-    stringTreeSym args (InjR a) = stringTreeSym args a---- | Convert an expression to a 'Tree' of strings-stringTree :: forall dom a . StringTree dom => ASTF dom a -> Tree String-stringTree = go []-  where-    go :: [Tree String] -> AST dom sig -> Tree String-    go args (Sym a)  = stringTreeSym args a-    go args (s :$ a) = go (go [] a : args) s-{-# INLINABLE stringTree #-}---- | Show a syntax tree using ASCII art-showAST :: StringTree dom => ASTF dom a -> String-showAST = showTree . stringTree-{-# INLINABLE showAST #-}---- | Print a syntax tree using ASCII art-drawAST :: StringTree dom => ASTF dom a -> IO ()-drawAST = putStrLn . showAST-{-# INLINABLE drawAST #-}--writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO ()-writeHtmlAST file = writeHtmlTree Nothing file . fmap (\n -> NodeInfo InitiallyExpanded n "") . stringTree-{-# INLINABLE writeHtmlAST #-}
− src/Language/Syntactic/Interpretation/Semantics.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Default implementations of some interpretation functions--module Language.Syntactic.Interpretation.Semantics where----import Language.Syntactic.Syntax----- | A representation of a syntactic construct as a 'String' and an evaluation--- function. It is not meant to be used as a syntactic symbol in an 'AST'. Its--- only purpose is to provide the default implementations of functions like--- `equal` via the `Semantic` class.-data Semantics a-  where-    Sem-        :: { semanticName :: String-           , semanticEval :: Denotation a-           }-        -> Semantics a----- | The denotation of a symbol with the given signature-type family   Denotation sig-type instance Denotation (Full a)    = a-type instance Denotation (a :-> sig) = a -> Denotation sig----- | Class of expressions that can be treated as constructs-class Semantic expr-  where-    semantics :: expr a -> Semantics a
− src/Language/Syntactic/Sharing/CodeMotion2.hs 
@@ -1,682 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DoRec #-}-module Language.Syntactic.Sharing.CodeMotion2-    ( codeMotion2-    , reifySmart2-    ) where--import Control.Arrow-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.RWS-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Array-import Data.List-import Data.Maybe (fromJust,fromMaybe)-import Data.Function-import Data.Hash-import Data.Typeable--import Language.Syntactic-import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Constructs.Binding.HigherOrder-import Language.Syntactic.Sharing.SimpleCodeMotion--typeEq :: forall dom a b. (Typeable a, Typeable b) => ASTF dom a -> ASTF dom b -> Bool-typeEq a b | Just _ <- (gcast b :: Maybe (ASTF dom a)) = True-typeEq _ _ = False--isVariable :: PrjDict dom -> ASTF (NodeDomain dom) a -> Bool-isVariable pd (Sym (C' (InjR (prjVariable pd -> Just _)))) = True-isVariable pd _ = False--newtype NodeId = NodeId { nodeInteger :: Integer }-  deriving (Eq, Ord, Num, Real, Integral, Enum, Ix)--instance Show NodeId-  where-    show (NodeId i) = show i--showNode :: NodeId -> String-showNode n = "node:" ++ show n--instance AlphaEq dom dom dom env => AlphaEq Node Node dom env-  where-    {-# SPECIALIZE instance AlphaEq dom dom dom env =>-          AlphaEq Node Node dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (Node n1) _ (Node n2) _ = return (n1 == n2)--instance Constrained Node-  where-    {-# SPECIALIZE instance Constrained Node #-}-    {-# INLINABLE exprDict #-}-    type Sat Node = Top-    exprDict _ = Dict--instance Equality Node-  where-    {-# INLINABLE equal #-}-    {-# INLINABLE exprHash #-}-    equal (Node n1) (Node n2) = error "can't compare nodes for equality"-    exprHash (Node n)         = hash (nodeInteger n)---- | Placeholder for a syntax tree. Similar to Node from Graph, but with the--- invariant that nodes with the same id are alpha-equivalent, given that they--- come from the same expression.-data Node a-  where-    Node :: NodeId -> Node (Full a)--instance Render Node where-  {-# INLINABLE renderSym #-}-  renderSym (Node n) = showNode n---type NodeDomain dom = (Node :+: dom) :|| Sat dom---- | A gathered sub-expression along with information used to decide where and--- if it should be shared.-data Gathered dom = Gathered-    { geExpr :: ASTSAT (NodeDomain dom)-        -- ^ The gathered expression.-    , geNodeId :: NodeId-        -- ^ The node id of the expression.-    , geFreeVars :: Set.Set VarId-        -- ^ Variables that occur free in the expression.-    , geInfo :: [(NodeId, GatherInfo)]-        -- ^ A list of nodes which the gathered expression occurs in, which it-        -- should not be hoisted out of, along with the number of times it occurs-        -- in it and the union of all the scopes where the variable occurs.-    }----- | An occurence count and a union of scopes for a gathered expression. Used--- for the heuristic for when to share an expression.-data GatherInfo = GatherInfo-    { giCount :: Int-    , giScopes :: Set.Set VarId-    }-  deriving Show---newtype HashySet a = HashySet { unHashySet :: Map.Map Hash [a] }--lookupWithHS :: ([a] -> b) -> Hash -> HashySet a -> b-lookupWithHS f h (HashySet m) = case Map.lookup h m of-    Nothing -> f []-    Just as -> f as--updateWithHS :: (Maybe [a] -> Maybe [a]) -> Hash -> HashySet a -> HashySet a-updateWithHS f h (HashySet m) = HashySet $ Map.alter f h m--emptyHS = HashySet Map.empty--toListHS (HashySet m) = concatMap snd $ Map.toList m---- | A set of expressions used to keep track of gathered expression in `gather`-type GatherSet dom = HashySet (Gathered dom)--lookupGS :: forall dom a-    .  ( AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)]-       , ConstrainedBy (NodeDomain dom) Typeable-       , Equality dom)-    => GatherSet dom-    -> ASTF (NodeDomain dom) a-    -> Maybe (Gathered dom)-lookupGS hs e = lookupWithHS look (exprHash e) hs-  where-    look :: [Gathered dom] -> Maybe (Gathered dom)-    look [] = Nothing-    look (g:gs) | ASTB ge <- geExpr g-                , Dict <- exprDictSub pTypeable ge-                , Dict <- exprDictSub pTypeable e-                , alphaEq ge e-                , typeEq ge e-                = Just g-    look (g:gs) = look gs--updateGS :: forall dom-    .  ( AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)]-       , ConstrainedBy (NodeDomain dom) Typeable-       , Equality dom)-    => GatherSet dom-    -> Gathered dom-    -> GatherSet dom-updateGS hs g-    | ASTB ge <- geExpr g-    = updateWithHS alt (exprHash ge) hs-  where-    alt :: Maybe [Gathered dom] -> Maybe [Gathered dom]-    alt (Just gs) = Just $ ins gs-    alt Nothing   = Just [g]-    ins :: [Gathered dom] -> [Gathered dom]-    ins [] = [g]-    ins (x:xs) | ASTB xe <- geExpr x-               , ASTB ge <- geExpr g-               , Dict <- exprDictSub pTypeable xe-               , Dict <- exprDictSub pTypeable ge-               , alphaEq xe ge-               , typeEq xe ge-               = g : xs-    ins (x:xs) = x : ins xs--emptyGS :: GatherSet dom-emptyGS = emptyHS--toListGS :: GatherSet dom -> [Gathered dom]-toListGS gs = toListHS gs--type RebuildEnv dom =-    ( Map.Map NodeId (ASTSAT dom)-        -- associates node ids with the AST they should be substituted by-    , Set.Set VarId-        -- bound variables-    , [NodeId]-        -- nodes that have been encountered-    )--type RebuildMonad dom m a = ReaderT (RebuildEnv dom) m a--runRebuild :: (MonadState VarId m) => RebuildMonad dom m a -> m a-runRebuild m = runReaderT m (Map.empty, Set.empty, [])--addBoundVar :: (Monad m) => VarId -> RebuildMonad dom m a -> RebuildMonad dom m a-addBoundVar v =  local (\(nm,vs,sn) -> (nm, Set.insert v vs, sn))--getBoundVars :: (Monad m) => RebuildMonad dom m (Set.Set VarId)-getBoundVars = do-    (_,bv,_) <- ask-    return bv--addNodeExpr :: (Monad m) => NodeId -> ASTSAT dom -> RebuildMonad dom m a -> RebuildMonad dom m a-addNodeExpr n a = local (\(nm,vs,sn) -> (Map.insert n a nm, vs, sn))--getNodeExprMap :: (Monad m) => RebuildMonad dom m (Map.Map NodeId (ASTSAT dom))-getNodeExprMap = do-    (nm,_,_) <- ask-    return nm--addSeenNode :: (Monad m) => NodeId -> RebuildMonad dom m a -> RebuildMonad dom m a-addSeenNode n = local (\(nm,vs,sn) -> (nm, vs, n:sn))--getSeenNodes :: (Monad m) => RebuildMonad dom m [NodeId]-getSeenNodes = do-    (_,_,sn) <- ask-    return sn----codeMotion2 :: forall dom m a-    .  ( ConstrainedBy dom Typeable-       , AlphaEq dom dom dom [(VarId,VarId)]-       , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)]-       , Equality dom-       , MonadState VarId m-       )-    => (forall c. ASTF dom c -> Bool)  -- ^ Control wether a sub-expression can be hoisted over the given expression-    -> PrjDict dom-    -> MkInjDict dom-    -> ASTF dom a-    -> m (ASTF dom a)-codeMotion2 hoistOver pd mkId a = rebuild pd mkId garr a'-  where-    (garr, a') = gather hoistOver pd a--type ShareInfo dom = (NodeId, ASTSAT (NodeDomain dom), GatherInfo)--rebuild :: forall dom m a-    .  ( ConstrainedBy dom Typeable-       , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)]-       , Equality dom-       , MonadState VarId m-       )-    => PrjDict dom-    -> MkInjDict dom-    -> Array NodeId (Gathered dom)-    -> ASTF (NodeDomain dom) a-    -> m (ASTF dom a)-rebuild pd mkId nodes (Sym (C' (InjL _))) = error "rebuild: root is a node"-rebuild pd mkId nodes a = runRebuild $ rebuild' 0 a-  where-    nodeExpr :: NodeId -> ASTSAT (NodeDomain dom)-    nodeExpr n = geExpr (nodes ! n)--    freeVars :: NodeId -> Set.Set VarId-    freeVars n = geFreeVars (nodes ! n)--    nodeDeps :: Array NodeId (Set.Set NodeId)-    nodeDeps = nodeDepsArray-      where-        nodeDepsArray = array (0,snd (bounds nodes)) [(n, nodeDepsNode n) | n <- 0 : indices nodes]--        nodeDepsNode :: NodeId -> Set.Set NodeId-        nodeDepsNode 0 = nodeDepsExp a-        nodeDepsNode n = liftASTB nodeDepsExp $ geExpr (nodes ! n)--        nodeDepsExp :: AST (NodeDomain dom) b -> Set.Set NodeId-        nodeDepsExp (Sym (C' (InjR _))) = Set.empty-        nodeDepsExp (Sym (C' (InjL (Node n)))) = Set.insert n (nodeDepsArray ! n)-        nodeDepsExp (s :$ b) = Set.union (nodeDepsExp s) (nodeDepsExp b)--    -- | Computes a list of nodes that should be considered for sharing at a-    -- particular node. Must return a ShareInfo corresponding to any node-    -- that might be encounter in direct sub-expression of the node that has-    -- not already been considered at a parent node. Otherwise we will not know-    -- what to do with that node.-    -- Implementation is pretty bizarre right now, but it should be replaced anyway.-    nodesToConsider :: NodeId -> (NodeId -> Bool) -> Set.Set VarId -> [NodeId] -> [ShareInfo dom]-    nodesToConsider n f bv seenNodes = concatMap mkShareInfo (map (\n -> (n, nodes ! n)) (Set.elems (nodeDeps ! n)))-      where-        maximumBy' f [] = []-        maximumBy' f xs = [maximumBy f xs]--        mkShareInfo (n,g) = map snd $ filter ((/=Nothing) . fst) $ maximumBy' (compare `on` fst)-            [ (elemIndex il seenNodes, (n, geExpr g, gi))-            | (il,gi) <- geInfo g-            , Set.null (freeVars n `Set.difference` bv)-                -- any free variables in the sub-expression must be bound-            , il /= n-                -- this case handled separately-            , f n-            ]--    -- Nodes which has the given node as its inner limit.-    unshareableNodes :: NodeId -> AST (NodeDomain dom) b -> [ShareInfo dom]-    unshareableNodes n (Sym s) = []-    unshareableNodes n (s :$ Sym (C' (InjL (Node n'))))-        | Just gi <- lookup n (geInfo (nodes ! n'))-        = (n', geExpr (nodes ! n'), gi) : unshareableNodes n s-        | Just gi <- lookup n' (geInfo (nodes ! n'))-        = (n', geExpr (nodes ! n'), gi) : unshareableNodes n s-    unshareableNodes n (b :$ s) = unshareableNodes n b--    unshareable2Nodes :: Maybe VarId -> ASTF (NodeDomain dom) b -> [ShareInfo dom]-    unshareable2Nodes Nothing  _ = []-    unshareable2Nodes (Just v) a = go a []-      where-        go :: AST (NodeDomain dom) c -> [ShareInfo dom] -> [ShareInfo dom]-        go (Sym s) l = l-        go (s :$ Sym (C' (InjL (Node n')))) l-            | Set.member v (freeVars n') = go s ((n', geExpr (nodes ! n'), undefined):l)-            | otherwise                  = go s l--    rebuild' :: forall b-        .  NodeId-        -> ASTF (NodeDomain dom) b-        -> RebuildMonad dom m (ASTF dom b)-    rebuild' n a@(Sym (C' (InjR lam)) :$ ns@(Sym (C' (InjL (Node nb)))))-        | Just v <- prjLambda pd lam-        = addSeenNode n $ shareExprsIn (Just v) n a-    rebuild' n (Sym (C' (InjR s))) = return $ Sym s-    rebuild' n a = addSeenNode n $ shareExprsIn Nothing n a--    shareExprsIn :: forall b-        .  Maybe VarId -- if the last argument is a lambda, this contains the lambda VarId, otherwise Nothing.-        -> NodeId-        -> ASTF (NodeDomain dom) b-        -> RebuildMonad dom m (ASTF dom b)-    shareExprsIn mlv n a = do-        bv <- getBoundVars-        seenNodes <- getSeenNodes-        nodeMap <- getNodeExprMap-        let considered = nodesToConsider n (\n' -> n' /= n && not (Map.member n' nodeMap) && Set.member n' (nodeDeps ! n)) bv seenNodes-        let sorted = sortBy (compare `on` (\(n,_,_) -> n)) considered-        let unshareable = nubBy ((==) `on` (\(n,_,_) -> n)) $ unshareableNodes n a ++ unshareable2Nodes mlv a-        unshare mlv unshareable $ shareEm mlv sorted a--    unshare :: Maybe VarId -> [ShareInfo dom] -> RebuildMonad dom m b -> RebuildMonad dom m b-    unshare mlv []     m = m-    unshare mlv ((n, ASTB b, gi):sis) m = do-          b' <- rebuildMaybeUnderLambda mlv n b-          addNodeExpr n (ASTB b') $ unshare mlv sis m--    shareEm-        :: Maybe VarId-        -> [ShareInfo dom]-        -> ASTF (NodeDomain dom) b-        -> RebuildMonad dom m (ASTF dom b)-    shareEm mlv [] a = fixNodeExprSub a-    shareEm mlv ((n, ASTB b, gi) : sis) a = do-        bv <- getBoundVars-        case mkId (inlineAll nodeExpr b) (inlineAll nodeExpr a) of-            Just id | heuristic bv gi b -> do-                b' <- rebuild' n b-                v <- get; put (v+1)-                a' <- addNodeExpr n (ASTB (Sym (injVariable id v))) $ shareEm mlv sis a-                return $ Sym (injLet id) :$ b' :$ (Sym (injLambda id v) :$ a')-            _ -> do-                b' <- rebuildMaybeUnderLambda mlv n b-                a' <- addNodeExpr n (ASTB b') $ shareEm mlv sis a-                return a'--    rebuildMaybeUnderLambda-        :: Maybe VarId-        -> NodeId-        -> ASTF (NodeDomain dom) b-        -> RebuildMonad dom m (ASTF dom b)-    rebuildMaybeUnderLambda (Just lv) n a = addBoundVar lv $ rebuild' n a-    rebuildMaybeUnderLambda Nothing   n a = rebuild' n a--    fixNodeExprSub :: forall b-        .  ( ConstrainedBy dom Typeable-           , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)]-           , Equality dom-           )-        => AST (NodeDomain dom) b-        -> RebuildMonad dom m (AST dom b)-    fixNodeExprSub (Sym (C' (InjR s))) = return (Sym s)-    fixNodeExprSub (s :$ b) = do-        b' <- fixNodeExpr b-        s' <- fixNodeExprSub s-        return (s' :$ b')--    fixNodeExpr :: forall b-                .  ASTF (NodeDomain dom) b -> RebuildMonad dom m (ASTF dom b)-    fixNodeExpr (ns@(Sym (C' (InjL (Node n))))) = do-        nodeMap <- getNodeExprMap-        let a = lookNode nodeMap-        return a-      where-        lookNode nodeMap = case Map.lookup n nodeMap of-            Just (ASTB a)-                | Dict <- exprDictSub pTypeable ns-                , Dict <- exprDictSub pTypeable a-                -> case gcast a of-                    Nothing -> error "rebuild: type mismatch"-                    Just a -> a-            Nothing -> error ("rebuild: lost node: " ++ show n)--    heuristic :: Set.Set VarId -> GatherInfo -> ASTF (NodeDomain dom) b -> Bool-    heuristic bv gi b = not (isVariable pd b) && (giCount gi > 1 || not (Set.null (giScopes gi `Set.difference` bv)))--inlineAll :: forall dom a-    .  ConstrainedBy dom Typeable-    => (NodeId -> ASTSAT (NodeDomain dom))-    -> ASTF (NodeDomain dom) a-    -> ASTF dom a-inlineAll nodes a = go a-  where-    go :: AST (NodeDomain dom) sig -> AST dom sig-    go (s :$ a) = go s :$ go a-    go (Sym (C' (InjR s))) = Sym s-    go s@(Sym (C' (InjL (Node n)))) = case nodes n of-        ASTB a-          | Dict <- exprDictSub pTypeable s-          , Dict <- exprDictSub pTypeable a-          -> case gcast a of-              Nothing -> error "inlineAll: type mismatch"-              Just a  -> go a---type GatherEnv =-    ( [NodeId]-        -- List of nodes upwards in the syntax tree that cannot be hoisted over-    , Set.Set VarId-        -- Varibles in scope-    )--type Additional = Map.Map NodeId [(NodeId, GatherInfo)]--data GatherState dom = GatherState-    { gatherSet :: GatherSet dom -- Set of expressions that have been recorded-    , nodeCounter :: NodeId-    , lambdaTable :: LambdaTable dom-    , additionals :: Map.Map NodeId [(NodeId, GatherInfo)]-    }--data LambdaInfo dom = LambdaInfo-    { liExpr :: ASTSAT dom-    , liLambdaNodeId :: NodeId-    , liFreeVars :: Set.Set VarId-    }--type GatherMonad dom a = RWS GatherEnv (Set.Set VarId) (GatherState dom) a--runGather :: GatherMonad dom a -> (GatherState dom, a)-runGather gather = (s', a)-  where-    (a,s',w) = runRWS gather ([0], Set.empty) (GatherState emptyGS 1 emptyHS Map.empty)--type LambdaTable dom = HashySet (LambdaInfo dom)--lookupLT :: forall dom a-    . ( AlphaEq dom dom dom [(VarId,VarId)]-      , Equality dom)-    => Hash-    -> ASTF dom a-    -> LambdaTable dom-    -> Maybe (LambdaInfo dom)-lookupLT h e t = lookupWithHS look h t-  where-    look :: [LambdaInfo dom] -> Maybe (LambdaInfo dom)-    look [] = Nothing-    look (li:xs) | liftASTB alphaEq (liExpr li) e-                 = Just li-    look (x:xs) = look xs---- | Note: Assumes the given lambda is not already in the map-insertLT :: forall dom a-    . ( Sat dom a-      , AlphaEq dom dom dom [(VarId,VarId)]-      , Equality dom)-    => Hash-    -> ASTF dom a-    -> NodeId-    -> Set.Set VarId-    -> LambdaTable dom-    -> LambdaTable dom-insertLT h e n fv t = updateWithHS ins h t-  where-    ins :: Maybe [LambdaInfo dom] -> Maybe [LambdaInfo dom]-    ins (Just xs) = Just (LambdaInfo (ASTB e) n fv : xs)-    ins Nothing = Just [LambdaInfo (ASTB e) n fv]---getInnerLimit :: GatherMonad dom NodeId-getInnerLimit = liftM (head . fst) ask--getScope :: GatherMonad dom (Set.Set VarId)-getScope = liftM snd ask--getLambdaTable :: GatherMonad dom (LambdaTable dom)-getLambdaTable = liftM lambdaTable get--putLambdaTable :: LambdaTable dom -> GatherMonad dom ()-putLambdaTable lt = do-    st <- get-    put (st { lambdaTable = lt })--addInnerLimit :: NodeId -> GatherMonad dom a -> GatherMonad dom a-addInnerLimit n = local (\(ns,vs) -> (n:ns,vs))--addScopeVar :: VarId -> GatherMonad dom a -> GatherMonad dom a-addScopeVar v = censor (Set.delete v) . local (\(ns,vs) -> (ns, Set.insert v vs ))---- | Convert an expression to a graph representation where each set of--- alpha-equivalent sub-expressions share a node. Occurence counts for the--- sub-expressions, and other information is also recorded.-gather :: forall dom a-    .  ( ConstrainedBy dom Typeable-       , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)]-       , AlphaEq dom dom dom [(VarId,VarId)]-       , Equality dom-       )-    => (forall c. ASTF dom c -> Bool)-    -> PrjDict dom-    -> ASTF dom a-    -> (Array NodeId (Gathered dom), ASTF (NodeDomain dom) a)-gather hoistOver pd a@(Sym s) | Dict <- exprDict a = (array (1,0) [], Sym (C' (InjR s)))-gather hoistOver pd a = (gatheredArr, a')-  where-    (st,a') | Dict <- exprDict a = runGather (gatherRoot a)--    gatherRoot :: ASTF dom b -> GatherMonad dom (ASTF (NodeDomain dom) b)-    gatherRoot a@(Sym lam :$ _) | Just v <- prjLambda pd lam-                                , Dict <- exprDict a-                                = addScopeVar v $ gatherRec (hoistOver a) a-    gatherRoot a | Dict <- exprDict a = gatherRec (hoistOver a) a--    gths = toListGS (gatherSet st)--    idx = map geNodeId gths--    adArr :: Array NodeId [(NodeId, GatherInfo)]-    adArr = accumArray (++) []-        (1, nodeCounter st - 1)-        ((Map.assocs (additionals st)) ++ [(n, []) | n <- [1..(nodeCounter st - 1)]])--    preGatheredArr :: Array NodeId (Gathered dom)-    preGatheredArr = array-        (1, nodeCounter st - 1)-        (zip idx gths)--    gatheredArr :: Array NodeId (Gathered dom)-    gatheredArr = array-        (1, nodeCounter st - 1)-        (zip idx (Prelude.map withAdditionals gths))--    withAdditionals g = g { geInfo = info}-      where-        info = mergeInfos-                (geInfo g)-                (Map.findWithDefault [] (geNodeId g) propagateAdditionals)--    propagateAdditionals :: Additional-    propagateAdditionals = foldr propAdditional (additionals st) $ Map.toDescList (additionals st)-      where-        propAdditional :: (NodeId, [(NodeId, GatherInfo)]) -> Additional -> Additional-        propAdditional (n, gi) ad = propAdditionalNode n gi ad--        propAdditionalNode :: NodeId -> [(NodeId, GatherInfo)] -> Additional -> Additional-        propAdditionalNode n gi ad = liftASTB (propAdditionalExpr n gi) (geExpr (preGatheredArr ! n)) ad--        propAdditionalExpr :: NodeId -> [(NodeId, GatherInfo)] -> AST (NodeDomain dom) b -> Additional -> Additional-        propAdditionalExpr n gi (Sym s) ad = ad-        propAdditionalExpr n gi (s :$ Sym (C' (InjL (Node n')))) ad = ad3-          where-            ad1 = Map.insertWith mergeInfos n' gi ad-            ad2 = propAdditionalNode n' gi ad1-            ad3 = propAdditionalExpr n gi s ad2--    applyAdditionals :: [(NodeId, GatherInfo)] -> Gathered dom -> Gathered dom-    applyAdditionals ad g = g { geInfo = mergeInfos ad (geInfo g) }--    varHash :: Map.Map VarId Hash-    varHash = lambdaHashes pd a--    gather'-        :: Bool-        -> ASTF dom b-        -> GatherMonad dom (ASTF (NodeDomain dom) b)-    gather' h a@(Sym lam :$ _) | Just v <- prjLambda pd lam-                               , Dict <- exprDict a = do-        lt <- getLambdaTable-        let hash = fromJust (Map.lookup v varHash)-        case lookupLT hash a lt of-            Just li -> do-                let n = liLambdaNodeId li-                anotherCopyOf n-                tell (liFreeVars li)-                return $ Sym $ C' $ InjL $ Node $ n-            Nothing -> do-                rec-                    (a',fv) <- listen $ addInnerLimitIf (not h) n $ addScopeVar v $ gatherRec (hoistOver a) a-                    n <- addInnerLimitIf (not h) n $ recordExpr fv a'-                putLambdaTable (insertLT hash a n fv lt)-                return $ Sym $ C' $ InjL $ Node n-    gather' h a | Dict <- exprDict a = do-        rec-            (a',fv) <- listen $ addInnerLimitIf (not h) n $ gatherRec (hoistOver a) a-            n <- addInnerLimitIf (not h) n $ recordExpr fv a'-        return $ Sym $ C' $ InjL $ Node n--    addInnerLimitIf True n m = addInnerLimit n m-    addInnerLimitIf _    n m = m--    gatherRec-        :: (Sat dom (DenResult b))-        => Bool-        -> AST dom b-        -> GatherMonad dom (AST (NodeDomain dom) b)-    gatherRec h (Sym var) | Just v <- prjVariable pd var = do-            tell (Set.singleton v)-            return $ Sym $ C' $ InjR var-    gatherRec h (Sym s) = return $ Sym $ C' $ InjR s-    gatherRec h (s :$ b) | Dict <- exprDict b = do-        b' <- gather' h b-        s' <- gatherRec h s-        return (s' :$ b')--    anotherCopyOf :: NodeId -> GatherMonad dom ()-    anotherCopyOf n = do-        st <- get-        let s = gatherSet st-        let ad = additionals st-        innerLimit <- getInnerLimit-        scope <- getScope-        put (st { additionals = Map.insertWith mergeInfos n [(innerLimit, GatherInfo 1 scope)] ad })--    recordExpr :: Set.Set VarId -> ASTF (NodeDomain dom) b -> GatherMonad dom NodeId-    recordExpr fv a | Dict <- exprDict a = do-        st <- get-        let s = gatherSet st-        let n = nodeCounter st-        innerLimit <- getInnerLimit-        scope <- getScope-        case lookupGS s a of-            Just ge -> do-                let ge' = ge { geInfo = updateInfo innerLimit (GatherInfo 1 scope) (geInfo ge) }-                put (st { gatherSet = updateGS s ge' })-                return (geNodeId ge)-            Nothing -> do-                let ge = Gathered { geExpr = ASTB a , geNodeId = n , geFreeVars = fv , geInfo = [(innerLimit, GatherInfo { giCount = 1 , giScopes = scope })] }-                put (st { gatherSet = updateGS s ge, nodeCounter = n+1 })-                return n--mergeInfos :: [(NodeId, GatherInfo)] -> [(NodeId, GatherInfo)] -> [(NodeId, GatherInfo)]-mergeInfos [] ys = ys-mergeInfos (x:xs) ys = mergeInfos xs (uncurry updateInfo x ys)--updateInfo :: NodeId -> GatherInfo -> [(NodeId, GatherInfo)] -> [(NodeId, GatherInfo)]-updateInfo il gi [] = [(il, gi)]-updateInfo il (GatherInfo c scope) ((n,gi):xs) | n == il = (n, gi') : xs-  where-    gi' = gi { giCount = giCount gi + c , giScopes = Set.union (giScopes gi) scope }-updateInfo il gi (x:xs) = x : updateInfo il gi xs---lambdaHashes :: forall dom a-    .  (Equality dom)-    => PrjDict dom-    -> ASTF dom a-    -> Map.Map VarId Hash-lambdaHashes pd a = execWriter (lambdaHashes' a)-  where-    lambdaHashes' :: AST dom b -> Writer (Map.Map VarId Hash) Hash-    lambdaHashes' (Sym lam :$ b) | Just v <- prjLambda pd lam = do-        h' <- lambdaHashes' b-        tell (Map.singleton v h')-        return $ hashInt 1 `combine` exprHash (Sym lam) `combine` h'-    lambdaHashes' (s :$ b) = do-        hs <- lambdaHashes' s-        hb <- lambdaHashes' b-        return $ hashInt 1 `combine` hs `combine` hb-    lambdaHashes' s = return $ hashInt 0 `combine` exprHash s---- | Like 'reify' but with common sub-expression elimination and variable hoisting-reifySmart2 :: forall dom p pVar a-    .  ( AlphaEq dom dom (NodeDomain (FODomain dom p pVar)) [(VarId,VarId)]-       , AlphaEq dom dom (FODomain dom p pVar) [(VarId,VarId)]-       , Equality dom-       , Syntactic a-       , Domain a ~ HODomain dom p pVar-       , p :< Typeable-       )-    => (forall c. ASTF (FODomain dom p pVar) c -> Bool)-    -> MkInjDict (FODomain dom p pVar)-    -> a-    -> ASTF (FODomain dom p pVar) (Internal a)-reifySmart2 hoistOver mkId = flip evalState 0 . (codeMotion2 hoistOver prjDictFO mkId <=< reifyM . desugar)
− src/Language/Syntactic/Sharing/Graph.hs 
@@ -1,348 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}---- | Representation and manipulation of abstract syntax graphs--module Language.Syntactic.Sharing.Graph where----import Control.Arrow ((***))-import Control.Monad.Reader-import Data.Array-import Data.Function-import Data.List-import Data.Typeable--import Data.Hash--import Language.Syntactic-import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Sharing.Utils--------------------------------------------------------------------------------------- * Representation------------------------------------------------------------------------------------- | Node identifier-newtype NodeId = NodeId { nodeInteger :: Integer }-  deriving (Eq, Ord, Num, Real, Integral, Enum, Ix)--instance Show NodeId-  where-    show (NodeId i) = show i--showNode :: NodeId -> String-showNode n = "node:" ++ show n------ | Placeholder for a syntax tree-data Node a-  where-    Node :: NodeId -> Node (Full a)--instance Constrained Node-  where-    {-# SPECIALIZE instance Constrained Node #-}-    {-# INLINABLE exprDict #-}-    type Sat Node = Top-    exprDict _ = Dict--instance Render Node-  where-    {-# INLINABLE renderSym #-}-    renderSym (Node a) = showNode a--instance StringTree Node------ | Environment for alpha-equivalence-class NodeEqEnv dom a-  where-    prjNodeEqEnv :: a -> NodeEnv dom (Sat dom)-    modNodeEqEnv :: (NodeEnv dom (Sat dom) -> NodeEnv dom (Sat dom)) -> (a -> a)--type EqEnv dom p = ([(VarId,VarId)], NodeEnv dom p)--type NodeEnv dom p =-    ( Array NodeId Hash-    , Array NodeId (ASTB dom p)-    )--instance (p ~ Sat dom) => NodeEqEnv dom (EqEnv dom p)-  where-    {-# SPECIALIZE instance (p ~ Sat dom) => NodeEqEnv dom (EqEnv dom p) #-}-    {-# INLINABLE prjNodeEqEnv #-}-    {-# INLINABLE modNodeEqEnv #-}-    prjNodeEqEnv   = snd-    modNodeEqEnv f = (id *** f)--instance VarEqEnv (EqEnv dom p)-  where-    {-# SPECIALIZE instance VarEqEnv (EqEnv dom p) #-}-    {-# INLINABLE prjVarEqEnv #-}-    {-# INLINABLE modVarEqEnv #-}-    prjVarEqEnv   = fst-    modVarEqEnv f = (f *** id)--instance (AlphaEq dom dom dom env, NodeEqEnv dom env) =>-    AlphaEq Node Node dom env-  where-    {-# SPECIALIZE instance (AlphaEq dom dom dom env, NodeEqEnv dom env) =>-          AlphaEq Node Node dom env #-}-    {-# INLINABLE alphaEqSym #-}-    alphaEqSym (Node n1) Nil (Node n2) Nil-        | n1 == n2  = return True-        | otherwise = do-            (hTab,nTab) :: NodeEnv dom (Sat dom) <- asks prjNodeEqEnv-            if hTab!n1 /= hTab!n2-              then return False-              else case (nTab!n1, nTab!n2) of-                  (ASTB a, ASTB b) -> alphaEqM a b-                    -- TODO The result could be memoized in a-                    -- @Map (NodeId,NodeId) Bool@--  -- TODO With only this instance, the result will be 'False' when one argument-  --      is a 'Node' and the other one isn't. This is not really correct since-  --      'Node's are just meta-variables and shouldn't be part of the-  --      comparison. But as long as equivalent expressions always have 'Node's-  --      at the same position, it doesn't matter. This could probably be fixed-  --      by adding two overlapping instances.------ | \"Abstract Syntax Graph\"------ A representation of a syntax tree with explicit sharing. An 'ASG' is valid if--- and only if 'inlineAll' succeeds (and the 'numNodes' field is correct).-data ASG dom a = ASG-    { topExpression :: ASTF (NodeDomain dom) a              -- ^ Top-level expression-    , graphNodes    :: [(NodeId, ASTSAT (NodeDomain dom))]  -- ^ Mapping from node id to sub-expression-    , numNodes      :: NodeId                               -- ^ Total number of nodes-    }--type NodeDomain dom = (Node :+: dom) :|| Sat dom------ | Show syntax graph using ASCII art-showASG :: forall dom a. StringTree dom => ASG dom a -> String-showASG (ASG top nodes _) =-    unlines ((line "top" ++ showAST top) : map showNode nodes)-  where-    line str = "---- " ++ str ++ " " ++ rest ++ "\n"-      where-        rest = replicate (40 - length str) '-'--    showNode :: (NodeId, ASTSAT (NodeDomain dom)) -> String-    showNode (n, ASTB expr) = concat-      [ line ("node:" ++ show n)-      , showAST expr-      ]---- | Print syntax graph using ASCII art-drawASG :: StringTree dom => ASG dom a -> IO ()-drawASG = putStrLn . showASG---- | Update the node identifiers in an 'AST' using the supplied reindexing--- function-reindexNodesAST ::-    (NodeId -> NodeId) -> AST (NodeDomain dom) a -> AST (NodeDomain dom) a-reindexNodesAST reix (Sym (C' (InjL (Node n)))) = injC $ Node $ reix n-reindexNodesAST reix (s :$ a) = reindexNodesAST reix s :$ reindexNodesAST reix a-reindexNodesAST reix a = a---- | Reindex the nodes according to the given index mapping. The number of nodes--- is unchanged, so if the index mapping is not 1:1, the resulting graph will--- contain duplicates.-reindexNodes :: (NodeId -> NodeId) -> ASG dom a -> ASG dom a-reindexNodes reix (ASG top nodes n) = ASG top' nodes' n-  where-    top'   = reindexNodesAST reix top-    nodes' =-      [ (reix n, ASTB $ reindexNodesAST reix a)-        | (n, ASTB a) <- nodes-      ]---- | Reindex the nodes to be in the range @[0 .. l-1]@, where @l@ is the number--- of nodes in the graph-reindexNodesFrom0 :: ASG dom a -> ASG dom a-reindexNodesFrom0 graph = reindexNodes reix graph-  where-    reix = reindex $ map fst $ graphNodes graph---- | Remove duplicate nodes from a graph. The function only looks at the--- 'NodeId' of each node. The 'numNodes' field is updated accordingly.-nubNodes :: ASG dom a -> ASG dom a-nubNodes (ASG top nodes n) = ASG top nodes' n'-  where-    nodes' = nubBy ((==) `on` fst) nodes-    n'     = genericLength nodes'--------------------------------------------------------------------------------------- * Folding------------------------------------------------------------------------------------- | Pattern functor representation of an 'AST' with 'Node's-data SyntaxPF dom a-  where-    AppPF  :: a -> a -> SyntaxPF dom a-    NodePF :: NodeId -> a -> SyntaxPF dom a-    DomPF  :: dom b -> SyntaxPF dom a-  -- NOTE: The important constructor is 'NodePF', which makes a 'Node' appear as-  -- any other recursive constructor.--instance Functor (SyntaxPF dom)-  where-    fmap f (AppPF g a)  = AppPF  (f g) (f a)-    fmap f (NodePF n a) = NodePF n (f a)-    fmap f (DomPF a)    = DomPF a------ | Folding over a graph------ The user provides a function to fold a single constructor (an \"algebra\").--- The result contains the result of folding the whole graph as well as the--- result of each internal node, represented both as an array and an association--- list. Each node is processed exactly once.-foldGraph :: forall dom a b .-    (SyntaxPF dom b -> b) -> ASG dom a -> (b, (Array NodeId b, [(NodeId,b)]))-foldGraph alg (ASG top ns nn) = (g top, (arr,nodes))-  where-    nodes = [(n, g expr) | (n, ASTB expr) <- ns]-    arr   = array (0, nn-1) nodes--    g :: AST (NodeDomain dom) c -> b-    g (h :$ a)                   = alg $ AppPF (g h) (g a)-    g (Sym (C' (InjL (Node n)))) = alg $ NodePF n (arr!n)-    g (Sym (C' (InjR a)))        = alg $ DomPF a--------------------------------------------------------------------------------------- * Inlining------------------------------------------------------------------------------------- | Convert an 'ASG' to an 'AST' by inlining all nodes-inlineAll :: forall dom a . ConstrainedBy dom Typeable =>-    ASG dom a -> ASTF dom a-inlineAll (ASG top nodes n) = inline top-  where-    nodeMap = array (0, n-1) nodes--    inline :: AST (NodeDomain dom) b -> AST dom b-    inline (s :$ a) = inline s :$ inline a-    inline s@(Sym (C' (InjL (Node n)))) = case nodeMap ! n of-        ASTB a-          | Dict <- exprDictSub pTypeable s-          , Dict <- exprDictSub pTypeable a-          -> case gcast a of-               Nothing -> error "inlineAll: type mismatch"-               Just a  -> inline a-    inline (Sym (C' (InjR a))) = Sym a------ | Find the child nodes of each node in an expression. The child nodes of a--- node @n@ are the first nodes along all paths from @n@.-nodeChildren :: ASG dom a -> [(NodeId, [NodeId])]-nodeChildren = map (id *** fromDList) . snd . snd . foldGraph children-  where-    children :: SyntaxPF dom (DList NodeId) -> DList NodeId-    children (AppPF ns1 ns2) = ns1 . ns2-    children (NodePF n _)    = single n-    children _               = empty---- | Count the number of occurrences of each node in an expression-occurrences :: ASG dom a -> Array NodeId Int-occurrences graph-    = count (0, numNodes graph - 1)-    $ concatMap snd-    $ nodeChildren graph---- | Inline all nodes that are not shared-inlineSingle :: forall dom a . ConstrainedBy dom Typeable =>-    ASG dom a -> ASG dom a-inlineSingle graph@(ASG top nodes n) = ASG top' nodes' n'-  where-    nodeTab  = array (0, n-1) nodes-    occs     = occurrences graph--    top'   = inline top-    nodes' = [(n, ASTB (inline a)) | (n, ASTB a) <- nodes, occs!n > 1]-    n'     = genericLength nodes'--    inline :: AST (NodeDomain dom) b -> AST (NodeDomain dom) b-    inline (s :$ a) = inline s :$ inline a-    inline s@(Sym (C' (InjL (Node n))))-        | occs!n > 1 = injC $ Node n-        | otherwise = case nodeTab ! n of-            ASTB a-              | Dict <- exprDictSub pTypeable s-              , Dict <- exprDictSub pTypeable a-              -> case gcast a of-                   Nothing -> error "inlineSingle: type mismatch"-                   Just a  -> inline a-    inline (Sym (C' (InjR a))) = Sym $ C' $ InjR a--------------------------------------------------------------------------------------- * Sharing------------------------------------------------------------------------------------- | Compute a table (both array and list representation) of hash values for--- each node-hashNodes :: Equality dom => ASG dom a -> (Array NodeId Hash, [(NodeId, Hash)])-hashNodes = snd . foldGraph hashNode-  where-    hashNode (AppPF h1 h2) = hashInt 0 `combine` h1 `combine` h2-    hashNode (NodePF _ h)  = h-    hashNode (DomPF a)     = hashInt 1 `combine` exprHash a------ | Partitions the nodes such that two nodes are in the same sub-list if and--- only if they are alpha-equivalent.-partitionNodes :: forall dom a-    .  ( Equality dom-       , AlphaEq dom dom (NodeDomain dom) (EqEnv (NodeDomain dom) (Sat dom))-       )-    => ASG dom a -> [[NodeId]]-partitionNodes graph = concatMap (fullPartition nodeEq) approxPartitioning-  where-    nTab          = array (0, numNodes graph - 1) (graphNodes graph)-    (hTab,hashes) = hashNodes graph--    -- | An approximate partitioning of the nodes: nodes in different partitions-    -- are guaranteed to be inequivalent, while nodes in the same partition-    -- might be equivalent.-    approxPartitioning-        = map (map fst)-        $ groupBy ((==) `on` snd)-        $ sortBy (compare `on` snd)-        $ hashes--    nodeEq :: NodeId -> NodeId -> Bool-    nodeEq n1 n2 = runReader-        (liftASTB2 alphaEqM (nTab!n1) (nTab!n2))-        (([],(hTab,nTab)) :: EqEnv (NodeDomain dom) (Sat dom))------ | Common sub-expression elimination based on alpha-equivalence-cse-    :: ( Equality dom-       , AlphaEq dom dom (NodeDomain dom) (EqEnv (NodeDomain dom) (Sat dom))-       )-    => ASG dom a -> ASG dom a-cse graph@(ASG top nodes n) = nubNodes $ reindexNodes (reixTab!) graph-  where-    parts   = partitionNodes graph-    reixTab = array (0,n-1) [(n,p) | (part,p) <- parts `zip` [0..], n <- part]
− src/Language/Syntactic/Sharing/Reify.hs 
@@ -1,80 +0,0 @@--- | Reifying the sharing in an 'AST'------ This module is based on the paper /Type-Safe Observable Sharing in Haskell/--- (Andy Gill, 2009, <http://dx.doi.org/10.1145/1596638.1596653>).--module Language.Syntactic.Sharing.Reify-    ( reifyGraph-    ) where----import Control.Monad.Writer-import Data.IntMap as Map-import Data.IORef-import System.Mem.StableName--import Language.Syntactic-import Language.Syntactic.Sharing.Graph-import Language.Syntactic.Sharing.StableName------ | Shorthand used by 'reifyGraphM'------ Writes out a list of encountered nodes and returns the top expression.-type GraphMonad dom a = WriterT-    [(NodeId, ASTB (NodeDomain dom) (Sat dom))]-    IO-    (AST (NodeDomain dom) a)----reifyGraphM :: forall dom a . Constrained dom-    => (forall a . ASTF dom a -> Bool)-    -> IORef NodeId-    -> IORef (History (AST dom))-    -> ASTF dom a-    -> GraphMonad dom (Full a)--reifyGraphM canShare nSupp history = reifyNode-  where-    reifyNode :: ASTF dom b -> GraphMonad dom (Full b)-    reifyNode a-      | Dict <- exprDict a = case canShare a of-          False -> reifyRec a-          True | a `seq` True -> do-            st   <- liftIO $ makeStableName a-            hist <- liftIO $ readIORef history-            case lookHistory hist (StName st) of-              Just n -> return $ injC $ Node n-              _ -> do-                n  <- fresh nSupp-                liftIO $ modifyIORef history $ remember (StName st) n-                a' <- reifyRec a-                tell [(n, ASTB a')]-                return $ injC $ Node n--    reifyRec :: Sat dom (DenResult b) => AST dom b -> GraphMonad dom b-    reifyRec (f :$ a) = liftM2 (:$) (reifyRec f) (reifyNode a)-    reifyRec (Sym s)  = return $ Sym $ C' $ InjR s------ | Convert a syntax tree to a sharing-preserving graph------ This function is not referentially transparent (hence the 'IO'). However, it--- is well-behaved in the sense that the worst thing that could happen is that--- sharing is lost. It is not possible to get false sharing.-reifyGraph :: Constrained dom-    => (forall a . ASTF dom a -> Bool)-         -- ^ A function that decides whether a given node can be shared-    -> ASTF dom a-    -> IO (ASG dom a)-reifyGraph canShare a = do-    nSupp   <- newIORef 0-    history <- newIORef empty-    (a',ns) <- runWriterT $ reifyGraphM canShare nSupp history a-    n       <- readIORef nSupp-    return (ASG a' ns n)-
− src/Language/Syntactic/Sharing/ReifyHO.hs 
@@ -1,109 +0,0 @@--- | This module is similar to "Language.Syntactic.Sharing.Reify", but operates--- on @`AST` (`HODomain` dom p)@ rather than a general 'AST'. The reason for--- having this module is that when using 'HODomain', it is important to do--- simultaneous sharing analysis and 'HOLambda' reification. Obviously we cannot--- do sharing analysis first (using--- 'Language.Syntactic.Sharing.Reify.reifyGraph' from--- "Language.Syntactic.Sharing.Reify"), since it needs to be able to look inside--- 'HOLambda'. On the other hand, if we did 'HOLambda' reification first (using--- 'reify'), we would destroy the sharing.------ This module is based on the paper /Type-Safe Observable Sharing in Haskell/--- (Andy Gill, 2009, <http://dx.doi.org/10.1145/1596638.1596653>).--module Language.Syntactic.Sharing.ReifyHO-    ( reifyGraphTop-    , reifyGraph-    ) where----import Control.Monad.Writer-import Data.IntMap as Map-import Data.IORef-import System.Mem.StableName--import Language.Syntactic-import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Constructs.Binding.HigherOrder-import Language.Syntactic.Sharing.Graph-import Language.Syntactic.Sharing.StableName-import qualified Language.Syntactic.Sharing.Reify  -- For Haddock------ | Shorthand used by 'reifyGraphM'------ Writes out a list of encountered nodes and returns the top expression.-type GraphMonad dom p pVar a = WriterT-    [(NodeId, ASTB (NodeDomain (FODomain dom p pVar)) p)]-    IO-    (AST (NodeDomain (FODomain dom p pVar)) a)----reifyGraphM :: forall dom p pVar a-    .  (forall a . ASTF (HODomain dom p pVar) a -> Bool)-    -> IORef VarId-    -> IORef NodeId-    -> IORef (History (AST (HODomain dom p pVar)))-    -> ASTF (HODomain dom p pVar) a-    -> GraphMonad dom p pVar (Full a)--reifyGraphM canShare vSupp nSupp history = reifyNode-  where-    reifyNode :: ASTF (HODomain dom p pVar) b -> GraphMonad dom p pVar (Full b)-    reifyNode a-      | Dict <- exprDict a = case canShare a of-          False -> reifyRec a-          True | a `seq` True -> do-            st   <- liftIO $ makeStableName a-            hist <- liftIO $ readIORef history-            case lookHistory hist (StName st) of-              Just n -> return $ injC $ Node n-              _ -> do-                n  <- fresh nSupp-                liftIO $ modifyIORef history $ remember (StName st) n-                a' <- reifyRec a-                tell [(n, ASTB a')]-                return $ injC $ Node n--    reifyRec :: AST (HODomain dom p pVar) b -> GraphMonad dom p pVar b-    reifyRec (f :$ a)            = liftM2 (:$) (reifyRec f) (reifyNode a)-    reifyRec (Sym (C' (InjR a))) = return $ Sym $ C' $ InjR $ C' $ InjR a-    reifyRec (Sym (C' (InjL (HOLambda f)))) = do-        v    <- fresh vSupp-        body <- reifyNode $ f $ injC $ symType pVar $ C' (Variable v)-        return $ injC (symType pLam $ SubConstr2 (Lambda v)) :$ body-      where-        pVar = P::P (Variable :|| pVar)-        pLam = P::P (CLambda pVar)------ | Convert a syntax tree to a sharing-preserving graph-reifyGraphTop-    :: (forall a . ASTF (HODomain dom p pVar) a -> Bool)-    -> ASTF (HODomain dom p pVar) a-    -> IO (ASG (FODomain dom p pVar) a, VarId)-reifyGraphTop canShare a = do-    vSupp   <- newIORef 0-    nSupp   <- newIORef 0-    history <- newIORef empty-    (a',ns) <- runWriterT $ reifyGraphM canShare vSupp nSupp history a-    v       <- readIORef vSupp-    n       <- readIORef nSupp-    return (ASG a' ns n, v)---- | Reifying an n-ary syntactic function to a sharing-preserving graph------ This function is not referentially transparent (hence the 'IO'). However, it--- is well-behaved in the sense that the worst thing that could happen is that--- sharing is lost. It is not possible to get false sharing.-reifyGraph :: (Syntactic a, Domain a ~ HODomain dom p pVar)-    => (forall a . ASTF (HODomain dom p pVar) a -> Bool)-         -- ^ A function that decides whether a given node can be shared-    -> a-    -> IO (ASG (FODomain dom p pVar) (Internal a), VarId)-reifyGraph canShare = reifyGraphTop canShare . desugar-
− src/Language/Syntactic/Sharing/SimpleCodeMotion.hs 
@@ -1,243 +0,0 @@--- | Simple code motion transformation performing common sub-expression elimination and variable--- hoisting. Note that the implementation is very inefficient.------ The code is based on an implementation by Gergely Dévai.--module Language.Syntactic.Sharing.SimpleCodeMotion-    ( PrjDict (..)-    , InjDict (..)-    , MkInjDict-    , codeMotion-    , prjDictFO-    , reifySmart-    , mkInjDictFO-    ) where----import Control.Monad.State-import Data.Set as Set-import Data.Typeable--import Language.Syntactic-import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Constructs.Binding.HigherOrder------ | Interface for projecting binding constructs-data PrjDict dom = PrjDict-    { prjVariable :: forall sig . dom sig -> Maybe VarId-    , prjLambda   :: forall sig . dom sig -> Maybe VarId-    }---- | Interface for injecting binding constructs-data InjDict dom a b = InjDict-    { injVariable :: VarId -> dom (Full a)-    , injLambda   :: VarId -> dom (b :-> Full (a -> b))-    , injLet      :: dom (a :-> (a -> b) :-> Full b)-    }---- | A function that, if possible, returns an 'InjDict' for sharing a specific sub-expression. The--- first argument is the expression to be shared, and the second argument the expression in which it--- will be shared.------ This function makes the caller of 'codeMotion' responsible for making sure that the necessary--- type constraints are fulfilled (otherwise 'Nothing' is returned). It also makes it possible to--- transfer information, e.g. from the shared expression to the introduced variable.-type MkInjDict dom = forall a b . ASTF dom a -> ASTF dom b -> Maybe (InjDict dom a b)------ | Substituting a sub-expression. Assumes no variable capturing in the--- expressions involved.-substitute :: forall dom a b-    .  (ConstrainedBy dom Typeable, AlphaEq dom dom dom [(VarId,VarId)])-    => ASTF dom a  -- ^ Sub-expression to be replaced-    -> ASTF dom a  -- ^ Replacing sub-expression-    -> ASTF dom b  -- ^ Whole expression-    -> ASTF dom b-substitute x y a-    | Dict <- exprDictSub pTypeable y-    , Dict <- exprDictSub pTypeable a-    , Just y' <- gcast y, alphaEq x a = y'-    | otherwise = subst a-  where-    subst :: AST dom c -> AST dom c-    subst (f :$ a) = subst f :$ substitute x y a-    subst a = a-  -- Note: Since `codeMotion` only uses `substitute` to replace sub-expressions-  -- with fresh variables, there's no risk of capturing.---- | Count the number of occurrences of a sub-expression-count :: forall dom a b-    .  AlphaEq dom dom dom [(VarId,VarId)]-    => ASTF dom a  -- ^ Expression to count-    -> ASTF dom b  -- ^ Expression to count in-    -> Int-count a b-    | alphaEq a b = 1-    | otherwise   = cnt b-  where-    cnt :: AST dom c -> Int-    cnt (f :$ b) = cnt f + count a b-    cnt _        = 0---- | Environment for the expression in the 'choose' function-data Env dom = Env-    { inLambda :: Bool  -- ^ Whether the current expression is inside a lambda-    , counter  :: ASTE dom -> Int-        -- ^ Counting the number of occurrences of an expression in the-        -- environment-    , dependencies :: Set VarId-        -- ^ The set of variables that are not allowed to occur in the chosen-        -- expression-    }--isVariable :: PrjDict dom -> ASTF dom a -> Bool-isVariable pd (Sym (prjVariable pd -> Just _)) = True-isVariable pd _ = False---- | Get the set of free variables in an expression-freeVars :: PrjDict dom -> AST dom sig -> Set VarId-freeVars pd (Sym var)-    | Just v <- prjVariable pd var = Set.singleton v-freeVars pd (Sym lam :$ body)-    | Just v <- prjLambda pd lam = Set.delete v (freeVars pd body)-freeVars pd (s :$ a) = Set.union (freeVars pd s) (freeVars pd a)-freeVars _ _ = Set.empty---- | Checks whether a sub-expression in a given environment can be lifted out-liftable :: PrjDict dom -> Env dom -> ASTF dom a -> Bool-liftable pd env a = independent && not (isVariable pd a) && heuristic-    -- Lifting dependent expressions is semantically incorrect-    -- Lifting variables would cause `codeMotion` to loop-  where-   independent = Set.null $ Set.intersection (freeVars pd a) (dependencies env)-   heuristic   = inLambda env || (counter env (ASTE a) > 1)------ | A sub-expression chosen to be shared together with an evidence that it can actually be shared--- in the whole expression under consideration-data Chosen dom a-  where-    Chosen :: InjDict dom b a -> ASTF dom b -> Chosen dom a---- | Choose a sub-expression to share-choose :: forall dom a-    .  AlphaEq dom dom dom [(VarId,VarId)]-    => (forall c. ASTF dom c -> Bool)-    -> PrjDict dom-    -> MkInjDict dom-    -> ASTF dom a-    -> Maybe (Chosen dom a)-choose hoistOver pd mkId a = chooseEnvSub initEnv a-  where-    initEnv = Env-        { inLambda     = False-        , counter      = \(ASTE b) -> count b a-        , dependencies = empty-        }--    chooseEnv :: Env dom -> ASTF dom b -> Maybe (Chosen dom a)-    chooseEnv env b-        | liftable pd env b-        , Just id <- mkId b a-        = Just $ Chosen id b-    chooseEnv env b-        | hoistOver b = chooseEnvSub env b-        | otherwise       = Nothing--    -- | Like 'chooseEnv', but does not consider the top expression for sharing-    chooseEnvSub :: Env dom -> AST dom b -> Maybe (Chosen dom a)-    chooseEnvSub env (Sym lam :$ b)-        | Just v <- prjLambda pd lam-        = chooseEnv (env' v) b-      where-        env' v = env-            { inLambda     = True-            , dependencies = insert v (dependencies env)-            }-    chooseEnvSub env (s :$ b) = chooseEnvSub env s `mplus` chooseEnv env b-    chooseEnvSub _ _ = Nothing------ | Perform common sub-expression elimination and variable hoisting-codeMotion :: forall dom m a-    .  ( ConstrainedBy dom Typeable-       , AlphaEq dom dom dom [(VarId,VarId)]-       , MonadState VarId m-       )-    => (forall c. ASTF dom c -> Bool)  -- ^ Control wether a sub-expression can be hoisted over the given expression-    -> PrjDict dom-    -> MkInjDict dom-    -> ASTF dom a-    -> m (ASTF dom a)-codeMotion hoistOver pd mkId a-    | Just (Chosen id b) <- choose hoistOver pd mkId a = share id b-    | otherwise = descend a-  where-    share :: InjDict dom b a -> ASTF dom b -> m (ASTF dom a)-    share id b = do-        b' <- codeMotion hoistOver pd mkId b-        v  <- get; put (v+1)-        let x = Sym (injVariable id v)-        body <- codeMotion hoistOver pd mkId $ substitute b x a-        return-            $  Sym (injLet id)-            :$ b'-            :$ (Sym (injLambda id v) :$ body)--    descend :: AST dom b -> m (AST dom b)-    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId a)-    descend a        = return a------ | A 'PrjDict' implementation for 'FODomain'-prjDictFO :: forall dom p pVar . PrjDict (FODomain dom p pVar)-prjDictFO = PrjDict-    { prjVariable = fmap (\(C' (Variable v)) -> v)       . prjP (P::P (Variable :|| pVar))-    , prjLambda   = fmap (\(SubConstr2 (Lambda v)) -> v) . prjP (P::P (CLambda pVar))-    }---- | Like 'reify' but with common sub-expression elimination and variable hoisting-reifySmart :: forall dom p pVar a-    .  ( AlphaEq dom dom (FODomain dom p pVar) [(VarId,VarId)]-       , Syntactic a-       , Domain a ~ HODomain dom p pVar-       , p :< Typeable-       )-    => (forall c. ASTF (FODomain dom p pVar) c -> Bool)-    -> MkInjDict (FODomain dom p pVar)-    -> a-    -> ASTF (FODomain dom p pVar) (Internal a)-reifySmart hoistOver mkId = flip evalState 0 . (codeMotion hoistOver prjDictFO mkId <=< reifyM . desugar)------ | An 'MkInjDict' implementation for 'FODomain'------ The supplied function determines whether or not an expression can be shared by returning a--- witness that the type of the expression satisfies the predicate @pVar@.-mkInjDictFO :: forall dom pVar . (Let :<: dom)-    => (forall a . ASTF (FODomain dom Typeable pVar) a -> Maybe (Dict (pVar a)))-    -> (forall b . ASTF (FODomain dom Typeable pVar) b -> Bool)-    -> MkInjDict (FODomain dom Typeable pVar)-mkInjDictFO canShare canShareIn a b-    | Dict <- exprDict a-    , Dict <- exprDict b-    , Just Dict <- canShare a-    , canShareIn b-    = Just $ InjDict-        { injVariable = \v -> injC (symType pVar $ C' (Variable v))-        , injLambda   = \v -> injC (symType pLam $ SubConstr2 (Lambda v))-        , injLet      = C' $ inj Let-        }-  where-    pVar = P::P (Variable :|| pVar)-    pLam = P::P (CLambda pVar)-mkInjDictFO _ _ _ _ = Nothing-
− src/Language/Syntactic/Sharing/StableName.hs 
@@ -1,53 +0,0 @@-module Language.Syntactic.Sharing.StableName where----import Control.Monad.IO.Class-import Data.IntMap as Map-import Data.IORef-import System.Mem.StableName-import Unsafe.Coerce--import Language.Syntactic-import Language.Syntactic.Sharing.Graph------ | 'StableName' of a @(c (Full a))@ with hidden result type-data StName c-  where-    StName :: StableName (c (Full a)) -> StName c--instance Eq (StName c)-  where-    StName a == StName b = a == unsafeCoerce b-      -- This is "probably" safe according to-      -- <http://www.haskell.org/pipermail/glasgow-haskell-users/2012-August/022758.html>--      -- TODO In future, use `eqStableName`. It should be in GHC 7.8.1.--hash :: StName c -> Int-hash (StName st) = hashStableName st---- | A hash table from 'StName' to 'NodeId' (with 'hash' as the hashing--- function). I.e. it is assumed that the 'StName's at each entry all have the--- same hash, and that this number is equal to the entry's key.-type History c = IntMap [(StName c, NodeId)]---- | Lookup a name in the history-lookHistory :: History c -> StName c -> Maybe NodeId-lookHistory hist st = case Map.lookup (hash st) hist of-    Nothing   -> Nothing-    Just list -> Prelude.lookup st list---- | Insert the name into the history-remember :: StName c -> NodeId -> History c -> History c-remember st n hist = insertWith (++) (hash st) [(st,n)] hist---- | Return a fresh identifier from the given supply-fresh :: (Enum a, MonadIO m) => IORef a -> m a-fresh aRef = do-    a <- liftIO $ readIORef aRef-    liftIO $ writeIORef aRef (succ a)-    return a-
− src/Language/Syntactic/Sharing/Utils.hs 
@@ -1,59 +0,0 @@--- | Some utility functions used by the other modules--module Language.Syntactic.Sharing.Utils where----import Data.Array-import Data.List--------------------------------------------------------------------------------------- * Difference lists------------------------------------------------------------------------------------- | Difference list-type DList a = [a] -> [a]---- | Empty list-empty :: DList a-empty = id---- | Singleton list-single :: a -> DList a-single = (:)--fromDList :: DList a -> [a]-fromDList = ($ [])--------------------------------------------------------------------------------------- * Misc.------------------------------------------------------------------------------------- | Given a list @is@ of unique natural numbers, returns a function that maps--- each number in @is@ to a unique number in the range @[0 .. length is-1]@. The--- complexity is O(@maximum is@).-reindex :: (Integral a, Ix a) => [a] -> a -> a-reindex is = (tab!)-  where-    tab = array (0, maximum is) $ zip is [0..]---- | Count the number of occurrences of each element in the list. The result is--- an array mapping each element to its number of occurrences.-count :: Ix a-    => (a,a)  -- ^ Upper and lower bound on the elements to be counted-    -> [a]    -- ^ Elements to be counted-    -> Array a Int-count bnds as = accumArray (+) 0 bnds [(n,1) | n <- as]---- | Partitions the list such that two elements are in the same sub-list if and--- only if they satisfy the equivalence check. The complexity is O(n^2).-fullPartition :: (a -> a -> Bool) -> [a] -> [[a]]-fullPartition eq []     = []-fullPartition eq (a:as) = (a:as1) : fullPartition eq as2-  where-    (as1,as2) = partition (eq a) as-
− src/Language/Syntactic/Sugar.hs 
@@ -1,136 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif---- | \"Syntactic sugar\"--module Language.Syntactic.Sugar where----import Language.Syntactic.Syntax-import Language.Syntactic.Constraint------ | It is usually assumed that @(`desugar` (`sugar` a))@ has the same meaning--- as @a@.-class Syntactic a-  where-    type Domain a :: * -> *-    type Internal a-    desugar :: a -> ASTF (Domain a) (Internal a)-    sugar   :: ASTF (Domain a) (Internal a) -> a--instance Syntactic (ASTF dom a)-  where-    {-# SPECIALIZE instance Syntactic (ASTF dom a) #-}-    type Domain (ASTF dom a)   = dom-    type Internal (ASTF dom a) = a-    desugar = id-    sugar   = id-    {-# INLINABLE desugar #-}-    {-# INLINABLE sugar #-}---- | Syntactic type casting-resugar :: (Syntactic a, Syntactic b, Domain a ~ Domain b, Internal a ~ Internal b) => a -> b-resugar = sugar . desugar-{-# INLINABLE resugar #-}---- | N-ary syntactic functions------ 'desugarN' has any type of the form:------ > desugarN ::--- >     ( Syntactic a--- >     , Syntactic b--- >     , ...--- >     , Syntactic x--- >     , Domain a ~ dom--- >     , Domain b ~ dom--- >     , ...--- >     , Domain x ~ dom--- >     ) => (a -> b -> ... -> x)--- >       -> (  ASTF dom (Internal a)--- >          -> ASTF dom (Internal b)--- >          -> ...--- >          -> ASTF dom (Internal x)--- >          )------ ...and vice versa for 'sugarN'.-class SyntacticN a internal | a -> internal-  where-    desugarN :: a -> internal-    sugarN   :: internal -> a--instance {-# OVERLAPPABLE #-}-    (Syntactic a, Domain a ~ dom, ia ~ AST dom (Full (Internal a))) => SyntacticN a ia-  where-    {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom-                            , ia ~ AST dom (Full (Internal a))-                            ) => SyntacticN a ia #-}-    desugarN = desugar-    sugarN   = sugar-    {-# INLINABLE desugarN #-}-    {-# INLINABLE sugarN #-}--instance {-# OVERLAPPABLE #-}-    ( Syntactic a-    , Domain a ~ dom-    , ia ~ Internal a-    , SyntacticN b ib-    ) =>-      SyntacticN (a -> b) (AST dom (Full ia) -> ib)-  where-    {-# SPECIALIZE instance ( Syntactic a-                            , Domain a ~ dom-                            , ia ~ Internal a-                            , SyntacticN b ib-                            ) => SyntacticN (a -> b) (AST dom (Full ia) -> ib) #-}-    desugarN f = desugarN . f . sugar-    sugarN f   = sugarN . f . desugar-    {-# INLINABLE desugarN #-}-    {-# INLINABLE sugarN #-}------ | \"Sugared\" symbol application------ 'sugarSym' has any type of the form:------ > sugarSym ::--- >     ( expr :<: AST dom--- >     , Syntactic a dom--- >     , Syntactic b dom--- >     , ...--- >     , Syntactic x dom--- >     ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x))--- >       -> (a -> b -> ... -> x)-sugarSym :: (sym :<: AST dom, ApplySym sig b dom, SyntacticN c b) =>-    sym sig -> c-sugarSym = sugarN . appSym-{-# INLINABLE sugarSym #-}---- | \"Sugared\" symbol application------ 'sugarSymC' has any type of the form:------ > sugarSymC ::--- >     ( InjectC expr (AST dom) (Internal x)--- >     , Syntactic a dom--- >     , Syntactic b dom--- >     , ...--- >     , Syntactic x dom--- >     ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x))--- >       -> (a -> b -> ... -> x)-sugarSymC-    :: ( InjectC sym (AST dom) (DenResult sig)-       , ApplySym sig b dom-       , SyntacticN c b-       )-    => sym sig -> c-sugarSymC = sugarN . appSymC-{-# INLINABLE sugarSymC #-}
− src/Language/Syntactic/Syntax.hs 
@@ -1,209 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif-{-# LANGUAGE UndecidableInstances #-}---- | Generic representation of typed syntax trees------ For details, see: A Generic Abstract Syntax Model for Embedded Languages--- (ICFP 2012, <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic.pdf>).--module Language.Syntactic.Syntax-    ( -- * Syntax trees-      AST (..)-    , ASTF-    , Full (..)-    , (:->) (..)-    , size-    , ApplySym (..)-    , DenResult-      -- * Symbol domains-    , (:+:) (..)-    , Project (..)-    , (:<:) (..)-    , appSym-      -- * Type inference-    , symType-    , prjP-    ) where---#if (__GLASGOW_HASKELL__ <= 704)-import Control.Monad.Instances ()-#endif-import Data.Typeable--import Data.PolyProxy--------------------------------------------------------------------------------------- * Syntax trees------------------------------------------------------------------------------------- | Generic abstract syntax tree, parameterized by a symbol domain------ @(`AST` dom (a `:->` b))@ represents a partially applied (or unapplied)--- symbol, missing at least one argument, while @(`AST` dom (`Full` a))@--- represents a fully applied symbol, i.e. a complete syntax tree.-data AST dom sig-  where-    Sym  :: dom sig -> AST dom sig-    (:$) :: AST dom (a :-> sig) -> AST dom (Full a) -> AST dom sig--infixl 1 :$---- | Fully applied abstract syntax tree-type ASTF dom a = AST dom (Full a)--instance Functor dom => Functor (AST dom)-  where-    fmap f (Sym s)  = Sym (fmap f s)-    fmap f (s :$ a) = fmap (fmap f) s :$ a---- | Signature of a fully applied symbol-newtype Full a = Full { result :: a }-  deriving (Eq, Show, Typeable, Functor)---- | Signature of a partially applied (or unapplied) symbol-newtype a :-> sig = Partial (a -> sig)-  deriving (Typeable, Functor)--infixr :->---- | Count the number of symbols in an expression-size :: AST dom sig -> Int-size (Sym _)  = 1-size (s :$ a) = size s + size a---- | Class for the type-level recursion needed by 'appSym'-class ApplySym sig f dom | sig dom -> f, f -> sig dom-  where-    appSym' :: AST dom sig -> f--instance ApplySym (Full a) (ASTF dom a) dom-  where-    {-# SPECIALIZE instance ApplySym (Full a) (ASTF dom a) dom #-}-    {-# INLINABLE appSym' #-}-    appSym' = id--instance ApplySym sig f dom => ApplySym (a :-> sig) (ASTF dom a -> f) dom-  where-    {-# SPECIALIZE instance ApplySym sig f dom => ApplySym (a :-> sig) (ASTF dom a -> f) dom #-}-    {-# INLINABLE appSym' #-}-    appSym' sym a = appSym' (sym :$ a)---- | The result type of a symbol with the given signature-type family   DenResult sig-type instance DenResult (Full a)    = a-type instance DenResult (a :-> sig) = DenResult sig--------------------------------------------------------------------------------------- * Symbol domains------------------------------------------------------------------------------------- | Direct sum of two symbol domains-data (dom1 :+: dom2) a-  where-    InjL :: dom1 a -> (dom1 :+: dom2) a-    InjR :: dom2 a -> (dom1 :+: dom2) a-  deriving (Functor)--infixr :+:---- | Symbol projection-class Project sub sup-  where-    -- | Partial projection from @sup@ to @sub@-    prj :: sup a -> Maybe (sub a)--instance Project sub sup => Project sub (AST sup)-  where-    {-# SPECIALIZE instance Project sub sup => Project sub (AST sup) #-}-    {-# INLINABLE prj #-}-    prj (Sym a) = prj a-    prj _       = Nothing--instance Project expr expr-  where-    {-# SPECIALIZE instance Project expr expr #-}-    {-# INLINABLE prj #-}-    prj = Just--instance {-# OVERLAPPING #-} Project expr1 (expr1 :+: expr2)-  where-    {-# SPECIALIZE instance Project expr1 (expr1 :+: expr2) #-}-    {-# INLINABLE prj #-}-    prj (InjL a) = Just a-    prj _        = Nothing--instance {-# OVERLAPPING #-} Project expr1 expr3 => Project expr1 (expr2 :+: expr3)-  where-    {-# SPECIALIZE instance Project expr1 expr3 => Project expr1 (expr2 :+: expr3) #-}-    {-# INLINABLE prj #-}-    prj (InjR a) = prj a-    prj _        = Nothing---- | Symbol subsumption-class Project sub sup => sub :<: sup-  where-    -- | Injection from @sub@ to @sup@-    inj :: sub a -> sup a--instance (sub :<: sup) => (sub :<: AST sup)-  where-    {-# SPECIALIZE instance (sub :<: sup) => (sub :<: AST sup) #-}-    {-# INLINABLE inj #-}-    inj = Sym . inj--instance (expr :<: expr)-  where-    {-# SPECIALIZE instance (expr :<: expr) #-}-    {-# INLINABLE inj #-}-    inj = id--instance {-# OVERLAPPING #-} (expr1 :<: (expr1 :+: expr2))-  where-    {-# SPECIALIZE instance (expr1 :<: (expr1 :+: expr2)) #-}-    {-# INLINABLE inj #-}-    inj = InjL--instance {-# OVERLAPPING #-} (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3))-  where-    {-# SPECIALIZE instance (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3)) #-}-    {-# INLINABLE inj #-}-    inj = InjR . inj---- The reason for separating the `Project` and `(:<:)` classes is that there are--- types that can be instances of the former but not the latter due to type--- constraints on the `a` type.---- | Generic symbol application------ 'appSym' has any type of the form:------ > appSym :: (expr :<: AST dom)--- >     => expr (a :-> b :-> ... :-> Full x)--- >     -> (ASTF dom a -> ASTF dom b -> ... -> ASTF dom x)-appSym :: (ApplySym sig f dom, sym :<: AST dom) => sym sig -> f-appSym = appSym' . inj-{-# INLINABLE appSym #-}--------------------------------------------------------------------------------------- * Type inference------------------------------------------------------------------------------------- | Constrain a symbol to a specific type-symType :: P sym -> sym sig -> sym sig-symType = const id-{-# INLINABLE symType #-}---- | Projection to a specific symbol type-prjP :: Project sub sup => P sub -> sup sig -> Maybe (sub sig)-prjP = const prj-{-# INLINABLE prjP #-}
− src/Language/Syntactic/Traversal.hs 
@@ -1,204 +0,0 @@--- | Generic traversals of 'AST' terms--module Language.Syntactic.Traversal-    ( gmapQ-    , gmapT-    , everywhereUp-    , everywhereDown-    , Args (..)-    , listArgs-    , mapArgs-    , mapArgsA-    , mapArgsM-    , appArgs-    , foldrArgs-    , listFold-    , match-    , query-    , simpleMatch-    , fold-    , simpleFold-    , matchTrans-    , WrapFull (..)-    , toTree-    ) where----import Control.Applicative-import Data.Tree--import Language.Syntactic.Syntax------ | Map a function over all immediate sub-terms (corresponds to the function--- with the same name in Scrap Your Boilerplate)-gmapT :: forall dom-      .  (forall a . ASTF dom a -> ASTF dom a)-      -> (forall a . ASTF dom a -> ASTF dom a)-gmapT f = go-  where-    go :: forall a . AST dom a -> AST dom a-    go (s :$ a) = go s :$ f a-    go s        = s---- | Map a function over all immediate sub-terms, collecting the results in a--- list (corresponds to the function with the same name in Scrap Your--- Boilerplate)-gmapQ :: forall dom b-      .  (forall a . ASTF dom a -> b)-      -> (forall a . ASTF dom a -> [b])-gmapQ f = go-  where-    go :: forall a . AST dom a -> [b]-    go (s :$ a) = f a : go s-    go _        = []---- | Apply a transformation bottom-up over an expression (corresponds to--- @everywhere@ in Scrap Your Boilerplate)-everywhereUp-    :: (forall a . ASTF dom a -> ASTF dom a)-    -> (forall a . ASTF dom a -> ASTF dom a)-everywhereUp f = f . gmapT (everywhereUp f)---- | Apply a transformation top-down over an expression (corresponds to--- @everywhere'@ in Scrap Your Boilerplate)-everywhereDown-    :: (forall a . ASTF dom a -> ASTF dom a)-    -> (forall a . ASTF dom a -> ASTF dom a)-everywhereDown f = gmapT (everywhereDown f) . f---- | List of symbol arguments-data Args c sig-  where-    Nil  :: Args c (Full a)-    (:*) :: c (Full a) -> Args c sig -> Args c (a :-> sig)--infixr :*---- | Map a function over an 'Args' list and collect the results in an ordinary--- list-listArgs :: (forall a . c (Full a) -> b) -> Args c sig -> [b]-listArgs _ Nil       = []-listArgs f (a :* as) = f a : listArgs f as---- | Map a function over an 'Args' list-mapArgs-    :: (forall a   . c1 (Full a) -> c2 (Full a))-    -> (forall sig . Args c1 sig -> Args c2 sig)-mapArgs _ Nil       = Nil-mapArgs f (a :* as) = f a :* mapArgs f as---- | Map an applicative function over an 'Args' list-mapArgsA :: Applicative f-    => (forall a   . c1 (Full a) -> f (c2 (Full a)))-    -> (forall sig . Args c1 sig -> f (Args c2 sig))-mapArgsA _ Nil       = pure Nil-mapArgsA f (a :* as) = (:*) <$> f a <*> mapArgsA f as---- | Map a monadic function over an 'Args' list-mapArgsM :: Monad m-    => (forall a   . c1 (Full a) -> m (c2 (Full a)))-    -> (forall sig . Args c1 sig -> m (Args c2 sig))-mapArgsM f = unwrapMonad . mapArgsA (WrapMonad . f)---- | Right fold for an 'Args' list-foldrArgs-    :: (forall a . c (Full a) -> b -> b)-    -> b-    -> (forall sig . Args c sig -> b)-foldrArgs _ b Nil       = b-foldrArgs f b (a :* as) = f a (foldrArgs f b as)---- | Apply a (partially applied) symbol to a list of argument terms-appArgs :: AST dom sig -> Args (AST dom) sig -> ASTF dom (DenResult sig)-appArgs a Nil       = a-appArgs s (a :* as) = appArgs (s :$ a) as---- | \"Pattern match\" on an 'AST' using a function that gets direct access to--- the top-most symbol and its sub-trees-match :: forall dom a c-    .  ( forall sig . (a ~ DenResult sig) =>-           dom sig -> Args (AST dom) sig -> c (Full a)-       )-    -> ASTF dom a-    -> c (Full a)-match f = flip go Nil-  where-    go :: (a ~ DenResult sig) => AST dom sig -> Args (AST dom) sig -> c (Full a)-    go (Sym a)  as = f a as-    go (s :$ a) as = go s (a :* as)-{-# INLINABLE match #-}--query :: forall dom a c-    .  ( forall sig . (a ~ DenResult sig) =>-           dom sig -> Args (AST dom) sig -> c (Full a)-       )-    -> ASTF dom a-    -> c (Full a)-query = match-{-# DEPRECATED query "Please use `match` instead." #-}---- | A version of 'match' with a simpler result type-simpleMatch :: forall dom a b-    .  (forall sig . (a ~ DenResult sig) => dom sig -> Args (AST dom) sig -> b)-    -> ASTF dom a-    -> b-simpleMatch f = getConst . match (\s -> Const . f s)-{-# INLINABLE simpleMatch #-}---- | Fold an 'AST' using an 'Args' list to hold the results of sub-terms-fold :: forall dom c-    .  (forall sig . dom sig -> Args c sig -> c (Full (DenResult sig)))-    -> (forall a   . ASTF dom a -> c (Full a))-fold f = match (\s -> f s . mapArgs (fold f))-{-# INLINABLE fold #-}---- | Simplified version of 'fold' for situations where all intermediate results--- have the same type-simpleFold :: forall dom b-    .  (forall sig . dom sig -> Args (Const b) sig -> b)-    -> (forall a   . ASTF dom a                    -> b)-simpleFold f = getConst . fold (\s -> Const . f s)-{-# INLINABLE simpleFold #-}---- | Fold an 'AST' using a list to hold the results of sub-terms-listFold :: forall dom b-    .  (forall sig . dom sig -> [b] -> b)-    -> (forall a   . ASTF dom a     -> b)-listFold f = simpleFold (\s -> f s . listArgs getConst)-{-# INLINABLE listFold #-}--newtype WrapAST c dom sig = WrapAST { unWrapAST :: c (AST dom sig) }-  -- Only used in the definition of 'matchTrans'---- | A version of 'match' where the result is a transformed syntax tree,--- wrapped in a type constructor @c@-matchTrans :: forall dom dom' c a-    .  ( forall sig . (a ~ DenResult sig) =>-           dom sig -> Args (AST dom) sig -> c (ASTF dom' a)-       )-    -> ASTF dom a-    -> c (ASTF dom' a)-matchTrans f = unWrapAST . match (\s -> WrapAST . f s)-{-# INLINABLE matchTrans #-}---- | Can be used to make an arbitrary type constructor indexed by @(`Full` a)@.--- This is useful as the type constructor parameter of 'Args'. That is, use------ > Args (WrapFull c) ...------ instead of------ > Args c ...------ if @c@ is not indexed by @(`Full` a)@.-data WrapFull c a-  where-    WrapFull :: { unwrapFull :: c a } -> WrapFull c (Full a)---- | Convert an 'AST' to a 'Tree'-toTree :: forall dom a b . (forall sig . dom sig -> b) -> ASTF dom a -> Tree b-toTree f = listFold (Node . f)-{-# INLINABLE toTree #-}
syntactic.cabal view
@@ -1,23 +1,11 @@ Name:           syntactic-Version:        1.17-Synopsis:       Generic abstract syntax, and utilities for embedded languages-Description:    This library provides:-                .-                  * Generic representation and manipulation of abstract syntax-                .-                  * Composable AST representations (partly based on Data Types à-                    la Carte [1])-                .-                  * A collection of common syntactic constructs, including-                    variable binding constructs-                .-                  * Utilities for analyzing and transforming generic abstract-                    syntax-                .-                  * Utilities for building extensible embedded languages based-                    on generic syntax+Version:        2.0+Synopsis:       Generic representation and manipulation of abstract syntax+Description:    The library provides a generic representation of type-indexed abstract syntax trees+                (or indexed data types in general). It also permits the definition of open syntax+                trees based on the technique in Data Types à la Carte [1].                 .-                For more information about the core functionality, see+                For more information, see                 \"A Generic Abstract Syntax Model for Embedded Languages\"                 (ICFP 2012):                 .@@ -27,20 +15,11 @@                   * Slides:                     <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic-slides.pdf>                 .-                For a practical example of how to use the library, see the-                proof-of-concept implementation Feldspar EDSL in the @examples@-                directory. (The real Feldspar [2] is also implemented using-                Syntactic.)-                .-                The maturity of this library varies between different modules.-                The core part ("Language.Syntactic") is rather stable, but many-                of the other modules are in a much more experimental state.+                Example EDSL can be found in the @examples@ folder.                 .                 \[1\] W. Swierstra. Data Types à la Carte.                 /Journal of Functional Programming/, 18(4):423-436, 2008,                 <http://dx.doi.org/10.1017/S0956796808006758>.-                .-                \[2\] <http://hackage.haskell.org/package/feldspar-language> License:        BSD3 License-file:   LICENSE Author:         Emil Axelsson@@ -48,15 +27,19 @@ Copyright:      Copyright (c) 2011-2014, Emil Axelsson Homepage:       https://github.com/emilaxelsson/syntactic Bug-reports:    https://github.com/emilaxelsson/syntactic/issues+Stability:      experimental Category:       Language Build-type:     Simple-Cabal-version:  >=1.10-Tested-with:    GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.*, GHC==7.11.*+Cabal-version:  >=1.16+Tested-with:    GHC==7.6.2, GHC==7.8.2  extra-source-files:   CONTRIBUTORS-  examples/NanoFeldspar/*.hs+  examples/*.hs+  tests/*.hs   tests/gold/*.txt+  extras/*.hs+  benchmarks/*.hs  source-repository head   type:     git@@ -64,189 +47,106 @@  library   exposed-modules:-    Data.PolyProxy-    Data.DynamicAlt-    Language.Syntactic-    Language.Syntactic.Syntax-    Language.Syntactic.Traversal-    Language.Syntactic.Constraint-    Language.Syntactic.Sugar-    Language.Syntactic.Interpretation-    Language.Syntactic.Interpretation.Equality-    Language.Syntactic.Interpretation.Evaluation-    Language.Syntactic.Interpretation.Render-    Language.Syntactic.Interpretation.Semantics-    Language.Syntactic.Constructs.Binding-    Language.Syntactic.Constructs.Binding.HigherOrder-    Language.Syntactic.Constructs.Binding.Optimize-    Language.Syntactic.Constructs.Condition-    Language.Syntactic.Constructs.Construct-    Language.Syntactic.Constructs.Decoration-    Language.Syntactic.Constructs.Identity-    Language.Syntactic.Constructs.Literal-    Language.Syntactic.Constructs.Monad-    Language.Syntactic.Constructs.Tuple-    Language.Syntactic.Frontend.Monad-    Language.Syntactic.Frontend.Tuple-    Language.Syntactic.Frontend.TupleConstrained-    Language.Syntactic.Sharing.SimpleCodeMotion-    Language.Syntactic.Sharing.CodeMotion2-    Language.Syntactic.Sharing.Utils-    Language.Syntactic.Sharing.Graph-    Language.Syntactic.Sharing.StableName-    Language.Syntactic.Sharing.Reify-    Language.Syntactic.Sharing.ReifyHO--  other-modules:+    Data.Syntactic+    Data.Syntactic.Syntax+    Data.Syntactic.Traversal+    Data.Syntactic.Interpretation+    Data.Syntactic.Sugar+    Data.Syntactic.Decoration+    Data.Syntactic.Functional+    Data.Syntactic.Sugar.Binding+    Data.Syntactic.Sugar.BindingT+    Data.Syntactic.Sugar.Monad+    Data.Syntactic.Sugar.MonadT    build-depends:-    array,-    base >= 4 && < 5.9,+    base >= 4 && < 5,     containers,     constraints,     data-hash,-    ghc-prim,     mtl >= 2 && < 3,+    safe,+    tagged,     template-haskell,-    transformers >= 0.2,-    tree-view >= 0.5,-    tuple >= 0.2+    tree-view    hs-source-dirs: src    default-language: Haskell2010    default-extensions:-    ConstraintKinds     DeriveDataTypeable     DeriveFunctor+    DeriveFoldable+    DeriveTraversable     FlexibleContexts     FlexibleInstances     FunctionalDependencies     GADTs     GeneralizedNewtypeDeriving-    Rank2Types+    RankNTypes     ScopedTypeVariables-    StandaloneDeriving     TypeFamilies     TypeOperators-    ViewPatterns    other-extensions:-    -- Not understood by Cabal: PolyKinds     OverlappingInstances+    TemplateHaskell     UndecidableInstances -test-suite NanoFeldsparEval+test-suite examples   type: exitcode-stdio-1.0    hs-source-dirs: tests examples -  main-is: NanoFeldsparEval.hs--  other-modules:-    NanoFeldspar.Core-    NanoFeldspar.Extra-    NanoFeldspar.Test-    NanoFeldspar.Vector+  main-is: Tests.hs    default-language: Haskell2010    default-extensions:-    FlexibleContexts-    FlexibleInstances-    GADTs-    MultiParamTypeClasses-    ScopedTypeVariables-    TypeFamilies-    TypeOperators-    UndecidableInstances-    ViewPatterns    other-extensions:-    TemplateHaskell--  build-depends:-    syntactic,-    base,-    mtl >= 2 && < 3,-    QuickCheck >= 2.4 && < 3,-    tasty,-    tasty-th,-    tasty-quickcheck--test-suite NanoFeldsparEval2-  type: exitcode-stdio-1.0--  hs-source-dirs: tests examples--  main-is: NanoFeldsparEval2.hs--  other-modules:-    NanoFeldspar.Core-    NanoFeldspar.Extra-    NanoFeldspar.Test-    NanoFeldspar.Vector--  default-language: Haskell2010--  default-extensions:     FlexibleContexts     FlexibleInstances     GADTs     MultiParamTypeClasses     ScopedTypeVariables+    TemplateHaskell     TypeFamilies     TypeOperators     UndecidableInstances-    ViewPatterns -  other-extensions:-    TemplateHaskell-   build-depends:     syntactic,     base,-    mtl >= 2 && < 3,-    QuickCheck >= 2.4 && < 3,+    containers,+    QuickCheck,+    tagged,     tasty,+    tasty-golden,+    tasty-quickcheck,     tasty-th,-    tasty-quickcheck+    utf8-string -test-suite NanoFeldsparTree+benchmark syntactic-bench   type: exitcode-stdio-1.0 -  hs-source-dirs: tests examples+  hs-source-dirs: benchmarks -  main-is: NanoFeldsparTree.hs+  main-is: MainBenchmark.hs -  other-modules:-    NanoFeldspar.Core-    NanoFeldspar.Extra-    NanoFeldspar.Test-    NanoFeldspar.Vector+  build-depends:+    base,+    criterion,+    syntactic    default-language: Haskell2010    default-extensions:-    FlexibleContexts     FlexibleInstances     GADTs     MultiParamTypeClasses-    ScopedTypeVariables-    TypeFamilies     TypeOperators-    UndecidableInstances-    ViewPatterns    other-extensions:     TemplateHaskell--  build-depends:-    syntactic,-    base,-    bytestring,-    mtl >= 2 && < 3,-    tasty,-    tasty-golden,-    utf8-string
+ tests/MonadTests.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module MonadTests where++++import Test.Tasty+import Test.Tasty.Golden++import Data.ByteString.Lazy.UTF8 (fromString)++import Data.Syntactic+import Data.Syntactic.Functional+import qualified Monad++++mkGold_ex1 = writeFile "tests/gold/ex1_Monad.txt" $ showAST $ desugar Monad.ex1++tests = testGroup "MonadTests"+    [ goldenVsString "ex1 tree" "tests/gold/ex1_Monad.txt" $ return $ fromString $ showAST $ desugar Monad.ex1+    ]++main = defaultMain tests+
− tests/NanoFeldsparEval.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--import Test.Tasty-import Test.Tasty.TH-import Test.Tasty.QuickCheck--import NanoFeldspar.Core (eval)-import NanoFeldspar.Test----prop_scProd a b = eval scProd a' b' == ref a' b'-  where-    a' = take 20 a-    b' = take 20 b-    ref a b = sum (zipWith (*) a b)--prop_1 a b = eval prog1 a' b == ref a' b-  where-    a' = a `mod` 20-    ref a b = [min (i+3) b | i <- [0..a-1]]--prop_2 a = eval prog2 a == ref a-  where-    ref a = max (min a a) (min a a)--prop_3 a b = eval prog3 a b' == ref a b'-  where-    b' = a - (b `mod` 20)-    ref a b = sum [l .. u]-      where-        l = min a b-        u = max a b--prop_4 a = eval prog4 a' == ref a'-  where-    a' = a `mod` 20-    ref a = [(a+a)*i | i <- [0..a-1]]--prop_5 a = eval prog5 a == ref a-  where-    ref a = let (b,c) = (a*2,a*3) in (b-c)*(c-b)--prop_6 = eval prog6 == ref-  where-    ref = as!!1 + sum as + sum as-      where-        as = map (*2) [1..20]--prop_8 a = eval prog8 a == ref a-  where-    ref a = [a .. a+9]----main = $(defaultMainGenerator)-
− tests/NanoFeldsparEval2.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--import Test.Tasty-import Test.Tasty.TH-import Test.Tasty.QuickCheck--import NanoFeldspar.Core (eval2)-import NanoFeldspar.Test----prop_scProd a b = eval2 scProd a' b' == ref a' b'-  where-    a' = take 20 a-    b' = take 20 b-    ref a b = sum (zipWith (*) a b)--prop_1 a b = eval2 prog1 a' b == ref a' b-  where-    a' = a `mod` 20-    ref a b = [min (i+3) b | i <- [0..a-1]]--prop_2 a = eval2 prog2 a == ref a-  where-    ref a = max (min a a) (min a a)--prop_3 a b = eval2 prog3 a b' == ref a b'-  where-    b' = a - (b `mod` 20)-    ref a b = sum [l .. u]-      where-        l = min a b-        u = max a b--prop_4 a = eval2 prog4 a' == ref a'-  where-    a' = a `mod` 20-    ref a = [(a+a)*i | i <- [0..a-1]]--prop_5 a = eval2 prog5 a == ref a-  where-    ref a = let (b,c) = (a*2,a*3) in (b-c)*(c-b)--prop_6 = eval2 prog6 == ref-  where-    ref = as!!1 + sum as + sum as-      where-        as = map (*2) [1..20]--prop_8 a = eval2 prog8 a == ref a-  where-    ref a = [a .. a+9]----main = $(defaultMainGenerator)-
+ tests/NanoFeldsparTests.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module NanoFeldsparTests where++++import Control.Monad+import Data.List++import Test.QuickCheck+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.QuickCheck++import Data.ByteString.Lazy.UTF8 (fromString)++import Data.Syntactic+import Data.Syntactic.Functional+import qualified NanoFeldspar as Nano++++scProd :: [Float] -> [Float] -> Float+scProd as bs = sum $ zipWith (*) as bs++prop_scProd as bs = scProd as bs == Nano.eval Nano.scProd as bs++genMat :: Gen [[Float]]+genMat = sized $ \s -> do+    x <- liftM succ $ choose (0, s `mod` 10)+    y <- liftM succ $ choose (0, s `mod` 10)+    replicateM y $ vector x++forEach = flip map++matMul :: [[Float]] -> [[Float]] -> [[Float]]+matMul a b = forEach a $ \a' ->+               forEach (transpose b) $ \b' ->+                 scProd a' b'++prop_matMul =+    forAll genMat $ \a ->+      forAll genMat $ \b ->+        matMul a b == Nano.eval Nano.matMul a b++mkGold_scProd = writeFile "tests/gold/scProd.txt" $ Nano.showAST Nano.scProd+mkGold_matMul = writeFile "tests/gold/matMul.txt" $ Nano.showAST Nano.matMul++alphaRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a+alphaRename = mapAST rename+  where+    rename :: Nano.FeldDomain a -> Nano.FeldDomain a+    rename s+        | Just (VarT v) <- prj s = inj (VarT (v+1))+        | Just (LamT v) <- prj s = inj (LamT (v+1))+        | otherwise = s++badRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a+badRename = mapAST rename+  where+    rename :: Nano.FeldDomain a -> Nano.FeldDomain a+    rename s+        | Just (VarT v) <- prj s = inj (VarT (v+1))+        | Just (LamT v) <- prj s = inj (LamT (v-1))+        | otherwise = s++prop_alphaEq a = alphaEq a (alphaRename a)++prop_alphaEqBad a = alphaEq a (badRename a)++tests = testGroup "NanoFeldsparTests"+    [ goldenVsString "scProd tree" "tests/gold/scProd.txt" $ return $ fromString $ Nano.showAST Nano.scProd+    , goldenVsString "matMul tree" "tests/gold/matMul.txt" $ return $ fromString $ Nano.showAST Nano.matMul++    , testProperty "scProd eval" prop_scProd+    , testProperty "matMul eval" prop_matMul++    , testProperty "alphaEq scProd"        (prop_alphaEq (desugar Nano.scProd))+    , testProperty "alphaEq matMul"        (prop_alphaEq (desugar Nano.matMul))+    , testProperty "alphaEq scProd matMul" (not (alphaEq (desugar Nano.scProd) (desugar Nano.matMul)))+    , testProperty "alphaEqBad scProd"     (not (prop_alphaEqBad (desugar Nano.scProd)))+    , testProperty "alphaEqBad matMul"     (not (prop_alphaEqBad (desugar Nano.matMul)))+    ]++main = defaultMain tests+
− tests/NanoFeldsparTree.hs 
@@ -1,36 +0,0 @@-import Test.Tasty-import Test.Tasty.Golden--import Data.ByteString.Lazy.UTF8 (fromString)--import NanoFeldspar.Core (showAST)-import NanoFeldspar.Test----mkGold_scProd = writeFile "tests/gold/scProd.txt" $ showAST scProd-mkGold_matMul = writeFile "tests/gold/matMul.txt" $ showAST matMul-mkGold_prog1  = writeFile "tests/gold/prog1.txt"  $ showAST prog1-mkGold_prog2  = writeFile "tests/gold/prog2.txt"  $ showAST prog2-mkGold_prog3  = writeFile "tests/gold/prog3.txt"  $ showAST prog3-mkGold_prog4  = writeFile "tests/gold/prog4.txt"  $ showAST prog4-mkGold_prog5  = writeFile "tests/gold/prog5.txt"  $ showAST prog5-mkGold_prog6  = writeFile "tests/gold/prog6.txt"  $ showAST prog6-mkGold_prog7  = writeFile "tests/gold/prog7.txt"  $ showAST prog7-mkGold_prog8  = writeFile "tests/gold/prog8.txt"  $ showAST prog8--tests = testGroup "TreeTests"-    [ goldenVsString "scProd" "tests/gold/scProd.txt" $ return $ fromString $ showAST scProd-    , goldenVsString "matMul" "tests/gold/matMul.txt" $ return $ fromString $ showAST matMul-    , goldenVsString "prog1"  "tests/gold/prog1.txt"  $ return $ fromString $ showAST prog1-    , goldenVsString "prog2"  "tests/gold/prog2.txt"  $ return $ fromString $ showAST prog2-    , goldenVsString "prog3"  "tests/gold/prog3.txt"  $ return $ fromString $ showAST prog3-    , goldenVsString "prog4"  "tests/gold/prog4.txt"  $ return $ fromString $ showAST prog4-    , goldenVsString "prog5"  "tests/gold/prog5.txt"  $ return $ fromString $ showAST prog5-    , goldenVsString "prog6"  "tests/gold/prog6.txt"  $ return $ fromString $ showAST prog6-    , goldenVsString "prog7"  "tests/gold/prog7.txt"  $ return $ fromString $ showAST prog7-    , goldenVsString "prog8"  "tests/gold/prog8.txt"  $ return $ fromString $ showAST prog8-    ]--main = defaultMain tests-
+ tests/Tests.hs view
@@ -0,0 +1,14 @@+import Test.Tasty++import qualified NanoFeldsparTests+import qualified WellScopedTests+import qualified MonadTests++tests = testGroup "AllTests"+    [ NanoFeldsparTests.tests+    , WellScopedTests.tests+    , MonadTests.tests+    ]++main = defaultMain tests+
+ tests/WellScopedTests.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module WellScopedTests where++++import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.QuickCheck++import Data.ByteString.Lazy.UTF8 (fromString)++import Data.Syntactic+import Data.Syntactic.Functional+import qualified WellScoped as WS++++ex1 a = let b = a+4 in let c = a+b in a+b+c++prop_ex1 a = ex1 a == evalClosedWS WS.ex1 a++mkGold_ex1 = writeFile "tests/gold/ex1_WS.txt" $ showAST $ fromWS WS.ex1++tests = testGroup "WellScopedTests"+    [ goldenVsString "ex1 tree" "tests/gold/ex1_WS.txt" $ return $ fromString $ showAST $ fromWS WS.ex1+    , testProperty   "ex1" prop_ex1+    ]++main = defaultMain tests+
+ tests/gold/ex1_Monad.txt view
@@ -0,0 +1,18 @@+Lam v3+ └╴(>>=)+    ├╴iter+    │  ├╴v3+    │  └╴(>>=)+    │     ├╴getDigit+    │     └╴Lam v2+    │        └╴(>>=)+    │           ├╴putDigit+    │           │  └╴(+)+    │           │     ├╴v2+    │           │     └╴v2+    │           └╴Lam v1+    │              └╴return+    │                 └╴v1+    └╴Lam v1+       └╴return+          └╴v1
+ tests/gold/ex1_WS.txt view
@@ -0,0 +1,14 @@+Lam v3+ └╴Let v2+    ├╴(+)+    │  ├╴v3+    │  └╴4+    └╴Let v1+       ├╴(+)+       │  ├╴v3+       │  └╴v2+       └╴(+)+          ├╴(+)+          │  ├╴v3+          │  └╴v2+          └╴v1
tests/gold/matMul.txt view
@@ -1,44 +1,36 @@-Lambda 0- └╴Lambda 1-    └╴Let 6+Lam v6+ └╴Lam v5+    └╴parallel        ├╴arrLength-       │  └╴getIx-       │     ├╴var:1-       │     └╴0-       └╴Let 7-          ├╴arrLength-          │  └╴var:1+       │  └╴v6+       └╴Lam v4           └╴parallel              ├╴arrLength-             │  └╴var:0-             └╴Lambda 2-                └╴Let 8+             │  └╴getIx+             │     ├╴v5+             │     └╴0+             └╴Lam v3+                └╴forLoop                    ├╴min                    │  ├╴arrLength                    │  │  └╴getIx-                   │  │     ├╴var:0-                   │  │     └╴var:2-                   │  └╴var:7-                   └╴Let 9-                      ├╴getIx-                      │  ├╴var:0-                      │  └╴var:2-                      └╴parallel-                         ├╴var:6-                         └╴Lambda 3-                            └╴forLoop-                               ├╴var:8-                               ├╴0.0-                               └╴Lambda 4-                                  └╴Lambda 5-                                     └╴(+)-                                        ├╴(*)-                                        │  ├╴getIx-                                        │  │  ├╴var:9-                                        │  │  └╴var:4-                                        │  └╴getIx-                                        │     ├╴getIx-                                        │     │  ├╴var:1-                                        │     │  └╴var:4-                                        │     └╴var:3-                                        └╴var:5+                   │  │     ├╴v6+                   │  │     └╴v4+                   │  └╴arrLength+                   │     └╴v5+                   ├╴0.0+                   └╴Lam v2+                      └╴Lam v1+                         └╴(+)+                            ├╴(*)+                            │  ├╴getIx+                            │  │  ├╴getIx+                            │  │  │  ├╴v6+                            │  │  │  └╴v4+                            │  │  └╴v2+                            │  └╴getIx+                            │     ├╴getIx+                            │     │  ├╴v5+                            │     │  └╴v2+                            │     └╴v3+                            └╴v1
− tests/gold/prog1.txt 
@@ -1,10 +0,0 @@-Lambda 0- └╴Lambda 1-    └╴parallel-       ├╴var:0-       └╴Lambda 2-          └╴min-             ├╴(+)-             │  ├╴var:2-             │  └╴3-             └╴var:1
− tests/gold/prog2.txt 
@@ -1,8 +0,0 @@-Lambda 0- └╴Let 1-    ├╴min-    │  ├╴var:0-    │  └╴var:0-    └╴max-       ├╴var:1-       └╴var:1
− tests/gold/prog3.txt 
@@ -1,30 +0,0 @@-Lambda 0- └╴Lambda 1-    └╴Let 4-       ├╴(+)-       │  ├╴(-)-       │  │  ├╴max-       │  │  │  ├╴var:0-       │  │  │  └╴var:1-       │  │  └╴min-       │  │     ├╴var:0-       │  │     └╴var:1-       │  └╴1-       └╴Let 5-          ├╴min-          │  ├╴var:0-          │  └╴var:1-          └╴forLoop-             ├╴var:4-             ├╴0-             └╴Lambda 2-                └╴Lambda 3-                   └╴(+)-                      ├╴(+)-                      │  ├╴(-)-                      │  │  ├╴(-)-                      │  │  │  ├╴var:4-                      │  │  │  └╴var:2-                      │  │  └╴1-                      │  └╴var:5-                      └╴var:3
− tests/gold/prog4.txt 
@@ -1,11 +0,0 @@-Lambda 0- └╴Let 2-    ├╴(+)-    │  ├╴var:0-    │  └╴var:0-    └╴parallel-       ├╴var:0-       └╴Lambda 1-          └╴(*)-             ├╴var:2-             └╴var:1
− tests/gold/prog5.txt 
@@ -1,22 +0,0 @@-Lambda 0- └╴Let 1-    ├╴tup2-    │  ├╴(*)-    │  │  ├╴var:0-    │  │  └╴2-    │  └╴(*)-    │     ├╴var:0-    │     └╴3-    └╴Let 2-       ├╴sel1-       │  └╴var:1-       └╴Let 3-          ├╴sel2-          │  └╴var:1-          └╴(*)-             ├╴(-)-             │  ├╴var:2-             │  └╴var:3-             └╴(-)-                ├╴var:3-                └╴var:2
− tests/gold/prog6.txt 
@@ -1,34 +0,0 @@-Let 9- ├╴parallel- │  ├╴(+)- │  │  ├╴(-)- │  │  │  ├╴20- │  │  │  └╴1- │  │  └╴1- │  └╴Lambda 0- │     └╴(+)- │        ├╴var:0- │        └╴1- └╴Let 10-    ├╴forLoop-    │  ├╴arrLength-    │  │  └╴var:9-    │  ├╴0-    │  └╴Lambda 2-    │     └╴Lambda 3-    │        └╴(+)-    │           ├╴(*)-    │           │  ├╴getIx-    │           │  │  ├╴var:9-    │           │  │  └╴var:2-    │           │  └╴2-    │           └╴var:3-    └╴(+)-       ├╴(+)-       │  ├╴(*)-       │  │  ├╴getIx-       │  │  │  ├╴var:9-       │  │  │  └╴1-       │  │  └╴2-       │  └╴var:10-       └╴var:10
− tests/gold/prog7.txt 
@@ -1,13 +0,0 @@-Lambda 0- └╴Let 1-    ├╴max-    │  ├╴5-    │  └╴(+)-    │     ├╴6-    │     └╴7-    └╴condition-       ├╴(==)-       │  ├╴var:0-       │  └╴10-       ├╴var:1-       └╴var:1
− tests/gold/prog8.txt 
@@ -1,20 +0,0 @@-Lambda 0- └╴Let 3-    ├╴parallel-    │  ├╴10-    │  └╴Lambda 1-    │     └╴(+)-    │        ├╴var:1-    │        └╴var:0-    └╴condition-       ├╴(==)-       │  ├╴(*)-       │  │  ├╴(*)-       │  │  │  ├╴(*)-       │  │  │  │  ├╴var:0-       │  │  │  │  └╴var:0-       │  │  │  └╴var:0-       │  │  └╴var:0-       │  └╴23-       ├╴var:3-       └╴var:3
tests/gold/scProd.txt view
@@ -1,20 +1,20 @@-Lambda 0- └╴Lambda 1+Lam v4+ └╴Lam v3     └╴forLoop        ├╴min        │  ├╴arrLength-       │  │  └╴var:0+       │  │  └╴v4        │  └╴arrLength-       │     └╴var:1+       │     └╴v3        ├╴0.0-       └╴Lambda 2-          └╴Lambda 3+       └╴Lam v2+          └╴Lam v1              └╴(+)                 ├╴(*)                 │  ├╴getIx-                │  │  ├╴var:0-                │  │  └╴var:2+                │  │  ├╴v4+                │  │  └╴v2                 │  └╴getIx-                │     ├╴var:1-                │     └╴var:2-                └╴var:3+                │     ├╴v3+                │     └╴v2+                └╴v1