packages feed

syntactic 1.11 → 3.8.5

raw patch · 83 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2011, Emil Axelsson+Copyright (c) 2011-2015, Emil Axelsson  All rights reserved.
+ benchmarks/JoiningTypes.hs view
@@ -0,0 +1,234 @@+module JoiningTypes (main) where++import Criterion.Main+import Criterion.Types+import Language.Syntactic+import Language.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"++instance Equality   Expr1+instance StringTree 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 signature p (EI n)+  compileSym p (EB b) = compileSymDefault signature p (EB b)+  compileSym p EAdd   = compileSymDefault signature p EAdd+  compileSym p EEq    = compileSymDefault signature p EEq+  compileSym p EIf    = compileSymDefault signature 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"++instance Equality   ExprI+instance StringTree ExprI+instance Equality   ExprB+instance StringTree 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 signature p (EIJ n)+  compileSym p EAddJ   = compileSymDefault signature p EAddJ++instance EvalEnv ExprB env where+  compileSym p (EBJ b) = compileSymDefault signature p (EBJ b)+  compileSym p EEqJ    = compileSymDefault signature p EEqJ+  compileSym p EIfJ    = compileSymDefault signature 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"++instance Equality   Expr4J1+instance StringTree Expr4J1+instance Equality   Expr4J2+instance StringTree Expr4J2+instance Equality   Expr4J3+instance StringTree Expr4J3+instance Equality   Expr4J5+instance StringTree 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 signature p (E4JI n)++instance EvalEnv Expr4J2 env where+  compileSym p (E4JB b)  = compileSymDefault signature p (E4JB b)++instance EvalEnv Expr4J3 env where+  compileSym p E4JAdd    = compileSymDefault signature p E4JAdd++instance EvalEnv Expr4J4 env where+  compileSym p E4JEq     = compileSymDefault signature p E4JEq++instance EvalEnv Expr4J5 env where+  compileSym p E4JIf     = compileSymDefault signature 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 {csvFile = Just "bench-results/joiningTypes.csv"})+         [ 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,127 @@+module Normal (main) where++import Criterion.Main+import Criterion.Types+import Language.Syntactic+import Language.Syntactic.Functional++main :: IO ()+main = defaultMainWith (defaultConfig {csvFile = Just "bench-results/normal.csv"})+         [ 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"++instance Equality   ExprS+instance StringTree 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 signature p (EI n)+  compileSym p (EB b) = compileSymDefault signature p (EB b)+  compileSym p EAdd   = compileSymDefault signature p EAdd+  compileSym p EEq    = compileSymDefault signature p EEq+  compileSym p EIf    = compileSymDefault signature p EIf+
+ benchmarks/WithArity.hs view
@@ -0,0 +1,125 @@+module WithArity (main) where++import Criterion.Main+import Criterion.Types+import Language.Syntactic hiding (E)+import Language.Syntactic.Functional++main :: IO ()+main = defaultMainWith (defaultConfig {csvFile = Just "bench-results/withArity.csv"})+         [ 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"++instance Equality   T+instance StringTree 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 signature p (T0 a)+    compileSym p T1     = compileSymDefault signature p T1+    compileSym p T2     = compileSymDefault signature p T2+    compileSym p T3     = compileSymDefault signature p T3+    compileSym p T5     = compileSymDefault signature p T5+    compileSym p T10    = compileSymDefault signature p T10+
+ examples/Monad.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -Wno-missing-methods #-}+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}++-- | This module demonstrates monad reification.+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011+-- <https://emilaxelsson.github.io/documents/persson2011generic.pdf>) for details.++module Monad where++++import Control.Monad (replicateM_)+import Data.Char (isDigit)+import Data.Typeable (Typeable)++import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Sugar.MonadTyped ()++import NanoFeldspar (Type, Arithmetic (..))++++type Dom = Typed (BindingT :+: MONAD IO :+: Construct :+: Arithmetic)++type Exp a = ASTF Dom a++type IO' a = Remon Dom IO (Exp a)++getDigit :: IO' Int+getDigit = sugarSymTyped $ Construct "getDigit" get+  where+    get = do+        c <- getChar+        if isDigit c then return (fromEnum c - fromEnum '0') else get++putDigit :: Exp Int -> IO' ()+putDigit = sugarSymTyped $ Construct "putDigit" print++iter :: Typeable a => Exp Int -> IO' a -> IO' ()+iter = sugarSymTyped $ Construct "iter" replicateM_++-- | Literal+value :: (Show a, Typeable a) => a -> Exp a+value a = sugarSymTyped $ Construct (show a) a++instance (Num a, Type a) => Num (Exp a)+  where+    fromInteger = value . fromInteger+    (+)         = sugarSymTyped Add+    (-)         = sugarSymTyped Sub+    (*)         = sugarSymTyped 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,378 @@+{-# 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.Typeable++import Language.Syntactic hiding (fold, printExpr, showAST, drawAST, writeHtmlAST)+import qualified Language.Syntactic as Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Sharing+import Language.Syntactic.Functional.Tuple+import Language.Syntactic.Sugar.BindingTyped ()+import Language.Syntactic.Sugar.TupleTyped ()+import Language.Syntactic.TH++++--------------------------------------------------------------------------------+-- * 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 sig+  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)++deriveSymbol   ''Arithmetic+deriveEquality ''Arithmetic++instance StringTree Arithmetic+instance EvalEnv Arithmetic env++instance Render Arithmetic+  where+    renderSym Add = "(+)"+    renderSym Sub = "(-)"+    renderSym Mul = "(*)"+    renderArgs = renderArgsSmart++instance Eval Arithmetic+  where+    evalSym Add = (+)+    evalSym Sub = (-)+    evalSym Mul = (*)++data Parallel sig+  where+    Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a])++deriveSymbol    ''Parallel+deriveRender id ''Parallel+deriveEquality  ''Parallel++instance StringTree Parallel+instance EvalEnv Parallel env++instance Eval Parallel+  where+    evalSym Parallel = \len ixf -> Prelude.map ixf [0 .. len-1]++data ForLoop sig+  where+    ForLoop :: Type st => ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st)++deriveSymbol    ''ForLoop+deriveRender id ''ForLoop+deriveEquality  ''ForLoop++instance StringTree ForLoop+instance EvalEnv ForLoop env++instance Eval ForLoop+  where+    evalSym ForLoop = \len init body -> foldl (flip body) init [0 .. len-1]++type FeldDomain = Typed+    (   BindingT+    :+: Let+    :+: Tuple+    :+: Arithmetic+    :+: Parallel+    :+: ForLoop+    :+: Construct+    )+  -- `Construct` can be used to create arbitrary symbols from a name and an+  -- evaluation function. We could have used `Construct` for all symbols, but+  -- the problem with `Construct` is that it does not know about the arity or+  -- type of the construct it represents, so it's easy to make mistakes, e.g.+  -- when transforming expressions with `Construct` symbols.++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 = showExpr++++--------------------------------------------------------------------------------+-- * "Backends"+--------------------------------------------------------------------------------++-- | Interface for controlling code motion+cmInterface :: CodeMotionInterface FeldDomain+cmInterface = defaultInterface VarT LamT sharable (const True)+  where+    sharable :: ASTF FeldDomain a -> ASTF FeldDomain b -> Bool+    sharable (Sym _) _ = False+      -- Simple expressions not shared+    sharable (lam :$ _) _+        | Just _ <- prLam lam = False+      -- Lambdas not shared+    sharable _ (lam :$ _)+        | Just _ <- prLam lam = False+      -- Don't place let bindings over lambdas. This ensures that function+      -- arguments of higher-order constructs such as `Parallel` are always+      -- lambdas.+    sharable (sel :$ _) _+        | Just Fst <- prj sel = False+        | Just Snd <- prj sel = False+      -- Tuple selection not shared+    sharable (arrl :$ _ ) _+        | Just (Construct "arrLen" _) <- prj arrl = False+      -- Array length not shared+    sharable (gix :$ _ :$ _) _+        | Just (Construct "arrIx" _) <- prj gix = False+      -- Array indexing not shared+    sharable _ _ = True++-- | Show the expression+showExpr :: (Syntactic a, Domain a ~ FeldDomain) => a -> String+showExpr = render . codeMotion cmInterface . 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 . codeMotion cmInterface . 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" . codeMotion cmInterface . desugar++-- | Evaluate an expression+eval :: (Syntactic a, Domain a ~ FeldDomain) => a -> Internal a+eval = evalClosed . desugar++++--------------------------------------------------------------------------------+-- * Front end+--------------------------------------------------------------------------------++-- | Literal+value :: Syntax a => Internal a -> a+value a = sugar $ injT $ Construct (show a) a++false :: Data Bool+false = value False++true :: Data Bool+true = value True++-- | Force computation+force :: Syntax a => a -> a+force = resugar++instance (Type a, Num a) => Num (Data a)+  where+    fromInteger = value . fromInteger+    (+)         = sugarSymTyped Add+    (-)         = sugarSymTyped Sub+    (*)         = sugarSymTyped Mul++-- | Explicit sharing+share :: (Syntax a, Syntax b) => a -> (a -> b) -> b+share = sugarSymTyped (Let "")++-- | Parallel array+parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]+parallel = sugarSymTyped Parallel++-- | For loop+forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st+forLoop = sugarSymTyped ForLoop++-- | Conditional expression+(?) :: forall a . Syntax a => Data Bool -> (a,a) -> a+c ? (t,f) = sugarSymTyped 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)++-- | Get the length of an array+arrLen :: Type a => Data [a] -> Data Length+arrLen = sugarSymTyped $ Construct "arrLen" Prelude.length++-- | Index into an array+arrIx :: Type a => Data [a] -> Data Index -> Data a+arrIx = sugarSymTyped $ Construct "arrIx" eval+  where+    eval as i+        | i >= len || i < 0 = error "arrIx: index out of bounds"+        | otherwise         = as !! i+      where+        len = Prelude.length as++not :: Data Bool -> Data Bool+not = sugarSymTyped $ Construct "not" Prelude.not++(==) :: Type a => Data a -> Data a -> Data Bool+(==) = sugarSymTyped $ Construct "(==)" (Prelude.==)++max :: Type a => Data a -> Data a -> Data a+max = sugarSymTyped $ Construct "max" Prelude.max++min :: Type a => Data a -> Data a -> Data a+min = sugarSymTyped $ 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 (arrLen arr) (arrIx 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)++fold1 :: Syntax a => (a -> a -> a) -> Vector a -> a+fold1 f (Indexed len ixf) = forLoop len (ixf 0) (\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+--------------------------------------------------------------------------------++-- | Fibonacci function+fib :: Data Int -> Data Int+fib n = fst $ forLoop n (0,1) $ \_ (a,b) -> (b,a+b)++-- | The span of a vector (difference between greatest and smallest element)+spanVec :: Vector (Data Int) -> Data Int+spanVec vec = hi-lo+  where+    (lo,hi) = fold (\a (l,h) -> (min a l, max a h)) (vec!0,vec!0) vec+  -- This demonstrates how tuples interplay with sharing. Tuples are essentially+  -- useless without sharing. This function would get two identical for loops if+  -- it wasn't for sharing.++-- | 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,267 +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--------------------------------------------------------------------------------------- * Types------------------------------------------------------------------------------------- | Convenient class alias-class    (Ord a, Show a, Typeable a) => Type a-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-    type Sat Parallel = Type-    exprDict Parallel = Dict--instance Semantic Parallel-  where-    semantics Parallel = Sem-        { semanticName = "parallel"-        , semanticEval = \len ixf -> map ixf [0 .. len-1]-        }--semanticInstances ''Parallel--instance EvalBind Parallel where evalBindSym = evalBindSymDefault--instance AlphaEq dom dom dom env => AlphaEq Parallel Parallel dom env-  where-    alphaEqSym = alphaEqSymDefault--------------------------------------------------------------------------------------- * 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--------------------------------------------------------------------------------------- * 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---- | 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--------------------------------------------------------------------------------------- * 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,93 +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-    optimizeSym = optimizeSymDefault--instance Optimize Parallel-  where-    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,99 +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-    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/NanoFeldsparComp.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++-- Note GADTs needed by GHC 7.6. In later GHCs is works with just TypeFamilies.++-- | A simple compiler for NanoFeldspar++module NanoFeldsparComp where++++import Control.Monad.State+import Control.Monad.Writer++import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Sharing+import Language.Syntactic.Functional.Tuple++import NanoFeldspar hiding ((==))++++--------------------------------------------------------------------------------+-- * Imperative programs+--------------------------------------------------------------------------------++type Var = String++varName :: Name -> Var+varName v = 'v' : show v++varNameE :: Name -> Exp+varNameE v = App (varName v) []++data Exp = App String [Exp]+  deriving (Eq, Show)++data Stmt+    = Assign Exp Exp+    | If Exp Prog Prog+    | For Exp Var Prog+  deriving (Eq, Show)++type Prog = [Stmt]++viewOp :: String -> Maybe String+viewOp op@(_:_:_)+    | head op == '(' && last op == ')' = Just $ tail $ init op+    | otherwise = Nothing++renderExp :: Exp -> String+renderExp (App f []) = f+renderExp (App f@(_:_) [a,b])+    | Just op <- viewOp f = concat ["(", renderExp a, " ", op, " ", renderExp b, ")"]+renderExp (App f args) = "(" ++ unwords (f : Prelude.map renderExp args) ++ ")"++indent :: [String] -> [String]+indent = Prelude.map ("    " ++)++renderProg :: Prog -> String+renderProg = unlines . concatMap render+  where+    render (Assign l r) = [unwords [renderExp l, "=", renderExp r]]+    render (If c t f) = concat+        [ [unwords ["if", renderExp c]]+        , indent (concatMap render t)+        , ["else"]+        , indent (concatMap render f)+        ]+    render (For l v body) = concat+        [ [unwords ["for",v,"<", renderExp l]]+        , indent (concatMap render body)+        ]++++--------------------------------------------------------------------------------+-- * Code generation+--------------------------------------------------------------------------------++type CodeGen = WriterT Prog (State Name)++type Dom = BindingT+       :+: Let+       :+: Tuple+       :+: Arithmetic+       :+: Parallel+       :+: ForLoop+       :+: Construct++fresh :: CodeGen Exp+fresh = do+    v <- get; put (v+1)+    return (varNameE v)++confiscate :: CodeGen Exp -> CodeGen (Exp,Prog)+confiscate = censor (const mempty) . listen++compileExp :: ASTF Dom a -> CodeGen Exp+compileExp var+    | Just (VarT v) <- prj var = return (varNameE v)+compileExp (lett :$ a :$ (lam :$ body))+    | Just (Let _)  <- prj lett+    , Just (LamT v) <- prj lam+    = do+        a' <- compileExp a+        tell [Assign (varNameE v) a']+        compileExp body+compileExp (par :$ len :$ (lam :$ body))+    | Just Parallel <- prj par+    , Just (LamT v) <- prj lam+    = do+        len' <- compileExp len+        (e,body') <- confiscate $ compileExp body+        arr <- fresh+        let arrPos = App "(!)" [arr, varNameE v]+        tell+            [ For len' (varName v)+                (  body'+                ++ [Assign arrPos e]+                )+            ]+        return arr+compileExp (for :$ len :$ init :$ (lam1 :$ (lam2 :$ body)))+    | Just ForLoop  <- prj for+    , Just (LamT i) <- prj lam1+    , Just (LamT s) <- prj lam2+    = do+        len'  <- compileExp len+        init' <- compileExp init+        (e,body') <- confiscate $ compileExp body+        next <- fresh+        tell+            [ Assign (varNameE s) init'+            , For len' (varName i)+                (  body'+                ++ [ Assign next e+                   , Assign (varNameE s) next+                   ]+                )+            ]+        return next+compileExp (cond :$ c :$ t :$ f)+    | Just (Construct "cond" _) <- prj cond+    = do+        c' <- compileExp c+        (t',tProg) <- confiscate $ compileExp t+        (f',fProg) <- confiscate $ compileExp f+        res <- fresh+        tell+            [ If c'+                (  tProg+                ++ [Assign res  t']+                )+                (  fProg+                ++ [Assign res  f']+                )+            ]+        return res+compileExp (arrIx :$ arr :$ ix)+    | Just (Construct "arrIx" _) <- prj arrIx = do+        arr' <- compileExp arr+        ix'  <- compileExp ix+        return $ App "(!)" [arr',ix']+-- Generic case for all other constructs+compileExp a = simpleMatch+  (\s as -> fmap (App (renderSym s)) $ sequence (listArgs compileExp as)) a++compileTop :: ASTF Dom a -> CodeGen ()+compileTop = go 0+  where+    go :: Int -> ASTF Dom a -> CodeGen ()+    go n (lam :$ body)+        | Just (LamT v) <- prj lam = do+            tell [Assign (varNameE v) (App ("inp" ++ show n) [])]+            go (n+1) body+    go _ a = do+        a' <- compileExp a+        tell [Assign (App "out" []) a']++++compile :: (Syntactic a, Domain a ~ Typed Dom) => a -> String+compile+    = renderProg+    . fst+    . flip runState 0+    . execWriterT+    . compileTop+    . mapAST (\(Typed s) -> s)+    . codeMotion cmInterface+    . desugar++icompile :: (Syntactic a, Domain a ~ Typed Dom) => a -> IO ()+icompile = putStrLn . compile++++--------------------------------------------------------------------------------+-- * Code generation+--------------------------------------------------------------------------------++test_matMul = icompile matMul+
+ examples/WellScoped.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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 Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.WellScoped++++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' :: Construct (Full a))+      where i' = fromInteger i+    (+) = smartWS (Construct "(+)" (+) :: Construct (a :-> a :-> Full a))++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+
− 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.Prim-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/NestTuple.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Conversion between tuples and nested pairs++module Data.NestTuple where++++import Data.NestTuple.TH++++-- | Tuples that can be converted to/from nested pairs+class Nestable tup+  where+    -- | Representation as nested pairs+    type Nested tup+    -- | Convert to nested pairs+    nest :: tup -> Nested tup+    -- | Convert from nested pairs+    unnest :: Nested tup -> tup++mkNestableInstances 15+
+ src/Data/NestTuple/TH.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}++module Data.NestTuple.TH where++++import Language.Haskell.TH++import Language.Syntactic.TH++++mkTupT :: [Type] -> Type+mkTupT ts = foldl AppT (TupleT (length ts)) ts++mkPairT :: Type -> Type -> Type+mkPairT a b = foldl AppT (TupleT 2) [a,b]++mkTupE :: [Exp] -> Exp+#if __GLASGOW_HASKELL__ >= 810+mkTupE = TupE . map Just+#else+mkTupE = TupE+#endif++mkPairE :: Exp -> Exp -> Exp+mkPairE a b = mkTupE [a,b]++mkPairP :: Pat -> Pat -> Pat+mkPairP a b = TupP [a,b]++data Nest a+    = Leaf a+    | Pair (Nest a) (Nest a)+  deriving (Eq, Show, Functor)++foldNest :: (a -> b) -> (b -> b -> b) -> Nest a -> b+foldNest leaf pair = go+  where+    go (Leaf a) = leaf a+    go (Pair a b) = pair (go a) (go b)++toNest :: [a] -> Nest a+toNest [a] = Leaf a+toNest as  = Pair (toNest bs) (toNest cs)+  where+    (bs,cs) = splitAt ((length as + 1) `div` 2) as++++-- Make instances of the form+--+-- > instance Nestable (a,...,x)+-- >   where+-- >     type Nested (a,...,x) = (a ... x)  -- nested pairs+-- >     nest   (a,...,x) = (a ... x)+-- >     unnest (a ... x) = (a,...,x)+mkNestableInstances+    :: Int  -- ^ Max tuple width+    -> DecsQ+mkNestableInstances n = return $ map nestableInstance [2..n]+  where+    nestableInstance w = instD+        []+        (AppT (ConT (mkName "Nestable")) tupT)+        [ tySynInst (mkName "Nested") [tupT] (foldNest VarT mkPairT $ toNest vars)+        , FunD (mkName "nest")+            [ Clause+                [TupP (map VarP vars)]+                (NormalB (foldNest VarE mkPairE $ toNest vars))+                []+            ]+        , FunD (mkName "unnest")+            [ Clause+                [foldNest VarP mkPairP $ toNest vars]+                (NormalB (mkTupE (map VarE vars)))+                []+            ]+        ]+      where+        vars = take w varSupply+        tupT = mkTupT $ map VarT vars+
− 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/Language/Syntactic.hs view
@@ -1,29 +1,18 @@ -- | The basic parts of the syntactic library  module Language.Syntactic-    ( module Data.PolyProxy-    , module Language.Syntactic.Syntax+    ( module Language.Syntactic.Syntax     , module Language.Syntactic.Traversal-    , module Language.Syntactic.Constraint+    , module Language.Syntactic.Interpretation     , module Language.Syntactic.Sugar-    , module Language.Syntactic.Interpretation.Equality-    , module Language.Syntactic.Interpretation.Render-    , module Language.Syntactic.Interpretation.Evaluation-    , module Language.Syntactic.Interpretation.Semantics-    , module Data.Constraint+    , module Language.Syntactic.Decoration     ) where   -import Data.PolyProxy import Language.Syntactic.Syntax import Language.Syntactic.Traversal-import Language.Syntactic.Constraint+import Language.Syntactic.Interpretation import Language.Syntactic.Sugar-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 (..))+import Language.Syntactic.Decoration
− src/Language/Syntactic/Constraint.hs 
@@ -1,396 +0,0 @@-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE UndecidableInstances #-}---- TODO Only `InjectC` should be used overlapped. Move to separate module?---- | 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--infixr 5 :/\:---- | Universal type predicate-class    Top a-instance Top a--pTop :: P Top-pTop = P--pTypeable :: P Typeable-pTypeable = P---- | 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---- | Weaken an intersection-weakR :: Sub (c1 :/\: c2) c2-weakR Dict = Dict---- | 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-    sub = id--instance (p :/\: ps) :< p-  where-    sub = weakL--instance (ps :< q) => ((p :/\: ps) :< q)-  where-    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-    prj (C s) = prj s--instance Equality dom => Equality (dom :| pred)-  where-    equal (C a) (C b) = equal a b-    exprHash (C a)    = exprHash a--instance Render dom => Render (dom :| pred)-  where-    renderSym (C a) = renderSym a-    renderArgs args (C a) = renderArgs args a--instance Eval dom => Eval (dom :| pred)-  where-    evaluate (C a) = evaluate a--instance StringTree dom => StringTree (dom :| pred)-  where-    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-    prj (C' s) = prj s--instance Equality dom => Equality (dom :|| pred)-  where-    equal (C' a) (C' b) = equal a b-    exprHash (C' a)     = exprHash a--instance Render dom => Render (dom :|| pred)-  where-    renderSym (C' a) = renderSym a-    renderArgs args (C' a) = renderArgs args a--instance Eval dom => Eval (dom :|| pred)-  where-    evaluate (C' a) = evaluate a--instance StringTree dom => StringTree (dom :|| pred)-  where-    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-    type Sat (AST dom) = Sat dom-    exprDict (Sym s)  = exprDict s-    exprDict (s :$ _) = exprDict s--instance Constrained (sub1 :+: sub2)-  where-    -- | An over-approximation of the union of @Sat sub1@ and @Sat sub2@-    type Sat (sub1 :+: sub2) = Top-    exprDict (InjL s) = Dict-    exprDict (InjR s) = Dict--instance Constrained dom => Constrained (dom :| pred)-  where-    type Sat (dom :| pred) = pred :/\: Sat dom-    exprDict (C s) = case exprDict s of Dict -> Dict--instance Constrained (dom :|| pred)-  where-    type Sat (dom :|| pred) = pred-    exprDict (C' s) = 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))-exprDictSub _ = 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))-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 => InjectC sub (AST sup) a-  where-    injC = Sym . injC--instance (InjectC sub sup a, pred a) => InjectC sub (sup :| pred) a-  where-    injC = C . injC--instance (InjectC sub sup a, pred a) => InjectC sub (sup :|| pred) a-  where-    injC = C' . injC--instance Sat expr a => InjectC expr expr a-  where-    injC = id--instance InjectC expr1 (expr1 :+: expr2) a-  where-    injC = InjL--instance InjectC expr1 expr3 a => InjectC expr1 (expr2 :+: expr3) a-  where-    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------ | 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-    type Sat (SubConstr1 c dom p) = Sat dom-    exprDict (SubConstr1 s) = exprDict s--instance Project sub sup => Project sub (SubConstr1 c sup p)-  where-    prj (SubConstr1 s) = prj s--instance Equality dom => Equality (SubConstr1 c dom p)-  where-    equal (SubConstr1 a) (SubConstr1 b) = equal a b-    exprHash (SubConstr1 s) = exprHash s--instance Render dom => Render (SubConstr1 c dom p)-  where-    renderSym (SubConstr1 s) = renderSym s-    renderArgs args (SubConstr1 s) = renderArgs args s--instance StringTree dom => StringTree (SubConstr1 c dom p)-  where-    stringTreeSym args (SubConstr1 a) = stringTreeSym args a--instance Eval dom => Eval (SubConstr1 c dom p)-  where-    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-    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-    prj (SubConstr2 s) = prj s--instance Equality dom => Equality (SubConstr2 c dom pa pb)-  where-    equal (SubConstr2 a) (SubConstr2 b) = equal a b-    exprHash (SubConstr2 s) = exprHash s--instance Render dom => Render (SubConstr2 c dom pa pb)-  where-    renderSym (SubConstr2 s) = renderSym s-    renderArgs args (SubConstr2 s) = renderArgs args s--instance StringTree dom => StringTree (SubConstr2 c dom pa pb)-  where-    stringTreeSym args (SubConstr2 a) = stringTreeSym args a--instance Eval dom => Eval (SubConstr2 c dom pa pb)-  where-    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--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------ | '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--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--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 s)  = []-    go (s :$ a) = go s ++ universe a-
− src/Language/Syntactic/Constructs/Binding.hs 
@@ -1,431 +0,0 @@-{-# 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.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-    type Sat Variable = Top-    exprDict _ = 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-    equal (Variable v1) (Variable v2) = v1==v2-    exprHash (Variable _)             = hashInt 0--instance Render Variable-  where-    renderSym (Variable v) = showVar v--instance StringTree Variable-  where-    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-    type Sat Lambda = Top-    exprDict _ = 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-    equal (Lambda v1) (Lambda v2) = v1==v2-    exprHash (Lambda _)           = hashInt 0--instance Render Lambda-  where-    renderSym (Lambda v) = "Lambda " ++ show v-    renderArgs [body] (Lambda v) = "(\\" ++ showVar v ++ " -> "  ++ body ++ ")"--instance StringTree Lambda-  where-    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--------------------------------------------------------------------------------------- * 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-    type Sat Let = Top-    exprDict _ = Dict--instance Equality Let-  where-    equal Let Let = True-    exprHash Let  = hashInt 0--instance Render Let-  where-    renderSym Let = "Let"-    renderArgs []    Let = "Let"-    renderArgs [f,a] Let = "(" ++ unwords ["letBind",f,a] ++ ")"--instance StringTree Let-  where-    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-        var                = drop 7 node  -- Drop the "Lambda " prefix--instance Eval Let-  where-    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 constr 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 a = go a-  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------ | 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)-  -- `(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-    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---- | Evaluation of closed expressions-evalBind :: (EvalBind dom, ConstrainedBy dom Typeable) => ASTF dom a -> a-evalBind = flip runReader [] . evalBindM---- | 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---- | 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'--instance EvalBind dom => EvalBind (dom :| pred)-  where-    evalBindSym (C a) = evalBindSym a--instance EvalBind dom => EvalBind (dom :|| pred)-  where-    evalBindSym (C' a) = evalBindSym a--instance EvalBind dom => EvalBind (SubConstr1 c dom p)-  where-    evalBindSym (SubConstr1 a) = evalBindSym a--instance EvalBind dom => EvalBind (SubConstr2 c dom pa pb)-  where-    evalBindSym (SubConstr2 a) = evalBindSym a--instance EvalBind Empty-  where-    evalBindSym = error "Not implemented: evalBindSym for Empty"--instance EvalBind dom => EvalBind (Decor info dom)-  where-    evalBindSym = evalBindSym . decorExpr--instance EvalBind Identity  where evalBindSym = evalBindSymDefault-instance EvalBind Construct where evalBindSym = evalBindSymDefault-instance EvalBind Literal   where evalBindSym = evalBindSymDefault-instance EvalBind Condition where evalBindSym = evalBindSymDefault-instance EvalBind Tuple     where evalBindSym = evalBindSymDefault-instance EvalBind Select    where evalBindSym = evalBindSymDefault-instance EvalBind Let       where evalBindSym = evalBindSymDefault--instance Monad m => EvalBind (MONAD m) where evalBindSym = evalBindSymDefault--instance EvalBind Variable-  where-    evalBindSym (Variable v) Nil = do-        env <- ask-        case lookup v env of-            Nothing -> return $ error "evalBind: evaluating free variable"-            Just a  -> case fromDyn a of-              Just a -> return a-              _      -> return $ error "evalBind: internal type error"--instance EvalBind Lambda-  where-    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 _ = 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-    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--instance (AlphaEq subA1 subB1 dom env, AlphaEq subA2 subB2 dom env) =>-    AlphaEq (subA1 :+: subA2) (subB1 :+: subB2) dom env-  where-    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--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---- | 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--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--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--instance AlphaEq sub sub dom env => AlphaEq (sub :| pred) (sub :| pred) dom env-  where-    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-    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-    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-    alphaEqSym (SubConstr2 a) aArgs (SubConstr2 b) bArgs = alphaEqSym a aArgs b bArgs--instance AlphaEq Empty Empty dom env-  where-    alphaEqSym = error "Not implemented: alphaEqSym for Empty"--instance AlphaEq dom dom dom env => AlphaEq Condition Condition dom env where alphaEqSym = alphaEqSymDefault-instance AlphaEq dom dom dom env => AlphaEq Construct Construct dom env where alphaEqSym = alphaEqSymDefault-instance AlphaEq dom dom dom env => AlphaEq Identity  Identity  dom env where alphaEqSym = alphaEqSymDefault-instance AlphaEq dom dom dom env => AlphaEq Let       Let       dom env where alphaEqSym = alphaEqSymDefault-instance AlphaEq dom dom dom env => AlphaEq Literal   Literal   dom env where alphaEqSym = alphaEqSymDefault-instance AlphaEq dom dom dom env => AlphaEq Select    Select    dom env where alphaEqSym = alphaEqSymDefault-instance AlphaEq dom dom dom env => AlphaEq Tuple     Tuple     dom env where alphaEqSym = alphaEqSymDefault--instance AlphaEq sub sub dom env =>-    AlphaEq (Decor info sub) (Decor info sub) dom env-  where-    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-    alphaEqSym = alphaEqSymDefault--instance (AlphaEq dom dom dom env, VarEqEnv env) =>-    AlphaEq Variable Variable dom env-  where-    alphaEqSym (Variable v1) Nil (Variable v2) Nil = 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-    alphaEqSym (Lambda v1) (body1 :* Nil) (Lambda v2) (body2 :* Nil) =-        local (modVarEqEnv ((v1,v2):)) $ alphaEqM body1 body2-
− src/Language/Syntactic/Constructs/Binding/HigherOrder.hs 
@@ -1,102 +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-    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-    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 a-    . AST (HODomain dom p pVar) a -> State VarId (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,145 +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))--  -- 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-    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-    optimizeSym cf i (C s) args = optimizeSym cf (i . C) s args--instance Optimize dom => Optimize (dom :|| p)-  where-    optimizeSym cf i (C' s) args = optimizeSym cf (i . C') s args--instance Optimize Empty-  where-    optimizeSym = error "Not implemented: optimizeSym for Empty"--instance Optimize dom => Optimize (SubConstr1 c dom p)-  where-    optimizeSym cf i (SubConstr1 s) args = optimizeSym cf (i . SubConstr1) s args--instance Optimize dom => Optimize (SubConstr2 c dom pa pb)-  where-    optimizeSym cf i (SubConstr2 s) args = optimizeSym cf (i . SubConstr2) s args--instance Optimize Identity  where optimizeSym = optimizeSymDefault-instance Optimize Construct where optimizeSym = optimizeSymDefault-instance Optimize Literal   where optimizeSym = optimizeSymDefault-instance Optimize Tuple     where optimizeSym = optimizeSymDefault-instance Optimize Select    where optimizeSym = optimizeSymDefault-instance Optimize Let       where optimizeSym = optimizeSymDefault--instance Optimize Condition-  where-    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-    optimizeSym _ injecter var@(Variable v) Nil = do-        tell (singleton v)-        return (injecter var)--instance Optimize Lambda-  where-    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,27 +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-    type Sat Condition = Top-    exprDict _ = Dict--instance Semantic Condition-  where-    semantics Condition = Sem "condition" (\c t e -> if c then t else e)--semanticInstances ''Condition-
− src/Language/Syntactic/Constructs/Construct.hs 
@@ -1,30 +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-    type Sat Construct = Top-    exprDict _ = Dict--instance Semantic Construct-  where-    semantics (Construct name den) = Sem name den--semanticInstances ''Construct-
− src/Language/Syntactic/Constructs/Decoration.hs 
@@ -1,120 +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-    type Sat (Decor info expr) = Sat expr-    exprDict (Decor _ a) = exprDict a--instance Project sub sup => Project sub (Decor info sup)-  where-    prj = prj . decorExpr--instance Equality expr => Equality (Decor info expr)-  where-    equal a b = decorExpr a `equal` decorExpr b-    exprHash  = exprHash . decorExpr--instance Render expr => Render (Decor info expr)-  where-    renderSym = renderSym . decorExpr-    renderArgs args = renderArgs args . decorExpr--instance StringTree expr => StringTree (Decor info expr)-  where-    stringTreeSym args = stringTreeSym args . decorExpr--instance Eval expr => Eval (Decor info expr)-  where-    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---- | 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---- | Collect the decorations of all nodes-collectInfo :: (forall sig . info sig -> b) -> AST (Decor info dom) sig -> [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 a. info a -> String) -> ASTF (Decor info dom) a -> Tree String-stringTreeDecor showInfo a = mkTree [] a-  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 a. info a -> String) -> ASTF (Decor info dom) a -> String-showDecorWith showInfo = showTree . stringTreeDecor showInfo---- | Print an decorated syntax tree using ASCII art-drawDecorWith :: StringTree dom => (forall a. info a -> String) -> ASTF (Decor info dom) a -> IO ()-drawDecorWith showInfo = putStrLn . showDecorWith showInfo---- | 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-
− src/Language/Syntactic/Constructs/Identity.hs 
@@ -1,28 +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-    type Sat Identity = Top-    exprDict _ = Dict--instance Semantic Identity-  where-    semantics Id = Sem "id" id--semanticInstances ''Identity-
− src/Language/Syntactic/Constructs/Literal.hs 
@@ -1,41 +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-    type Sat Literal = Eq :/\: Show :/\: Typeable :/\: Top-    exprDict (Literal _) = Dict--instance Equality Literal-  where-    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-    renderSym (Literal a) = show a--instance StringTree Literal--instance Eval Literal-  where-    evaluate (Literal a) = a-
− src/Language/Syntactic/Constructs/Monad.hs 
@@ -1,45 +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-    type Sat (MONAD m) = Top-    exprDict _ = Dict--instance Monad m => Semantic (MONAD m)-  where-    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 equal      = equalDefault; exprHash = exprHashDefault-instance Monad m => Render     (MONAD m) where renderSym  = renderSymDefault-                                               renderArgs = renderArgsDefault-instance Monad m => Eval       (MONAD m) where evaluate   = evaluateDefault-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-
− src/Language/Syntactic/Constructs/Tuple.hs 
@@ -1,135 +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))--instance Constrained Tuple-  where-    type Sat Tuple = Top-    exprDict _ = Dict--instance Semantic Tuple-  where-    semantics Tup2 = Sem "tup2" (,)-    semantics Tup3 = Sem "tup3" (,,)-    semantics Tup4 = Sem "tup4" (,,,)-    semantics Tup5 = Sem "tup5" (,,,,)-    semantics Tup6 = Sem "tup6" (,,,,,)-    semantics Tup7 = Sem "tup7" (,,,,,,)--semanticInstances ''Tuple--------------------------------------------------------------------------------------- * Projection------------------------------------------------------------------------------------- | These families ('Sel1'' - 'Sel7'') 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 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 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 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 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 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 family Sel7' a-type instance Sel7' (a,b,c,d,e,f,g) = g---- | 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)--instance Constrained Select-  where-    type Sat Select = Top-    exprDict _ = Dict--instance Semantic Select-  where-    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--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-
+ src/Language/Syntactic/Decoration.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_GLASGOW_HASKELL+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0+#endif+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10++#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+#else+{-# LANGUAGE OverlappingInstances #-}+#endif++-- | Construct for decorating symbols or expressions with additional information++module Language.Syntactic.Decoration where++++import Data.Tree (Tree (..))++import Data.Tree.View++import Language.Syntactic.Syntax+import Language.Syntactic.Traversal+import Language.Syntactic.Interpretation+import Language.Syntactic.Sugar++++-- | 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 Symbol sym => Symbol (sym :&: info)+  where+    symSig = symSig . decorExpr++instance (NFData1 sym, NFData1 info) => NFData1 (sym :&: info)+  where+    rnf1 (s :&: i) = rnf1 s `seq` rnf1 i `seq` ()++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++writeHtmlDecorWith :: forall info sym a. (StringTree sym)+                   => (forall b. info b -> String) -> FilePath -> ASTF (sym :&: info) a -> IO ()+writeHtmlDecorWith showInfo file a = writeHtmlTree Nothing file $ mkTree [] a+  where+    mkTree :: [Tree NodeInfo] -> AST (sym :&: info) sig -> Tree NodeInfo+    mkTree args (f :$ a) = mkTree (mkTree [] a : args) f+    mkTree args (Sym (expr :&: info)) =+      Node (NodeInfo InitiallyExpanded (renderSym expr) (showInfo info)) args++-- | Make a smart constructor of a symbol. 'smartSymDecor' has any type of the+-- form:+--+-- > smartSymDecor :: (sub :<: AST (sup :&: info))+-- >     => info x+-- >     -> sub (a :-> b :-> ... :-> Full x)+-- >     -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x)+smartSymDecor+    :: ( Signature sig+       , f              ~ SmartFun (sup :&: info) sig+       , sig            ~ SmartSig f+       , (sup :&: info) ~ SmartSym f+       , sub :<: sup+       )+    => info (DenResult sig) -> sub sig -> f+smartSymDecor d = smartSym' . (:&: d) . inj++-- | \"Sugared\" symbol application+--+-- 'sugarSymDecor' has any type of the form:+--+-- > sugarSymDecor ::+-- >     ( sub :<: AST (sup :&: info)+-- >     , Syntactic a+-- >     , Syntactic b+-- >     , ...+-- >     , Syntactic x+-- >     , Domain a ~ Domain b ~ ... ~ Domain x+-- >     ) => info (Internal x)+-- >       -> sub (Internal a :-> Internal b :-> ... :-> Full (Internal x))+-- >       -> (a -> b -> ... -> x)+sugarSymDecor+    :: ( Signature sig+       , fi             ~ SmartFun (sup :&: info) sig+       , sig            ~ SmartSig fi+       , (sup :&: info) ~ SmartSym fi+       , SyntacticN f fi+       , sub :<: sup+       )+    => info (DenResult sig) -> sub sig -> f+sugarSymDecor i = sugarN . smartSymDecor i+
− src/Language/Syntactic/Frontend/Monad.hs 
@@ -1,100 +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-    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,233 +0,0 @@-{-# 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-    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-    , 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-    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-    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-    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-    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-    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-        )-
− src/Language/Syntactic/Frontend/TupleConstrained.hs 
@@ -1,330 +0,0 @@-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE UndecidableInstances #-}---- | 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-instance TupleSat ((Tuple :|| p) :+: dom2) p--instance TupleSat (Select :|| p) p-instance TupleSat ((Select :|| p) :+: dom2) p--instance TupleSat dom p => TupleSat (dom :| q) p-instance TupleSat dom p => TupleSat (dom :|| q) p-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)----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-    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-    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-    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-    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-    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-    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-        )-
+ src/Language/Syntactic/Functional.hs view
@@ -0,0 +1,789 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}++#ifndef MIN_VERSION_GLASGOW_HASKELL+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0+#endif+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10++#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+#else+{-# LANGUAGE OverlappingInstances #-}+#endif++#if __GLASGOW_HASKELL__ < 708+#define TYPEABLE Typeable1+#else+#define TYPEABLE Typeable+#endif++-- | Basics for implementing functional EDSLs++module Language.Syntactic.Functional+    ( -- * Syntactic constructs+      Name (..)+    , Literal (..)+    , Construct (..)+    , Binding (..)+    , maxLam+    , lam_template+    , lam+    , fromDeBruijn+    , BindingT (..)+    , maxLamT+    , lamT_template+    , lamT+    , lamTyped+    , BindingDomain (..)+    , Let (..)+    , MONAD (..)+    , Remon (..)+    , desugarMonad+    , desugarMonadTyped+      -- * Free and bound variables+    , freeVars+    , allVars+    , renameUnique'+    , renameUnique+      -- * Alpha-equivalence+    , AlphaEnv+    , alphaEq'+    , alphaEq+      -- * Evaluation+    , Denotation+    , Eval (..)+    , evalDen+    , DenotationM+    , liftDenotationM+    , RunEnv+    , EvalEnv (..)+    , compileSymDefault+    , evalOpen+    , evalClosed+    ) where++++#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+#else+import Control.Applicative+#endif+import Control.DeepSeq (NFData (..))+import Control.Monad (liftM2)+import Control.Monad.Cont+import Control.Monad.Reader+import Control.Monad.State+import Data.Dynamic+import Data.Kind (Type)+import Data.List (genericIndex)+import Data.Proxy+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Tree++import Data.Hash (hashInt)++import Language.Syntactic++++----------------------------------------------------------------------------------------------------+-- * Syntactic constructs+----------------------------------------------------------------------------------------------------++-- | Literal+data Literal sig+  where+    Literal :: Show a => a -> Literal (Full a)++instance Symbol Literal+  where+    symSig (Literal _) = signature++instance Render Literal+  where+    renderSym (Literal a) = show a++instance Equality Literal+instance StringTree Literal++-- | Generic N-ary syntactic construct+--+-- 'Construct' gives a quick way to introduce a syntactic construct by giving its name and semantic+-- function.+data Construct sig+  where+    Construct :: Signature sig => String -> Denotation sig -> Construct sig+  -- There is no `NFData1` instance for `Construct` because that would give rise+  -- to a constraint `NFData (Denotation sig)`, which easily spreads to other+  -- functions.++instance Symbol Construct+  where+    symSig (Construct _ _) = signature++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, NFData)++instance Show Name+  where+    show (Name n) = show n++-- | Variables and binders+data Binding sig+  where+    Var :: Name -> Binding (Full a)+    Lam :: Name -> Binding (b :-> Full (a -> b))++instance Symbol Binding+  where+    symSig (Var _) = signature+    symSig (Lam _) = signature++instance NFData1 Binding+  where+    rnf1 (Var v) = rnf v+    rnf1 (Lam v) = rnf v++-- | '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 :: (Project 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 for domains based on '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, <https://emilaxelsson.github.io/documents/axelsson2013using.pdf>).+lam_template :: (Project Binding sym)+    => (Name -> sym (Full a))+         -- ^ Variable symbol constructor+    -> (Name -> ASTF sym b -> ASTF sym (a -> b))+         -- ^ Lambda constructor+    -> (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)+lam_template mkVar mkLam f = mkLam v body+  where+    body = f $ Sym $ mkVar v+    v    = succ $ maxLam body++-- | Higher-order interface for variable binding+--+-- This function is 'lamT_template' specialized to domains @sym@ satisfying+-- @(`Binding` `:<:` sym)@.+lam :: (Binding :<: sym) => (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)+lam = lam_template (inj . Var) (\v a -> Sym (inj (Lam v)) :$ a)++-- | 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 sig+  where+    VarT :: Typeable a => Name -> BindingT (Full a)+    LamT :: Typeable a => Name -> BindingT (b :-> Full (a -> b))++instance Symbol BindingT+  where+    symSig (VarT _) = signature+    symSig (LamT _) = signature++instance NFData1 BindingT+  where+    rnf1 (VarT v) = rnf v+    rnf1 (LamT v) = rnf v++-- | '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 :: Project BindingT sym => AST sym 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 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, <https://emilaxelsson.github.io/documents/axelsson2013using.pdf>).+lamT_template :: Project BindingT sym+    => (Name -> sym (Full a))+         -- ^ Variable symbol constructor+    -> (Name -> ASTF sym b -> ASTF sym (a -> b))+         -- ^ Lambda constructor+    -> (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)+lamT_template mkVar mkLam f = mkLam v body+  where+    body = f $ Sym $ mkVar v+    v    = succ $ maxLamT body++-- | Higher-order interface for variable binding+--+-- This function is 'lamT_template' specialized to domains @sym@ satisfying+-- @(`BindingT` `:<:` sym)@.+lamT :: (BindingT :<: sym, Typeable a) =>+    (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)+lamT = lamT_template (inj . VarT) (\v a -> Sym (inj (LamT v)) :$ a)++-- | Higher-order interface for variable binding+--+-- This function is 'lamT_template' specialized to domains @sym@ satisfying+-- @(sym ~ `Typed` s, `BindingT` `:<:` s)@.+lamTyped :: (sym ~ Typed s, BindingT :<: s, Typeable a, Typeable b) =>+    (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)+lamTyped = lamT_template+    (Typed . inj . VarT)+    (\v a -> Sym (Typed (inj (LamT v))) :$ a)++-- | Domains that \"might\" include variables and binders+class BindingDomain sym+  where+    prVar :: sym sig -> Maybe Name+    prLam :: sym sig -> Maybe Name++    -- | Rename a variable or a lambda (no effect for other symbols)+    renameBind :: (Name -> Name) -> sym sig -> sym sig++instance {-# OVERLAPPING #-}+         (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+    renameBind re (InjL s) = InjL $ renameBind re s+    renameBind re (InjR s) = InjR $ renameBind re s++instance {-# OVERLAPPING #-} BindingDomain sym => BindingDomain (Typed sym)+  where+    prVar (Typed s) = prVar s+    prLam (Typed s) = prLam s+    renameBind re (Typed s) = Typed $ renameBind re s++instance {-# OVERLAPPING #-} BindingDomain sym => BindingDomain (sym :&: i)+  where+    prVar = prVar . decorExpr+    prLam = prLam . decorExpr+    renameBind re (s :&: d) = renameBind re s :&: d++instance {-# OVERLAPPING #-} BindingDomain sym => BindingDomain (AST sym)+  where+    prVar (Sym s) = prVar s+    prVar _       = Nothing+    prLam (Sym s) = prLam s+    prLam _       = Nothing+    renameBind re (Sym s) = Sym $ renameBind re s++instance {-# OVERLAPPING #-} BindingDomain Binding+  where+    prVar (Var v) = Just v+    prLam (Lam v) = Just v+    renameBind re (Var v) = Var $ re v+    renameBind re (Lam v) = Lam $ re v++instance {-# OVERLAPPING #-} BindingDomain BindingT+  where+    prVar (VarT v) = Just v+    prLam (LamT v) = Just v+    renameBind re (VarT v) = VarT $ re v+    renameBind re (LamT v) = LamT $ re v++instance {-# OVERLAPPABLE #-} BindingDomain sym+  where+    prVar _ = Nothing+    prLam _ = Nothing+    renameBind _ a = a+  -- This instance seems to overlap all others on GHC 8.2.2. This leads to+  -- failures in the test suite. Removing the instance and declaring one+  -- instance per type solves the problem. Earlier and later GHC versions don't+  -- have this problem, so I assume it's a bug in 8.2.++-- | A symbol for let bindings+--+-- This symbol is just an application operator. The actual binding has to be+-- done by a lambda that constructs the second argument.+--+-- The provided string is just a tag and has nothing to do with the name of the+-- variable of the second argument (if that argument happens to be a lambda).+-- However, a back end may use the tag to give a sensible name to the generated+-- variable.+--+-- The string tag may be empty.+data Let sig+  where+    Let :: String -> Let (a :-> (a -> b) :-> Full b)++instance Symbol Let where symSig (Let _) = signature++instance Render Let+  where+    renderSym (Let "") = "Let"+    renderSym (Let nm) = "Let " ++ nm++instance Equality Let+  where+    equal = equalDefault+    hash  = hashDefault++instance StringTree Let+  where+    stringTreeSym [a, Node lam [body]] letSym+        | ("Lam",v) <- splitAt 3 lam = Node (renderSym letSym ++ v) [a,body]+    stringTreeSym [a,f] letSym = Node (renderSym letSym) [a,f]++-- | Monadic constructs+--+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011+-- <https://emilaxelsson.github.io/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 Symbol (MONAD m)+  where+    symSig Return = signature+    symSig Bind   = signature++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 <https://emilaxelsson.github.io/documents/persson2011generic.pdf>).+--+-- It is advised to convert to/from 'Remon' using the 'Syntactic' instance+-- provided in the modules "Language.Syntactic.Sugar.Monad" or+-- "Language.Syntactic.Sugar.MonadT".+newtype Remon sym m a+  where+    Remon+        :: { unRemon :: forall r . Typeable r => Cont (ASTF sym (m r)) a }+        -> Remon sym m a+  deriving (Functor)+  -- The `Typeable` constraint is a bit unfortunate. It's only needed when using+  -- a `Typed` domain. Since this is probably the most common case I decided to+  -- bake in `Typeable` here. A more flexible solution would be to parameterize+  -- `Remon` on the constraint.++  -- Note that `Remon` can be seen as a variant of the codensity monad:+  -- <https://hackage.haskell.org/package/kan-extensions/docs/Control-Monad-Codensity.html>++instance Applicative (Remon sym m)+  where+    pure a  = Remon $ pure a+    f <*> a = Remon $ unRemon f <*> unRemon a++instance Monad (Remon dom m)+  where+    return = pure+    ma >>= f = Remon $ unRemon ma >>= \a -> unRemon (f a)++-- | One-layer desugaring of monadic actions+desugarMonad+    :: ( MONAD m :<: sym+       , Typeable a+       , TYPEABLE m+       )+    => Remon sym m (ASTF sym a) -> ASTF sym (m a)+desugarMonad (Remon m) = flip runCont (sugarSym Return) m++-- | One-layer desugaring of monadic actions+desugarMonadTyped+    :: ( MONAD m :<: s+       , sym ~ Typed s+       , Typeable a+       , TYPEABLE m+       )+    => Remon sym m (ASTF sym a) -> ASTF sym (m a)+desugarMonadTyped (Remon m) = flip runCont (sugarSymTyped Return) m++++----------------------------------------------------------------------------------------------------+-- * Free and bound variables+----------------------------------------------------------------------------------------------------++-- | Get the set of free variables in an expression+freeVars :: BindingDomain sym => AST sym sig -> Set Name+freeVars var+    | Just v <- prVar var = Set.singleton v+freeVars (lam :$ body)+    | Just v <- prLam lam = Set.delete v (freeVars body)+freeVars (s :$ a) = Set.union (freeVars s) (freeVars a)+freeVars _ = Set.empty++-- | Get the set of variables (free, bound and introduced by lambdas) in an+-- expression+allVars :: BindingDomain sym => AST sym sig -> Set Name+allVars var+    | Just v <- prVar var = Set.singleton v+allVars (lam :$ body)+    | Just v <- prLam lam = Set.insert v (allVars body)+allVars (s :$ a) = Set.union (allVars s) (allVars a)+allVars _ = Set.empty++-- | Generate an infinite list of fresh names given a list of allocated names+--+-- The argument is assumed to be sorted and not contain an infinite number of adjacent names.+freshVars :: [Name] -> [Name]+freshVars as = go 0 as+  where+    go c [] = [c..]+    go c (v:as)+      | c < v     = c : go (c+1) (v:as)+      | c == v    = go (c+1) as+      | otherwise = go c as++freshVar :: MonadState [Name] m => m Name+freshVar = do+    vs <- get+    case vs of+      v:vs' -> do+        put vs'+        return v++-- | Rename the bound variables in a term+--+-- The free variables are left untouched. The bound variables are given unique+-- names using as small names as possible. The first argument is a list of+-- reserved names. Reserved names and names of free variables are not used when+-- renaming bound variables.+renameUnique' :: forall sym a . BindingDomain sym =>+    [Name] -> ASTF sym a -> ASTF sym a+renameUnique' vs a = flip evalState fs $ go Map.empty a+  where+    fs = freshVars $ Set.toAscList (freeVars a `Set.union` Set.fromList vs)++    go :: Map Name Name -> AST sym sig -> State [Name] (AST sym sig)+    go env var+      | Just v <- prVar var = case Map.lookup v env of+          Just w -> return $ renameBind (\_ -> w) var+          _ -> return var  -- Free variable+    go env (lam :$ body)+      | Just v <- prLam lam = do+          w     <- freshVar+          body' <- go (Map.insert v w env) body+          return $ renameBind (\_ -> w) lam :$ body'+    go env (s :$ a) = liftM2 (:$) (go env s) (go env a)+    go env s = return s++-- | Rename the bound variables in a term+--+-- The free variables are left untouched. The bound variables are given unique+-- names using as small names as possible. Names of free variables are not used+-- when renaming bound variables.+renameUnique :: BindingDomain sym => ASTF sym a -> ASTF sym a+renameUnique = renameUnique' []++++----------------------------------------------------------------------------------------------------+-- * 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, lookup v2 env') of+        (Nothing, Nothing)   -> v1==v2  -- Free variables+        (Just v2', Just v1') -> v1==v1' && v2==v2'+        _                    -> False+  where+    env' = [(v2,v1) | (v1,v2) <- env]+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 Literal+  where+    evalSym (Literal a) = a++instance Eval Construct+  where+    evalSym (Construct _ d) = d++instance Eval Let+  where+    evalSym (Let _) = flip ($)++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 :: Type -> Type) 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 =>+    SigRep sig -> proxy1 m -> proxy2 sig -> Denotation sig -> DenotationM m sig+liftDenotationM sig _ _ = help2 sig . help1 sig+  where+    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++    default compileSym :: (Symbol sym, Eval sym) =>+        proxy env -> sym sig -> DenotationM (Reader env) sig+    compileSym p s = compileSymDefault (symSig s) p s++-- | Simple implementation of `compileSym` from a 'Denotation'+compileSymDefault :: forall proxy env sym sig . Eval sym =>+    SigRep sig -> proxy env -> sym sig -> DenotationM (Reader env) sig+compileSymDefault sig p s = liftDenotationM sig (Proxy :: Proxy (Reader env)) s (evalSym s)++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 (Typed sym) env+  where+    compileSym p (Typed s) = compileSym p s++instance EvalEnv sym env => EvalEnv (sym :&: info) env+  where+    compileSym p = compileSym p . decorExpr++instance EvalEnv Literal env++instance EvalEnv Construct env++instance EvalEnv Let env++instance Monad m => EvalEnv (MONAD m) env++instance EvalEnv BindingT RunEnv+  where+    compileSym _ (VarT v) = reader $ \env ->+        case lookup v env of+          Nothing -> error $ "compileSym: Variable " ++ show v ++ " not in scope"+          Just d  -> case fromDynamic d of+            Nothing -> error "compileSym: type error"  -- TODO Print types+            Just a -> a+    compileSym _ (LamT v) = \body -> reader $ \env a -> runReader body ((v, toDyn a) : env)++-- | \"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) []
+ src/Language/Syntactic/Functional/Sharing.hs view
@@ -0,0 +1,321 @@+-- | 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.Functional.Sharing+    ( -- * Interface+      InjDict (..)+    , CodeMotionInterface (..)+    , defaultInterface+    , defaultInterfaceDecor+      -- * Code motion+    , codeMotion+    ) where++++import Control.Monad (liftM2, mplus)+import Control.Monad.State+import Data.Maybe (isNothing)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Typeable++import Data.Constraint (Dict (..))++import Language.Syntactic+import Language.Syntactic.Functional++++--------------------------------------------------------------------------------+-- * Interface+--------------------------------------------------------------------------------++-- | Interface for injecting binding constructs+data InjDict sym a b = InjDict+    { injVariable :: Name -> sym (Full a)+        -- ^ Inject a variable+    , injLambda   :: Name -> sym (b :-> Full (a -> b))+        -- ^ Inject a lambda+    , injLet      :: sym (a :-> (a -> b) :-> Full b)+        -- ^ Inject a "let" symbol+    }++-- | Code motion interface+data CodeMotionInterface sym = Interface+    { mkInjDict   :: forall a b . ASTF sym a -> ASTF sym b -> Maybe (InjDict sym a b)+        -- ^ Try to construct an 'InjDict'. The first argument is the expression+        -- to be shared, and the second argument the expression in which it will+        -- be shared. This function can be used to transfer information (e.g.+        -- from static analysis) from the shared expression to the introduced+        -- variable.+    , castExprCM  :: forall a b . ASTF sym a -> ASTF sym b -> Maybe (ASTF sym b)+        -- ^ Try to type cast an expression. The first argument is the+        -- expression to cast. The second argument can be used to construct a+        -- witness to support the casting. The resulting expression (if any)+        -- should be equal to the first argument.+    , hoistOver   :: forall c. ASTF sym c -> Bool+        -- ^ Whether a sub-expression can be hoisted over the given expression+    }++-- | Default 'CodeMotionInterface' for domains of the form+-- @`Typed` (... `:+:` `Binding` `:+:` ...)@.+defaultInterface :: forall binding sym symT+    .  ( binding :<: sym+       , Let     :<: sym+       , symT ~ Typed sym+       )+    => (forall a .   Typeable a => Name -> binding (Full a))+         -- ^ Variable constructor (e.g. 'Var' or 'VarT')+    -> (forall a b . Typeable a => Name -> binding (b :-> Full (a -> b)))+         -- ^ Lambda constructor (e.g. 'Lam' or 'LamT')+    -> (forall a b . ASTF symT a -> ASTF symT b -> Bool)+         -- ^ Can the expression represented by the first argument be shared in+         -- the second argument?+    -> (forall a . ASTF symT a -> Bool)+         -- ^ Can we hoist over this expression?+    -> CodeMotionInterface symT+defaultInterface var lam sharable hoistOver = Interface {..}+  where+    mkInjDict :: ASTF symT a -> ASTF symT b -> Maybe (InjDict symT a b)+    mkInjDict a b | not (sharable a b) = Nothing+    mkInjDict a b =+        simpleMatch+          (\(Typed _) _ -> simpleMatch+            (\(Typed _) _ ->+              let injVariable = Typed . inj . var+                  injLambda   = Typed . inj . lam+                  injLet      = Typed $ inj (Let "")+              in  Just InjDict {..}+            ) b+          ) a++    castExprCM = castExpr++-- | Default 'CodeMotionInterface' for domains of the form+-- @(... `:&:` info)@, where @info@ can be used to witness type casting+defaultInterfaceDecor :: forall binding sym symI info+    .  ( binding :<: sym+       , Let     :<: sym+       , symI ~ (sym :&: info)+       )+    => (forall a b . info a -> info b -> Maybe (Dict (a ~ b)))+         -- ^ Construct a type equality witness+    -> (forall a b . info a -> info b -> info (a -> b))+         -- ^ Construct info for a function, given info for the argument and the+         -- result+    -> (forall a . info a -> Name -> binding (Full a))+         -- ^ Variable constructor+    -> (forall a b . info a -> info b -> Name -> binding (b :-> Full (a -> b)))+         -- ^ Lambda constructor+    -> (forall a b . ASTF symI a -> ASTF symI b -> Bool)+         -- ^ Can the expression represented by the first argument be shared in+         -- the second argument?+    -> (forall a . ASTF symI a -> Bool)+         -- ^ Can we hoist over this expression?+    -> CodeMotionInterface symI+defaultInterfaceDecor teq mkFunInfo var lam sharable hoistOver = Interface {..}+  where+    mkInjDict :: ASTF symI a -> ASTF symI b -> Maybe (InjDict symI a b)+    mkInjDict a b | not (sharable a b) = Nothing+    mkInjDict a b =+        simpleMatch+          (\(_ :&: aInfo) _ -> simpleMatch+            (\(_ :&: bInfo) _ ->+              let injVariable v = inj (var aInfo v) :&: aInfo+                  injLambda   v = inj (lam aInfo bInfo v) :&: mkFunInfo aInfo bInfo+                  injLet        = inj (Let "") :&: bInfo+              in  Just InjDict {..}+            ) b+          ) a++    castExprCM :: ASTF symI a -> ASTF symI b -> Maybe (ASTF symI b)+    castExprCM a b =+        simpleMatch+          (\(_ :&: aInfo) _ -> simpleMatch+            (\(_ :&: bInfo) _ -> case teq aInfo bInfo of+              Just Dict -> Just a+              _ -> Nothing+            ) b+          ) a++++--------------------------------------------------------------------------------+-- * Code motion+--------------------------------------------------------------------------------++-- | Substituting a sub-expression. Assumes that the free variables of the+-- replacing expression do not occur as binders in the whole expression (so that+-- there is no risk of capturing).+substitute :: forall sym a b+    .  (Equality sym, BindingDomain sym)+    => CodeMotionInterface sym+    -> ASTF sym a  -- ^ Sub-expression to be replaced+    -> ASTF sym a  -- ^ Replacing sub-expression+    -> ASTF sym b  -- ^ Whole expression+    -> ASTF sym b+substitute iface x y a = subst a+  where+    fv = freeVars x++    subst :: ASTF sym c -> ASTF sym c+    subst a+      | Just y' <- castExprCM iface y a, alphaEq x a = y'+      | otherwise = subst' a++    subst' :: AST sym c -> AST sym c+    subst' a@(lam :$ body)+      | Just v <- prLam lam+      , Set.member v fv = a+    subst' (s :$ a) = subst' s :$ subst a+    subst' a = a++  -- Note: Since `codeMotion` only uses `substitute` to replace sub-expressions+  -- with fresh variables, the assumption above is fulfilled. However, the+  -- matching in `subst` needs to be aware of free variables, which is why the+  -- substitution stops when reaching a lambda that binds a variable that is+  -- free in the expression to be replaced.++-- | Count the number of occurrences of a sub-expression+count :: forall sym a b+    .  (Equality sym, BindingDomain sym)+    => ASTF sym a  -- ^ Expression to count+    -> ASTF sym b  -- ^ Expression to count in+    -> Int+count a b = cnt b+  where+    fv = freeVars a++    cnt :: ASTF sym c -> Int+    cnt c+      | alphaEq a c = 1+      | otherwise   = cnt' c++    cnt' :: AST sym sig -> Int+    cnt' (lam :$ body)+      | Just v <- prLam lam+      , Set.member v fv = 0+          -- There can be no match under a lambda that binds a variable that is+          -- free in `a`. This case needs to be handled in order to avoid false+          -- matches.+          --+          -- Consider the following expression:+          --+          --     (\x -> f x) 0 + f x+          --+          -- The sub-expression `f x` appear twice, but `x` means different+          -- things in the two cases.+    cnt' (s :$ c) = cnt' s + cnt c+    cnt' _        = 0++-- | Environment for the expression in the 'choose' function+data Env sym = Env+    { inLambda :: Bool  -- ^ Whether the current expression is inside a lambda+    , counter  :: EF (AST sym) -> Int+        -- ^ Counting the number of occurrences of an expression in the+        -- environment+    , dependencies :: Set Name+        -- ^ The set of variables that are not allowed to occur in the chosen+        -- expression+    }++-- | Checks whether a sub-expression in a given environment can be lifted out+liftable :: BindingDomain sym => Env sym -> ASTF sym a -> Bool+liftable env a = independent && isNothing (prVar a) && heuristic+      -- Lifting dependent expressions is semantically incorrect. Lifting+      -- variables would cause `codeMotion` to loop.+  where+    independent = Set.null $ Set.intersection (freeVars a) (dependencies env)+    heuristic   = inLambda env || (counter env (EF 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 sym a+  where+    Chosen :: InjDict sym b a -> ASTF sym b -> Chosen sym a++-- | Choose a sub-expression to share+choose :: forall sym a+    .  (Equality sym, BindingDomain sym)+    => CodeMotionInterface sym+    -> ASTF sym a+    -> Maybe (Chosen sym a)+choose iface a = chooseEnvSub initEnv a+  where+    initEnv = Env+        { inLambda     = False+        , counter      = \(EF b) -> count b a+        , dependencies = Set.empty+        }++    chooseEnv :: Env sym -> ASTF sym b -> Maybe (Chosen sym a)+    chooseEnv env b+        | liftable env b+        , Just id <- mkInjDict iface b a+        = Just $ Chosen id b+    chooseEnv env b+        | hoistOver iface b = chooseEnvSub env b+        | otherwise         = Nothing++    -- | Like 'chooseEnv', but does not consider the top expression for sharing+    chooseEnvSub :: Env sym -> AST sym b -> Maybe (Chosen sym a)+    chooseEnvSub env (Sym lam :$ b)+        | Just v <- prLam lam+        = chooseEnv (env' v) b+      where+        env' v = env+            { inLambda     = True+            , dependencies = Set.insert v (dependencies env)+            }+    chooseEnvSub env (s :$ b) = chooseEnvSub env s `mplus` chooseEnv env b+    chooseEnvSub _ _ = Nothing++-- If `codeMotionM` loops forever, the reason may be that `castExprCM` is+-- broken. If `castExprCM` fails to cast even when it should, it means that+-- we can get into situations where `substitute` returns the same expression+-- unchanged. This in turn means that `codeMotionM` will loop, since it calls+-- itself with `codeMotionM iface $ substitute iface b x a`.++codeMotionM :: forall sym m a+    .  ( Equality sym+       , BindingDomain sym+       , MonadState Name m+       )+    => CodeMotionInterface sym+    -> ASTF sym a+    -> m (ASTF sym a)+codeMotionM iface a+    | Just (Chosen id b) <- choose iface a = share id b+    | otherwise = descend a+  where+    share :: InjDict sym b a -> ASTF sym b -> m (ASTF sym a)+    share id b = do+        b' <- codeMotionM iface b+        v  <- get; put (v+1)+        let x = Sym (injVariable id v)+        body <- codeMotionM iface $ substitute iface b x a+        return+            $  Sym (injLet id)+            :$ b'+            :$ (Sym (injLambda id v) :$ body)++    descend :: AST sym b -> m (AST sym b)+    descend (s :$ a) = liftM2 (:$) (descend s) (codeMotionM iface a)+    descend a        = return a++-- | Perform common sub-expression elimination and variable hoisting+codeMotion :: forall sym m a+    .  ( Equality sym+       , BindingDomain sym+       )+    => CodeMotionInterface sym+    -> ASTF sym a+    -> ASTF sym a+codeMotion iface a = flip evalState maxVar $ codeMotionM iface a+  where+    maxVar = succ $ Set.findMax $ Set.insert 0 $ allVars a+
+ src/Language/Syntactic/Functional/Tuple.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Construction and elimination of tuples++module Language.Syntactic.Functional.Tuple where++++import Language.Syntactic+import Language.Syntactic.TH+import Language.Syntactic.Functional++++data Tuple a+  where+    Pair :: Tuple (a :-> b :-> Full (a,b))+    Fst  :: Tuple ((a,b) :-> Full a)+    Snd  :: Tuple ((a,b) :-> Full b)++deriveSymbol    ''Tuple+deriveEquality  ''Tuple+deriveRender id ''Tuple++instance StringTree Tuple++instance Eval Tuple+  where+    evalSym Pair = (,)+    evalSym Fst  = fst+    evalSym Snd  = snd++instance EvalEnv Tuple env+
+ src/Language/Syntactic/Functional/Tuple/TH.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -Wno-x-partial #-}++-- | Generate 'Syntactic' instances for tuples++module Language.Syntactic.Functional.Tuple.TH+  ( deriveSyntacticForTuples+  ) where++++import Language.Haskell.TH++import Data.NestTuple+import Data.NestTuple.TH++import Language.Syntactic ((:<:), Syntactic (..))+import Language.Syntactic.TH++++-- Make instances of the form+--+-- > instance+-- >     ( Syntactic a+-- >     , ...+-- >     , Syntactic x+-- >+-- >     , internalPred (Internal a)+-- >     , ...+-- >     , internalPred (Internal x)+-- >+-- >     , Tuple :<: sym+-- >     , Domain a ~ mkDomain sym+-- >+-- >     , Domain a ~ Domain b+-- >     , ...+-- >     , Domain a ~ Domain x+-- >     , extraConstraint+-- >     ) =>+-- >       Syntactic (a,...,x)+-- >   where+-- >     type Domain (a,...,x)   = Domain a+-- >     type Internal (a,...,x) = (Internal a ... Internal x)  -- nested pairs+-- >     desugar = desugar . nestTup  -- use pair instance+-- >     sugar   = unnestTup . sugar  -- use pair instance+--+-- Instances will be generated for width 3 and upwards. The existence of an+-- instance for pairs is assumed.+deriveSyntacticForTuples+    :: (Type -> Cxt)   -- ^ @internalPred@ (see above)+    -> (Type -> Type)  -- ^ @mkDomain@ (see above)+    -> Cxt             -- ^ @extraConstraint@ (see above)+    -> Int             -- ^ Max tuple width+    -> DecsQ+deriveSyntacticForTuples internalPred mkDomain extraConstraint n = return $+    map deriveSyntacticForTuple [3..n]+  where+    deriveSyntacticForTuple w = instD+        ( concat+            [ map (classPred ''Syntactic ConT . return) varsT+            , concatMap internalPred $ map (AppT (ConT ''Internal)) varsT+            , [classPred ''(:<:) ConT [ConT (mkName "Tuple"), VarT (mkName "sym")]]+            , [eqPred domainA (mkDomain (VarT (mkName "sym")))]+            , [eqPred domainA (AppT (ConT ''Domain) b)+                | b <- tail varsT+              ]+            , extraConstraint+            ]+        )+        (AppT (ConT ''Syntactic) tupT)+        [ tySynInst ''Domain [tupT] domainA+        , tySynInst ''Internal [tupT] tupTI+        , FunD 'desugar+            [ Clause+                []+                (NormalB (foldl AppE (VarE '(.)) $ map VarE [mkName "desugar", 'nest]))+                []+            ]+        , FunD 'sugar+            [ Clause+                []+                (NormalB (foldl AppE (VarE '(.)) $ map VarE ['unnest, mkName "sugar"]))+                []+            ]+        ]+      where+        varsT   = map VarT $ take w varSupply+        tupT    = foldl AppT (TupleT w) varsT+        tupTI   = foldNest id mkPairT $ toNest $ map (AppT (ConT ''Internal)) varsT+        domainA = AppT (ConT ''Domain) (VarT (mkName "a"))+
+ src/Language/Syntactic/Functional/WellScoped.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}++#ifndef MIN_VERSION_GLASGOW_HASKELL+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0+#endif+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10++#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+#else+{-# LANGUAGE OverlappingInstances #-}+#endif++-- | Well-scoped terms++module Language.Syntactic.Functional.WellScoped where++++import Control.Monad.Reader+import Data.Proxy++import Language.Syntactic+import Language.Syntactic.Functional++++-- | 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 {-# OVERLAPS #-} Ext env env+  where+    unext = id+    diff _ _ = 0++instance {-# OVERLAPS #-} (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) = 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 sig+  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 Symbol BindingWS+  where+    symSig (VarWS _) = signature+    symSig LamWS     = signature++instance NFData1 BindingWS+  where+    rnf1 (VarWS Proxy) = ()+    rnf1 LamWS         = ()++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 sig+  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 signature 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/Language/Syntactic/Interpretation.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE DefaultSignatures #-}++-- | Equality and rendering of 'AST's++module Language.Syntactic.Interpretation+    ( -- * Equality+      Equality (..)+      -- * Rendering+    , Render (..)+    , renderArgsSmart+    , render+    , StringTree (..)+    , stringTree+    , showAST+    , drawAST+    , writeHtmlAST+      -- * Default interpretation+    , equalDefault+    , hashDefault+    ) where++++import Data.Tree (Tree (..))++import Data.Hash (Hash, combine, hashInt)+import qualified Data.Hash as Hash+import Data.Tree.View++import Language.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+    default equal :: Render e => e a -> e b -> Bool+    equal = equalDefault++    -- | 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+    default hash :: Render e => e a -> Hash+    hash = hashDefault++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"++instance Equality sym => Equality (Typed sym)+  where+    equal (Typed s1) (Typed s2) = equal s1 s2+    hash (Typed s) = hash s++++----------------------------------------------------------------------------------------------------+-- * 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 [a, b] sym+    | '(' : name <- renderSym sym+    , last name == ')'+    , let op = init name+    = "(" ++ unwords [a, op, b] ++ ")"+renderArgsSmart args sym = "(" ++ unwords (renderSym sym : args) ++ ")"++-- | 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 => Render (Typed sym)+  where+    renderSym (Typed s)  = renderSym s+    renderArgs args (Typed s) = renderArgs args s++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++instance StringTree sym => StringTree (Typed sym)+  where+    stringTreeSym args (Typed s) = stringTreeSym args s++-- | 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 Nothing file+    . fmap (\n -> NodeInfo InitiallyExpanded 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
− src/Language/Syntactic/Interpretation/Equality.hs 
@@ -1,52 +0,0 @@-module Language.Syntactic.Interpretation.Equality where----import Data.Hash--import Language.Syntactic.Syntax------ | 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---instance Equality dom => Equality (AST dom)-  where-    equal (Sym a)    (Sym b)    = equal a b-    equal (s1 :$ a1) (s2 :$ a2) = equal s1 s2 && equal a1 a2-    equal _ _                   = False--    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-    (==) = equal--instance (Equality expr1, Equality expr2) => Equality (expr1 :+: expr2)-  where-    equal (InjL a) (InjL b) = equal a b-    equal (InjR a) (InjR b) = equal a b-    equal _ _               = False--    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-    (==) = equal-
− src/Language/Syntactic/Interpretation/Evaluation.hs 
@@ -1,28 +0,0 @@-module Language.Syntactic.Interpretation.Evaluation where----import Language.Syntactic.Syntax------ | 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 Eval expr-  where-    -- | Evaluation of expressions-    evaluate :: expr a -> Denotation a--instance Eval dom => Eval (AST dom)-  where-    evaluate (Sym a)  = evaluate a-    evaluate (s :$ a) = evaluate s $ evaluate a--instance (Eval expr1, Eval expr2) => Eval (expr1 :+: expr2)-  where-    evaluate (InjL a) = evaluate a-    evaluate (InjR a) = evaluate a-
− src/Language/Syntactic/Interpretation/Render.hs 
@@ -1,84 +0,0 @@-module Language.Syntactic.Interpretation.Render-    ( Render (..)-    , render-    , StringTree (..)-    , stringTree-    , showAST-    , drawAST-    , writeHtmlAST-    ) where----import Data.Tree (Tree (..))--import Data.Tree.View--import Language.Syntactic.Syntax------ | 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) ++ ")"--instance (Render expr1, Render expr2) => Render (expr1 :+: expr2)-  where-    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--instance Render dom => Show (ASTF dom a)-  where-    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--instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2)-  where-    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 (stringTree a : args) s---- | Show a syntax tree using ASCII art-showAST :: StringTree dom => ASTF dom a -> String-showAST = showTree . stringTree---- | Print a syntax tree using ASCII art-drawAST :: StringTree dom => ASTF dom a -> IO ()-drawAST = putStrLn . showAST--writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO ()-writeHtmlAST file = writeHtmlTree file . fmap (\n -> NodeInfo n "") . stringTree-
− src/Language/Syntactic/Interpretation/Semantics.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Default implementations of some interpretation functions--module Language.Syntactic.Interpretation.Semantics where----import Language.Haskell.TH-import Language.Haskell.TH.Quote--import Data.Hash--import Language.Syntactic.Syntax-import Language.Syntactic.Interpretation.Equality-import Language.Syntactic.Interpretation.Render-import Language.Syntactic.Interpretation.Evaluation------ | 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----instance Equality Semantics-  where-    equal (Sem a _) (Sem b _) = a==b-    exprHash (Sem name _)     = hash name--instance Render Semantics-  where-    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 Eval Semantics-  where-    evaluate (Sem _ a) = a------ | Class of expressions that can be treated as constructs-class Semantic expr-  where-    semantics :: expr a -> Semantics a---- | Default implementation of 'equal'-equalDefault :: Semantic expr => expr a -> expr b -> Bool-equalDefault a b = equal (semantics a) (semantics b)---- | Default implementation of 'exprHash'-exprHashDefault :: Semantic expr => expr a -> Hash-exprHashDefault = exprHash . semantics---- | Default implementation of 'renderSym'-renderSymDefault :: Semantic expr => expr a -> String-renderSymDefault = renderSym . semantics---- | Default implementation of 'renderArgs'-renderArgsDefault :: Semantic expr => [String] -> expr a -> String-renderArgsDefault args = renderArgs args . semantics---- | Default implementation of 'evaluate'-evaluateDefault :: Semantic expr => expr a -> Denotation a-evaluateDefault = evaluate . semantics---- | Derive instances for 'Semantic' related classes--- ('Equality', 'Render', 'StringTree', 'Eval')-semanticInstances :: Name -> DecsQ-semanticInstances n =-    [d|-        instance Equality $(typ) where-          equal    = equalDefault-          exprHash = exprHashDefault-        instance Render $(typ) where-          renderSym  = renderSymDefault-          renderArgs = renderArgsDefault-        instance StringTree $(typ)-        instance Eval $(typ) where evaluate = evaluateDefault-    |]-  where-    typ = conT n-
− src/Language/Syntactic/Sharing/Graph.hs 
@@ -1,337 +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-    type Sat Node = Top-    exprDict _ = Dict--instance Render Node-  where-    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-    prjNodeEqEnv   = snd-    modNodeEqEnv f = (id *** f)--instance VarEqEnv (EqEnv dom p)-  where-    prjVarEqEnv   = fst-    modVarEqEnv f = (f *** id)--instance (AlphaEq dom dom dom env, NodeEqEnv dom env) =>-    AlphaEq Node Node dom env-  where-    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,235 +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---- | 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-    }--independent :: PrjDict dom -> Env dom -> AST dom a -> Bool-independent pd env (Sym (prjVariable pd -> Just v)) = not (v `member` dependencies env)-independent pd env (f :$ a) = independent pd env f && independent pd env a-independent _ _ _ = True--isVariable :: PrjDict dom -> ASTF dom a -> Bool-isVariable pd (Sym (prjVariable pd -> Just _)) = True-isVariable pd _ = False---- | 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 pd env a && not (isVariable pd a) && heuristic-    -- Lifting dependent expressions is semantically incorrect-    -- Lifting variables would cause `codeMotion` to loop-  where-    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 = chooseEnv 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 a-    .  ( ConstrainedBy dom Typeable-       , AlphaEq dom dom dom [(VarId,VarId)]-       )-    => (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-    -> State VarId (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 -> State VarId (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 -> State VarId (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 view
@@ -1,14 +1,29 @@-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} +#ifndef MIN_VERSION_GLASGOW_HASKELL+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0+#endif+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10++#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+#else+{-# LANGUAGE OverlappingInstances #-}+#endif+ -- | \"Syntactic sugar\"+--+-- For details, see "Combining Deep and Shallow Embedding for EDSL"+-- (TFP 2013, <https://emilaxelsson.github.io/documents/svenningsson2013combining.pdf>).  module Language.Syntactic.Sugar where   +import Data.Kind (Type)+import Data.Typeable+ import Language.Syntactic.Syntax-import Language.Syntactic.Constraint   @@ -16,18 +31,25 @@ -- as @a@. class Syntactic a   where-    type Domain a :: * -> *+    type Domain a :: Type -> Type     type Internal a     desugar :: a -> ASTF (Domain a) (Internal a)     sugar   :: ASTF (Domain a) (Internal a) -> a -instance Syntactic (ASTF dom a)+instance Syntactic (ASTF sym a)   where-    type Domain (ASTF dom a)   = dom-    type Internal (ASTF dom a) = a+    type Domain (ASTF sym a)   = sym+    type Internal (ASTF sym a) = a     desugar = id     sugar   = id +instance Syntactic (ASTFull sym a)+  where+    type Domain (ASTFull sym a)   = sym+    type Internal (ASTFull sym a) = a+    desugar = unASTFull+    sugar   = ASTFull+ -- | Syntactic type casting resugar :: (Syntactic a, Syntactic b, Domain a ~ Domain b, Internal a ~ Internal b) => a -> b resugar = sugar . desugar@@ -41,74 +63,86 @@ -- >     , Syntactic b -- >     , ... -- >     , Syntactic x--- >     , Domain a ~ dom--- >     , Domain b ~ dom+-- >     , Domain a ~ sym+-- >     , Domain b ~ sym -- >     , ...--- >     , Domain x ~ dom+-- >     , Domain x ~ sym -- >     ) => (a -> b -> ... -> x)--- >       -> (  ASTF dom (Internal a)--- >          -> ASTF dom (Internal b)+-- >       -> (  ASTF sym (Internal a)+-- >          -> ASTF sym (Internal b) -- >          -> ...--- >          -> ASTF dom (Internal x)+-- >          -> ASTF sym (Internal x) -- >          ) -- -- ...and vice versa for 'sugarN'.-class SyntacticN a internal | a -> internal+class SyntacticN f internal | f -> internal   where-    desugarN :: a -> internal-    sugarN   :: internal -> a+    desugarN :: f -> internal+    sugarN   :: internal -> f -instance (Syntactic a, Domain a ~ dom, ia ~ AST dom (Full (Internal a))) => SyntacticN a ia+instance {-# OVERLAPS #-}+         (Syntactic f, Domain f ~ sym, fi ~ AST sym (Full (Internal f))) => SyntacticN f fi   where     desugarN = desugar     sugarN   = sugar -instance+instance {-# OVERLAPS #-}     ( Syntactic a-    , Domain a ~ dom+    , Domain a ~ sym     , ia ~ Internal a-    , SyntacticN b ib+    , SyntacticN f fi     ) =>-      SyntacticN (a -> b) (AST dom (Full ia) -> ib)+      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 ::--- >     ( expr :<: AST dom--- >     , Syntactic a dom--- >     , Syntactic b dom+-- >     ( sub :<: AST sup+-- >     , Syntactic a+-- >     , Syntactic b -- >     , ...--- >     , Syntactic x dom--- >     ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x))+-- >     , Syntactic x+-- >     , Domain a ~ Domain b ~ ... ~ Domain x+-- >     ) => sub (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+sugarSym+    :: ( Signature sig+       , fi  ~ SmartFun sup sig+       , sig ~ SmartSig fi+       , sup ~ SmartSym fi+       , SyntacticN f fi+       , sub :<: sup+       )+    => sub sig -> f+sugarSym = sugarN . smartSym  -- | \"Sugared\" symbol application ----- 'sugarSymC' has any type of the form:+-- 'sugarSymTyped' has any type of the form: ----- > sugarSymC ::--- >     ( InjectC expr (AST dom) (Internal x)--- >     , Syntactic a dom--- >     , Syntactic b dom+-- > sugarSymTyped ::+-- >     ( sub :<: AST (Typed sup)+-- >     , Syntactic a+-- >     , Syntactic b -- >     , ...--- >     , Syntactic x dom--- >     ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x))+-- >     , Syntactic x+-- >     , Domain a ~ Domain b ~ ... ~ Domain x+-- >     , Typeable (Internal x)+-- >     ) => sub (Internal a :-> Internal b :-> ... :-> Full (Internal x)) -- >       -> (a -> b -> ... -> x)-sugarSymC-    :: ( InjectC sym (AST dom) (DenResult sig)-       , ApplySym sig b dom-       , SyntacticN c b+sugarSymTyped+    :: ( Signature sig+       , fi        ~ SmartFun (Typed sup) sig+       , sig       ~ SmartSig fi+       , Typed sup ~ SmartSym fi+       , SyntacticN f fi+       , sub :<: sup+       , Typeable (DenResult sig)        )-    => sym sig -> c-sugarSymC = sugarN . appSymC-+    => sub sig -> f+sugarSymTyped = sugarN . smartSymTyped
+ src/Language/Syntactic/Sugar/Binding.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instance for functions for domains based on 'Binding'++module Language.Syntactic.Sugar.Binding where++++import Language.Syntactic+import Language.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/Language/Syntactic/Sugar/BindingTyped.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instance for functions for domains based on 'Typed' and+-- 'BindingT'++module Language.Syntactic.Sugar.BindingTyped where++++import Data.Typeable++import Language.Syntactic+import Language.Syntactic.Functional++++instance+    ( sym ~ Typed s+    , Syntactic a, Domain a ~ sym+    , Syntactic b, Domain b ~ sym+    , BindingT :<: s+    , Typeable (Internal a)+    , Typeable (Internal b)+    ) =>+      Syntactic (a -> b)+  where+    type Domain (a -> b)   = Domain a+    type Internal (a -> b) = Internal a -> Internal b+    desugar f = lamTyped (desugar . f . sugar)+    sugar     = error "sugar not implemented for (a -> b)"+
+ src/Language/Syntactic/Sugar/Monad.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ < 708+#define TYPEABLE Typeable1+#else+#define TYPEABLE Typeable+#endif++-- | 'Syntactic' instance for 'Remon' for domains based on 'Binding'++module Language.Syntactic.Sugar.Monad where++++import Control.Monad.Cont+import Data.Typeable++import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Sugar.Binding ()++++-- | One-layer sugaring of monadic actions+sugarMonad :: (Binding :<: sym, MONAD m :<: 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+    , TYPEABLE m+    , Typeable (Internal a)+        -- The `Typeable` constraints are only needed due to the `Typeable`+        -- constraint in `Remon`. That constraint, in turn, is only needed by+        -- the module "Language.Syntactic.Sugar.MonadT".+    ) =>+      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/Language/Syntactic/Sugar/MonadTyped.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ < 708+#define TYPEABLE Typeable1+#else+#define TYPEABLE Typeable+#endif++-- | 'Syntactic' instance for 'Remon' for domains based on 'Typed' and+-- 'BindingT'++module Language.Syntactic.Sugar.MonadTyped where++++import Control.Monad.Cont+import Data.Typeable++import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Sugar.BindingTyped ()++++-- | One-layer sugaring of monadic actions+sugarMonad+    :: ( sym ~ Typed s+       , BindingT :<: s+       , MONAD m  :<: s+       , TYPEABLE m+       , Typeable a+       )+    => ASTF sym (m a) -> Remon sym m (ASTF sym a)+sugarMonad ma = Remon $ cont $ sugarSymTyped Bind ma++instance+    ( sym ~ Typed s+    , Syntactic a, Domain a ~ sym+    , BindingT :<: s+    , MONAD m  :<: s+    , TYPEABLE 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 = desugarMonadTyped . fmap desugar+    sugar   = fmap sugar   . sugarMonad+
+ src/Language/Syntactic/Sugar/Tuple.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instances for tuples++module Language.Syntactic.Sugar.Tuple where++++import Language.Syntactic+import Language.Syntactic.Functional.Tuple+import Language.Syntactic.Functional.Tuple.TH++++instance+    ( Syntactic a+    , Syntactic b+    , Tuple :<: Domain a+    , Domain a ~ Domain b+    ) =>+      Syntactic (a,b)+  where+    type Domain (a,b)   = Domain a+    type Internal (a,b) = (Internal a, Internal b)+    desugar (a,b) = inj Pair :$ desugar a :$ desugar b+    sugar ab      = (sugar $ inj Fst :$ ab, sugar $ inj Snd :$ ab)++-- `desugar` and `sugar` can be seen as applying the eta-rule for pairs.+-- <https://mail.haskell.org/pipermail/haskell-cafe/2016-April/123639.html>++deriveSyntacticForTuples (const []) id [] 15+
+ src/Language/Syntactic/Sugar/TupleTyped.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instances for tuples and 'Typed' symbol domains++module Language.Syntactic.Sugar.TupleTyped where++++import Data.Typeable+import Language.Haskell.TH++#if __GLASGOW_HASKELL__ < 710+import Data.Orphans ()+#endif++import Language.Syntactic+import Language.Syntactic.TH+import Language.Syntactic.Functional.Tuple+import Language.Syntactic.Functional.Tuple.TH++++instance+    ( Syntactic a+    , Syntactic b+    , Typeable (Internal a)+    , Typeable (Internal b)+    , Tuple :<: sym+    , Domain a ~ Typed sym+    , Domain a ~ Domain b+    ) =>+      Syntactic (a,b)+  where+    type Domain (a,b)   = Domain a+    type Internal (a,b) = (Internal a, Internal b)+    desugar (a,b) = Sym (Typed $ inj Pair) :$ desugar a :$ desugar b+    sugar ab      = (sugar $ Sym (Typed $ inj Fst) :$ ab, sugar $ Sym (Typed $ inj Snd) :$ ab)++-- `desugar` and `sugar` can be seen as applying the eta-rule for pairs.+-- <https://mail.haskell.org/pipermail/haskell-cafe/2016-April/123639.html>++deriveSyntacticForTuples+    (return . classPred ''Typeable ConT . return)+    (AppT (ConT ''Typed))+    []+#if __GLASGOW_HASKELL__ < 708+    7+#else+    15+#endif+
src/Language/Syntactic/Syntax.hs view
@@ -1,38 +1,73 @@-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -cpp #-}+#ifndef MIN_VERSION_GLASGOW_HASKELL+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0+#endif+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10 +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+#else+{-# LANGUAGE OverlappingInstances #-}+#endif+ -- | 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>).+-- (ICFP 2012, <https://emilaxelsson.github.io/documents/axelsson2012generic.pdf>).  module Language.Syntactic.Syntax     ( -- * Syntax trees       AST (..)     , ASTF+    , ASTFull (..)     , Full (..)     , (:->) (..)-    , size-    , ApplySym (..)+    , SigRep (..)+    , Signature (..)     , DenResult-      -- * Symbol domains+    , Symbol (..)+    , size+      -- * Smart constructors+    , SmartFun+    , SmartSig+    , SmartSym+    , smartSym'+      -- * Open symbol domains     , (:+:) (..)     , Project (..)     , (:<:) (..)-    , appSym-      -- * Type inference+    , smartSym+    , smartSymTyped+    , Empty+      -- * Existential quantification+    , E (..)+    , liftE+    , liftE2+    , EF (..)+    , liftEF+    , liftEF2+      -- * Type casting expressions+    , Typed (..)+    , injT+    , castExpr+      -- * Misc.+    , NFData1 (..)     , symType     , prjP     ) where   -import Control.Monad.Instances  -- Not needed in GHC 7.6+import Control.DeepSeq (NFData (..))+import Data.Kind (Type) import Data.Typeable--import Data.PolyProxy+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+#else+import Data.Foldable (Foldable)+import Data.Proxy  -- Needed by GHC < 7.8+import Data.Traversable (Traversable)+#endif   @@ -42,20 +77,26 @@  -- | 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))@+-- @(`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 dom sig+data AST sym sig   where-    Sym  :: dom sig -> AST dom sig-    (:$) :: AST dom (a :-> sig) -> AST dom (Full a) -> AST dom sig+    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 dom a = AST dom (Full a)+type ASTF sym a = AST sym (Full a) -instance Functor dom => Functor (AST dom)+-- | Fully applied abstract syntax tree+--+-- This type is like 'AST', but being a newtype, it is a proper type constructor+-- that can be partially applied.+newtype ASTFull sym a = ASTFull {unASTFull :: ASTF sym 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@@ -70,45 +111,118 @@  infixr :-> --- | Count the number of symbols in an expression-size :: AST dom sig -> Int-size (Sym _)  = 1-size (s :$ a) = size s + size a+-- | Witness of the arity of a symbol signature+data SigRep sig+  where+    SigFull :: SigRep (Full a)+    SigMore :: SigRep sig -> SigRep (a :-> sig) --- | Class for the type-level recursion needed by 'appSym'-class ApplySym sig f dom | sig dom -> f, f -> sig dom+-- | Valid symbol signatures+class Signature sig   where-    appSym' :: AST dom sig -> f+    signature :: SigRep sig -instance ApplySym (Full a) (ASTF dom a) dom+instance Signature (Full a)   where-    appSym' = id+    signature = SigFull -instance ApplySym sig f dom => ApplySym (a :-> sig) (ASTF dom a -> f) dom+instance Signature sig => Signature (a :-> sig)   where-    appSym' sym a = appSym' (sym :$ a)+    signature = SigMore signature  -- | 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 +-- | Valid symbols to use in an 'AST'+class Symbol sym+  where+    -- | Reify the signature of a symbol+    symSig :: sym sig -> SigRep sig +instance NFData1 sym => NFData (AST sym sig)+  where+    rnf (Sym s)  = rnf1 s+    rnf (s :$ a) = rnf s `seq` rnf a +-- | Count the number of symbols in an 'AST'+size :: AST sym sig -> Int+size (Sym _)  = 1+size (s :$ a) = size s + size a+++ ----------------------------------------------------------------------------------- * Symbol domains+-- * Smart constructors -------------------------------------------------------------------------------- +-- | 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 :: Type -> Type) 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 -> Type+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 (dom1 :+: dom2) a+data (sym1 :+: sym2) sig   where-    InjL :: dom1 a -> (dom1 :+: dom2) a-    InjR :: dom2 a -> (dom1 :+: dom2) a-  deriving (Functor)+    InjL :: sym1 a -> (sym1 :+: sym2) a+    InjR :: sym2 a -> (sym1 :+: sym2) a+  deriving (Functor, Foldable, Traversable)  infixr :+: +instance (Symbol sym1, Symbol sym2) => Symbol (sym1 :+: sym2)+  where+    symSig (InjL s) = symSig s+    symSig (InjR s) = symSig s++instance (NFData1 sym1, NFData1 sym2) => NFData1 (sym1 :+: sym2)+  where+    rnf1 (InjL s) = rnf1 s+    rnf1 (InjR s) = rnf1 s+ -- | 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@@@ -116,42 +230,45 @@  instance Project sub sup => Project sub (AST sup)   where-    prj (Sym a) = prj a+    prj (Sym s) = prj s     prj _       = Nothing -instance Project expr expr+instance {-# OVERLAPS #-} Project sym sym   where     prj = Just -instance Project expr1 (expr1 :+: expr2)+instance {-# OVERLAPS #-} Project sym1 (sym1 :+: sym2)   where     prj (InjL a) = Just a     prj _        = Nothing -instance Project expr1 expr3 => Project expr1 (expr2 :+: expr3)+instance {-# OVERLAPS #-} Project sym1 sym3 => Project sym1 (sym2 :+: sym3)   where     prj (InjR a) = prj a     prj _        = Nothing --- | Symbol subsumption++-- | 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)+instance {-# OVERLAPS #-} (sub :<: sup) => (sub :<: AST sup)   where     inj = Sym . inj -instance (expr :<: expr)+instance {-# OVERLAPS #-} (sym :<: sym)   where     inj = id -instance (expr1 :<: (expr1 :+: expr2))+instance {-# OVERLAPS #-} (sym1 :<: (sym1 :+: sym2))   where     inj = InjL -instance (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3))+instance {-# OVERLAPS #-} (sym1 :<: sym3) => (sym1 :<: (sym2 :+: sym3))   where     inj = InjR . inj @@ -159,27 +276,136 @@ -- types that can be instances of the former but not the latter due to type -- constraints on the `a` type. --- | Generic symbol application+-- | Make a smart constructor of a symbol. 'smartSym' has any type of the form: ----- 'appSym' 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++-- | Make a smart constructor of a symbol. 'smartSymTyped' 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+-- > smartSymTyped :: (sub :<: AST (Typed sup), Typeable x)+-- >     => sub (a :-> b :-> ... :-> Full x)+-- >     -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x)+smartSymTyped+    :: ( Signature sig+       , f         ~ SmartFun (Typed sup) sig+       , sig       ~ SmartSig f+       , Typed sup ~ SmartSym f+       , sub :<: sup+       , Typeable (DenResult sig)+       )+    => sub sig -> f+smartSymTyped = smartSym' . Typed . 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 :: Type -> Type  + ----------------------------------------------------------------------------------- * Type inference+-- * 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 casting expressions+--------------------------------------------------------------------------------++-- | \"Typed\" symbol. Using @`Typed` sym@ instead of @sym@ gives access to the+-- function 'castExpr' for casting expressions.+data Typed sym sig+  where+    Typed :: Typeable (DenResult sig) => sym sig -> Typed sym sig++instance Project sub sup => Project sub (Typed sup)+  where+    prj (Typed s) = prj s++-- | Inject a symbol in an 'AST' with a 'Typed' domain+injT :: (sub :<: sup, Typeable (DenResult sig)) =>+    sub sig -> AST (Typed sup) sig+injT = Sym . Typed . inj++-- | Type cast an expression+castExpr :: forall sym a b+    .  ASTF (Typed sym) a  -- ^ Expression to cast+    -> ASTF (Typed sym) b  -- ^ Witness for typeability of result+    -> Maybe (ASTF (Typed sym) b)+castExpr a b = cast1 a+  where+    cast1 :: (DenResult sig ~ a) => AST (Typed sym) sig -> Maybe (ASTF (Typed sym) b)+    cast1 (s :$ _) = cast1 s+    cast1 (Sym (Typed _)) = cast2 b+      where+        cast2 :: (DenResult sig ~ b) => AST (Typed sym) sig -> Maybe (ASTF (Typed sym) b)+        cast2 (s :$ _)        = cast2 s+        cast2 (Sym (Typed _)) = gcast a+  -- Could be simplified using `simpleMatch`, but that would give an import+  -- cycle.+  --+  --     castExpr a b =+  --       simpleMatch+  --         (\(Typed _) _ -> simpleMatch+  --           (\(Typed _) _ -> gcast a+  --           ) b+  --         ) a++++--------------------------------------------------------------------------------+-- * Misc.+--------------------------------------------------------------------------------++-- | Higher-kinded version of 'NFData'+class NFData1 c+  where+    -- | Force a symbol to normal form+    rnf1 :: c a -> ()+    rnf1 s = s `seq` ()+ -- | Constrain a symbol to a specific type-symType :: P sym -> sym sig -> sym sig+symType :: Proxy sym -> sym sig -> sym sig symType _ = id  -- | Projection to a specific symbol type-prjP :: Project sub sup => P sub -> sup sig -> Maybe (sub sig)+prjP :: Project sub sup => Proxy sub -> sup sig -> Maybe (sub sig) prjP _ = prj-
+ src/Language/Syntactic/TH.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -Wno-x-partial #-}++module Language.Syntactic.TH where++++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++import Language.Haskell.TH++import Data.Hash (hashInt, combine)+import qualified Data.Hash as Hash++import Language.Syntactic++++-- | Get the name and arity of a constructor+conName :: Con -> (Name, Int)+conName (NormalC name args) = (name, length args)+conName (RecC name args)    = (name, length args)+conName (InfixC _ name _)   = (name, 2)+conName (ForallC _ _ c)     = conName c+#if __GLASGOW_HASKELL__ >= 800+conName (GadtC [n] as _)    = (n, length as)+conName (RecGadtC [n] as _) = (n, length as)+  -- I don't know what it means when a `GadtC` and `RecGadtC` don't have+  -- singleton lists of names+#endif++-- | Description of class methods+data Method+    = DefaultMethod Name Name+        -- ^ rhs = lhs+    | MatchingMethod Name (Con -> Int -> Name -> Int -> Clause) [Clause]+        -- ^ @MatchingMethod methodName mkClause extraClauses@+        --+        -- @mkClause@ takes as arguments (1) a description of the constructor,+        -- (2) the constructor's index, (3) the constructor's name, and (4) its+        -- arity.++-- | General method for class deriving+deriveClass+    :: Cxt       -- ^ Instance context+    -> Name      -- ^ Type constructor name+    -> Type      -- ^ Class head (e.g. @Render Con@)+    -> [Method]  -- ^ Methods+    -> DecsQ+deriveClass cxt ty clHead methods = do+    Just cs <- viewDataDef <$> reify ty+    return+      [ instD cxt clHead $+          [ FunD method (clauses ++ extra)+            | MatchingMethod method mkClause extra <- methods+            , let clauses = [ mkClause c i nm ar | (i,c) <- zip [0..] cs+                            , let (nm,ar) = conName c+                            ]+          ] +++          [ FunD rhs [Clause [] (NormalB (VarE lhs)) []]+            | DefaultMethod rhs lhs <- methods+          ]+      ]++-- | General method for class deriving+deriveClassSimple+    :: Name      -- ^ Class name+    -> Name      -- ^ Type constructor name+    -> [Method]  -- ^ Methods+    -> DecsQ+deriveClassSimple cl ty = deriveClass [] ty (AppT (ConT cl) (ConT ty))++varSupply :: [Name]+varSupply = map mkName $ tail $ concat $ iterate step [[]]+  where+    step :: [String] -> [String]+    step vars = concatMap (\c -> map (c:) vars) ['a' .. 'z']++-- | Derive 'Symbol' instance for a type+deriveSymbol+    :: Name  -- ^ Type name+    -> DecsQ+deriveSymbol ty =+    deriveClassSimple ''Symbol ty [MatchingMethod 'symSig  symSigClause []]+  where+    symSigClause _ _ con arity =+      Clause [conPat con (replicate arity WildP)] (NormalB (VarE 'signature)) []++-- | Derive 'Equality' instance for a type+--+-- > equal Con1 Con1 = True+-- > equal (Con2 a1 ... x1) (Con2 a2 ... x2) = and [a1==a2, ... x1==x2]+-- > equal _ _ = False+--+-- > hash Con1           = hashInt 0+-- > hash (Con2 a ... x) = foldr1 combine [hashInt 1, hash a, ... hash x]+deriveEquality+    :: Name  -- ^ Type name+    -> DecsQ+deriveEquality ty = do+    Just cs <- viewDataDef <$> reify ty+    let equalFallThrough = if length cs > 1+          then [Clause [WildP, WildP] (NormalB $ ConE 'False) []]+          else []+    deriveClassSimple ''Equality ty+      [ MatchingMethod 'equal equalClause equalFallThrough+      , MatchingMethod 'hash hashClause []+      ]+  where+    equalClause _ _ con arity = Clause+        [ conPat con [VarP v | v <- vs1]+        , conPat con [VarP v | v <- vs2]+        ]+        (NormalB body)+        []+      where+        vs1 = take arity varSupply+        vs2 = take arity $ drop arity varSupply++        body = case arity of+          0 -> ConE 'True+          _ -> AppE (VarE 'and)+                 ( ListE+                     [ InfixE (Just (VarE v1)) (VarE '(==)) (Just (VarE v2))+                       | (v1,v2) <- zip vs1 vs2+                     ]+                 )++    hashClause _ i con arity = Clause+        [conPat con [VarP v | v <- vs]]+        (NormalB body)+        []+      where+        vs = take arity varSupply+        body = case arity of+          0 -> AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))+          _ -> foldl1 AppE+                [ VarE 'foldr1+                , VarE 'combine+                , ListE+                    $ AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))+                    : [ AppE (VarE 'Hash.hash) (VarE v)+                        | v <- vs+                      ]+                ]++-- | Derive 'Render' instance for a type+--+-- > renderSym Con1           = "Con1"+-- > renderSym (Con2 a ... x) = concat ["(", unwords ["Con2", show a, ... show x], ")"]+deriveRender+    :: (String -> String)  -- ^ Constructor name modifier+    -> Name                -- ^ Type name+    -> DecsQ+deriveRender modify ty =+    deriveClassSimple ''Render ty [MatchingMethod 'renderSym renderClause []]+  where+    conName = modify . nameBase++    renderClause _ _ con arity = Clause+        [conPat con [VarP v | v <- take arity varSupply]]+        (NormalB body)+        []+      where+        body = case arity of+            0 -> LitE $ StringL $ conName con+            _ -> renderRHS con $ take arity varSupply++    renderRHS :: Name -> [Name] -> Exp+    renderRHS con args =+      AppE (VarE 'concat)+        ( ListE+            [ LitE (StringL "(")+            , AppE (VarE 'unwords)+                (ListE (LitE (StringL (conName con)) : map showArg args))+            , LitE (StringL ")")+            ]+        )++    showArg :: Name -> Exp+    showArg arg = AppE (VarE 'show) (VarE arg)++++--------------------------------------------------------------------------------+-- * Portability+--------------------------------------------------------------------------------++-- Using `__GLASGOW_HASKELL__` instead of `MIN_VERSION_template_haskell`,+-- because the latter doesn't work when the package is compiled with `-f-th`.++-- | Construct an instance declaration+instD+    :: Cxt    -- ^ Context+    -> Type   -- ^ Instance+    -> [Dec]  -- ^ Methods, etc.+    -> Dec+#if __GLASGOW_HASKELL__ >= 800+instD = InstanceD Nothing+#else+instD = InstanceD+#endif++-- | Get the constructors of a data type definition+viewDataDef :: Info -> Maybe [Con]+#if __GLASGOW_HASKELL__ >= 800+viewDataDef (TyConI (DataD _ _ _ _ cs _)) = Just cs+#else+viewDataDef (TyConI (DataD _ _ _ cs _)) = Just cs+#endif+viewDataDef _ = Nothing++-- | Portable method for constructing a 'Pred' of the form @(t1 ~ t2)@+eqPred :: Type -> Type -> Pred+#if __GLASGOW_HASKELL__ >= 710+eqPred t1 t2 = foldl1 AppT [EqualityT,t1,t2]+#else+eqPred = EqualP+#endif++-- | Portable method for constructing a 'Pred' of the form @SomeClass t1 t2 ...@+classPred+    :: Name            -- ^ Class name+    -> (Name -> Type)  -- ^ How to make a type for the class (typically 'ConT' or 'VarT')+    -> [Type]          -- ^ Class arguments+    -> Pred+#if __GLASGOW_HASKELL__ >= 710+classPred cl con = foldl AppT (con cl)+#else+classPred cl con = ClassP cl+#endif++-- | Portable method for constructing a type synonym instance+tySynInst :: Name -> [Type] -> Type -> Dec+#if __GLASGOW_HASKELL__ >= 808+tySynInst t as rhs = TySynInstD $+  TySynEqn Nothing (foldl AppT (ConT t) as) rhs+#elif __GLASGOW_HASKELL__ >= 708+tySynInst t as rhs = TySynInstD t (TySynEqn as rhs)+#else+tySynInst = TySynInstD+#endif++conPat :: Name -> [Pat] -> Pat+#if __GLASGOW_HASKELL__ >= 902+conPat name ps = ConP name [] ps+#else+conPat name ps = ConP name ps+#endif+
src/Language/Syntactic/Traversal.hs view
@@ -5,19 +5,21 @@     , gmapT     , everywhereUp     , everywhereDown+    , universe     , Args (..)     , listArgs     , mapArgs     , mapArgsA     , mapArgsM+    , foldrArgs     , appArgs     , listFold     , match-    , query     , simpleMatch     , fold     , simpleFold     , matchTrans+    , mapAST     , WrapFull (..)     , toTree     ) where@@ -33,41 +35,49 @@  -- | 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 :: 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 :: forall a . AST dom a -> AST dom a+    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 dom b-      .  (forall a . ASTF dom a -> b)-      -> (forall a . ASTF dom a -> [b])+gmapQ :: forall sym b+      .  (forall a . ASTF sym a -> b)+      -> (forall a . ASTF sym a -> [b]) gmapQ f a = go a   where-    go :: forall a . AST dom a -> [b]+    go :: AST sym 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)+-- | Apply a transformation bottom-up over an 'AST' (corresponds to @everywhere@ in Scrap Your+-- Boilerplate) everywhereUp-    :: (forall a . ASTF dom a -> ASTF dom a)-    -> (forall a . ASTF dom a -> ASTF dom a)+    :: (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 expression (corresponds to--- @everywhere'@ in Scrap Your Boilerplate)+-- | Apply a transformation top-down over an 'AST' (corresponds to @everywhere'@ in Scrap Your+-- Boilerplate) everywhereDown-    :: (forall a . ASTF dom a -> ASTF dom a)-    -> (forall a . ASTF dom a -> ASTF dom a)+    :: (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@@ -76,8 +86,7 @@  infixr :* --- | Map a function over an 'Args' list and collect the results in an ordinary--- list+-- | 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@@ -111,71 +120,67 @@ 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 :: 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 dom a c+match :: forall sym a c     .  ( forall sig . (a ~ DenResult sig) =>-           dom sig -> Args (AST dom) sig -> c (Full a)+           sym sig -> Args (AST sym) sig -> c (Full a)        )-    -> ASTF dom a+    -> ASTF sym a     -> c (Full a) match f a = go a Nil   where-    go :: (a ~ DenResult sig) => AST dom sig -> Args (AST dom) sig -> c (Full a)+    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) -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+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 dom c-    .  (forall sig . dom sig -> Args c sig -> c (Full (DenResult sig)))-    -> (forall a   . ASTF dom a -> c (Full a))+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 dom b-    .  (forall sig . dom sig -> Args (Const b) sig -> b)-    -> (forall a   . ASTF dom a                    -> b)+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 dom b-    .  (forall sig . dom sig -> [b] -> b)-    -> (forall a   . ASTF dom a     -> b)+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 dom sig = WrapAST { unWrapAST :: c (AST dom sig) }+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 dom dom' c a+matchTrans :: forall sym sym' c a     .  ( forall sig . (a ~ DenResult sig) =>-           dom sig -> Args (AST dom) sig -> c (ASTF dom' a)+           sym sig -> Args (AST sym) sig -> c (ASTF sym' a)        )-    -> ASTF dom a-    -> c (ASTF dom' 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
syntactic.cabal view
@@ -1,202 +1,196 @@ Name:           syntactic-Version:        1.11-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+Version:        3.8.5+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].                 .-                  * Utilities for analyzing and transforming generic abstract-                    syntax+                This package does not work on GHC version 8.2, but works on many+                earlier and later versions.                 .-                  * Utilities for building extensible embedded languages based-                    on generic syntax+                (Note that the difference between version 2.x and 3.0 is not that big. The bump to+                3.0 was done because the modules changed namespace.)                 .-                For more information about the core functionality, see+                For more information, see                 \"A Generic Abstract Syntax Model for Embedded Languages\"                 (ICFP 2012):                 .                   * Paper:-                    <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic.pdf>+                    <https://emilaxelsson.github.io/documents/axelsson2012generic.pdf>                 .-                  * Slides:-                    <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic-slides.pdf>+                  * Literal source:+                    <https://emilaxelsson.github.io/documents/axelsson2012generic.lhs>                 .-                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.)+                  * Slides:+                    <https://emilaxelsson.github.io/documents/axelsson2012generic-slides.pdf>                 .-                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 EDSLs 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-Maintainer:     emax@chalmers.se-Copyright:      Copyright (c) 2011-2014, Emil Axelsson+Maintainer:     78emil@gmail.com+Copyright:      Copyright (c) 2011-2015, 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.6.1, GHC==7.4.2+Cabal-version:  1.16  extra-source-files:   CONTRIBUTORS-  examples/NanoFeldspar/*.hs+  examples/*.hs+  tests/*.hs   tests/gold/*.txt+  benchmarks/*.hs  source-repository head   type:     git   location: https://github.com/emilaxelsson/syntactic +flag th+  description: Include the module Language.Syntactic.TH, which uses Template+               Haskell+  default:     True+ library   exposed-modules:-    Data.PolyProxy-    Data.DynamicAlt     Language.Syntactic     Language.Syntactic.Syntax     Language.Syntactic.Traversal-    Language.Syntactic.Constraint+    Language.Syntactic.Interpretation     Language.Syntactic.Sugar-    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.Utils-    Language.Syntactic.Sharing.Graph-    Language.Syntactic.Sharing.StableName-    Language.Syntactic.Sharing.Reify-    Language.Syntactic.Sharing.ReifyHO--  other-modules:+    Language.Syntactic.Decoration+    Language.Syntactic.Functional+    Language.Syntactic.Functional.Sharing+    Language.Syntactic.Functional.WellScoped+    Language.Syntactic.Sugar.Binding+    Language.Syntactic.Sugar.BindingTyped+    Language.Syntactic.Sugar.Monad+    Language.Syntactic.Sugar.MonadTyped+  if flag(th)+    exposed-modules:+      Data.NestTuple+      Data.NestTuple.TH+      Language.Syntactic.TH+      Language.Syntactic.Functional.Tuple+      Language.Syntactic.Functional.Tuple.TH+      Language.Syntactic.Sugar.Tuple+      Language.Syntactic.Sugar.TupleTyped    build-depends:-    array,-    base >= 4 && < 4.8,-    containers,-    constraints,-    data-hash,-    ghc-prim,-    mtl >= 2 && < 3,-    template-haskell,-    transformers >= 0.2,-    tree-view,-    tuple >= 0.2+    base >= 4.6 && < 4.22,+    constraints < 0.15,+    containers < 0.9,+    data-hash < 0.3,+    deepseq < 1.6,+    mtl >= 2 && < 2.4,+    syb < 0.8,+    tree-view >= 0.5 && < 0.6 +  if impl(ghc == 8.2.*)+    build-depends: base<0+    -- See the note to the catch-all instance of `BindingDomain`. Since this can+    -- lead to subtle errors and non-termination in user code, we prefer not to+    -- support GHC 8.2.++  if impl(ghc < 7.10)+    build-depends: base-orphans++  if impl(ghc < 7.8)+    build-depends: tagged++  if flag(th)+    build-depends: template-haskell+   hs-source-dirs: src    default-language: Haskell2010    default-extensions:-    ConstraintKinds+    DefaultSignatures     DeriveDataTypeable     DeriveFunctor+    DeriveFoldable+    DeriveTraversable     FlexibleContexts     FlexibleInstances     FunctionalDependencies     GADTs     GeneralizedNewtypeDeriving-    Rank2Types+    RankNTypes+    RecordWildCards     ScopedTypeVariables-    StandaloneDeriving     TypeFamilies     TypeOperators-    ViewPatterns    other-extensions:-    -- Not understood by Cabal: PolyKinds     OverlappingInstances     UndecidableInstances -test-suite NanoFeldsparEval+test-suite examples   type: exitcode-stdio-1.0    hs-source-dirs: tests examples -  main-is: NanoFeldsparEval.hs+  main-is: Tests.hs -  other-modules:+  other-modules: AlgorithmTests+                 Monad+                 MonadTests+                 NanoFeldspar+                 NanoFeldsparComp+                 NanoFeldsparTests+                 SyntaxTests+                 TH+                 WellScoped+                 WellScopedTests    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,+    containers,+    mtl,+    QuickCheck,+    tagged,     tasty,+    tasty-hunit,+    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: JoiningTypes+                 Normal+                 WithArity++  build-depends:+    base,+    criterion >= 1,+    deepseq,+    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/AlgorithmTests.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module AlgorithmTests where++++import Data.List+import qualified Data.Set as Set+import Data.Dynamic++import Language.Syntactic+import Language.Syntactic.TH+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Sharing++import Test.QuickCheck++import Test.Tasty.QuickCheck+import Test.Tasty.TH++++subCap :: (Num a, Ord a) => a -> a -> a+subCap a b = max 0 (a - b)++data Sym sig+  where+    Int   :: Int -> Sym (Full Int)+    Neg   :: Sym (Full (Int -> Int))+    Add   :: Sym (Full (Int -> Int -> Int))+    App1  :: Sym ((Int -> Int) :-> Int :-> Full Int)+    App2  :: Sym ((Int -> Int -> Int) :-> Int :-> Int :-> Full Int)+    App3  :: Sym ((Int -> Int -> Int -> Int) :-> Int :-> Int :-> Int :-> Full Int)++deriveSymbol    ''Sym+deriveRender id ''Sym+deriveEquality  ''Sym++instance StringTree Sym+instance EvalEnv Sym env++instance Eval Sym+  where+    evalSym (Int i) = i+    evalSym Neg     = negate+    evalSym Add     = (+)+    evalSym App1    = ($)+    evalSym App2    = \f a b -> f a b+    evalSym App3    = \f a b c -> f a b c++type Dom = Typed (BindingT :+: Let :+: Sym)++type Exp a = ASTF Dom a++int :: Int -> Exp Int+int = sugarSymTyped . Int++neg :: Exp Int -> Exp Int+neg = app1 (sugarSymTyped Neg)++add :: Exp Int -> Exp Int -> Exp Int+add = app2 (sugarSymTyped Add)++app1 :: Exp (Int -> Int) -> Exp Int -> Exp Int+app1 = sugarSymTyped App1++app2 :: Exp (Int -> Int -> Int) -> Exp Int -> Exp Int -> Exp Int+app2 = sugarSymTyped App2++app3 :: Exp (Int -> Int -> Int -> Int) -> Exp Int -> Exp Int -> Exp Int -> Exp Int+app3 = sugarSymTyped App3++varr :: Name -> Exp Int+varr = sugarSymTyped . VarT++lamm :: Typeable a => Name -> Exp a -> Exp (Int -> a)+lamm v = sugarSymTyped (LamT v)++++-- | Return a 'Name' not in the given list+notIn :: [Name] -> Name+notIn = go 0 . sort+  where+    go prev [] = prev+1+    go prev (n:ns)+        | n > prev+1 = prev+1+        | otherwise  = go n ns++-- | Generate a variable name+genVar+    :: Int     -- ^ Frequency for bound+    -> Int     -- ^ Frequency for free+    -> [Name]  -- ^ Names in scope+    -> Gen Name+genVar fb ff inScope = fmap fromIntegral $ frequency+    [ (fb, elements (0:inScope))+    , (ff, return $ notIn inScope)+    ]++genExp :: Int -> [Name] -> Gen (ASTF Dom Int)+genExp s _ | s < 0 = error (show s)+genExp s inScope = frequency+    [ (1, fmap int arbitrary)+    , (1, fmap varr $ genVar 1 1 inScope)+    , (s, do a <- genExp (s `subCap` 1) inScope+             return $ neg a+      )+    , (s, do a <- genExp (s `div` 2) inScope+             b <- genExp (s `div` 2) inScope+             return $ add a b+      )+    , (s, do f <- genExp1 (s `div` 2) inScope+             a <- genExp (s `div` 2) inScope+             return $ app1 f a+      )+    , (s, do f <- genExp2 (s `div` 3) inScope+             a <- genExp (s `div` 3) inScope+             b <- genExp (s `div` 3) inScope+             return $ app2 f a b+      )+    , (s, do f <- genExp3 (s `div` 4) inScope+             a <- genExp (s `div` 4) inScope+             b <- genExp (s `div` 4) inScope+             c <- genExp (s `div` 4) inScope+             return $ app3 f a b c+      )+    ]++genExp1 :: Int -> [Name] -> Gen (ASTF Dom (Int -> Int))+genExp1 s inScope = do+    v    <- genVar 1 2 inScope+    body <- genExp (s `subCap` 1) (v:inScope)+    return $ lamm v body++genExp2 :: Int -> [Name] -> Gen (ASTF Dom (Int -> Int -> Int))+genExp2 s inScope = do+    v1   <- genVar 1 2 inScope+    v2   <- genVar 1 2 (v1:inScope)+    body <- genExp (s `subCap` 2) (v2:v1:inScope)+    return $ lamm v1 $ lamm v2 body++genExp3 :: Int -> [Name] -> Gen (ASTF Dom (Int -> Int -> Int -> Int))+genExp3 s inScope = do+    v1   <- genVar 1 2 inScope+    v2   <- genVar 1 2 (v1:inScope)+    v3   <- genVar 1 2 (v2:v1:inScope)+    body <- genExp (s `subCap` 3) (v3:v2:v1:inScope)+    return $ lamm v1 $ lamm v2 $ lamm v3 body++shrinkExp :: AST Dom sig -> [AST Dom sig]+shrinkExp s+    | Just (Int i) <- prj s = map int $ shrink i+shrinkExp (Sym (Typed lam) :$ body)+    | Just (LamT v) <- prj lam = [sugarSymTyped (LamT v) b | b <- shrinkExp body]+shrinkExp (app1 :$ f :$ a)+    | Just App1 <- prj app1 = concat+        [ case f of+            lam :$ body | Just (LamT _) <- prj lam -> [body]+            _ -> []+        , [a]+        , [ sugarSymTyped App1 f' a' | (f',a') <- shrink (f,a) ]+        ]+shrinkExp (app2 :$ f :$ a :$ b)+    | Just App2 <- prj app2 = concat+        [ case f of+            lam1 :$ (lam2 :$ body)+                | Just (LamT _) <- prj lam1+                , Just (LamT _) <- prj lam2+                -> [body]+            _ -> []+        , [a,b]+        , [ sugarSymTyped App2 f' a' b' | (f',a',b') <- shrink (f,a,b) ]+        ]+shrinkExp (app3 :$ f :$ a :$ b :$ c)+    | Just App3 <- prj app3 = concat+        [ case f of+            lam1 :$ (lam2 :$ (lam3 :$ body))+                | Just (LamT _) <- prj lam1+                , Just (LamT _) <- prj lam2+                , Just (LamT _) <- prj lam3+                -> [body]+            _ -> []+        , [a,b,c]+        , [ sugarSymTyped App3 f' a' b' c' | (f',a',b',c') <- shrink (f,a,b,c) ]+        ]+shrinkExp _ = []++instance Arbitrary (Exp Int)+  where+    arbitrary = sized $ \s -> genExp s []+    shrink = shrinkExp++instance Arbitrary (Exp (Int -> Int))+  where+    arbitrary = sized $ \s -> genExp1 s []+    shrink = shrinkExp++instance Arbitrary (Exp (Int -> Int -> Int))+  where+    arbitrary = sized $ \s -> genExp2 s []+    shrink = shrinkExp++instance Arbitrary (Exp (Int -> Int -> Int -> Int))+  where+    arbitrary = sized $ \s -> genExp3 s []+    shrink = shrinkExp++prop_freeVars (a :: Exp Int) = freeVars a `Set.isSubsetOf` allVars a++prop_alphaEq_refl (a :: Exp Int) = alphaEq a a++prop_alphaEq_rename (a :: Exp Int) = alphaEq a (renameUnique a)++evalAny :: Exp Int -> Int+evalAny a = evalOpen env a+  where+    fv  = freeVars a+    env = zip (Set.toList fv) (map toDyn [(100 :: Int), 110 ..])++prop_renameUnique_vars (a :: Exp Int) = freeVars a == freeVars (renameUnique a)+prop_renameUnique_eval (a :: Exp Int) = evalAny a == evalAny (renameUnique a)++cm :: Exp a -> Exp a+cm = codeMotion $ defaultInterface VarT LamT (\_ _ -> True) (\_ -> True)++prop_codeMotion_vars (a :: Exp Int) = freeVars a == freeVars (cm a)+prop_codeMotion_eval (a :: Exp Int) = evalAny a == evalAny (cm a)++prop_bug1 = prop_codeMotion_eval exp+  where+    exp = add+        (app2 (lamm 0 (lamm 0 (varr 1))) (int 0) (int 0))+        (app2 (lamm 1 (lamm 2 (varr 1))) (int 0) (int 0))+++tests = $testGroupGenerator+
+ tests/MonadTests.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module MonadTests where++++import Test.Tasty+import Test.Tasty.Golden++import Data.ByteString.Lazy.UTF8 (fromString)++import Language.Syntactic+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/NanoFeldsparTests.hs view
@@ -0,0 +1,124 @@+{-# 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 Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Sharing+import qualified NanoFeldspar as Nano+import qualified NanoFeldsparComp as Nano++++-- | Evaluate after code motion. Used to test that 'codeMotion' doesn't change+-- semantics.+evalCM :: (Syntactic a, Domain a ~ Nano.FeldDomain) => a -> Internal a+evalCM = evalClosed . codeMotion Nano.cmInterface . desugar++fib :: Int -> Int+fib n = fibs !! n+  where+    fibs = 0 : 1 : zipWith (+) fibs (tail fibs)++prop_fib (NonNegative (Small n))   = fib n == Nano.eval Nano.fib n+prop_fibCM (NonNegative (Small n)) = fib n == evalCM Nano.fib n++spanVec :: [Int] -> Int+spanVec as = maximum as - minimum as++prop_spanVec (NonEmpty as)   = spanVec as == Nano.eval Nano.spanVec as+prop_spanVecCM (NonEmpty as) = spanVec as == evalCM Nano.spanVec as++scProd :: [Float] -> [Float] -> Float+scProd as bs = sum $ zipWith (*) as bs++prop_scProd as bs   = scProd as bs == Nano.eval Nano.scProd as bs+prop_scProdCM as bs = scProd as bs == evalCM 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++prop_matMulCM =+    forAll genMat $ \a ->+      forAll genMat $ \b ->+        matMul a b == evalCM Nano.matMul a b++alphaRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a+alphaRename = mapAST rename+  where+    rename :: Nano.FeldDomain a -> Nano.FeldDomain a+    rename (Typed s)+        | Just (VarT v) <- prj s = Typed $ inj (VarT (v+1))+        | Just (LamT v) <- prj s = Typed $ inj (LamT (v+1))+        | otherwise = Typed s++badRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a+badRename = mapAST rename+  where+    rename :: Nano.FeldDomain a -> Nano.FeldDomain a+    rename (Typed s)+        | Just (VarT v) <- prj s = Typed $ inj (VarT (v+1))+        | Just (LamT v) <- prj s = Typed $ inj (LamT (v-1))+        | otherwise = Typed s++prop_alphaEq a = alphaEq a (alphaRename a)++prop_alphaEqBad a = alphaEq a (badRename a)++tests = testGroup "NanoFeldsparTests"+    [ goldenVsString "fib tree"     "tests/gold/fib.txt"     $ return $ fromString $ Nano.showAST Nano.fib+    , goldenVsString "spanVec tree" "tests/gold/spanVec.txt" $ return $ fromString $ Nano.showAST Nano.spanVec+    , 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++    , goldenVsString "fib comp"     "tests/gold/fib.comp"     $ return $ fromString $ Nano.compile Nano.fib+    , goldenVsString "spanVec comp" "tests/gold/spanVec.comp" $ return $ fromString $ Nano.compile Nano.spanVec+    , goldenVsString "scProd comp"  "tests/gold/scProd.comp"  $ return $ fromString $ Nano.compile Nano.scProd+    , goldenVsString "matMul comp"  "tests/gold/matMul.comp"  $ return $ fromString $ Nano.compile Nano.matMul++    , testProperty "fib eval"     prop_fib+    , testProperty "spanVec eval" prop_spanVec+    , testProperty "scProd eval"  prop_scProd+    , testProperty "matMul eval"  prop_matMul++    , testProperty "fib evalCM"    prop_fibCM+    , testProperty "scProd evalCM" prop_scProdCM+    , testProperty "matMul evalCM" prop_matMulCM++    , 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/SyntaxTests.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+module SyntaxTests where++import Data.Maybe+import Language.Syntactic+import Language.Syntactic.TH+import Test.Tasty+import Test.Tasty.HUnit++data A sig+  where+    A1 :: Int -> A (Full Int)+    A2 :: A (Int :-> Full Int)++deriving instance Eq (A sig)+deriving instance Show (A sig)++data B sig+  where+    B1 :: Char -> B (Full Char)++deriving instance Eq (B sig)+deriving instance Show (B sig)++data C sig+  where+    C1 :: C (Full ())+    C2 :: C (Int :-> Int :-> Full Int)++deriving instance Eq (C sig)+deriving instance Show (C sig)++type Dom = A :+: B :+: C++type Exp a = ASTF Dom a++a1 :: Int -> Exp Int+a1 = inj . A1++a2 :: Exp Int -> Exp Int+a2 a = inj A2 :$ a++b1 :: Char -> Exp Char+b1 = inj . B1++c1 :: Exp ()+c1 = inj $ C1++c2 :: Exp Int -> Exp Int -> Exp Int+c2 a b = inj C2 :$ a :$ b++tests = testGroup "SyntaxTests"+  [+    testCase "project first domain entry 1" $ prj (a1 5)      @?= Just (A1 5)+  , testCase "project first domain entry 2" $ prj (a2 (a1 1)) @?= (Nothing :: Maybe (A (Full Int)))+  , testCase "project second domain entry"  $ prj (b1 'b')    @?= Just (B1 'b')+  , testCase "project third domain entry 1" $ prj (c1)        @?= Just C1+  , testCase "project third domain entry 2" $ prj (c2 (a1 3) (a2 (a1 9))) @?= (Nothing :: Maybe (C (Full Int)))+  ]
+ tests/TH.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module TH where++++import Data.List (nub)++import Language.Syntactic+import Language.Syntactic.TH++++data Sym sig+  where+    A :: Int -> Bool -> Sym (a :-> a :-> Full a)+    B :: Sym (Full Bool)+    C :: String -> Sym (a :-> Int :-> Full a)++deriveSymbol    ''Sym+deriveEquality  ''Sym+deriveRender id ''Sym++tests =+    [ equal B B+    , equal (A 5 True) (A 5 True)+    , equal (C "syntactic") (C "syntactic")+    , not $ equal (A 5 True) (A 6 True)+    , not $ equal (A 5 True) (C "c")+    , hashes == nub hashes+    , renderSym (A 5 True) == "(A 5 True)"+    ]+  where+    hashes =+        [ hash $ A 5 True+        , hash $ B+        , hash $ C "a"+        , hash $ A 6 True+        , hash $ C "b"+        ]++main :: IO ()+main = if and tests+    then return ()+    else error "TH tests failed"+
+ tests/Tests.hs view
@@ -0,0 +1,21 @@+import Test.Tasty++import qualified AlgorithmTests+import qualified NanoFeldsparTests+import qualified WellScopedTests+import qualified MonadTests+import qualified SyntaxTests+import qualified TH++tests = testGroup "AllTests"+    [ SyntaxTests.tests+    , AlgorithmTests.tests+    , NanoFeldsparTests.tests+    , WellScopedTests.tests+    , MonadTests.tests+    ]++main = do+    TH.main+    defaultMain tests+
+ tests/WellScopedTests.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module WellScopedTests where++++import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.QuickCheck++import Data.ByteString.Lazy.UTF8 (fromString)++import Language.Syntactic+import Language.Syntactic.Functional.WellScoped+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/fib.txt view
@@ -0,0 +1,17 @@+Lam v3+ └╴Fst+    └╴ForLoop+       ├╴v3+       ├╴Pair+       │  ├╴0+       │  └╴1+       └╴Lam v2+          └╴Lam v1+             └╴Pair+                ├╴Snd+                │  └╴v1+                └╴(+)+                   ├╴Fst+                   │  └╴v1+                   └╴Snd+                      └╴v1
tests/gold/matMul.txt view
@@ -1,44 +1,38 @@-Lambda 0- └╴Lambda 1-    └╴Let 6-       ├╴arrLength-       │  └╴getIx-       │     ├╴var:1-       │     └╴0-       └╴Let 7-          ├╴arrLength-          │  └╴var:1-          └╴parallel-             ├╴arrLength-             │  └╴var:0-             └╴Lambda 2-                └╴Let 8-                   ├╴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+Lam v6+ └╴Lam v5+    └╴Parallel+       ├╴arrLen+       │  └╴v6+       └╴Lam v4+          └╴Let v7+             ├╴min+             │  ├╴arrLen+             │  │  └╴arrIx+             │  │     ├╴v6+             │  │     └╴v4+             │  └╴arrLen+             │     └╴v5+             └╴Parallel+                ├╴arrLen+                │  └╴arrIx+                │     ├╴v5+                │     └╴0+                └╴Lam v3+                   └╴ForLoop+                      ├╴v7+                      ├╴0.0+                      └╴Lam v2+                         └╴Lam v1+                            └╴(+)+                               ├╴(*)+                               │  ├╴arrIx+                               │  │  ├╴arrIx+                               │  │  │  ├╴v6+                               │  │  │  └╴v4+                               │  │  └╴v2+                               │  └╴arrIx+                               │     ├╴arrIx+                               │     │  ├╴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-    └╴forLoop+Lam v4+ └╴Lam v3+    └╴ForLoop        ├╴min-       │  ├╴arrLength-       │  │  └╴var:0-       │  └╴arrLength-       │     └╴var:1+       │  ├╴arrLen+       │  │  └╴v4+       │  └╴arrLen+       │     └╴v3        ├╴0.0-       └╴Lambda 2-          └╴Lambda 3+       └╴Lam v2+          └╴Lam v1              └╴(+)                 ├╴(*)-                │  ├╴getIx-                │  │  ├╴var:0-                │  │  └╴var:2-                │  └╴getIx-                │     ├╴var:1-                │     └╴var:2-                └╴var:3+                │  ├╴arrIx+                │  │  ├╴v4+                │  │  └╴v2+                │  └╴arrIx+                │     ├╴v3+                │     └╴v2+                └╴v1
+ tests/gold/spanVec.txt view
@@ -0,0 +1,32 @@+Lam v3+ └╴Let v4+    ├╴ForLoop+    │  ├╴arrLen+    │  │  └╴v3+    │  ├╴Pair+    │  │  ├╴arrIx+    │  │  │  ├╴v3+    │  │  │  └╴0+    │  │  └╴arrIx+    │  │     ├╴v3+    │  │     └╴0+    │  └╴Lam v2+    │     └╴Lam v1+    │        └╴Pair+    │           ├╴min+    │           │  ├╴arrIx+    │           │  │  ├╴v3+    │           │  │  └╴v2+    │           │  └╴Fst+    │           │     └╴v1+    │           └╴max+    │              ├╴arrIx+    │              │  ├╴v3+    │              │  └╴v2+    │              └╴Snd+    │                 └╴v1+    └╴(-)+       ├╴Snd+       │  └╴v4+       └╴Fst+          └╴v4