diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -3,5 +3,3 @@ * Anders Persson * Daniel Schoepe * Dmytro Lypai - * Johan Ankner - * Peter Jonsson diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2011, Emil Axelsson +Copyright (c) 2011-2014, Emil Axelsson All rights reserved. diff --git a/benchmarks/JoiningTypes.hs b/benchmarks/JoiningTypes.hs new file mode 100644 --- /dev/null +++ b/benchmarks/JoiningTypes.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE TemplateHaskell #-} + +module JoiningTypes (main) where + +import Criterion.Main +import Criterion.Config +import Data.Monoid +import Data.Syntactic +import Data.Syntactic.Functional + +-- Normal DSL, not joined types. +data Expr1 t where + EI :: Int -> Expr1 (Full Int) + EB :: Bool -> Expr1 (Full Bool) + EAdd :: Expr1 (Int :-> Int :-> Full Int) + EEq :: (Eq t) => Expr1 (t :-> t :-> Full Bool) + EIf :: Expr1 (Bool :-> a :-> a :-> Full a) + +type Expr1' a = AST Expr1 (Full a) + +int :: Int -> Expr1' Int +int = Sym . EI + +bool :: Bool -> Expr1' Bool +bool = Sym . EB + +add :: Expr1' Int -> Expr1' Int -> Expr1' Int +add a b = Sym EAdd :$ a :$ b + +eq :: (Eq a) => Expr1' a -> Expr1' a -> Expr1' Bool +eq a b = Sym EEq :$ a :$ b + +if' :: Expr1' Bool -> Expr1' a -> Expr1' a -> Expr1' a +if' c a b = Sym EIf :$ c :$ a :$ b + +instance Render Expr1 where + renderSym (EI n) = "EI" + renderSym (EB b) = "EB" + renderSym (EAdd) = "EAdd" + renderSym (EEq) = "EEq" + renderSym (EIf) = "EIf" + +interpretationInstances ''Expr1 + +instance Eval Expr1 where + evalSym (EI n) = n + evalSym (EB b) = b + evalSym EAdd = (+) + evalSym EEq = (==) + evalSym EIf = \c a b -> if c then a else b + +instance EvalEnv Expr1 env where + compileSym p (EI n) = compileSymDefault p (EI n) + compileSym p (EB b) = compileSymDefault p (EB b) + compileSym p EAdd = compileSymDefault p EAdd + compileSym p EEq = compileSymDefault p EEq + compileSym p EIf = compileSymDefault p EIf + +-- Joined types +data ExprI t where + EIJ :: Int -> ExprI (Full Int) + EAddJ :: ExprI (Int :-> Int :-> Full Int) + +data ExprB t where + EBJ :: Bool -> ExprB (Full Bool) + EEqJ :: (Eq t) => ExprB (t :-> t :-> Full Bool) + EIfJ :: ExprB (Bool :-> a :-> a :-> Full a) + +type ExprJ = ExprI :+: ExprB +type ExprJ' a = AST ExprJ (Full a) + +intJ :: Int -> ExprJ' Int +intJ = Sym . inj . EIJ + +boolJ :: Bool -> ExprJ' Bool +boolJ = Sym . inj . EBJ + +addJ :: ExprJ' Int -> ExprJ' Int -> ExprJ' Int +addJ a b = Sym (inj EAddJ) :$ a :$ b + +eqJ :: (Eq a) => ExprJ' a -> ExprJ' a -> ExprJ' Bool +eqJ a b = Sym (inj EEqJ) :$ a :$ b + +ifJ :: ExprJ' Bool -> ExprJ' a -> ExprJ' a -> ExprJ' a +ifJ c a b = Sym (inj EIfJ) :$ c :$ a :$ b + +instance Render ExprI where + renderSym (EIJ n) = "EI" + renderSym (EAddJ) = "EAdd" +instance Render ExprB where + renderSym (EBJ b) = "EB" + renderSym (EEqJ) = "EEq" + renderSym (EIfJ) = "EIf" + +interpretationInstances ''ExprI +interpretationInstances ''ExprB + +instance Eval ExprI where + evalSym (EIJ n) = n + evalSym EAddJ = (+) + +instance Eval ExprB where + evalSym (EBJ b) = b + evalSym EEqJ = (==) + evalSym EIfJ = \c a b -> if c then a else b + +instance EvalEnv ExprI env where + compileSym p (EIJ n) = compileSymDefault p (EIJ n) + compileSym p EAddJ = compileSymDefault p EAddJ + +instance EvalEnv ExprB env where + compileSym p (EBJ b) = compileSymDefault p (EBJ b) + compileSym p EEqJ = compileSymDefault p EEqJ + compileSym p EIfJ = compileSymDefault p EIfJ + +-- Joined types (4 joins) + +data Expr4J1 t where + E4JI :: Int -> Expr4J1 (Full Int) +data Expr4J2 t where + E4JB :: Bool -> Expr4J2 (Full Bool) +data Expr4J3 t where + E4JAdd :: Expr4J3 (Int :-> Int :-> Full Int) +data Expr4J4 t where + E4JEq :: (Eq t) => Expr4J4 (t :-> t :-> Full Bool) +data Expr4J5 t where + E4JIf :: Expr4J5 (Bool :-> a :-> a :-> Full a) + +type Expr4J = Expr4J1 :+: Expr4J2 :+: Expr4J3 :+: Expr4J4 :+: Expr4J5 +type Expr4J' a = AST Expr4J (Full a) + +int4 :: Int -> Expr4J' Int +int4 = Sym . inj . E4JI + +bool4 :: Bool -> Expr4J' Bool +bool4 = Sym . inj . E4JB + +add4 :: Expr4J' Int -> Expr4J' Int -> Expr4J' Int +add4 a b = Sym (inj E4JAdd) :$ a :$ b + +eq4 :: (Eq a) => Expr4J' a -> Expr4J' a -> Expr4J' Bool +eq4 a b = Sym (inj E4JEq) :$ a :$ b + +if4 :: Expr4J' Bool -> Expr4J' a -> Expr4J' a -> Expr4J' a +if4 c a b = Sym (inj E4JIf) :$ c :$ a :$ b + +instance Render Expr4J1 where + renderSym (E4JI n) = "EI" + +instance Render Expr4J2 where + renderSym (E4JB b) = "EB" + +instance Render Expr4J3 where + renderSym (E4JAdd) = "EAdd" + +instance Render Expr4J4 where + renderSym (E4JEq) = "EEq" + +instance Render Expr4J5 where + renderSym (E4JIf) = "EIf" + +interpretationInstances ''Expr4J1 +interpretationInstances ''Expr4J2 +interpretationInstances ''Expr4J3 +interpretationInstances ''Expr4J4 +interpretationInstances ''Expr4J5 + +instance Eval Expr4J1 where + evalSym (E4JI n) = n + +instance Eval Expr4J2 where + evalSym (E4JB b) = b + +instance Eval Expr4J3 where + evalSym E4JAdd = (+) + +instance Eval Expr4J4 where + evalSym E4JEq = (==) + +instance Eval Expr4J5 where + evalSym E4JIf = \c a b -> if c then a else b + +instance EvalEnv Expr4J1 env where + compileSym p (E4JI n) = compileSymDefault p (E4JI n) + +instance EvalEnv Expr4J2 env where + compileSym p (E4JB b) = compileSymDefault p (E4JB b) + +instance EvalEnv Expr4J3 env where + compileSym p E4JAdd = compileSymDefault p E4JAdd + +instance EvalEnv Expr4J4 env where + compileSym p E4JEq = compileSymDefault p E4JEq + +instance EvalEnv Expr4J5 env where + compileSym p E4JIf = compileSymDefault p E4JIf + +-- Expressions +syntacticExpr :: Int -> Expr1' Int +syntacticExpr 0 = if' (eq (int 5) (int 4)) (int 5) (int 0) +syntacticExpr n = (add (syntacticExpr (n-1)) (syntacticExpr (n-1))) + +syntacticExprJ :: Int -> ExprJ' Int +syntacticExprJ 0 = ifJ (eqJ (intJ 5) (intJ 4)) (intJ 5) (intJ 0) +syntacticExprJ n = (addJ (syntacticExprJ (n-1)) (syntacticExprJ (n-1))) + +syntacticExpr4J :: Int -> Expr4J' Int +syntacticExpr4J 0 = if4 (eq4 (int4 5) (int4 4)) (int4 5) (int4 0) +syntacticExpr4J n = (add4 (syntacticExpr4J (n-1)) (syntacticExpr4J (n-1))) + +main :: IO () +main = defaultMainWith (defaultConfig {cfgSummaryFile = Last $ Just "bench-results/joiningTypes.csv"}) (return ()) + [ bgroup "eval 10" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 10) + , bench "syntactic 1 join" $ nf evalDen (syntacticExprJ 10) + , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 10)] + , bgroup "eval 15" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 15) + , bench "syntactic 1 join" $ nf evalDen (syntacticExprJ 15) + , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 15)] + , bgroup "eval 20" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 20) + , bench "syntactic 1 join" $ nf evalDen (syntacticExprJ 20) + , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 20)] + , bgroup "size 10" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 10) + , bench "syntactic 1 join" $ nf size (syntacticExprJ 10) + , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 10)] + , bgroup "size 15" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 15) + , bench "syntactic 1 join" $ nf size (syntacticExprJ 15) + , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 15)] + , bgroup "size 20" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 20) + , bench "syntactic 1 join" $ nf size (syntacticExprJ 20) + , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 20)]] + diff --git a/benchmarks/MainBenchmark.hs b/benchmarks/MainBenchmark.hs new file mode 100644 --- /dev/null +++ b/benchmarks/MainBenchmark.hs @@ -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 diff --git a/benchmarks/Normal.hs b/benchmarks/Normal.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Normal.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Normal (main) where + +import Criterion.Main +import Criterion.Config +import Data.Monoid +import Data.Syntactic +import Data.Syntactic.Functional + +main :: IO () +main = defaultMainWith (defaultConfig {cfgSummaryFile = Last $ Just "bench-results/normal.csv"}) (return ()) + [ bgroup "Eval Tree 10" [ bench "gadt" $ nf evl (gadtExpr 10) + , bench "syntactic" $ nf evalDen (syntacticExpr 10)] + , bgroup "Eval Tree 15" [ bench "gadt" $ nf evl (gadtExpr 15) + , bench "syntactic" $ nf evalDen(syntacticExpr 15)] + , bgroup "Eval Tree 20" [ bench "gadt" $ nf evl (gadtExpr 20) + , bench "syntactic" $ nf evalDen(syntacticExpr 20) ] + , bgroup "Size Tree 10" [ bench "gadt" $ nf gSize (gadtExpr 10) + , bench "syntactic" $ nf size (syntacticExpr 10)] + , bgroup "Size Tree 15" [ bench "gadt" $ nf gSize (gadtExpr 15) + , bench "syntactic" $ nf size (syntacticExpr 15)] + , bgroup "Size Tree 20" [ bench "gadt" $ nf gSize (gadtExpr 20) + , bench "syntactic" $ nf size (syntacticExpr 20)] + , bgroup "Eval IFTree 10" [ bench "if gadt" $ nf evl (gadtExpr 10) + , bench "syntactic" $ nf evalDen(syntacticExpr 10)] + , bgroup "Eval IFTree 15" [ bench "gadt" $ nf evl (gadtExpr 15) + , bench "syntactic" $ nf evalDen(syntacticExpr 15)] + , bgroup "Eval IFTree 20" [ bench "gadt" $ nf evl (gadtExpr 20) + , bench "syntactic" $ nf evalDen(syntacticExpr 20) ] + , bgroup "Size IFTree 10" [ bench "gadt" $ nf gSize (gadtExpr 10) + , bench "syntactic" $ nf evalDen(syntacticExpr 10)] + , bgroup "Size IFTree 15" [ bench "gadt" $ nf gSize (gadtExpr 15) + , bench "syntactic" $ nf evalDen(syntacticExpr 15)] + , bgroup "Size IFTree 20" [ bench "gadt" $ nf gSize (gadtExpr 20) + , bench "syntactic" $ nf evalDen(syntacticExpr 20) ]] + +-- Expressions +gadtExpr :: Int -> Expr Int +gadtExpr 0 = (If ((LitI 5) :== (LitI 4)) (LitI 5) (LitI 0)) +gadtExpr n = gadtExpr (n-1) :+ gadtExpr (n-1) + +gadtExprIf :: Int -> Expr Int +gadtExprIf 0 = (If ((LitI 5) :== (LitI 4)) (LitI 5) (LitI 0)) +gadtExprIf n = (If (gadtExprIf (n-1) :== (LitI 0)) (gadtExprIf (n-1)) (gadtExprIf (n-1))) + +syntacticExpr :: Int -> ExprS' Int +syntacticExpr 0 = if' (eq (int 5) (int 4)) (int 5) (int 0) +syntacticExpr n = (add (syntacticExpr (n-1)) (syntacticExpr (n-1))) + +-- We also test an expression with several ifs so the tree has higher width. +syntacticExprIf :: Int -> ExprS' Int +syntacticExprIf 0 = if' (eq (int 5) (int 4)) (int 5) (int 0) +syntacticExprIf n = if' (eq (syntacticExprIf(n-1)) (int 0)) (syntacticExprIf (n-1)) (syntacticExprIf (n-1)) + + +-- Comparing Syntactic with GADTs +-- GADTs +data Expr t where + LitI :: Int -> Expr Int + LitB :: Bool -> Expr Bool + (:+) :: Expr Int -> Expr Int -> Expr Int + (:==) :: Eq t => Expr t -> Expr t -> Expr Bool + If :: Expr Bool -> Expr t -> Expr t -> Expr t + +evl :: Expr t -> t +evl (LitI n) = n +evl (LitB b) = b +evl (e1 :+ e2) = evl e1 + evl e2 +evl (e1 :== e2) = evl e1 == evl e2 +evl (If b t e) = if evl b then evl t else evl e + +gSize :: Expr t -> Int +gSize (LitI n) = 1 +gSize (LitB b) = 1 +gSize (e1 :+ e2) = gSize e1 + gSize e2 +gSize (e1 :== e2) = gSize e1 + gSize e2 +gSize (If b t e) = gSize b + gSize t + gSize e + +-- Syntactic + +data ExprS t where + EI :: Int -> ExprS (Full Int) + EB :: Bool -> ExprS (Full Bool) + EAdd :: ExprS (Int :-> Int :-> Full Int) + EEq :: (Eq t) => ExprS (t :-> t :-> Full Bool) + EIf :: ExprS (Bool :-> a :-> a :-> Full a) + +type ExprS' a = AST ExprS (Full a) + +-- Smart constructors +int :: Int -> ExprS' Int +int = Sym . EI + +bool :: Bool -> ExprS' Bool +bool = Sym . EB + +add :: ExprS' Int -> ExprS' Int -> ExprS' Int +add a b = Sym EAdd :$ a :$ b + +eq :: (Eq a) => ExprS' a -> ExprS' a -> ExprS' Bool +eq a b = Sym EEq :$ a :$ b + +if' :: ExprS' Bool -> ExprS' a -> ExprS' a -> ExprS' a +if' c a b = Sym EIf :$ c :$ a :$ b + +instance Render ExprS where + renderSym (EI n) = "EI" + renderSym (EB b) = "EB" + renderSym EAdd = "EAdd" + renderSym EEq = "EEq" + renderSym EIf = "EIf" + +interpretationInstances ''ExprS + +instance Eval ExprS where + evalSym (EI n) = n + evalSym (EB b) = b + evalSym EAdd = (+) + evalSym EEq = (==) + evalSym EIf = \c a b -> if c then a else b + +instance EvalEnv ExprS env where + compileSym p (EI n) = compileSymDefault p (EI n) + compileSym p (EB b) = compileSymDefault p (EB b) + compileSym p EAdd = compileSymDefault p EAdd + compileSym p EEq = compileSymDefault p EEq + compileSym p EIf = compileSymDefault p EIf + diff --git a/benchmarks/WithArity.hs b/benchmarks/WithArity.hs new file mode 100644 --- /dev/null +++ b/benchmarks/WithArity.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TemplateHaskell #-} + +module WithArity (main) where + +import Criterion.Main +import Criterion.Config +import Data.Monoid +import Data.Syntactic hiding (E) +import Data.Syntactic.Functional + +main :: IO () +main = defaultMainWith (defaultConfig {cfgSummaryFile = Last $ Just "bench-results/withArity.csv"}) (return ()) + [ bgroup "eval 5" [ bench "gadt" $ nf evl (gExpr 5) + , bench "Syntactic" $ nf evalDen (sExpr 5) ] + , bgroup "eval 6" [ bench "gadt" $ nf evl (gExpr 6) + , bench "Syntactic" $ nf evalDen (sExpr 6) ] + , bgroup "eval 7" [ bench "gadt" $ nf evl (gExpr 7) + , bench "Syntactic" $ nf evalDen (sExpr 7) ] + , bgroup "size 5" [ bench "gadt" $ nf gSize (gExpr 5) + , bench "Syntactic" $ nf size (sExpr 5) ] + , bgroup "size 6" [ bench "gadt" $ nf gSize (gExpr 6) + , bench "Syntactic" $ nf size (sExpr 6) ] + , bgroup "size 7" [ bench "gadt" $ nf gSize (gExpr 7) + , bench "Syntactic" $ nf size (sExpr 7) ]] + +-- Expressions +gExpr :: Int -> E Int +gExpr 0 = E0 1 +gExpr 1 = E2 (E2 (E0 1) (E0 1)) (E1 (E0 1)) +gExpr n = E10 (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) + (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) + +sExpr :: Int -> T' Int +sExpr 0 = t0 1 +sExpr 1 = t2 (t2 (t0 1) (t0 1)) (t1 (t0 1)) +sExpr n = t10 (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) + (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) + +gSize :: E a -> Int +gSize (E0 _) = 1 +gSize (E1 a) = gSize a +gSize (E2 a b) = gSize a + gSize b +gSize (E3 a b c) = gSize a + gSize b + gSize c +gSize (E5 a b c d e) = gSize a + gSize b + gSize c + gSize d + gSize e +gSize (E10 a b c d e f g h i j) = gSize a + gSize b + gSize c + gSize d + gSize e + + gSize f + gSize g + gSize h + gSize i + gSize j + + +-- Comparing Syntactic with GADTs +-- GADTs +data E a where + E0 :: a -> E a + E1 :: E a -> E a + E2 :: E a -> E a -> E a + E3 :: E a -> E a -> E a -> E a + E5 :: E a -> E a -> E a -> E a -> E a -> E a + E10 :: E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a + + +evl :: E Int -> Int +evl (E0 n) = n +evl (E1 a) = evl a +evl (E2 a b) = evl a + evl b +evl (E3 a b c) = evl a + evl b + evl c +evl (E5 a b c d e) = evl a + evl b + evl c + evl d + evl e +evl (E10 a b c d e f g h i j) = + evl a + evl b + evl c + evl d + evl e + evl f + evl g + evl h + evl i + evl j + +-- Syntactic + +data T a where + T0 :: Num a => a -> T (Full a) + T1 :: Num a => T (a :-> Full a) + T2 :: Num a => T (a :-> a :-> Full a) + T3 :: Num a => T (a :-> a :-> a :-> Full a) + T5 :: Num a => T (a :-> a :-> a :-> a :-> a :-> Full a) + T10 :: Num a => T (a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> Full a) + +type T' a = AST T (Full a) + +t0 :: Num a => a -> T' a +t0 = Sym . T0 + +t1 :: Num a => T' a -> T' a +t1 a = Sym T1 :$ a + +t2 :: Num a => T' a -> T' a -> T' a +t2 a b = Sym T2 :$ a :$ b + +t3 :: Num a => T' a -> T' a -> T' a -> T' a +t3 a b c = Sym T3 :$ a :$ b :$ c + +t5 :: Num a => T' a -> T' a -> T' a -> T' a -> T' a -> T' a +t5 a b c d e = Sym T5 :$ a :$ b :$ c :$ d :$ e + +t10 :: Num a => T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a +t10 a b c d e f g h i j = Sym T10 :$ a :$ b :$ c :$ d :$ e :$ f :$ g :$ h :$ i:$ j + +instance Render T + where + renderSym (T0 a) = "T0" + renderSym T1 = "T1" + renderSym T2 = "T2" + renderSym T3 = "T3" + renderSym T5 = "T5" + renderSym T10 = "T10" + +interpretationInstances ''T + +instance Eval T + where + evalSym (T0 a) = a + evalSym T1 = id + evalSym T2 = (+) + evalSym T3 = \a b c -> a + b + c + evalSym T5 = \a b c d e -> a + b + c + d + e + evalSym T10 = \a b c d e f g h i j -> a + b + c + d + e + f + g + h + i + j + +instance EvalEnv T env + where + compileSym p (T0 a) = compileSymDefault p (T0 a) + compileSym p T1 = compileSymDefault p T1 + compileSym p T2 = compileSymDefault p T2 + compileSym p T3 = compileSymDefault p T3 + compileSym p T5 = compileSymDefault p T5 + compileSym p T10 = compileSymDefault p T10 + diff --git a/examples/Monad.hs b/examples/Monad.hs new file mode 100644 --- /dev/null +++ b/examples/Monad.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | This module demonstrates monad reification. +-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011 +-- ) for details. + +module Monad where + + + +import Control.Monad (replicateM_) +import Data.Char (isDigit) +import Data.Typeable (Typeable) + +import Data.Syntactic +import Data.Syntactic.Functional +import Data.Syntactic.Sugar.MonadT + +import NanoFeldspar (Type, Arithmetic (..)) + + + +type Dom = BindingT :+: MONAD IO :+: Construct :+: Arithmetic + +type Exp a = ASTF Dom a + +type IO' a = Remon Dom IO (Exp a) + +getDigit :: IO' Int +getDigit = sugarSym $ Construct "getDigit" get + where + get = do + c <- getChar + if isDigit c then return (fromEnum c - fromEnum '0') else get + +putDigit :: Exp Int -> IO' () +putDigit = sugarSym $ Construct "putDigit" print + +iter :: Typeable a => Exp Int -> IO' a -> IO' () +iter = sugarSym $ Construct "iter" replicateM_ + +-- | Literal +value :: Show a => a -> Exp a +value a = sugar $ inj $ Construct (show a) a + +instance (Num a, Type a) => Num (Exp a) + where + fromInteger = value . fromInteger + (+) = sugarSym Add + (-) = sugarSym Sub + (*) = sugarSym Mul + +ex1 :: Exp Int -> IO' () +ex1 n = iter n $ do + d <- getDigit + putDigit (d+d) + +test1 = evalClosed (desugar ex1) 5 +test2 = drawAST $ desugar ex1 + diff --git a/examples/NanoFeldspar.hs b/examples/NanoFeldspar.hs new file mode 100644 --- /dev/null +++ b/examples/NanoFeldspar.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | A minimal Feldspar core language implementation. The intention of this module is to demonstrate +-- how to quickly make a language prototype using Syntactic. + +module NanoFeldspar where + + + +import Prelude hiding (max, min, not, (==), length, map, sum, zip, zipWith) +import qualified Prelude + +import Data.Tree +import Data.Typeable + +import Data.Syntactic hiding (fold, printExpr, showAST, drawAST, writeHtmlAST) +import qualified Data.Syntactic as Syntactic +import Data.Syntactic.Functional +import Data.Syntactic.Sugar.BindingT + + + +-------------------------------------------------------------------------------- +-- * Types +-------------------------------------------------------------------------------- + +-- | Convenient class alias +class (Typeable a, Show a, Eq a, Ord a) => Type a +instance (Typeable a, Show a, Eq a, Ord a) => Type a + +type Length = Int +type Index = Int + + + +-------------------------------------------------------------------------------- +-- * Abstract syntax +-------------------------------------------------------------------------------- + +data Arithmetic a + where + Add :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a) + Sub :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a) + Mul :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a) + +instance Render Arithmetic + where + renderSym Add = "(+)" + renderSym Sub = "(-)" + renderSym Mul = "(*)" + renderArgs = renderArgsSmart + +interpretationInstances ''Arithmetic + +instance Eval Arithmetic + where + evalSym Add = (+) + evalSym Sub = (-) + evalSym Mul = (*) + +instance EvalEnv Arithmetic env + where + compileSym p Add = compileSymDefault p Add + compileSym p Sub = compileSymDefault p Sub + compileSym p Mul = compileSymDefault p Mul + -- Pattern matching on the individual constructors is needed in order to fulfill the + -- 'Signature' constraint required by the right-hand side. + +data Let a + where + Let :: Let (a :-> (a -> b) :-> Full b) + +instance Equality Let + where + equal = equalDefault + hash = hashDefault + +instance Render Let + where + renderSym Let = "letBind" + +instance StringTree Let + where + stringTreeSym [a, Node lam [body]] Let + | ("Lam",v) <- splitAt 3 lam = Node ("Let" ++ v) [a,body] + stringTreeSym [a,f] Let = Node "Let" [a,f] + +instance Eval Let + where + evalSym Let = flip ($) + +instance EvalEnv Let env + where + compileSym p Let = compileSymDefault p Let + +data Parallel a + where + Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a]) + +instance Render Parallel + where + renderSym Parallel = "parallel" + +interpretationInstances ''Parallel + +instance Eval Parallel + where + evalSym Parallel = \len ixf -> Prelude.map ixf [0 .. len-1] + +instance EvalEnv Parallel env + where + compileSym p Parallel = compileSymDefault p Parallel + +data ForLoop a + where + ForLoop :: Type st => ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st) + +instance Render ForLoop + where + renderSym ForLoop = "forLoop" + +interpretationInstances ''ForLoop + +instance Eval ForLoop + where + evalSym ForLoop = \len init body -> foldl (flip body) init [0 .. len-1] + +instance EvalEnv ForLoop env + where + compileSym p ForLoop = compileSymDefault p ForLoop + +type FeldDomain + = Arithmetic + :+: BindingT + :+: Let + :+: Parallel + :+: ForLoop + :+: Construct + +newtype Data a = Data { unData :: ASTF FeldDomain a } + +-- | Declaring 'Data' as syntactic sugar +instance Type a => Syntactic (Data a) + where + type Domain (Data a) = FeldDomain + type Internal (Data a) = a + desugar = unData + sugar = Data + +-- | Specialization of the 'Syntactic' class for the Feldspar domain +class (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a +instance (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a + +instance Type a => Show (Data a) + where + show = render . unData + + + +-------------------------------------------------------------------------------- +-- * "Backends" +-------------------------------------------------------------------------------- + +-- | Show the expression +showExpr :: (Syntactic a, Domain a ~ FeldDomain) => a -> String +showExpr = render . desugar + +-- | Print the expression +printExpr :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO () +printExpr = putStrLn . showExpr + +-- | Show the syntax tree using unicode art +showAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> String +showAST = Syntactic.showAST . desugar + +-- | Draw the syntax tree on the terminal using unicode art +drawAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO () +drawAST = putStrLn . showAST + +-- | Write the syntax tree to an HTML file with foldable nodes +writeHtmlAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO () +writeHtmlAST = Syntactic.writeHtmlAST "tree.html" . desugar + +eval :: (Syntactic a, Domain a ~ FeldDomain) => a -> Internal a +eval = evalClosed . desugar + + + +-------------------------------------------------------------------------------- +-- * Front end +-------------------------------------------------------------------------------- + +-- | Literal +value :: Syntax a => Internal a -> a +value a = sugar $ inj $ Construct (show a) a + +false :: Data Bool +false = value False + +true :: Data Bool +true = value True + +-- | For types containing some kind of \"thunk\", this function can be used to +-- force computation +force :: Syntax a => a -> a +force = resugar + +instance (Type a, Num a) => Num (Data a) + where + fromInteger = value . fromInteger + (+) = sugarSym Add + (-) = sugarSym Sub + (*) = sugarSym Mul + +share :: (Syntax a, Syntactic b, Domain b ~ FeldDomain) => a -> (a -> b) -> b +share = sugarSym Let + +-- | Parallel array +parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a] +parallel = sugarSym Parallel + +-- | For loop +forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st +forLoop = sugarSym ForLoop + +(?) :: forall a . Syntax a => Data Bool -> (a,a) -> a +c ? (t,f) = sugarSym sym c t f + where + sym :: Construct (Bool :-> Internal a :-> Internal a :-> Full (Internal a)) + sym = Construct "cond" (\c t f -> if c then t else f) + +arrLength :: Type a => Data [a] -> Data Length +arrLength = sugarSym $ Construct "arrLength" Prelude.length + +-- | Array indexing +getIx :: Type a => Data [a] -> Data Index -> Data a +getIx = sugarSym $ Construct "getIx" eval + where + eval as i + | i >= len || i < 0 = error "getIx: index out of bounds" + | otherwise = as !! i + where + len = Prelude.length as + +not :: Data Bool -> Data Bool +not = sugarSym $ Construct "not" Prelude.not + +(==) :: Type a => Data a -> Data a -> Data Bool +(==) = sugarSym $ Construct "(==)" (Prelude.==) + +max :: Type a => Data a -> Data a -> Data a +max = sugarSym $ Construct "max" Prelude.max + +min :: Type a => Data a -> Data a -> Data a +min = sugarSym $ Construct "min" Prelude.min + + + +-------------------------------------------------------------------------------- +-- * Vector library +-------------------------------------------------------------------------------- + +data Vector a + where + Indexed :: Data Length -> (Data Index -> a) -> Vector a + +instance Syntax a => Syntactic (Vector a) + where + type Domain (Vector a) = FeldDomain + type Internal (Vector a) = [Internal a] + desugar = desugar . freezeVector . map resugar + sugar = map resugar . thawVector . sugar + +length :: Vector a -> Data Length +length (Indexed len _) = len + +indexed :: Data Length -> (Data Index -> a) -> Vector a +indexed = Indexed + +index :: Vector a -> Data Index -> a +index (Indexed _ ixf) = ixf + +(!) :: Vector a -> Data Index -> a +Indexed _ ixf ! i = ixf i + +infixl 9 ! + +freezeVector :: Type a => Vector (Data a) -> Data [a] +freezeVector vec = parallel (length vec) (index vec) + +thawVector :: Type a => Data [a] -> Vector (Data a) +thawVector arr = Indexed (arrLength arr) (getIx arr) + +zip :: Vector a -> Vector b -> Vector (a,b) +zip a b = indexed (length a `min` length b) (\i -> (index a i, index b i)) + +unzip :: Vector (a,b) -> (Vector a, Vector b) +unzip ab = (indexed len (fst . index ab), indexed len (snd . index ab)) + where + len = length ab + +permute :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a) +permute perm vec = indexed len (index vec . perm len) + where + len = length vec + +reverse :: Vector a -> Vector a +reverse = permute $ \len i -> len-i-1 + +(...) :: Data Index -> Data Index -> Vector (Data Index) +l ... h = indexed (h-l+1) (+l) + +map :: (a -> b) -> Vector a -> Vector b +map f (Indexed len ixf) = Indexed len (f . ixf) + +zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c +zipWith f a b = map (uncurry f) $ zip a b + +fold :: Syntax b => (a -> b -> b) -> b -> Vector a -> b +fold f b (Indexed len ixf) = forLoop len b (\i st -> f (ixf i) st) + +sum :: (Num a, Syntax a) => Vector a -> a +sum = fold (+) 0 + +type Matrix a = Vector (Vector (Data a)) + +-- | Transpose of a matrix. Assumes that the number of rows is > 0. +transpose :: Type a => Matrix a -> Matrix a +transpose a = indexed (length (a!0)) $ \k -> indexed (length a) $ \l -> a ! l ! k + + + +-------------------------------------------------------------------------------- +-- * Examples +-------------------------------------------------------------------------------- + +-- | Scalar product +scProd :: Vector (Data Float) -> Vector (Data Float) -> Data Float +scProd a b = sum (zipWith (*) a b) + +forEach = flip map + +-- | Matrix multiplication +matMul :: Matrix Float -> Matrix Float -> Matrix Float +matMul a b = forEach a $ \a' -> + forEach (transpose b) $ \b' -> + scProd a' b' + diff --git a/examples/NanoFeldspar/Core.hs b/examples/NanoFeldspar/Core.hs deleted file mode 100644 --- a/examples/NanoFeldspar/Core.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | A minimal Feldspar core language implementation. The intention of this --- module is to demonstrate how to quickly make a language prototype using --- syntactic. --- --- A more realistic implementation would use custom contexts to restrict the --- types at which constructors operate. Currently, all general constructs (such --- as 'Literal' and 'Tuple') use a 'SimpleCtx' context, which means that the --- types are quite unrestricted. A real implementation would also probably use --- custom types for primitive functions, since 'Construct' is quite unsafe (uses --- only a 'String' to distinguish between functions). - -module NanoFeldspar.Core where - - - -import Data.Typeable - -import Language.Syntactic as Syntactic -import Language.Syntactic.Constructs.Binding -import Language.Syntactic.Constructs.Binding.HigherOrder -import Language.Syntactic.Constructs.Condition -import Language.Syntactic.Constructs.Construct -import Language.Syntactic.Constructs.Literal -import Language.Syntactic.Constructs.Tuple -import Language.Syntactic.Frontend.Tuple -import Language.Syntactic.Sharing.SimpleCodeMotion -import Language.Syntactic.Sharing.CodeMotion2 - - - --------------------------------------------------------------------------------- --- * Types --------------------------------------------------------------------------------- - --- | Convenient class alias -class (Ord a, Show a, Typeable a) => Type a -instance (Ord a, Show a, Typeable a) => Type a where - {-# SPECIALIZE instance (Ord a, Show a, Typeable a) => Type a #-} - -type Length = Int -type Index = Int - - - --------------------------------------------------------------------------------- --- * Parallel arrays --------------------------------------------------------------------------------- - -data Parallel a - where - Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a]) - -instance Constrained Parallel - where - {-# SPECIALIZE instance Constrained Parallel #-} - {-# INLINABLE exprDict #-} - type Sat Parallel = Type - exprDict Parallel = Dict - -instance Semantic Parallel - where - {-# SPECIALIZE instance Semantic Parallel #-} - {-# INLINABLE semantics #-} - semantics Parallel = Sem - { semanticName = "parallel" - , semanticEval = \len ixf -> map ixf [0 .. len-1] - } - -semanticInstances ''Parallel - -instance EvalBind Parallel where - {-# SPECIALIZE instance EvalBind Parallel #-} - -instance AlphaEq dom dom dom env => AlphaEq Parallel Parallel dom env - where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Parallel Parallel dom env #-} - - - --------------------------------------------------------------------------------- --- * For loops --------------------------------------------------------------------------------- - -data ForLoop a - where - ForLoop :: Type st => - ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st) - -instance Constrained ForLoop - where - type Sat ForLoop = Type - exprDict ForLoop = Dict - -instance Semantic ForLoop - where - semantics ForLoop = Sem - { semanticName = "forLoop" - , semanticEval = \len init body -> foldl (flip body) init [0 .. len-1] - } - -semanticInstances ''ForLoop - -instance EvalBind ForLoop where evalBindSym = evalBindSymDefault - -instance AlphaEq dom dom dom env => AlphaEq ForLoop ForLoop dom env - where - alphaEqSym = alphaEqSymDefault - - - --------------------------------------------------------------------------------- --- * Feldspar domain --------------------------------------------------------------------------------- - --- | The Feldspar domain -type FeldDomain - = Construct - :+: Literal - :+: Condition - :+: Tuple - :+: Select - :+: Parallel - :+: ForLoop - -type FeldSyms = Let :+: (FeldDomain :|| Eq :| Show) -type FeldDomainAll = HODomain FeldSyms Typeable Top - -newtype Data a = Data { unData :: ASTF FeldDomainAll a } - --- | Declaring 'Data' as syntactic sugar -instance Type a => Syntactic (Data a) - where - type Domain (Data a) = FeldDomainAll - type Internal (Data a) = a - desugar = unData - sugar = Data - --- | Specialization of the 'Syntactic' class for the Feldspar domain -class (Syntactic a, Domain a ~ FeldDomainAll, Type (Internal a)) => Syntax a -instance (Syntactic a, Domain a ~ FeldDomainAll, Type (Internal a)) => Syntax a - --- | A predicate deciding which constructs can be shared. Lambdas and literals are not shared. -canShare :: ASTF (FODomain FeldSyms Typeable Top) a -> Maybe (Dict (Top a)) -canShare (lam :$ _) - | Just _ <- prjP (P::P (CLambda Top)) lam = Nothing -canShare (prj -> Just (Literal _)) = Nothing -canShare _ = Just Dict - -canShareIn :: ASTF (FODomain FeldSyms Typeable Top) a -> Bool -canShareIn (lam :$ _) - | Just _ <- prjP (P::P (CLambda Top)) lam = False -canShareIn _ = True - -canShareDict :: MkInjDict (FODomain FeldSyms Typeable Top) -canShareDict = mkInjDictFO canShare canShareIn - -canShareDict2 :: MkInjDict (FODomain FeldSyms Typeable Top) -canShareDict2 = mkInjDictFO canShare (const True) - - - --------------------------------------------------------------------------------- --- * Back ends --------------------------------------------------------------------------------- - --- | Show the expression -showExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String -showExpr = render . reifySmart (const True) canShareDict - --- | Print the expression -printExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO () -printExpr = print . reifySmart (const True) canShareDict - --- | Show the syntax tree using Unicode art -showAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String -showAST = Syntactic.showAST . reifySmart (const True) canShareDict - -showAST2 :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String -showAST2 = Syntactic.showAST . reifySmart2 (const True) canShareDict - --- | Draw the syntax tree on the terminal using Unicode art -drawAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO () -drawAST = Syntactic.drawAST . reifySmart (const True) canShareDict - --- | Write the syntax tree to an HTML file with foldable nodes -writeHtmlAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO () -writeHtmlAST = Syntactic.writeHtmlAST "tree.html" . desugar - --- | Evaluation -eval :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> Internal a -eval = evalBind . reifySmart (const True) canShareDict - -eval2 :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> Internal a -eval2 = evalBind . reifySmart2 (const True) canShareDict2 - - - --------------------------------------------------------------------------------- --- * Core library --------------------------------------------------------------------------------- - --- | Literal -value :: Syntax a => Internal a -> a -value = sugarSymC . Literal - -false :: Data Bool -false = value False - -true :: Data Bool -true = value True - --- | For types containing some kind of \"thunk\", this function can be used to --- force computation -force :: Syntax a => a -> a -force = resugar - --- | Share a value using let binding -share :: (Syntax a, Syntax b) => a -> (a -> b) -> b -share = sugarSymC Let - --- | Alpha equivalence -instance Type a => Eq (Data a) - where - Data a == Data b = alphaEq (reify a) (reify b) - -instance Type a => Show (Data a) - where - show (Data a) = render $ reify a - -instance (Type a, Num a) => Num (Data a) - where - fromInteger = value . fromInteger - abs = sugarSymC $ Construct "abs" abs - signum = sugarSymC $ Construct "signum" signum - (+) = sugarSymC $ Construct "(+)" (+) - (-) = sugarSymC $ Construct "(-)" (-) - (*) = sugarSymC $ Construct "(*)" (*) - -(?) :: Syntax a => Data Bool -> (a,a) -> a -cond ? (t,e) = sugarSymC Condition cond t e - --- | Parallel array -parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a] -parallel = sugarSymC Parallel - -forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st -forLoop = sugarSymC ForLoop - -arrLength :: Type a => Data [a] -> Data Length -arrLength = sugarSymC $ Construct "arrLength" Prelude.length - --- | Array indexing -getIx :: Type a => Data [a] -> Data Index -> Data a -getIx = sugarSymC $ Construct "getIx" eval - where - eval as i - | i >= len || i < 0 = error "getIx: index out of bounds" - | otherwise = as !! i - where - len = Prelude.length as - -not :: Data Bool -> Data Bool -not = sugarSymC $ Construct "not" Prelude.not - -(==) :: Type a => Data a -> Data a -> Data Bool -(==) = sugarSymC $ Construct "(==)" (Prelude.==) - -max :: Type a => Data a -> Data a -> Data a -max = sugarSymC $ Construct "max" Prelude.max - -min :: Type a => Data a -> Data a -> Data a -min = sugarSymC $ Construct "min" Prelude.min diff --git a/examples/NanoFeldspar/Extra.hs b/examples/NanoFeldspar/Extra.hs deleted file mode 100644 --- a/examples/NanoFeldspar/Extra.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -module NanoFeldspar.Extra where - - - -import Control.Monad.State -import Data.Typeable - -import Language.Syntactic as Syntactic -import Language.Syntactic.Constructs.Binding -import Language.Syntactic.Constructs.Binding.HigherOrder -import Language.Syntactic.Constructs.Binding.Optimize -import Language.Syntactic.Constructs.Construct -import Language.Syntactic.Constructs.Literal -import Language.Syntactic.Sharing.SimpleCodeMotion -import Language.Syntactic.Sharing.Graph -import Language.Syntactic.Sharing.ReifyHO - -import NanoFeldspar.Core - - - --------------------------------------------------------------------------------- --- * Graph reification --------------------------------------------------------------------------------- - --- | A predicate deciding which constructs can be shared. Variables, lambdas and literals are not --- shared. -canShare2 :: ASTF (HODomain FeldSyms Typeable Top) a -> Bool -canShare2 (prjP (P::P (Variable :|| Top)) -> Just _) = False -canShare2 (prjP (P::P (HOLambda FeldSyms Typeable Top)) -> Just _) = False -canShare2 (prj -> Just (Literal _)) = False -canShare2 _ = True - --- | Draw the syntax graph after common sub-expression elimination -drawCSE :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO () -drawCSE a = do - (g,_) <- reifyGraph canShare2 a - drawASG - $ reindexNodesFrom0 - $ inlineSingle - $ cse - $ g - --- | Draw the syntax graph after observing sharing -drawObs :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO () -drawObs a = do - (g,_) <- reifyGraph canShare2 a - drawASG - $ reindexNodesFrom0 - $ inlineSingle - $ g - - - --------------------------------------------------------------------------------- --- * Simplification/constant folding --------------------------------------------------------------------------------- - -instance Optimize ForLoop - where - {-# SPECIALIZE instance Optimize ForLoop #-} - {-# INLINABLE optimizeSym #-} - optimizeSym = optimizeSymDefault - -instance Optimize Parallel - where - {-# SPECIALIZE instance Optimize Parallel #-} - {-# INLINABLE optimizeSym #-} - optimizeSym = optimizeSymDefault - -constFold :: forall a - . ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) a - -> a - -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) a -constFold expr a = match (\sym _ -> case sym of - C' (InjR (InjR (InjR (C (C' _))))) -> injC (Literal a) - _ -> expr - ) expr - -reifySimp :: (Syntactic a, Domain a ~ FeldDomainAll) => - a -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) (Internal a) -reifySimp = flip evalState 0 . - ( codeMotion (const True) prjDictFO canShareDict - . optimize constFold - <=< reifyM - . desugar - ) - -drawSimp :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO () -drawSimp = Syntactic.drawAST . reifySimp diff --git a/examples/NanoFeldspar/Test.hs b/examples/NanoFeldspar/Test.hs deleted file mode 100644 --- a/examples/NanoFeldspar/Test.hs +++ /dev/null @@ -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 - diff --git a/examples/NanoFeldspar/Vector.hs b/examples/NanoFeldspar/Vector.hs deleted file mode 100644 --- a/examples/NanoFeldspar/Vector.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | A simple vector library for NanoFeldspar. The intention of this module is --- to demonstrate how to add language features without extending the underlying --- core language. By declaring 'Vector' as syntactic sugar, vector operations --- can work seamlessly with the functions of the core language. --- --- An interesting aspect of the 'Vector' interface is that the only operation --- that produces a core language array (i.e. allocates memory) is 'freezeVector' --- (which uses 'parallel'). This means that expressions not involving --- 'freezeVector' are guaranteed to be fused. (Note, however, that --- 'freezeVector' is introduced by 'desugar', which in turn is used by many --- other functions.) - -module NanoFeldspar.Vector where - - - -import Prelude hiding (length, map, (==), max, min, reverse, sum, unzip, zip, zipWith) - -import Language.Syntactic (Syntactic (..), resugar) - -import NanoFeldspar.Core - - - -data Vector a - where - Indexed :: Data Length -> (Data Index -> a) -> Vector a - -instance Syntax a => Syntactic (Vector a) - where - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (Vector a) = FeldDomainAll - type Internal (Vector a) = [Internal a] - desugar = desugar . freezeVector . map resugar - sugar = map resugar . unfreezeVector . sugar - - - -length :: Vector a -> Data Length -length (Indexed len _) = len - -indexed :: Data Length -> (Data Index -> a) -> Vector a -indexed = Indexed - -index :: Vector a -> Data Index -> a -index (Indexed _ ixf) = ixf - -(!) :: Vector a -> Data Index -> a -Indexed _ ixf ! i = ixf i - -infixl 9 ! - -freezeVector :: Type a => Vector (Data a) -> Data [a] -freezeVector vec = parallel (length vec) (index vec) - -unfreezeVector :: Type a => Data [a] -> Vector (Data a) -unfreezeVector arr = Indexed (arrLength arr) (getIx arr) - -zip :: Vector a -> Vector b -> Vector (a,b) -zip a b = indexed (length a `min` length b) (\i -> (index a i, index b i)) - -unzip :: Vector (a,b) -> (Vector a, Vector b) -unzip ab = (indexed len (fst . index ab), indexed len (snd . index ab)) - where - len = length ab - -permute :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a) -permute perm vec = indexed len (index vec . perm len) - where - len = length vec - -reverse :: Vector a -> Vector a -reverse = permute $ \len i -> len-i-1 - -(...) :: Data Index -> Data Index -> Vector (Data Index) -l ... h = indexed (h-l+1) (+l) - -map :: (a -> b) -> Vector a -> Vector b -map f (Indexed len ixf) = Indexed len (f . ixf) - -zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c -zipWith f a b = map (uncurry f) $ zip a b - -fold :: Syntax b => (a -> b -> b) -> b -> Vector a -> b -fold f b (Indexed len ixf) = forLoop len b (\i st -> f (ixf i) st) - -sum :: (Num a, Syntax a) => Vector a -> a -sum = fold (+) 0 - -type Matrix a = Vector (Vector (Data a)) - --- | Transpose of a matrix. Assumes that the number of rows is > 0. -transpose :: Type a => Matrix a -> Matrix a -transpose a = indexed (length (a!0)) $ \k -> indexed (length a) $ \l -> a ! l ! k diff --git a/examples/WellScoped.hs b/examples/WellScoped.hs new file mode 100644 --- /dev/null +++ b/examples/WellScoped.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | This module demonstrates the use of 'WS' terms. In particular, note that 'share' has no +-- constraints on the type @a@ in contrast to the corresponding function in NanoFeldspar. +-- +-- 'WS' terms can be evaluated directly using 'evalClosedWS' and they can be examined by first +-- converting them using the function 'fromWS'. + +module WellScoped where + + + +import Data.Proxy + +import Data.Syntactic +import Data.Syntactic.Functional + +import NanoFeldspar (Arithmetic (..), Let (..)) + + + +type Exp e a = WS (Let :+: Construct) e a + +instance (Num a, Show a) => Num (Exp e a) + where + fromInteger i = smartWS $ Construct (show i') i' + where i' = fromInteger i + (+) = smartWS $ Construct "(+)" (+) + +share :: forall e a b . + Exp e a -> ((forall e' . Ext e' (a,e) => Exp e' a) -> Exp (a,e) b) -> Exp e b +share a f = smartWS Let a $ lamWS f + +ex1 :: Exp e (Int -> Int) +ex1 = lamWS $ \a -> share (a + 4) $ \b -> share (a+b) $ \c -> a+b+c + +test1 = evalClosedWS ex1 5 +test2 = drawAST $ fromWS ex1 + diff --git a/extras/TypeUniverseClosed.hs b/extras/TypeUniverseClosed.hs new file mode 100644 --- /dev/null +++ b/extras/TypeUniverseClosed.hs @@ -0,0 +1,93 @@ +-- | Typed type reification, type-level reasoning and dynamic types +-- +-- This module is meant as a reference for understanding the "Data.Syntactic.TypeUniverse" module. + +module TypeUniverseClosed where + + + +import Data.Constraint + + + +-- | Typed representation of types (reification of type @a@) +data TypeRep a + where + BoolType :: TypeRep Bool + IntType :: TypeRep Int + FloatType :: TypeRep Float + ListType :: TypeRep a -> TypeRep [a] + +-- | Type reification +class Typeable a + where + -- | Reifies type @a@ + typeRep :: TypeRep a + +instance Typeable Bool where typeRep = BoolType +instance Typeable Int where typeRep = IntType +instance Typeable Float where typeRep = FloatType +instance Typeable a => Typeable [a] where typeRep = ListType typeRep + +typeEq :: TypeRep a -> TypeRep b -> Maybe (Dict (a ~ b)) +typeEq BoolType BoolType = Just Dict +typeEq IntType IntType = Just Dict +typeEq FloatType FloatType = Just Dict +typeEq (ListType t1) (ListType t2) = do Dict <- typeEq t1 t2; return Dict +typeEq _ _ = Nothing + +hasTypeable :: TypeRep a -> Dict (Typeable a) +hasTypeable BoolType = Dict +hasTypeable IntType = Dict +hasTypeable FloatType = Dict +hasTypeable (ListType t) | Dict <- hasTypeable t = Dict + +hasEq :: TypeRep a -> Dict (Eq a) +hasEq BoolType = Dict +hasEq IntType = Dict +hasEq FloatType = Dict +hasEq (ListType t) | Dict <- hasEq t = Dict + +hasShow :: TypeRep a -> Dict (Show a) +hasShow BoolType = Dict +hasShow IntType = Dict +hasShow FloatType = Dict +hasShow (ListType t) | Dict <- hasShow t = Dict + +hasNum :: TypeRep a -> Maybe (Dict (Num a)) +hasNum BoolType = Nothing +hasNum IntType = Just Dict +hasNum FloatType = Just Dict +hasNum (ListType t) = Nothing + +-- | Safe cast (does not use @unsafeCoerce@ underneath) +cast :: forall a b . (Typeable a, Typeable b) => a -> Maybe b +cast a = do + Dict <- typeEq (typeRep :: TypeRep a) (typeRep :: TypeRep b) + return a + +typeOf :: Typeable a => a -> TypeRep a +typeOf _ = typeRep + +data Dynamic + where + Dyn :: TypeRep a -> a -> Dynamic + +toDyn :: Typeable a => a -> Dynamic +toDyn = Dyn typeRep + +fromDyn :: Typeable a => Dynamic -> Maybe a +fromDyn (Dyn t a) | Dict <- hasTypeable t = cast a + +instance Eq Dynamic + where + Dyn ta a == Dyn tb b + | Just Dict <- typeEq ta tb + , Dict <- hasEq ta + = a == b + _ == _ = False + +instance Show Dynamic + where + show (Dyn t a) | Dict <- hasShow t = show a + diff --git a/src/Data/DynamicAlt.hs b/src/Data/DynamicAlt.hs deleted file mode 100644 --- a/src/Data/DynamicAlt.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | An alternative to "Data.Dynamic" with a different constraint on 'toDyn' - -module Data.DynamicAlt where - - - -import Data.Dynamic () -import Data.Typeable -import GHC.Exts -import Unsafe.Coerce - -import Data.PolyProxy - - - -data Dynamic = Dynamic TypeRep Any - -toDyn :: forall a b . Typeable (a -> b) => P (a -> b) -> a -> Dynamic -toDyn _ a = case splitTyConApp $ typeOf (undefined :: a -> b) of - (_,[ta,_]) -> Dynamic ta (unsafeCoerce a) - -fromDyn :: Typeable a => Dynamic -> Maybe a -fromDyn (Dynamic t a) - | b <- unsafeCoerce a - , t == typeOf b - = Just b -fromDyn _ = Nothing - diff --git a/src/Data/PolyProxy.hs b/src/Data/PolyProxy.hs deleted file mode 100644 --- a/src/Data/PolyProxy.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Syntactic.hs b/src/Data/Syntactic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic.hs @@ -0,0 +1,18 @@ +-- | The basic parts of the syntactic library + +module Data.Syntactic + ( module Data.Syntactic.Syntax + , module Data.Syntactic.Traversal + , module Data.Syntactic.Interpretation + , module Data.Syntactic.Sugar + , module Data.Syntactic.Decoration + ) where + + + +import Data.Syntactic.Syntax +import Data.Syntactic.Traversal +import Data.Syntactic.Interpretation +import Data.Syntactic.Sugar +import Data.Syntactic.Decoration + diff --git a/src/Data/Syntactic/Decoration.hs b/src/Data/Syntactic/Decoration.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Decoration.hs @@ -0,0 +1,110 @@ +-- | Construct for decorating symbols or expressions with additional information + +module Data.Syntactic.Decoration where + + + +import Data.Tree (Tree (..)) + +import Data.Tree.View + +import Data.Syntactic.Syntax +import Data.Syntactic.Traversal +import Data.Syntactic.Interpretation + + + +-- | Decorating symbols or expressions with additional information +-- +-- One usage of ':&:' is to decorate every node of a syntax tree. This is done +-- simply by changing +-- +-- > AST sym sig +-- +-- to +-- +-- > AST (sym :&: info) sig +data (expr :&: info) sig + where + (:&:) + :: { decorExpr :: expr sig + , decorInfo :: info (DenResult sig) + } + -> (expr :&: info) sig + +instance Project sub sup => Project sub (sup :&: info) + where + prj = prj . decorExpr + +instance Equality expr => Equality (expr :&: info) + where + equal a b = decorExpr a `equal` decorExpr b + hash = hash . decorExpr + +instance Render expr => Render (expr :&: info) + where + renderSym = renderSym . decorExpr + renderArgs args = renderArgs args . decorExpr + +instance StringTree expr => StringTree (expr :&: info) + where + stringTreeSym args = stringTreeSym args . decorExpr + + + +-- | Map over a decoration +mapDecor + :: (sym1 sig -> sym2 sig) + -> (info1 (DenResult sig) -> info2 (DenResult sig)) + -> ((sym1 :&: info1) sig -> (sym2 :&: info2) sig) +mapDecor fs fi (s :&: i) = fs s :&: fi i + +-- | Get the decoration of the top-level node +getDecor :: AST (sym :&: info) sig -> info (DenResult sig) +getDecor (Sym (_ :&: info)) = info +getDecor (f :$ _) = getDecor f + +-- | Update the decoration of the top-level node +updateDecor :: forall info sym a . + (info a -> info a) -> ASTF (sym :&: info) a -> ASTF (sym :&: info) a +updateDecor f = match update + where + update + :: (a ~ DenResult sig) + => (sym :&: info) sig + -> Args (AST (sym :&: info)) sig + -> ASTF (sym :&: info) a + update (a :&: info) args = appArgs (Sym sym) args + where + sym = a :&: (f info) + +-- | Lift a function that operates on expressions with associated information to +-- operate on a ':&:' expression. This function is convenient to use together +-- with e.g. 'queryNodeSimple' when the domain has the form @(sym `:&:` info)@. +liftDecor :: (expr s -> info (DenResult s) -> b) -> ((expr :&: info) s -> b) +liftDecor f (a :&: info) = f a info + +-- | Strip decorations from an 'AST' +stripDecor :: AST (sym :&: info) sig -> AST sym sig +stripDecor (Sym (a :&: _)) = Sym a +stripDecor (f :$ a) = stripDecor f :$ stripDecor a + +-- | Rendering of decorated syntax trees +stringTreeDecor :: forall info sym a . StringTree sym => + (forall a . info a -> String) -> ASTF (sym :&: info) a -> Tree String +stringTreeDecor showInfo a = mkTree [] a + where + mkTree :: [Tree String] -> AST (sym :&: info) sig -> Tree String + mkTree args (Sym (expr :&: info)) = Node infoStr [stringTreeSym args expr] + where + infoStr = "<<" ++ showInfo info ++ ">>" + mkTree args (f :$ a) = mkTree (mkTree [] a : args) f + +-- | Show an decorated syntax tree using ASCII art +showDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> String +showDecorWith showInfo = showTree . stringTreeDecor showInfo + +-- | Print an decorated syntax tree using ASCII art +drawDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> IO () +drawDecorWith showInfo = putStrLn . showDecorWith showInfo + diff --git a/src/Data/Syntactic/Functional.hs b/src/Data/Syntactic/Functional.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Functional.hs @@ -0,0 +1,666 @@ +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Basics for implementing functional EDSLs + +module Data.Syntactic.Functional + ( -- * Syntactic constructs + Name (..) + , Construct (..) + , Binding (..) + , maxLam + , lam + , fromDeBruijn + , BindingT (..) + , maxLamT + , lamT + , BindingDomain (..) + , MONAD (..) + , Remon (..) + , desugarMonad + -- * Alpha-equivalence + , AlphaEnv + , alphaEq' + , alphaEq + -- * Evaluation + , Denotation + , Eval (..) + , evalDen + , DenotationM + , liftDenotationM + , RunEnv + , EvalEnv (..) + , compileSymDefault + , evalOpen + , evalClosed + -- * Well-scoped terms + , Ext (..) + , lookEnv + , BindingWS (..) + , lamWS + , evalOpenWS + , evalClosedWS + , LiftReader + , UnReader + , LowerReader + , ReaderSym (..) + , WS + , fromWS + , smartWS + ) where + + + +import Control.Applicative +import Control.Monad.Cont +import Control.Monad.Reader +import Data.Dynamic +import Data.List (genericIndex) +import Data.Tree + +import Data.Hash (hashInt) +import Data.Proxy +import Safe + +import Data.Syntactic + + + +---------------------------------------------------------------------------------------------------- +-- * Syntactic constructs +---------------------------------------------------------------------------------------------------- + +-- | Generic N-ary syntactic construct +-- +-- 'Construct' gives a quick way to introduce a syntactic construct by giving its name and semantic +-- function. +data Construct a + where + Construct :: Signature sig => String -> Denotation sig -> Construct sig + +instance Render Construct + where + renderSym (Construct name _) = name + renderArgs = renderArgsSmart + +instance Equality Construct + where + equal = equalDefault + hash = hashDefault + +instance StringTree Construct + +-- | Variable name +newtype Name = Name Integer + deriving (Eq, Ord, Num, Enum, Real, Integral) + +instance Show Name + where + show (Name n) = show n + +-- | Variables and binders +data Binding a + where + Var :: Name -> Binding (Full a) + Lam :: Name -> Binding (b :-> Full (a -> b)) + +-- | 'equal' does strict identifier comparison; i.e. no alpha equivalence. +-- +-- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation +-- that enables the following property: +-- +-- @`alphaEq` a b ==> `hash` a == `hash` b@ +instance Equality Binding + where + equal (Var v1) (Var v2) = v1==v2 + equal (Lam v1) (Lam v2) = v1==v2 + equal _ _ = False + + hash (Var _) = hashInt 0 + hash (Lam _) = hashInt 0 + +instance Render Binding + where + renderSym (Var v) = 'v' : show v + renderSym (Lam v) = "Lam v" ++ show v + renderArgs [] (Var v) = 'v' : show v + renderArgs [body] (Lam v) = "(\\" ++ ('v':show v) ++ " -> " ++ body ++ ")" + +instance StringTree Binding + where + stringTreeSym [] (Var v) = Node ('v' : show v) [] + stringTreeSym [body] (Lam v) = Node ("Lam " ++ 'v' : show v) [body] + +-- | Get the highest name bound by the first 'Lam' binders at every path from the root. If the term +-- has /ordered binders/ \[1\], 'maxLam' returns the highest name introduced in the whole term. +-- +-- \[1\] Ordered binders means that the names of 'Lam' nodes are decreasing along every path from +-- the root. +maxLam :: (Binding :<: s) => AST s a -> Name +maxLam (Sym lam :$ _) | Just (Lam v) <- prj lam = v +maxLam (s :$ a) = maxLam s `Prelude.max` maxLam a +maxLam _ = 0 + +-- | Higher-order interface for variable binding +-- +-- Assumptions: +-- +-- * The body @f@ does not inspect its argument. +-- +-- * Applying @f@ to a term with ordered binders results in a term with /ordered binders/ \[1\]. +-- +-- \[1\] Ordered binders means that the names of 'Lam' nodes are decreasing along every path from +-- the root. +-- +-- See \"Using Circular Programs for Higher-Order Syntax\" +-- (ICFP 2013, ). +lam :: (Binding :<: s) => (ASTF s a -> ASTF s b) -> ASTF s (a -> b) +lam f = smartSym (Lam v) body + where + body = f (smartSym (Var v)) + v = succ $ maxLam body + +-- | Convert from a term with De Bruijn indexes to one with explicit names +-- +-- In the argument term, variable 'Name's are treated as De Bruijn indexes, and lambda 'Name's are +-- ignored. (Ideally, one should use a different type for De Bruijn terms.) +fromDeBruijn :: (Binding :<: sym) => ASTF sym a -> ASTF sym a +fromDeBruijn = go [] + where + go :: (Binding :<: sym) => [Name] -> ASTF sym a -> (ASTF sym a) + go vs var | Just (Var i) <- prj var = inj $ Var $ genericIndex vs i + go vs (lam :$ body) | Just (Lam _) <- prj lam = inj (Lam v) :$ body' + where + body' = go (v:vs) body + v = succ $ maxLam body' + -- Same trick as in `lam` + go vs a = gmapT (go vs) a + +-- | Typed variables and binders +data BindingT a + where + VarT :: Typeable a => Name -> BindingT (Full a) + LamT :: Typeable a => Name -> BindingT (b :-> Full (a -> b)) + +-- | 'equal' does strict identifier comparison; i.e. no alpha equivalence. +-- +-- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation +-- that enables the following property: +-- +-- @`alphaEq` a b ==> `hash` a == `hash` b@ +instance Equality BindingT + where + equal (VarT v1) (VarT v2) = v1==v2 + equal (LamT v1) (LamT v2) = v1==v2 + equal _ _ = False + + hash (VarT _) = hashInt 0 + hash (LamT _) = hashInt 0 + +instance Render BindingT + where + renderSym (VarT v) = renderSym (Var v) + renderSym (LamT v) = renderSym (Lam v) + renderArgs args (VarT v) = renderArgs args (Var v) + renderArgs args (LamT v) = renderArgs args (Lam v) + +instance StringTree BindingT + where + stringTreeSym args (VarT v) = stringTreeSym args (Var v) + stringTreeSym args (LamT v) = stringTreeSym args (Lam v) + +-- | Get the highest name bound by the first 'LamT' binders at every path from the root. If the term +-- has /ordered binders/ \[1\], 'maxLamT' returns the highest name introduced in the whole term. +-- +-- \[1\] Ordered binders means that the names of 'LamT' nodes are decreasing along every path from +-- the root. +maxLamT :: (BindingT :<: s) => AST s a -> Name +maxLamT (Sym lam :$ _) | Just (LamT n :: BindingT (b :-> a)) <- prj lam = n +maxLamT (s :$ a) = maxLamT s `Prelude.max` maxLamT a +maxLamT _ = 0 + +-- | Higher-order interface for typed variable binding +-- +-- Assumptions: +-- +-- * The body @f@ does not inspect its argument. +-- +-- * Applying @f@ to a term with ordered binders results in a term with /ordered binders/ \[1\]. +-- +-- \[1\] Ordered binders means that the names of 'LamT' nodes are decreasing along every path from +-- the root. +-- +-- See \"Using Circular Programs for Higher-Order Syntax\" +-- (ICFP 2013, ). +lamT :: forall s a b . (BindingT :<: s, Typeable a) => (ASTF s a -> ASTF s b) -> ASTF s (a -> b) +lamT f = smartSym (LamT v :: BindingT (b :-> Full (a -> b))) body + where + body = f (smartSym (VarT v)) + v = succ $ maxLamT body + +-- | Domains that \"might\" include variables and binders +class BindingDomain sym + where + prVar :: sym sig -> Maybe Name + prLam :: sym sig -> Maybe Name + -- It is in principle possible to replace a constraint `BindingDomain s` by + -- `(Project Binding s, Project BindingT s)`. However, the problem is that one then has to + -- specify the type `t` through a `Proxy`. The `BindingDomain` class gets around this problem. + +instance (BindingDomain sym1, BindingDomain sym2) => BindingDomain (sym1 :+: sym2) + where + prVar (InjL s) = prVar s + prVar (InjR s) = prVar s + prLam (InjL s) = prLam s + prLam (InjR s) = prLam s + +instance BindingDomain sym => BindingDomain (sym :&: i) + where + prVar = prVar . decorExpr + prLam = prLam . decorExpr + +instance BindingDomain sym => BindingDomain (AST sym) + where + prVar (Sym s) = prVar s + prVar _ = Nothing + prLam (Sym s) = prLam s + prLam _ = Nothing + +instance BindingDomain Binding + where + prVar (Var v) = Just v + prVar _ = Nothing + prLam (Lam v) = Just v + prLam _ = Nothing + +instance BindingDomain BindingT + where + prVar (VarT v) = Just v + prVar _ = Nothing + prLam (LamT v) = Just v + prLam _ = Nothing + +instance BindingDomain sym + where + prVar _ = Nothing + prLam _ = Nothing + +-- | Monadic constructs +-- +-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011 +-- ). +data MONAD m sig + where + Return :: MONAD m (a :-> Full (m a)) + Bind :: MONAD m (m a :-> (a -> m b) :-> Full (m b)) + +instance Render (MONAD m) + where + renderSym Return = "return" + renderSym Bind = "(>>=)" + renderArgs = renderArgsSmart + +instance Equality (MONAD m) + where + equal = equalDefault + hash = hashDefault + +instance StringTree (MONAD m) + +-- | Reifiable monad +-- +-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011 +-- ). +-- +-- It is advised to convert to/from 'Mon' using the 'Syntactic' instance provided in the modules +-- @Data.Syntactic.Sugar.Monad@ or @Data.Syntactic.Sugar.MonadT@. +newtype Remon sym m a + where + Remon + :: { unRemon :: forall r . (Monad m, MONAD m :<: sym) => Cont (ASTF sym (m r)) a } + -> Remon sym m a + deriving (Functor) + +instance (Applicative m) => Applicative (Remon sym m) + where + pure a = Remon $ pure a + f <*> a = Remon $ unRemon f <*> unRemon a + +instance (Monad m) => Monad (Remon dom m) + where + return a = Remon $ return a + ma >>= f = Remon $ unRemon ma >>= unRemon . f + +-- | One-layer desugaring of monadic actions +desugarMonad :: (MONAD m :<: sym, Monad m) => Remon sym m (ASTF sym a) -> ASTF sym (m a) +desugarMonad = flip runCont (sugarSym Return) . unRemon + + + +---------------------------------------------------------------------------------------------------- +-- * Alpha-equivalence +---------------------------------------------------------------------------------------------------- + +-- | Environment used by 'alphaEq'' +type AlphaEnv = [(Name,Name)] + +alphaEq' :: (Equality sym, BindingDomain sym) => AlphaEnv -> ASTF sym a -> ASTF sym b -> Bool +alphaEq' env var1 var2 + | Just v1 <- prVar var1 + , Just v2 <- prVar var2 + = case lookup v1 env of + Nothing -> v1==v2 -- Free variables + Just v2' -> v2==v2' +alphaEq' env (lam1 :$ body1) (lam2 :$ body2) + | Just v1 <- prLam lam1 + , Just v2 <- prLam lam2 + = alphaEq' ((v1,v2):env) body1 body2 +alphaEq' env a b = simpleMatch (alphaEq'' env b) a + +alphaEq'' :: (Equality sym, BindingDomain sym) => + AlphaEnv -> ASTF sym b -> sym a -> Args (AST sym) a -> Bool +alphaEq'' env b a aArgs = simpleMatch (alphaEq''' env a aArgs) b + +alphaEq''' :: (Equality sym, BindingDomain sym) => + AlphaEnv -> sym a -> Args (AST sym) a -> sym b -> Args (AST sym) b -> Bool +alphaEq''' env a aArgs b bArgs + | equal a b = alphaEqChildren env a' b' + | otherwise = False + where + a' = appArgs (Sym undefined) aArgs + b' = appArgs (Sym undefined) bArgs + +alphaEqChildren :: (Equality sym, BindingDomain sym) => AlphaEnv -> AST sym a -> AST sym b -> Bool +alphaEqChildren _ (Sym _) (Sym _) = True +alphaEqChildren env (s :$ a) (t :$ b) = alphaEqChildren env s t && alphaEq' env a b +alphaEqChildren _ _ _ = False + +-- | Alpha-equivalence +alphaEq :: (Equality sym, BindingDomain sym) => ASTF sym a -> ASTF sym b -> Bool +alphaEq = alphaEq' [] + + + +---------------------------------------------------------------------------------------------------- +-- * Evaluation +---------------------------------------------------------------------------------------------------- + +-- | Semantic function type of the given symbol signature +type family Denotation sig +type instance Denotation (Full a) = a +type instance Denotation (a :-> sig) = a -> Denotation sig + +class Eval s + where + evalSym :: s sig -> Denotation sig + +instance (Eval s, Eval t) => Eval (s :+: t) + where + evalSym (InjL s) = evalSym s + evalSym (InjR s) = evalSym s + +instance Eval Empty + where + evalSym = error "evalSym: Empty" + +instance Eval sym => Eval (sym :&: info) + where + evalSym = evalSym . decorExpr + +instance Eval Construct + where + evalSym (Construct _ d) = d + +instance Monad m => Eval (MONAD m) + where + evalSym Return = return + evalSym Bind = (>>=) + +-- | Evaluation +evalDen :: Eval s => AST s sig -> Denotation sig +evalDen = go + where + go :: Eval s => AST s sig -> Denotation sig + go (Sym s) = evalSym s + go (s :$ a) = go s $ go a + +-- | Monadic denotation; mapping from a symbol signature +-- +-- > a :-> b :-> Full c +-- +-- to +-- +-- > m a -> m b -> m c +type family DenotationM (m :: * -> *) sig +type instance DenotationM m (Full a) = m a +type instance DenotationM m (a :-> sig) = m a -> DenotationM m sig + +-- | Lift a 'Denotation' to 'DenotationM' +liftDenotationM :: forall m sig proxy1 proxy2 . (Monad m, Signature sig) => + proxy1 m -> proxy2 sig -> Denotation sig -> DenotationM m sig +liftDenotationM _ _ = help2 sig . help1 sig + where + sig = signature :: SigRep sig + + help1 :: Monad m => + SigRep sig' -> Denotation sig' -> Args (WrapFull m) sig' -> m (DenResult sig') + help1 SigFull f _ = return f + help1 (SigMore sig) f (WrapFull ma :* as) = do + a <- ma + help1 sig (f a) as + + help2 :: SigRep sig' -> (Args (WrapFull m) sig' -> m (DenResult sig')) -> DenotationM m sig' + help2 SigFull f = f Nil + help2 (SigMore sig) f = \a -> help2 sig (\as -> f (WrapFull a :* as)) + +-- | Runtime environment +type RunEnv = [(Name, Dynamic)] + -- TODO Use a more efficient data structure? + +-- | Evaluation +class EvalEnv sym env + where + compileSym :: proxy env -> sym sig -> DenotationM (Reader env) sig + +instance (EvalEnv sym1 env, EvalEnv sym2 env) => EvalEnv (sym1 :+: sym2) env + where + compileSym p (InjL s) = compileSym p s + compileSym p (InjR s) = compileSym p s + +instance EvalEnv Empty env + where + compileSym = error "compileSym: Empty" + +instance EvalEnv sym env => EvalEnv (sym :&: info) env + where + compileSym p = compileSym p . decorExpr + +instance EvalEnv Construct env + where + compileSym _ s@(Construct _ d :: Construct sig) = liftDenotationM p s d + where + p = Proxy :: Proxy (Reader env) + +instance Monad m => EvalEnv (MONAD m) env + where + compileSym p Return = compileSymDefault p Return + compileSym p Bind = compileSymDefault p Bind + -- Pattern matching on the individual constructors is needed in order to fulfill the + -- 'Signature' constraint required by the right-hand side. + +instance EvalEnv BindingT RunEnv + where + compileSym _ (VarT v) = reader $ \env -> case fromJustNote (msgVar v) $ lookup v env of + d -> fromJustNote msgType $ fromDynamic d + where + msgVar v = "compileSym: Variable " ++ show v ++ " not in scope" + msgType = "compileSym: type error" -- TODO Print types + compileSym _ (LamT v) = \body -> reader $ \env a -> runReader body ((v, toDyn a) : env) + +-- | Simple implementation of `compileSym` from a 'Denotation' +compileSymDefault :: forall proxy env sym sig . (Eval sym, Signature sig) => + proxy env -> sym sig -> DenotationM (Reader env) sig +compileSymDefault p s = liftDenotationM (Proxy :: Proxy (Reader env)) s (evalSym s) + +-- | \"Compile\" a term to a Haskell function +compile :: EvalEnv sym env => proxy env -> AST sym sig -> DenotationM (Reader env) sig +compile p (Sym s) = compileSym p s +compile p (s :$ a) = compile p s $ compile p a + -- This use of the term \"compile\" comes from \"Typing Dynamic Typing\" (Baars and Swierstra, + -- ICFP 2002, ) + +-- | Evaluation of open terms +evalOpen :: EvalEnv sym env => env -> ASTF sym a -> a +evalOpen env a = runReader (compile Proxy a) env + +-- | Evaluation of closed terms where 'RunEnv' is used as the internal environment +-- +-- (Note that there is no guarantee that the term is actually closed.) +evalClosed :: EvalEnv sym RunEnv => ASTF sym a -> a +evalClosed a = runReader (compile (Proxy :: Proxy RunEnv) a) [] + + + +---------------------------------------------------------------------------------------------------- +-- * Well-scoped terms +---------------------------------------------------------------------------------------------------- + +-- | Environment extension +class Ext ext orig + where + -- | Remove the extension of an environment + unext :: ext -> orig + -- | Return the amount by which an environment has been extended + diff :: Num a => Proxy ext -> Proxy orig -> a + +instance Ext env env + where + unext = id + diff _ _ = 0 + +instance (Ext env e, ext ~ (a,env)) => Ext ext e + where + unext = unext . snd + diff m n = diff (fmap snd m) n + 1 + +-- | Lookup in an extended environment +lookEnv :: forall env a e . Ext env (a,e) => Proxy e -> Reader env a +lookEnv _ = reader $ \env -> let (a, e :: e) = unext env in a + +-- | Well-scoped variable binding +-- +-- Well-scoped terms are introduced to be able to evaluate without type casting. The implementation +-- is inspired by \"Typing Dynamic Typing\" (Baars and Swierstra, ICFP 2002, +-- ) where expressions are represented as (essentially) +-- @`Reader` env a@ after \"compilation\". However, a major difference is that +-- \"Typing Dynamic Typing\" starts from an untyped term, and thus needs (safe) dynamic type casting +-- during compilation. In contrast, the denotational semantics of 'BindingWS' (the 'Eval' instance) +-- uses no type casting. +data BindingWS a + where + VarWS :: Ext env (a,e) => Proxy e -> BindingWS (Full (Reader env a)) + LamWS :: BindingWS (Reader (a,e) b :-> Full (Reader e (a -> b))) + +instance Eval BindingWS + where + evalSym (VarWS p) = lookEnv p + evalSym LamWS = \f -> reader $ \e -> \a -> runReader f (a,e) + +-- | Higher-order interface for well-scoped variable binding +-- +-- Inspired by Conor McBride's "I am not a number, I am a classy hack" +-- (). +lamWS :: forall a e sym b . (BindingWS :<: sym) + => ((forall env . (Ext env (a,e)) => ASTF sym (Reader env a)) -> ASTF sym (Reader (a,e) b)) + -> ASTF sym (Reader e (a -> b)) +lamWS f = smartSym LamWS $ f $ smartSym (VarWS (Proxy :: Proxy e)) + +-- | Evaluation of open well-scoped terms +evalOpenWS :: Eval s => env -> ASTF s (Reader env a) -> a +evalOpenWS e = ($ e) . runReader . evalDen + +-- | Evaluation of closed well-scoped terms +evalClosedWS :: Eval s => ASTF s (Reader () a) -> a +evalClosedWS = evalOpenWS () + +-- | Mapping from a symbol signature +-- +-- > a :-> b :-> Full c +-- +-- to +-- +-- > Reader env a :-> Reader env b :-> Full (Reader env c) +type family LiftReader env sig +type instance LiftReader env (Full a) = Full (Reader env a) +type instance LiftReader env (a :-> sig) = Reader env a :-> LiftReader env sig + +type family UnReader a +type instance UnReader (Reader e a) = a + +-- | Mapping from a symbol signature +-- +-- > Reader e a :-> Reader e b :-> Full (Reader e c) +-- +-- to +-- +-- > a :-> b :-> Full c +type family LowerReader sig +type instance LowerReader (Full a) = Full (UnReader a) +type instance LowerReader (a :-> sig) = UnReader a :-> LowerReader sig + +-- | Wrap a symbol to give it a 'LiftReader' signature +data ReaderSym sym a + where + ReaderSym + :: ( Signature sig + , Denotation (LiftReader env sig) ~ DenotationM (Reader env) sig + , LowerReader (LiftReader env sig) ~ sig + ) + => Proxy env + -> sym sig + -> ReaderSym sym (LiftReader env sig) + +instance Eval sym => Eval (ReaderSym sym) + where + evalSym (ReaderSym (_ :: Proxy env) s) = liftDenotationM p s $ evalSym s + where + p = Proxy :: Proxy (Reader env) + +-- | Well-scoped 'AST' +type WS sym env a = ASTF (BindingWS :+: ReaderSym sym) (Reader env a) + +-- | Convert the representation of variables and binders from 'BindingWS' to 'Binding'. The latter +-- is easier to analyze, has a 'Render' instance, etc. +fromWS :: WS sym env a -> ASTF (Binding :+: sym) a +fromWS = fromDeBruijn . go + where + go :: AST (BindingWS :+: ReaderSym sym) sig -> AST (Binding :+: sym) (LowerReader sig) + go (Sym (InjL s@(VarWS p))) = Sym (InjL (Var (diff (mkProxy2 s) (mkProxy1 s p)))) + where + mkProxy1 = (\_ _ -> Proxy) :: BindingWS (Full (Reader e' a)) -> Proxy e -> Proxy (a,e) + mkProxy2 = (\_ -> Proxy) :: BindingWS (Full (Reader e' a)) -> Proxy e' + go (Sym (InjL LamWS)) = Sym $ InjL $ Lam (-1) -- -1 since we're using De Bruijn + go (s :$ a) = go s :$ go a + go (Sym (InjR (ReaderSym _ s))) = Sym $ InjR s + +-- | Make a smart constructor for well-scoped terms. 'smartWS' has any type of the form: +-- +-- > smartWS :: (sub :<: sup, bsym ~ (BindingWS :+: ReaderSym sup)) +-- > => sub (a :-> b :-> ... :-> Full x) +-- > -> ASTF bsym (Reader env a) -> ASTF bsym (Reader env b) -> ... -> ASTF bsym (Reader env x) +smartWS :: forall sig sig' bsym f sub sup env a + . ( Signature sig + , Signature sig' + , sub :<: sup + , bsym ~ (BindingWS :+: ReaderSym sup) + , f ~ SmartFun bsym sig' + , sig' ~ SmartSig f + , bsym ~ SmartSym f + , sig' ~ LiftReader env sig + , Denotation (LiftReader env sig) ~ DenotationM (Reader env) sig + , LowerReader (LiftReader env sig) ~ sig + , Reader env a ~ DenResult sig' + ) + => sub sig -> f +smartWS s = smartSym' $ InjR $ ReaderSym (Proxy :: Proxy env) $ inj s + diff --git a/src/Data/Syntactic/Interpretation.hs b/src/Data/Syntactic/Interpretation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Interpretation.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Equality and rendering of 'AST's + +module Data.Syntactic.Interpretation + ( -- * Equality + Equality (..) + -- * Rendering + , Render (..) + , renderArgsSmart + , render + , StringTree (..) + , stringTree + , showAST + , drawAST + , writeHtmlAST + -- * Default interpretation + , equalDefault + , hashDefault + , interpretationInstances + ) where + + + +import Data.Tree (Tree (..)) +import Language.Haskell.TH + +import Data.Hash (Hash, combine, hashInt) +import qualified Data.Hash as Hash +import Data.Tree.View + +import Data.Syntactic.Syntax + + + +---------------------------------------------------------------------------------------------------- +-- * Equality +---------------------------------------------------------------------------------------------------- + +-- | Higher-kinded equality +class Equality e + where + -- | Higher-kinded equality + -- + -- Comparing elements of different types is often needed when dealing with expressions with + -- existentially quantified sub-terms. + equal :: e a -> e b -> Bool + + -- | Higher-kinded hashing. Elements that are equal according to 'equal' must result in the same + -- hash: + -- + -- @equal a b ==> hash a == hash b@ + hash :: e a -> Hash + +instance Equality sym => Equality (AST sym) + where + equal (Sym s1) (Sym s2) = equal s1 s2 + equal (s1 :$ a1) (s2 :$ a2) = equal s1 s2 && equal a1 a2 + equal _ _ = False + + hash (Sym s) = hashInt 0 `combine` hash s + hash (s :$ a) = hashInt 1 `combine` hash s `combine` hash a + +instance Equality sym => Eq (AST sym a) + where + (==) = equal + +instance (Equality sym1, Equality sym2) => Equality (sym1 :+: sym2) + where + equal (InjL a) (InjL b) = equal a b + equal (InjR a) (InjR b) = equal a b + equal _ _ = False + + hash (InjL a) = hashInt 0 `combine` hash a + hash (InjR a) = hashInt 1 `combine` hash a + +instance (Equality sym1, Equality sym2) => Eq ((sym1 :+: sym2) a) + where + (==) = equal + +instance Equality Empty + where + equal = error "equal: Empty" + hash = error "hash: Empty" + + + +---------------------------------------------------------------------------------------------------- +-- * Rendering +---------------------------------------------------------------------------------------------------- + +-- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym' +-- method. +class Render sym + where + -- | Show a symbol as a 'String' + renderSym :: sym sig -> String + + -- | Render a symbol given a list of rendered arguments + renderArgs :: [String] -> sym sig -> String + renderArgs [] s = renderSym s + renderArgs args s = "(" ++ unwords (renderSym s : args) ++ ")" + +instance (Render sym1, Render sym2) => Render (sym1 :+: sym2) + where + renderSym (InjL s) = renderSym s + renderSym (InjR s) = renderSym s + renderArgs args (InjL s) = renderArgs args s + renderArgs args (InjR s) = renderArgs args s + +-- | Implementation of 'renderArgs' that handles infix operators +renderArgsSmart :: Render sym => [String] -> sym a -> String +renderArgsSmart [] sym = renderSym sym +renderArgsSmart args sym + | isInfix = "(" ++ unwords [a,op,b] ++ ")" + | otherwise = "(" ++ unwords (name : args) ++ ")" + where + name = renderSym sym + [a,b] = args + op = init $ tail name + isInfix + = not (null name) + && head name == '(' + && last name == ')' + && length args == 2 + +-- | Render an 'AST' as concrete syntax +render :: forall sym a. Render sym => ASTF sym a -> String +render = go [] + where + go :: [String] -> AST sym sig -> String + go args (Sym s) = renderArgs args s + go args (s :$ a) = go (render a : args) s + +instance Render Empty + where + renderSym = error "renderSym: Empty" + renderArgs = error "renderArgs: Empty" + +instance Render sym => Show (ASTF sym a) + where + show = render + + + +-- | Convert a symbol to a 'Tree' of strings +class Render sym => StringTree sym + where + -- | Convert a symbol to a 'Tree' given a list of argument trees + stringTreeSym :: [Tree String] -> sym a -> Tree String + stringTreeSym args s = Node (renderSym s) args + +instance (StringTree sym1, StringTree sym2) => StringTree (sym1 :+: sym2) + where + stringTreeSym args (InjL s) = stringTreeSym args s + stringTreeSym args (InjR s) = stringTreeSym args s + +instance StringTree Empty + +-- | Convert an 'AST' to a 'Tree' of strings +stringTree :: forall sym a . StringTree sym => ASTF sym a -> Tree String +stringTree = go [] + where + go :: [Tree String] -> AST sym sig -> Tree String + go args (Sym s) = stringTreeSym args s + go args (s :$ a) = go (stringTree a : args) s + +-- | Show a syntax tree using ASCII art +showAST :: StringTree sym => ASTF sym a -> String +showAST = showTree . stringTree + +-- | Print a syntax tree using ASCII art +drawAST :: StringTree sym => ASTF sym a -> IO () +drawAST = putStrLn . showAST + +-- | Write a syntax tree to an HTML file with foldable nodes +writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO () +writeHtmlAST file = writeHtmlTree file . fmap (\n -> NodeInfo n "") . stringTree + + + +---------------------------------------------------------------------------------------------------- +-- * Default interpretation +---------------------------------------------------------------------------------------------------- + +-- | Default implementation of 'equal' +equalDefault :: Render sym => sym a -> sym b -> Bool +equalDefault a b = renderSym a == renderSym b + +-- | Default implementation of 'hash' +hashDefault :: Render sym => sym a -> Hash +hashDefault = Hash.hash . renderSym + +-- | Derive instances for 'Equality' and 'StringTree' +interpretationInstances :: Name -> DecsQ +interpretationInstances n = + [d| + instance Equality $(typ) where + equal = equalDefault + hash = hashDefault + instance StringTree $(typ) + |] + where + typ = conT n + diff --git a/src/Data/Syntactic/Sugar.hs b/src/Data/Syntactic/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Sugar.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | \"Syntactic sugar\" +-- +-- For details, see "Combining Deep and Shallow Embedding for EDSL" +-- (TFP 2013, ). + +module Data.Syntactic.Sugar where + + + +import Data.Syntactic.Syntax + + + +-- | It is usually assumed that @(`desugar` (`sugar` a))@ has the same meaning +-- as @a@. +class Syntactic a + where + type Domain a :: * -> * + type Internal a + desugar :: a -> ASTF (Domain a) (Internal a) + sugar :: ASTF (Domain a) (Internal a) -> a + +instance Syntactic (ASTF sym a) + where + type Domain (ASTF sym a) = sym + type Internal (ASTF sym a) = a + desugar = id + sugar = id + +-- | Syntactic type casting +resugar :: (Syntactic a, Syntactic b, Domain a ~ Domain b, Internal a ~ Internal b) => a -> b +resugar = sugar . desugar + +-- | N-ary syntactic functions +-- +-- 'desugarN' has any type of the form: +-- +-- > desugarN :: +-- > ( Syntactic a +-- > , Syntactic b +-- > , ... +-- > , Syntactic x +-- > , Domain a ~ sym +-- > , Domain b ~ sym +-- > , ... +-- > , Domain x ~ sym +-- > ) => (a -> b -> ... -> x) +-- > -> ( ASTF sym (Internal a) +-- > -> ASTF sym (Internal b) +-- > -> ... +-- > -> ASTF sym (Internal x) +-- > ) +-- +-- ...and vice versa for 'sugarN'. +class SyntacticN f internal | f -> internal + where + desugarN :: f -> internal + sugarN :: internal -> f + +instance (Syntactic f, Domain f ~ sym, fi ~ AST sym (Full (Internal f))) => SyntacticN f fi + where + desugarN = desugar + sugarN = sugar + +instance + ( Syntactic a + , Domain a ~ sym + , ia ~ Internal a + , SyntacticN f fi + ) => + SyntacticN (a -> f) (AST sym (Full ia) -> fi) + where + desugarN f = desugarN . f . sugar + sugarN f = sugarN . f . desugar + +-- | \"Sugared\" symbol application +-- +-- 'sugarSym' has any type of the form: +-- +-- > sugarSym :: +-- > ( sub :<: AST sup +-- > , Syntactic a +-- > , Syntactic b +-- > , ... +-- > , Syntactic x +-- > , Domain a ~ Domain b ~ ... ~ Domain x +-- > ) => sub (Internal a :-> Internal b :-> ... :-> Full (Internal x)) +-- > -> (a -> b -> ... -> x) +sugarSym + :: ( Signature sig + , fi ~ SmartFun sup sig + , sig ~ SmartSig fi + , sup ~ SmartSym fi + , SyntacticN f fi + , sub :<: sup + ) + => sub sig -> f +sugarSym = sugarN . smartSym + diff --git a/src/Data/Syntactic/Sugar/Binding.hs b/src/Data/Syntactic/Sugar/Binding.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Sugar/Binding.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | 'Syntactic' instance for functions +-- +-- This module is based on having 'Binding' in the domain. For 'BindingT' import module +-- "Data.Syntactic.Sugar.BindingT" instead + +module Data.Syntactic.Sugar.Binding where + + + +import Data.Syntactic +import Data.Syntactic.Functional + + + +instance + ( Syntactic a, Domain a ~ dom + , Syntactic b, Domain b ~ dom + , Binding :<: dom + ) => + Syntactic (a -> b) + where + type Domain (a -> b) = Domain a + type Internal (a -> b) = Internal a -> Internal b + desugar f = lam (desugar . f . sugar) + sugar = error "sugar not implemented for (a -> b)" + diff --git a/src/Data/Syntactic/Sugar/BindingT.hs b/src/Data/Syntactic/Sugar/BindingT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Sugar/BindingT.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | 'Syntactic' instance for functions +-- +-- This module is based on having 'BindingT' in the domain. For 'Binding' import module +-- "Data.Syntactic.Sugar.Binding" instead + +module Data.Syntactic.Sugar.BindingT where + + + +import Data.Typeable + +import Data.Syntactic +import Data.Syntactic.Functional + + + +instance + ( Syntactic a, Domain a ~ dom + , Syntactic b, Domain b ~ dom + , BindingT :<: dom + , Typeable (Internal a) + ) => + Syntactic (a -> b) + where + type Domain (a -> b) = Domain a + type Internal (a -> b) = Internal a -> Internal b + desugar f = lamT (desugar . f . sugar) + sugar = error "sugar not implemented for (a -> b)" + diff --git a/src/Data/Syntactic/Sugar/Monad.hs b/src/Data/Syntactic/Sugar/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Sugar/Monad.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | 'Syntactic' instance for 'Remon' using 'Binding' to handle variable binding + +module Data.Syntactic.Sugar.Monad where + + + +import Control.Monad.Cont + +import Data.Syntactic +import Data.Syntactic.Functional +import Data.Syntactic.Sugar.Binding + + + +-- | One-layer sugaring of monadic actions +sugarMonad :: (Binding :<: sym) => ASTF sym (m a) -> Remon sym m (ASTF sym a) +sugarMonad ma = Remon $ cont $ sugarSym Bind ma + +instance + ( Syntactic a + , Domain a ~ sym + , Binding :<: sym + , MONAD m :<: sym + , Monad m + ) => + Syntactic (Remon sym m a) + where + type Domain (Remon sym m a) = sym + type Internal (Remon sym m a) = m (Internal a) + desugar = desugarMonad . fmap desugar + sugar = fmap sugar . sugarMonad + diff --git a/src/Data/Syntactic/Sugar/MonadT.hs b/src/Data/Syntactic/Sugar/MonadT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Sugar/MonadT.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | 'Syntactic' instance for 'Remon' using 'BindingT' to handle variable binding + +module Data.Syntactic.Sugar.MonadT where + + + +import Control.Monad.Cont +import Data.Typeable + +import Data.Syntactic +import Data.Syntactic.Functional +import Data.Syntactic.Sugar.BindingT + + + +-- | One-layer sugaring of monadic actions +sugarMonad :: (BindingT :<: sym, Typeable a) => ASTF sym (m a) -> Remon sym m (ASTF sym a) +sugarMonad ma = Remon $ cont $ sugarSym Bind ma + +instance + ( Syntactic a + , Domain a ~ sym + , BindingT :<: sym + , MONAD m :<: sym + , Monad m + , Typeable (Internal a) + ) => + Syntactic (Remon sym m a) + where + type Domain (Remon sym m a) = sym + type Internal (Remon sym m a) = m (Internal a) + desugar = desugarMonad . fmap desugar + sugar = fmap sugar . sugarMonad + diff --git a/src/Data/Syntactic/Syntax.hs b/src/Data/Syntactic/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Syntax.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Generic representation of typed syntax trees +-- +-- For details, see: A Generic Abstract Syntax Model for Embedded Languages +-- (ICFP 2012, ). + +module Data.Syntactic.Syntax + ( -- * Syntax trees + AST (..) + , ASTF + , Full (..) + , (:->) (..) + , size + , DenResult + -- Smart constructors + , SigRep (..) + , Signature (..) + , SmartFun + , SmartSig + , SmartSym + , smartSym' + -- * Open symbol domains + , (:+:) (..) + , Project (..) + , (:<:) (..) + , smartSym + , Empty + -- * Existential quantification + , E (..) + , liftE + , liftE2 + , EF (..) + , liftEF + , liftEF2 + -- * Type inference + , symType + , prjP + ) where + + + +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +import Data.Typeable + +import Data.Proxy + + + +-------------------------------------------------------------------------------- +-- * Syntax trees +-------------------------------------------------------------------------------- + +-- | Generic abstract syntax tree, parameterized by a symbol domain +-- +-- @(`AST` sym (a `:->` b))@ represents a partially applied (or unapplied) +-- symbol, missing at least one argument, while @(`AST` sym (`Full` a))@ +-- represents a fully applied symbol, i.e. a complete syntax tree. +data AST sym sig + where + Sym :: sym sig -> AST sym sig + (:$) :: AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig + +infixl 1 :$ + +-- | Fully applied abstract syntax tree +type ASTF sym a = AST sym (Full a) + +instance Functor sym => Functor (AST sym) + where + fmap f (Sym s) = Sym (fmap f s) + fmap f (s :$ a) = fmap (fmap f) s :$ a + +-- | Signature of a fully applied symbol +newtype Full a = Full { result :: a } + deriving (Eq, Show, Typeable, Functor) + +-- | Signature of a partially applied (or unapplied) symbol +newtype a :-> sig = Partial (a -> sig) + deriving (Typeable, Functor) + +infixr :-> + +-- | Count the number of symbols in an 'AST' +size :: AST sym sig -> Int +size (Sym _) = 1 +size (s :$ a) = size s + size a + +-- | The result type of a symbol with the given signature +type family DenResult sig +type instance DenResult (Full a) = a +type instance DenResult (a :-> sig) = DenResult sig + + + +-------------------------------------------------------------------------------- +-- * Smart constructors +-------------------------------------------------------------------------------- + +-- | Witness of the arity of a symbol signature +data SigRep sig + where + SigFull :: SigRep (Full a) + SigMore :: SigRep sig -> SigRep (a :-> sig) + +-- | Symbol signatures +class Signature sig + where + signature :: SigRep sig + +instance Signature (Full a) + where + signature = SigFull + +instance Signature sig => Signature (a :-> sig) + where + signature = SigMore signature + +-- | Maps a symbol signature to the type of the corresponding smart constructor: +-- +-- > SmartFun sym (a :-> b :-> ... :-> Full x) = ASTF sym a -> ASTF sym b -> ... -> ASTF sym x +type family SmartFun (sym :: * -> *) sig +type instance SmartFun sym (Full a) = ASTF sym a +type instance SmartFun sym (a :-> sig) = ASTF sym a -> SmartFun sym sig + +-- | Maps a smart constructor type to the corresponding symbol signature: +-- +-- > SmartSig (ASTF sym a -> ASTF sym b -> ... -> ASTF sym x) = a :-> b :-> ... :-> Full x +type family SmartSig f +type instance SmartSig (AST sym sig) = sig +type instance SmartSig (ASTF sym a -> f) = a :-> SmartSig f + +-- | Returns the symbol in the result of a smart constructor +type family SmartSym f :: * -> * +type instance SmartSym (AST sym sig) = sym +type instance SmartSym (a -> f) = SmartSym f + +-- | Make a smart constructor of a symbol. 'smartSym' has any type of the form: +-- +-- > smartSym +-- > :: sym (a :-> b :-> ... :-> Full x) +-- > -> (ASTF sym a -> ASTF sym b -> ... -> ASTF sym x) +smartSym' :: forall sig f sym + . ( Signature sig + , f ~ SmartFun sym sig + , sig ~ SmartSig f + , sym ~ SmartSym f + ) + => sym sig -> f +smartSym' s = go (signature :: SigRep sig) (Sym s) + where + go :: forall sig . SigRep sig -> AST sym sig -> SmartFun sym sig + go SigFull s = s + go (SigMore sig) s = \a -> go sig (s :$ a) + + + +-------------------------------------------------------------------------------- +-- * Open symbol domains +-------------------------------------------------------------------------------- + +-- | Direct sum of two symbol domains +data (sym1 :+: sym2) a + where + InjL :: sym1 a -> (sym1 :+: sym2) a + InjR :: sym2 a -> (sym1 :+: sym2) a + deriving (Functor, Foldable, Traversable) + +infixr :+: + +-- | Symbol projection +-- +-- The class is defined for /all pairs of types/, but 'prj' can only succeed if @sup@ is of the form +-- @(... `:+:` sub `:+:` ...)@. +class Project sub sup + where + -- | Partial projection from @sup@ to @sub@ + prj :: sup a -> Maybe (sub a) + +instance Project sub sup => Project sub (AST sup) + where + prj (Sym s) = prj s + prj _ = Nothing + +instance Project sym sym + where + prj = Just + +instance Project sym1 (sym1 :+: sym2) + where + prj (InjL a) = Just a + prj _ = Nothing + +instance Project sym1 sym3 => Project sym1 (sym2 :+: sym3) + where + prj (InjR a) = prj a + prj _ = Nothing + +-- | If @sub@ is not in @sup@, 'prj' always returns 'Nothing'. +instance Project sub sup + where + prj _ = Nothing + +-- | Symbol injection +-- +-- The class includes types @sub@ and @sup@ where @sup@ is of the form @(... `:+:` sub `:+:` ...)@. +class Project sub sup => sub :<: sup + where + -- | Injection from @sub@ to @sup@ + inj :: sub a -> sup a + +instance (sub :<: sup) => (sub :<: AST sup) + where + inj = Sym . inj + +instance (sym :<: sym) + where + inj = id + +instance (sym1 :<: (sym1 :+: sym2)) + where + inj = InjL + +instance (sym1 :<: sym3) => (sym1 :<: (sym2 :+: sym3)) + where + inj = InjR . inj + +-- The reason for separating the `Project` and `(:<:)` classes is that there are +-- types that can be instances of the former but not the latter due to type +-- constraints on the `a` type. + +-- | Make a smart constructor of a symbol. 'smartSym' has any type of the form: +-- +-- > smartSym :: (sub :<: AST sup) +-- > => sub (a :-> b :-> ... :-> Full x) +-- > -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x) +smartSym + :: ( Signature sig + , f ~ SmartFun sup sig + , sig ~ SmartSig f + , sup ~ SmartSym f + , sub :<: sup + ) + => sub sig -> f +smartSym = smartSym' . inj + +-- | Empty symbol type +-- +-- Can be used to make uninhabited 'AST' types. It can also be used as a terminator in co-product +-- lists (e.g. to avoid overlapping instances): +-- +-- > (A :+: B :+: Empty) +data Empty :: * -> * + + + +-------------------------------------------------------------------------------- +-- * Existential quantification +-------------------------------------------------------------------------------- + +-- | Existential quantification +data E e + where + E :: e a -> E e + +liftE :: (forall a . e a -> b) -> E e -> b +liftE f (E a) = f a + +liftE2 :: (forall a b . e a -> e b -> c) -> E e -> E e -> c +liftE2 f (E a) (E b) = f a b + +-- | Existential quantification of 'Full'-indexed type +data EF e + where + EF :: e (Full a) -> EF e + +liftEF :: (forall a . e (Full a) -> b) -> EF e -> b +liftEF f (EF a) = f a + +liftEF2 :: (forall a b . e (Full a) -> e (Full b) -> c) -> EF e -> EF e -> c +liftEF2 f (EF a) (EF b) = f a b + + + +-------------------------------------------------------------------------------- +-- * Type inference +-------------------------------------------------------------------------------- + +-- | Constrain a symbol to a specific type +symType :: Proxy sym -> sym sig -> sym sig +symType _ = id + +-- | Projection to a specific symbol type +prjP :: Project sub sup => Proxy sub -> sup sig -> Maybe (sub sig) +prjP _ = prj + diff --git a/src/Data/Syntactic/Traversal.hs b/src/Data/Syntactic/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Syntactic/Traversal.hs @@ -0,0 +1,202 @@ +-- | Generic traversals of 'AST' terms + +module Data.Syntactic.Traversal + ( gmapQ + , gmapT + , everywhereUp + , everywhereDown + , universe + , Args (..) + , listArgs + , mapArgs + , mapArgsA + , mapArgsM + , foldrArgs + , appArgs + , listFold + , match + , simpleMatch + , fold + , simpleFold + , matchTrans + , mapAST + , WrapFull (..) + , toTree + ) where + + + +import Control.Applicative +import Data.Tree + +import Data.Syntactic.Syntax + + + +-- | Map a function over all immediate sub-terms (corresponds to the function +-- with the same name in Scrap Your Boilerplate) +gmapT :: forall sym + . (forall a . ASTF sym a -> ASTF sym a) + -> (forall a . ASTF sym a -> ASTF sym a) +gmapT f a = go a + where + go :: AST sym a -> AST sym a + go (s :$ a) = go s :$ f a + go s = s + +-- | Map a function over all immediate sub-terms, collecting the results in a +-- list (corresponds to the function with the same name in Scrap Your +-- Boilerplate) +gmapQ :: forall sym b + . (forall a . ASTF sym a -> b) + -> (forall a . ASTF sym a -> [b]) +gmapQ f a = go a + where + go :: AST sym a -> [b] + go (s :$ a) = f a : go s + go _ = [] + +-- | Apply a transformation bottom-up over an 'AST' (corresponds to @everywhere@ in Scrap Your +-- Boilerplate) +everywhereUp + :: (forall a . ASTF sym a -> ASTF sym a) + -> (forall a . ASTF sym a -> ASTF sym a) +everywhereUp f = f . gmapT (everywhereUp f) + +-- | Apply a transformation top-down over an 'AST' (corresponds to @everywhere'@ in Scrap Your +-- Boilerplate) +everywhereDown + :: (forall a . ASTF sym a -> ASTF sym a) + -> (forall a . ASTF sym a -> ASTF sym a) +everywhereDown f = gmapT (everywhereDown f) . f + +-- | List all sub-terms (corresponds to @universe@ in Uniplate) +universe :: ASTF sym a -> [EF (AST sym)] +universe a = EF a : go a + where + go :: AST sym a -> [EF (AST sym)] + go (Sym s) = [] + go (s :$ a) = go s ++ universe a + +-- | List of symbol arguments +data Args c sig + where + Nil :: Args c (Full a) + (:*) :: c (Full a) -> Args c sig -> Args c (a :-> sig) + +infixr :* + +-- | Map a function over an 'Args' list and collect the results in an ordinary list +listArgs :: (forall a . c (Full a) -> b) -> Args c sig -> [b] +listArgs f Nil = [] +listArgs f (a :* as) = f a : listArgs f as + +-- | Map a function over an 'Args' list +mapArgs + :: (forall a . c1 (Full a) -> c2 (Full a)) + -> (forall sig . Args c1 sig -> Args c2 sig) +mapArgs f Nil = Nil +mapArgs f (a :* as) = f a :* mapArgs f as + +-- | Map an applicative function over an 'Args' list +mapArgsA :: Applicative f + => (forall a . c1 (Full a) -> f (c2 (Full a))) + -> (forall sig . Args c1 sig -> f (Args c2 sig)) +mapArgsA f Nil = pure Nil +mapArgsA f (a :* as) = (:*) <$> f a <*> mapArgsA f as + +-- | Map a monadic function over an 'Args' list +mapArgsM :: Monad m + => (forall a . c1 (Full a) -> m (c2 (Full a))) + -> (forall sig . Args c1 sig -> m (Args c2 sig)) +mapArgsM f = unwrapMonad . mapArgsA (WrapMonad . f) + +-- | Right fold for an 'Args' list +foldrArgs + :: (forall a . c (Full a) -> b -> b) + -> b + -> (forall sig . Args c sig -> b) +foldrArgs f b Nil = b +foldrArgs f b (a :* as) = f a (foldrArgs f b as) + +-- | Apply a (partially applied) symbol to a list of argument terms +appArgs :: AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig) +appArgs a Nil = a +appArgs s (a :* as) = appArgs (s :$ a) as + +-- | \"Pattern match\" on an 'AST' using a function that gets direct access to +-- the top-most symbol and its sub-trees +match :: forall sym a c + . ( forall sig . (a ~ DenResult sig) => + sym sig -> Args (AST sym) sig -> c (Full a) + ) + -> ASTF sym a + -> c (Full a) +match f a = go a Nil + where + go :: (a ~ DenResult sig) => AST sym sig -> Args (AST sym) sig -> c (Full a) + go (Sym a) as = f a as + go (s :$ a) as = go s (a :* as) + +-- | A version of 'match' with a simpler result type +simpleMatch :: forall sym a b + . (forall sig . (a ~ DenResult sig) => sym sig -> Args (AST sym) sig -> b) + -> ASTF sym a + -> b +simpleMatch f = getConst . match (\s -> Const . f s) + +-- | Fold an 'AST' using an 'Args' list to hold the results of sub-terms +fold :: forall sym c + . (forall sig . sym sig -> Args c sig -> c (Full (DenResult sig))) + -> (forall a . ASTF sym a -> c (Full a)) +fold f = match (\s -> f s . mapArgs (fold f)) + +-- | Simplified version of 'fold' for situations where all intermediate results +-- have the same type +simpleFold :: forall sym b + . (forall sig . sym sig -> Args (Const b) sig -> b) + -> (forall a . ASTF sym a -> b) +simpleFold f = getConst . fold (\s -> Const . f s) + +-- | Fold an 'AST' using a list to hold the results of sub-terms +listFold :: forall sym b + . (forall sig . sym sig -> [b] -> b) + -> (forall a . ASTF sym a -> b) +listFold f = simpleFold (\s -> f s . listArgs getConst) + +newtype WrapAST c sym sig = WrapAST { unWrapAST :: c (AST sym sig) } + -- Only used in the definition of 'matchTrans' + +-- | A version of 'match' where the result is a transformed syntax tree, +-- wrapped in a type constructor @c@ +matchTrans :: forall sym sym' c a + . ( forall sig . (a ~ DenResult sig) => + sym sig -> Args (AST sym) sig -> c (ASTF sym' a) + ) + -> ASTF sym a + -> c (ASTF sym' a) +matchTrans f = unWrapAST . match (\s -> WrapAST . f s) + +-- | Update the symbols in an AST +mapAST :: (forall sig' . sym1 sig' -> sym2 sig') -> AST sym1 sig -> AST sym2 sig +mapAST f (Sym s) = Sym (f s) +mapAST f (s :$ a) = mapAST f s :$ mapAST f a + +-- | Can be used to make an arbitrary type constructor indexed by @(`Full` a)@. +-- This is useful as the type constructor parameter of 'Args'. That is, use +-- +-- > Args (WrapFull c) ... +-- +-- instead of +-- +-- > Args c ... +-- +-- if @c@ is not indexed by @(`Full` a)@. +data WrapFull c a + where + WrapFull :: { unwrapFull :: c a } -> WrapFull c (Full a) + +-- | Convert an 'AST' to a 'Tree' +toTree :: forall dom a b . (forall sig . dom sig -> b) -> ASTF dom a -> Tree b +toTree f = listFold (Node . f) + diff --git a/src/Language/Syntactic.hs b/src/Language/Syntactic.hs deleted file mode 100644 --- a/src/Language/Syntactic.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | The basic parts of the syntactic library - -module Language.Syntactic - ( module Data.PolyProxy - , module Language.Syntactic.Syntax - , module Language.Syntactic.Traversal - , module Language.Syntactic.Constraint - , module Language.Syntactic.Sugar - , module Language.Syntactic.Interpretation - , module Language.Syntactic.Interpretation.Equality - , module Language.Syntactic.Interpretation.Render - , module Language.Syntactic.Interpretation.Evaluation - , module Language.Syntactic.Interpretation.Semantics - , module Data.Constraint - ) where - - - -import Data.PolyProxy -import Language.Syntactic.Syntax -import Language.Syntactic.Traversal -import Language.Syntactic.Constraint -import Language.Syntactic.Sugar -import Language.Syntactic.Interpretation -import Language.Syntactic.Interpretation.Equality -import Language.Syntactic.Interpretation.Render -import Language.Syntactic.Interpretation.Evaluation -import Language.Syntactic.Interpretation.Semantics - -import Data.Constraint (Constraint, Dict (..)) diff --git a/src/Language/Syntactic/Constraint.hs b/src/Language/Syntactic/Constraint.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constraint.hs +++ /dev/null @@ -1,517 +0,0 @@ -{-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ <= 708) -{-# LANGUAGE OverlappingInstances #-} -#endif -{-# LANGUAGE UndecidableInstances #-} -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 800) -{-# LANGUAGE UndecidableSuperClasses #-} -#endif - - --- | Type-constrained syntax trees - -module Language.Syntactic.Constraint where - - - -import Data.Typeable - -import Data.Constraint - -import Data.PolyProxy -import Language.Syntactic.Syntax -import Language.Syntactic.Interpretation.Equality -import Language.Syntactic.Interpretation.Render -import Language.Syntactic.Interpretation.Evaluation - - - --------------------------------------------------------------------------------- --- * Type predicates --------------------------------------------------------------------------------- - --- | Intersection of type predicates -class (c1 a, c2 a) => (c1 :/\: c2) a -instance (c1 a, c2 a) => (c1 :/\: c2) a - where - {-# SPECIALIZE instance (c1 a, c2 a) => (c1 :/\: c2) a #-} - -infixr 5 :/\: - --- | Universal type predicate -class Top a -instance Top a where - {-# SPECIALIZE instance Top a #-} - -pTop :: P Top -pTop = P -{-# INLINABLE pTop #-} - -pTypeable :: P Typeable -pTypeable = P -{-# INLINABLE pTypeable #-} - --- | Evidence that the predicate @sub@ is a subset of @sup@ -type Sub sub sup = forall a . Dict (sub a) -> Dict (sup a) - --- | Weaken an intersection -weakL :: Sub (c1 :/\: c2) c1 -weakL Dict = Dict -{-# INLINABLE weakL #-} - --- | Weaken an intersection -weakR :: Sub (c1 :/\: c2) c2 -weakR Dict = Dict -{-# INLINABLE weakR #-} - --- | Subset relation on type predicates -class (sub :: * -> Constraint) :< (sup :: * -> Constraint) - where - -- | Compute evidence that @sub@ is a subset of @sup@ (i.e. that @(sup a)@ - -- implies @(sub a)@) - sub :: Sub sub sup - -instance p :< p - where - {-# SPECIALIZE instance p :< p #-} - {-# INLINABLE sub #-} - sub = id - -instance (p :/\: ps) :< p - where - {-# SPECIALIZE instance (p :/\: ps) :< p #-} - {-# INLINABLE sub #-} - sub = weakL - -instance (ps :< q) => ((p :/\: ps) :< q) - where - {-# SPECIALIZE instance (ps :< q) => ((p :/\: ps) :< q) #-} - {-# INLINABLE sub #-} - sub = sub . weakR - - - --------------------------------------------------------------------------------- --- * Constrained syntax --------------------------------------------------------------------------------- - --- | Constrain the result type of the expression by the given predicate -data (:|) :: (* -> *) -> (* -> Constraint) -> (* -> *) - where - C :: pred (DenResult sig) => expr sig -> (expr :| pred) sig - -infixl 4 :| - -instance Project sub sup => Project sub (sup :| pred) - where - {-# SPECIALIZE instance (Project sub sup) => Project sub (sup :| pred) #-} - {-# INLINABLE prj #-} - prj (C s) = prj s - -instance Equality dom => Equality (dom :| pred) - where - {-# SPECIALIZE instance (Equality dom) => Equality (dom :| pred) #-} - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (C a) (C b) = equal a b - exprHash (C a) = exprHash a - -instance Render dom => Render (dom :| pred) - where - {-# SPECIALIZE instance (Render dom) => Render (dom :| pred) #-} - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym (C a) = renderSym a - renderArgs args (C a) = renderArgs args a - -instance Eval dom => Eval (dom :| pred) - where - {-# SPECIALIZE instance (Eval dom) => Eval (dom :| pred) #-} - {-# INLINABLE evaluate #-} - evaluate (C a) = evaluate a - -instance StringTree dom => StringTree (dom :| pred) - where - {-# SPECIALIZE instance (StringTree dom) => StringTree (dom :| pred) #-} - {-# INLINABLE stringTreeSym #-} - stringTreeSym args (C a) = stringTreeSym args a - - - --- | Constrain the result type of the expression by the given predicate --- --- The difference between ':||' and ':|' is seen in the instances of the 'Sat' --- type: --- --- > type Sat (dom :| pred) = pred :/\: Sat dom --- > type Sat (dom :|| pred) = pred -data (:||) :: (* -> *) -> (* -> Constraint) -> (* -> *) - where - C' :: pred (DenResult sig) => expr sig -> (expr :|| pred) sig - -infixl 4 :|| - -instance Project sub sup => Project sub (sup :|| pred) - where - {-# SPECIALIZE instance (Project sub sup) => Project sub (sup :|| pred) #-} - {-# INLINABLE prj #-} - prj (C' s) = prj s - -instance Equality dom => Equality (dom :|| pred) - where - {-# SPECIALIZE instance (Equality dom) => Equality (dom :|| pred) #-} - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (C' a) (C' b) = equal a b - exprHash (C' a) = exprHash a - -instance Render dom => Render (dom :|| pred) - where - {-# SPECIALIZE instance (Render dom) => Render (dom :|| pred) #-} - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym (C' a) = renderSym a - renderArgs args (C' a) = renderArgs args a - -instance Eval dom => Eval (dom :|| pred) - where - {-# SPECIALIZE instance (Eval dom) => Eval (dom :|| pred) #-} - {-# INLINABLE evaluate #-} - evaluate (C' a) = evaluate a - -instance StringTree dom => StringTree (dom :|| pred) - where - {-# SPECIALIZE instance (StringTree dom) => StringTree (dom :|| pred) #-} - {-# INLINABLE stringTreeSym #-} - stringTreeSym args (C' a) = stringTreeSym args a - - - --- | Expressions that constrain their result types -class Constrained expr - where - -- | Returns a predicate that is satisfied by the result type of all - -- expressions of the given type (see 'exprDict'). - type Sat expr :: * -> Constraint - - -- | Compute a constraint on the result type of an expression - exprDict :: expr a -> Dict (Sat expr (DenResult a)) - -instance Constrained dom => Constrained (AST dom) - where - {-# SPECIALIZE instance (Constrained dom) => Constrained (AST dom) #-} - {-# INLINABLE exprDict #-} - type Sat (AST dom) = Sat dom - exprDict (Sym s) = exprDict s - exprDict (s :$ _) = exprDict s - -instance Constrained (sub1 :+: sub2) - where - {-# SPECIALIZE instance (Constrained (sub1 :+: sub2)) #-} - {-# INLINABLE exprDict #-} - -- | An over-approximation of the union of @Sat sub1@ and @Sat sub2@ - type Sat (sub1 :+: sub2) = Top - exprDict (InjL _) = Dict - exprDict (InjR _) = Dict - -instance Constrained dom => Constrained (dom :| pred) - where - {-# SPECIALIZE instance (Constrained dom) => Constrained (dom :| pred) #-} - {-# INLINABLE exprDict #-} - type Sat (dom :| pred) = pred :/\: Sat dom - exprDict (C s) = case exprDict s of Dict -> Dict - -instance Constrained (dom :|| pred) - where - {-# SPECIALIZE instance Constrained (dom :|| pred) #-} - {-# INLINABLE exprDict #-} - type Sat (dom :|| pred) = pred - exprDict (C' _) = Dict - -type ConstrainedBy expr p = (Constrained expr, Sat expr :< p) - --- | A version of 'exprDict' that returns a constraint for a particular --- predicate @p@ as long as @(p :< Sat dom)@ holds -exprDictSub :: ConstrainedBy expr p => P p -> expr a -> Dict (p (DenResult a)) -{-# SPECIALIZE INLINE exprDictSub :: (ConstrainedBy expr p) => P p -> expr a -> Dict (p (DenResult a)) #-} -exprDictSub = const $ sub . exprDict - --- | A version of 'exprDict' that works for domains of the form --- @(dom1 :+: dom2)@ as long as @(Sat dom1 ~ Sat dom2)@ holds -exprDictPlus :: (Constrained dom1, Constrained dom2, Sat dom1 ~ Sat dom2) => - AST (dom1 :+: dom2) a -> Dict (Sat dom1 (DenResult a)) -{-# SPECIALIZE INLINE - exprDictPlus :: (Constrained dom1, Constrained dom2, Sat dom1 ~ Sat dom2) - => AST (dom1 :+: dom2) a -> Dict (Sat dom1 (DenResult a)) #-} -exprDictPlus (s :$ _) = exprDictPlus s -exprDictPlus (Sym (InjL a)) = exprDict a -exprDictPlus (Sym (InjR a)) = exprDict a - - - --- | Symbol injection (like ':<:') with constrained result types -class (Project sub sup, Sat sup a) => InjectC sub sup a - where - injC :: (DenResult sig ~ a) => sub sig -> sup sig - -instance (InjectC sub sup a, Sat (AST sup) a) => - InjectC sub (AST sup) a - where -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) - {-# SPECIALIZE instance (InjectC sub sup a, Sat (AST sup) a) => InjectC sub (AST sup) a #-} -#endif -#endif - {-# INLINABLE injC #-} - injC = Sym . injC - -instance (InjectC sub sup a, Sat (sup :| pred) a) => - InjectC sub (sup :| pred) a - where - {-# SPECIALIZE instance (InjectC sub sup a, Sat (sup :| pred) a) => InjectC sub (sup :| pred) a #-} - {-# INLINABLE injC #-} - injC = C . injC - -instance (InjectC sub sup a, Sat (sup :|| pred) a) => - InjectC sub (sup :|| pred) a - where -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) - {-# SPECIALIZE instance (InjectC sub sup a, Sat (sup :|| pred) a) => InjectC sub (sup :|| pred) a #-} -#endif -#endif - {-# INLINABLE injC #-} - injC = C' . injC - -instance (Sat expr a) => InjectC expr expr a - where - {-# SPECIALIZE instance (Sat expr a) => InjectC expr expr a #-} - {-# INLINABLE injC #-} - injC = id - -instance {-# OVERLAPPABLE #-} InjectC expr1 (expr1 :+: expr2) a - where -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) - {-# SPECIALIZE instance InjectC expr1 (expr1 :+: expr2) a #-} -#endif -#endif - {-# INLINABLE injC #-} - injC = InjL - -instance {-# OVERLAPPABLE #-} InjectC expr1 expr3 a => - InjectC expr1 (expr2 :+: expr3) a - where -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) - {-# SPECIALIZE instance InjectC expr1 expr3 a => InjectC expr1 (expr2 :+: expr3) a #-} -#endif -#endif - {-# INLINABLE injC #-} - injC = InjR . injC - - - --- | Generic symbol application --- --- 'appSymC' has any type of the form: --- --- > appSymC :: InjectC expr (AST dom) x --- > => expr (a :-> b :-> ... :-> Full x) --- > -> (ASTF dom a -> ASTF dom b -> ... -> ASTF dom x) -appSymC :: (ApplySym sig f dom, InjectC sym (AST dom) (DenResult sig)) => sym sig -> f -appSymC = appSym' . injC -{-# INLINABLE appSymC #-} - - - --- | Similar to ':||', but rather than constraining the whole result type, it assumes a result --- type of the form @c a@ and constrains the @a@. -data SubConstr1 :: (* -> *) -> (* -> *) -> (* -> Constraint) -> (* -> *) - where - SubConstr1 :: (p a, DenResult sig ~ c a) => dom sig -> SubConstr1 c dom p sig - -instance Constrained dom => Constrained (SubConstr1 c dom p) - where - {-# SPECIALIZE instance Constrained dom => Constrained (SubConstr1 c dom p) #-} - {-# INLINABLE exprDict #-} - type Sat (SubConstr1 c dom p) = Sat dom - exprDict (SubConstr1 s) = exprDict s - -instance Project sub sup => Project sub (SubConstr1 c sup p) - where - {-# SPECIALIZE instance Project sub sup => Project sub (SubConstr1 c sup p) #-} - {-# INLINABLE prj #-} - prj (SubConstr1 s) = prj s - -instance Equality dom => Equality (SubConstr1 c dom p) - where - {-# SPECIALIZE instance Equality dom => Equality (SubConstr1 c dom p) #-} - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (SubConstr1 a) (SubConstr1 b) = equal a b - exprHash (SubConstr1 s) = exprHash s - -instance Render dom => Render (SubConstr1 c dom p) - where - {-# SPECIALIZE instance Render dom => Render (SubConstr1 c dom p) #-} - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym (SubConstr1 s) = renderSym s - renderArgs args (SubConstr1 s) = renderArgs args s - -instance StringTree dom => StringTree (SubConstr1 c dom p) - where - {-# SPECIALIZE instance StringTree dom => StringTree (SubConstr1 c dom p) #-} - {-# INLINABLE stringTreeSym #-} - stringTreeSym args (SubConstr1 a) = stringTreeSym args a - -instance Eval dom => Eval (SubConstr1 c dom p) - where - {-# SPECIALIZE instance Eval dom => Eval (SubConstr1 c dom p) #-} - {-# INLINABLE evaluate #-} - evaluate (SubConstr1 a) = evaluate a - - - --- | Similar to 'SubConstr1', but assumes a result type of the form @c a b@ and constrains both @a@ --- and @b@. -data SubConstr2 :: (* -> * -> *) -> (* -> *) -> (* -> Constraint) -> (* -> Constraint) -> (* -> *) - where - SubConstr2 :: (DenResult sig ~ c a b, pa a, pb b) => dom sig -> SubConstr2 c dom pa pb sig - -instance Constrained dom => Constrained (SubConstr2 c dom pa pb) - where - {-# SPECIALIZE instance Constrained dom => Constrained (SubConstr2 c dom pa pb) #-} - {-# INLINABLE exprDict #-} - type Sat (SubConstr2 c dom pa pb) = Sat dom - exprDict (SubConstr2 s) = exprDict s - -instance Project sub sup => Project sub (SubConstr2 c sup pa pb) - where - {-# SPECIALIZE instance Project sub sup => Project sub (SubConstr2 c sup pa pb) #-} - {-# INLINABLE prj #-} - prj (SubConstr2 s) = prj s - -instance Equality dom => Equality (SubConstr2 c dom pa pb) - where - {-# SPECIALIZE instance Equality dom => Equality (SubConstr2 c dom pa pb) #-} - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (SubConstr2 a) (SubConstr2 b) = equal a b - exprHash (SubConstr2 s) = exprHash s - -instance Render dom => Render (SubConstr2 c dom pa pb) - where - {-# SPECIALIZE instance Render dom => Render (SubConstr2 c dom pa pb) #-} - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym (SubConstr2 s) = renderSym s - renderArgs args (SubConstr2 s) = renderArgs args s - -instance StringTree dom => StringTree (SubConstr2 c dom pa pb) - where - {-# SPECIALIZE instance StringTree dom => StringTree (SubConstr2 c dom pa pb) #-} - {-# INLINABLE stringTreeSym #-} - stringTreeSym args (SubConstr2 a) = stringTreeSym args a - -instance Eval dom => Eval (SubConstr2 c dom pa pb) - where - {-# SPECIALIZE instance Eval dom => Eval (SubConstr2 c dom pa pb) #-} - {-# INLINABLE evaluate #-} - evaluate (SubConstr2 a) = evaluate a - - - --------------------------------------------------------------------------------- --- * Existential quantification --------------------------------------------------------------------------------- - --- | 'AST' with existentially quantified result type -data ASTE :: (* -> *) -> * - where - ASTE :: ASTF dom a -> ASTE dom - -liftASTE - :: (forall a . ASTF dom a -> b) - -> ASTE dom - -> b -liftASTE f (ASTE a) = f a -{-# INLINABLE liftASTE #-} - -liftASTE2 - :: (forall a b . ASTF dom a -> ASTF dom b -> c) - -> ASTE dom -> ASTE dom -> c -liftASTE2 f (ASTE a) (ASTE b) = f a b -{-# INLINABLE liftASTE2 #-} - - - --- | 'AST' with bounded existentially quantified result type -data ASTB :: (* -> *) -> (* -> Constraint) -> * - where - ASTB :: p a => ASTF dom a -> ASTB dom p - -liftASTB - :: (forall a . p a => ASTF dom a -> b) - -> ASTB dom p - -> b -liftASTB f (ASTB a) = f a -{-# INLINABLE liftASTB #-} - -liftASTB2 - :: (forall a b . (p a, p b) => ASTF dom a -> ASTF dom b -> c) - -> ASTB dom p -> ASTB dom p -> c -liftASTB2 f (ASTB a) (ASTB b) = f a b -{-# INLINABLE liftASTB2 #-} - -type ASTSAT dom = ASTB dom (Sat dom) - - - --------------------------------------------------------------------------------- --- * Misc. --------------------------------------------------------------------------------- - --- | Empty symbol type --- --- Use-case: --- --- > data A a --- > data B a --- > --- > test :: AST (A :+: (B:||Eq) :+: Empty) a --- > test = injC (undefined :: (B :|| Eq) a) --- --- Without 'Empty', this would lead to an overlapping instance error due to the instances --- --- > InjectC (B :|| Eq) (B :|| Eq) (DenResult a) --- --- and --- --- > InjectC sub sup a, pred a) => InjectC sub (sup :|| pred) a -data Empty :: * -> * - -instance Constrained Empty - where - type Sat Empty = Top - exprDict = error "Not implemented: exprDict for Empty" - -instance Equality Empty where - equal = error "Not implemented: equal for Empty" - exprHash = error "Not implemented: exprHash for Empty" -instance Eval Empty where - evaluate = error "Not implemented: equal for Empty" -instance Render Empty where - renderSym = error "Not implemented: renderSym for Empty" - renderArgs = error "Not implemented: renderArgs for Empty" -instance StringTree Empty - - - -universe :: ASTF dom a -> [ASTE dom] -universe a = ASTE a : go a - where - go :: AST dom a -> [ASTE dom] - go (Sym _) = [] - go (s :$ b) = go s ++ universe b diff --git a/src/Language/Syntactic/Constructs/Binding.hs b/src/Language/Syntactic/Constructs/Binding.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Binding.hs +++ /dev/null @@ -1,539 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE UndecidableInstances #-} - --- | General binding constructs - -module Language.Syntactic.Constructs.Binding where - - - -import qualified Control.Monad.Identity as Monad -import Control.Monad.Reader -import Data.Ix -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Tree -import Data.Typeable - -import Data.Hash - -import Data.PolyProxy -import Data.DynamicAlt -import Language.Syntactic -import Language.Syntactic.Constructs.Condition -import Language.Syntactic.Constructs.Construct -import Language.Syntactic.Constructs.Decoration -import Language.Syntactic.Constructs.Identity -import Language.Syntactic.Constructs.Literal -import Language.Syntactic.Constructs.Monad -import Language.Syntactic.Constructs.Tuple - - - --------------------------------------------------------------------------------- --- * Variables --------------------------------------------------------------------------------- - --- | Variable identifier -newtype VarId = VarId { varInteger :: Integer } - deriving (Eq, Ord, Num, Real, Integral, Enum, Ix) - -instance Show VarId - where - show (VarId i) = show i - -showVar :: VarId -> String -showVar v = "var" ++ show v - - - --- | Variables -data Variable a - where - Variable :: VarId -> Variable (Full a) - -instance Constrained Variable - where - {-# SPECIALIZE instance Constrained Variable #-} - {-# INLINABLE exprDict #-} - type Sat Variable = Top - exprDict = const Dict - --- | 'equal' does strict identifier comparison; i.e. no alpha equivalence. --- --- 'exprHash' assigns the same hash to all variables. This is a valid --- over-approximation that enables the following property: --- --- @`alphaEq` a b ==> `exprHash` a == `exprHash` b@ -instance Equality Variable - where - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (Variable v1) (Variable v2) = v1==v2 - exprHash (Variable _) = hashInt 0 - -instance Render Variable - where - {-# INLINABLE renderSym #-} - renderSym (Variable v) = showVar v - -instance StringTree Variable - where - {-# INLINABLE stringTreeSym #-} - stringTreeSym [] (Variable v) = Node ("var:" ++ show v) [] - - - --------------------------------------------------------------------------------- --- * Lambda binding --------------------------------------------------------------------------------- - --- | Lambda binding -data Lambda a - where - Lambda :: VarId -> Lambda (b :-> Full (a -> b)) - -instance Constrained Lambda - where - {-# INLINABLE exprDict #-} - type Sat Lambda = Top - exprDict = const Dict - --- | 'equal' does strict identifier comparison; i.e. no alpha equivalence. --- --- 'exprHash' assigns the same hash to all 'Lambda' bindings. This is a valid --- over-approximation that enables the following property: --- --- @`alphaEq` a b ==> `exprHash` a == `exprHash` b@ -instance Equality Lambda - where - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (Lambda v1) (Lambda v2) = v1==v2 - exprHash (Lambda _) = hashInt 0 - -instance Render Lambda - where - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym (Lambda v) = "Lambda " ++ show v - renderArgs [body] (Lambda v) = "(\\" ++ showVar v ++ " -> " ++ body ++ ")" - -instance StringTree Lambda - where - {-# INLINABLE stringTreeSym #-} - stringTreeSym [body] (Lambda v) = Node ("Lambda " ++ show v) [body] - --- | Allow an existing binding to be used with a body of a different type -reuseLambda :: Lambda (b :-> Full (a -> b)) -> Lambda (c :-> Full (a -> c)) -reuseLambda (Lambda v) = Lambda v -{-# INLINABLE reuseLambda #-} - - - --------------------------------------------------------------------------------- --- * Let binding --------------------------------------------------------------------------------- - --- | Let binding --- --- 'Let' is just an application operator with flipped argument order. The argument --- @(a -> b)@ is preferably constructed by 'Lambda'. -data Let a - where - Let :: Let (a :-> (a -> b) :-> Full b) - -instance Constrained Let - where - {-# INLINABLE exprDict #-} - type Sat Let = Top - exprDict = const Dict - -instance Equality Let - where - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal Let Let = True - exprHash Let = hashInt 0 - -instance Render Let - where - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym Let = "Let" - renderArgs [] Let = "Let" - renderArgs [f,a] Let = "(" ++ unwords ["letBind",f,a] ++ ")" - -instance StringTree Let - where - {-# INLINABLE stringTreeSym #-} - stringTreeSym [a,body] Let = case splitAt 7 node of - ("Lambda ", var) -> Node ("Let " ++ var) [a,body'] - _ -> Node "Let" [a,body] - where - Node node ~[body'] = body - -instance Eval Let - where - {-# INLINABLE evaluate #-} - evaluate Let = flip ($) - - - --------------------------------------------------------------------------------- --- * Interpretation --------------------------------------------------------------------------------- - --- | Should be a capture-avoiding substitution, but it is currently not correct. --- --- Note: Variables with a different type than the new expression will be --- silently ignored. -subst :: forall dom a b - . ( ConstrainedBy dom Typeable - , Project Lambda dom - , Project Variable dom - ) - => VarId -- ^ Variable to be substituted - -> ASTF dom a -- ^ Expression to substitute for - -> ASTF dom b -- ^ Expression to substitute in - -> ASTF dom b -subst v new = go - where - go :: AST dom c -> AST dom c - go a@((prj -> Just (Lambda w)) :$ _) - | v==w = a -- Capture - go (f :$ a) = go f :$ go a - go var - | Just (Variable w) <- prj var - , v==w - , Dict <- exprDictSub pTypeable new - , Dict <- exprDictSub pTypeable var - , Just new' <- gcast new - = new' - go a = a - -- TODO Make it correct (may need to alpha-convert `new` before inserting it) - -- TODO Should there be an error if `gcast` fails? (See note in Haddock - -- comment.) - --- | Beta-reduction of an expression. The expression to be reduced is assumed to --- be a `Lambda`. -betaReduce - :: ( ConstrainedBy dom Typeable - , Project Lambda dom - , Project Variable dom - ) - => ASTF dom a -- ^ Argument - -> ASTF dom (a -> b) -- ^ Function to be reduced - -> ASTF dom b -betaReduce new (lam :$ body) - | Just (Lambda v) <- prj lam = subst v new body -{-# INLINABLE betaReduce #-} - - - --- | Evaluation of expressions with variables -class EvalBind sub - where - evalBindSym - :: (EvalBind dom, ConstrainedBy dom Typeable, Typeable (DenResult sig)) - => sub sig - -> Args (AST dom) sig - -> Reader [(VarId,Dynamic)] (DenResult sig) - default evalBindSym - :: (Eval sub, EvalBind dom, ConstrainedBy dom Typeable, Typeable (DenResult sig)) - => sub sig - -> Args (AST dom) sig - -> Reader [(VarId,Dynamic)] (DenResult sig) - evalBindSym = evalBindSymDefault - {-# INLINABLE evalBindSym #-} - -- `(Typeable (DenResult sig))` is required because this dictionary cannot (in - -- general) be obtained from `sub`. It can only be obtained from `dom`, and - -- this is what `evalBindM` does. - -instance (EvalBind sub1, EvalBind sub2) => EvalBind (sub1 :+: sub2) - where - {-# SPECIALIZE instance (EvalBind sub1, EvalBind sub2) => EvalBind (sub1 :+: sub2) #-} - {-# INLINABLE evalBindSym #-} - evalBindSym (InjL a) = evalBindSym a - evalBindSym (InjR a) = evalBindSym a - --- | Evaluation of possibly open expressions -evalBindM :: (EvalBind dom, ConstrainedBy dom Typeable) => - ASTF dom a -> Reader [(VarId,Dynamic)] a -evalBindM a - | Dict <- exprDictSub pTypeable a - = liftM result $ match (\s -> liftM Full . evalBindSym s) a -{-# INLINABLE evalBindM #-} - --- | Evaluation of closed expressions -evalBind :: (EvalBind dom, ConstrainedBy dom Typeable) => ASTF dom a -> a -evalBind = flip runReader [] . evalBindM -{-# INLINABLE evalBind #-} - --- | Apply a symbol denotation to a list of arguments -appDen :: Denotation sig -> Args Monad.Identity sig -> DenResult sig -appDen a Nil = a -appDen f (a :* as) = appDen (f $ result $ Monad.runIdentity a) as -{-# INLINABLE appDen #-} - --- | Convenient default implementation of 'evalBindSym' -evalBindSymDefault - :: (Eval sub, EvalBind dom, ConstrainedBy dom Typeable) - => sub sig - -> Args (AST dom) sig - -> Reader [(VarId,Dynamic)] (DenResult sig) -evalBindSymDefault sym args = do - args' <- mapArgsM (liftM (Monad.Identity . Full) . evalBindM) args - return $ appDen (evaluate sym) args' -{-# INLINABLE evalBindSymDefault #-} - -instance EvalBind dom => EvalBind (dom :| pred) - where - {-# SPECIALIZE instance (EvalBind dom) => EvalBind (dom :| pred) #-} - {-# INLINABLE evalBindSym #-} - evalBindSym (C a) = evalBindSym a - -instance EvalBind dom => EvalBind (dom :|| pred) - where - {-# SPECIALIZE instance (EvalBind dom) => EvalBind (dom :|| pred) #-} - {-# INLINABLE evalBindSym #-} - evalBindSym (C' a) = evalBindSym a - -instance EvalBind dom => EvalBind (SubConstr1 c dom p) - where - {-# SPECIALIZE instance (EvalBind dom) => EvalBind (SubConstr1 c dom p) #-} - {-# INLINABLE evalBindSym #-} - evalBindSym (SubConstr1 a) = evalBindSym a - -instance EvalBind dom => EvalBind (SubConstr2 c dom pa pb) - where - {-# SPECIALIZE instance (EvalBind dom) => EvalBind (SubConstr2 c dom pa pb) #-} - {-# INLINABLE evalBindSym #-} - evalBindSym (SubConstr2 a) = evalBindSym a - -instance EvalBind Empty - where - {-# SPECIALIZE instance EvalBind Empty #-} - evalBindSym = error "Not implemented: evalBindSym for Empty" - -instance EvalBind dom => EvalBind (Decor info dom) - where - {-# SPECIALIZE instance (EvalBind dom) => EvalBind (Decor info dom) #-} - {-# INLINABLE evalBindSym #-} - evalBindSym = evalBindSym . decorExpr - -instance EvalBind Identity where {-# SPECIALIZE instance EvalBind Identity #-} -instance EvalBind Construct where {-# SPECIALIZE instance EvalBind Construct #-} -instance EvalBind Literal where {-# SPECIALIZE instance EvalBind Literal #-} -instance EvalBind Condition where {-# SPECIALIZE instance EvalBind Condition #-} -instance EvalBind Tuple where {-# SPECIALIZE instance EvalBind Tuple #-} -instance EvalBind Select where {-# SPECIALIZE instance EvalBind Select #-} -instance EvalBind Let where {-# SPECIALIZE instance EvalBind Let #-} - -instance Monad m => EvalBind (MONAD m) where - {-# SPECIALIZE instance Monad m => EvalBind (MONAD m) #-} - -instance EvalBind Variable - where - {-# SPECIALIZE instance EvalBind Variable #-} - {-# INLINABLE evalBindSym #-} - evalBindSym (Variable v) _ = do - env <- ask - case lookup v env of - Nothing -> return $ error "evalBind: evaluating free variable" - Just a -> case fromDyn a of - Just b -> return b - _ -> return $ error "evalBind: internal type error" - -instance EvalBind Lambda - where - {-# SPECIALIZE instance EvalBind Lambda #-} - {-# INLINABLE evalBindSym #-} - evalBindSym lam@(Lambda v) (body :* Nil) = do - env <- ask - return - $ \a -> flip runReader ((v, toDyn (funType lam) a):env) - $ evalBindM body - where - funType :: Lambda (b :-> Full (a -> b)) -> P (a -> b) - funType = const P - - - --------------------------------------------------------------------------------- --- * Alpha equivalence --------------------------------------------------------------------------------- - --- | Environments containing a list of variable equivalences -class VarEqEnv a - where - prjVarEqEnv :: a -> [(VarId,VarId)] - modVarEqEnv :: ([(VarId,VarId)] -> [(VarId,VarId)]) -> (a -> a) - -instance VarEqEnv [(VarId,VarId)] - where - {-# INLINABLE prjVarEqEnv #-} - {-# INLINABLE modVarEqEnv #-} - prjVarEqEnv = id - modVarEqEnv = id - --- | Alpha-equivalence -class AlphaEq sub1 sub2 dom env - where - alphaEqSym - :: sub1 a - -> Args (AST dom) a - -> sub2 b - -> Args (AST dom) b - -> Reader env Bool - default alphaEqSym - :: (AlphaEq dom dom dom env, Equality sub2, sub1 ~ sub2) - => sub1 a - -> Args (AST dom) a - -> sub2 b - -> Args (AST dom) b - -> Reader env Bool - alphaEqSym = alphaEqSymDefault - {-# INLINABLE alphaEqSym #-} - -instance (AlphaEq subA1 subB1 dom env, AlphaEq subA2 subB2 dom env) => - AlphaEq (subA1 :+: subA2) (subB1 :+: subB2) dom env - where - {-# SPECIALIZE instance - (AlphaEq subA1 subB1 dom env, AlphaEq subA2 subB2 dom env) => - AlphaEq (subA1 :+: subA2) (subB1 :+: subB2) dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (InjL a) aArgs (InjL b) bArgs = alphaEqSym a aArgs b bArgs - alphaEqSym (InjR a) aArgs (InjR b) bArgs = alphaEqSym a aArgs b bArgs - alphaEqSym _ _ _ _ = return False - -alphaEqM :: AlphaEq dom dom dom env => - ASTF dom a -> ASTF dom b -> Reader env Bool -alphaEqM a b = simpleMatch (alphaEqM2 b) a -{-# INLINABLE alphaEqM #-} - -alphaEqM2 :: AlphaEq dom dom dom env => - ASTF dom b -> dom a -> Args (AST dom) a -> Reader env Bool -alphaEqM2 b a aArgs = simpleMatch (alphaEqSym a aArgs) b -{-# INLINABLE alphaEqM2 #-} - --- | Alpha-equivalence on lambda expressions. Free variables are taken to be --- equivalent if they have the same identifier. -alphaEq :: AlphaEq dom dom dom [(VarId,VarId)] => - ASTF dom a -> ASTF dom b -> Bool -alphaEq a b = flip runReader ([] :: [(VarId,VarId)]) $ alphaEqM a b -{-# INLINABLE alphaEq #-} - -alphaEqSymDefault :: (Equality sub, AlphaEq dom dom dom env) - => sub a - -> Args (AST dom) a - -> sub b - -> Args (AST dom) b - -> Reader env Bool -alphaEqSymDefault a aArgs b bArgs - | equal a b = alphaEqChildren a' b' - | otherwise = return False - where - a' = appArgs (Sym (undefined :: dom a)) aArgs - b' = appArgs (Sym (undefined :: dom b)) bArgs -{-# INLINABLE alphaEqSymDefault #-} - -alphaEqChildren :: AlphaEq dom dom dom env => - AST dom a -> AST dom b -> Reader env Bool -alphaEqChildren (Sym _) (Sym _) = return True -alphaEqChildren (f :$ a) (g :$ b) = liftM2 (&&) - (alphaEqChildren f g) - (alphaEqM a b) -alphaEqChildren _ _ = return False -{-# INLINABLE alphaEqChildren #-} - -instance AlphaEq sub sub dom env => AlphaEq (sub :| pred) (sub :| pred) dom env - where - {-# SPECIALIZE instance (AlphaEq sub sub dom env) => - AlphaEq (sub :| pred) (sub :| pred) dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (C a) aArgs (C b) bArgs = alphaEqSym a aArgs b bArgs - -instance AlphaEq sub sub dom env => AlphaEq (sub :|| pred) (sub :|| pred) dom env - where - {-# SPECIALIZE instance (AlphaEq sub sub dom env) => - AlphaEq (sub :|| pred) (sub :|| pred) dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (C' a) aArgs (C' b) bArgs = alphaEqSym a aArgs b bArgs - -instance AlphaEq sub sub dom env => AlphaEq (SubConstr1 c sub p) (SubConstr1 c sub p) dom env - where - {-# SPECIALIZE instance (AlphaEq sub sub dom env) => - AlphaEq (SubConstr1 c sub p) (SubConstr1 c sub p) dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (SubConstr1 a) aArgs (SubConstr1 b) bArgs = alphaEqSym a aArgs b bArgs - -instance AlphaEq sub sub dom env => - AlphaEq (SubConstr2 c sub pa pb) (SubConstr2 c sub pa pb) dom env - where - {-# SPECIALIZE instance (AlphaEq sub sub dom env) => - AlphaEq (SubConstr2 c sub pa pb) (SubConstr2 c sub pa pb) dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (SubConstr2 a) aArgs (SubConstr2 b) bArgs = alphaEqSym a aArgs b bArgs - -instance AlphaEq Empty Empty dom env - where - {-# SPECIALIZE instance AlphaEq Empty Empty dom env #-} - alphaEqSym = error "Not implemented: alphaEqSym for Empty" - -instance AlphaEq dom dom dom env => AlphaEq Condition Condition dom env where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Condition Condition dom env #-} -instance AlphaEq dom dom dom env => AlphaEq Construct Construct dom env where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Construct Construct dom env #-} -instance AlphaEq dom dom dom env => AlphaEq Identity Identity dom env where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Identity Identity dom env #-} -instance AlphaEq dom dom dom env => AlphaEq Let Let dom env where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Let Let dom env #-} -instance AlphaEq dom dom dom env => AlphaEq Literal Literal dom env where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Literal Literal dom env #-} -instance AlphaEq dom dom dom env => AlphaEq Select Select dom env where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Select Select dom env #-} -instance AlphaEq dom dom dom env => AlphaEq Tuple Tuple dom env where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Tuple Tuple dom env #-} - -instance AlphaEq sub sub dom env => - AlphaEq (Decor info sub) (Decor info sub) dom env - where - {-# SPECIALIZE instance (AlphaEq sub sub dom env) => - AlphaEq (Decor info sub) (Decor info sub) dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym a aArgs b bArgs = - alphaEqSym (decorExpr a) aArgs (decorExpr b) bArgs - -instance (AlphaEq dom dom dom env, Monad m) => AlphaEq (MONAD m) (MONAD m) dom env - where - {-# SPECIALIZE instance (AlphaEq dom dom dom env, Monad m) => - AlphaEq (MONAD m) (MONAD m) dom env #-} - -instance (AlphaEq dom dom dom env, VarEqEnv env) => - AlphaEq Variable Variable dom env - where - {-# SPECIALIZE instance (AlphaEq dom dom dom env, VarEqEnv env) => - AlphaEq Variable Variable dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (Variable v1) _ (Variable v2) _ = do - env <- asks prjVarEqEnv - case lookup v1 env of - Nothing -> return (v1==v2) -- Free variables - Just v2' -> return (v2==v2') - -instance (AlphaEq dom dom dom env, VarEqEnv env) => - AlphaEq Lambda Lambda dom env - where - {-# SPECIALIZE instance (AlphaEq dom dom dom env, VarEqEnv env) => - AlphaEq Lambda Lambda dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (Lambda v1) (body1 :* Nil) (Lambda v2) (body2 :* Nil) = - local (modVarEqEnv ((v1,v2):)) $ alphaEqM body1 body2 diff --git a/src/Language/Syntactic/Constructs/Binding/HigherOrder.hs b/src/Language/Syntactic/Constructs/Binding/HigherOrder.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Binding/HigherOrder.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module provides binding constructs using higher-order syntax and a --- function ('reify') for translating to first-order syntax. Expressions --- constructed using the exported interface (specifically, not introducing --- 'Variable's explicitly) are guaranteed to have well-behaved translation. - -module Language.Syntactic.Constructs.Binding.HigherOrder - ( Variable - , Let (..) - , HOLambda (..) - , HODomain - , FODomain - , CLambda - , IsHODomain (..) - , reifyM - , reifyTop - , reify - ) where - - - -import Control.Monad.State - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding - - - --- | Higher-order lambda binding -data HOLambda dom p pVar a - where - HOLambda - :: (p a, pVar a) - => (ASTF (HODomain dom p pVar) a -> ASTF (HODomain dom p pVar) b) - -> HOLambda dom p pVar (Full (a -> b)) - --- | Adding support for higher-order abstract syntax to a domain -type HODomain dom p pVar = (HOLambda dom p pVar :+: (Variable :|| pVar) :+: dom) :|| p - --- | Equivalent to 'HODomain' (including type constraints), but using a first-order representation --- of binding -type FODomain dom p pVar = (CLambda pVar :+: (Variable :|| pVar) :+: dom) :|| p - --- | 'Lambda' with a constraint on the bound variable type -type CLambda pVar = SubConstr2 (->) Lambda pVar Top - - - --- | An abstraction of 'HODomain' -class IsHODomain dom p pVar | dom -> p pVar - where - lambda :: (p (a -> b), p a, pVar a) => (ASTF dom a -> ASTF dom b) -> ASTF dom (a -> b) - -instance IsHODomain (HODomain dom p pVar) p pVar - where - {-# SPECIALIZE instance IsHODomain (HODomain dom p pVar) p pVar #-} - {-# INLINABLE lambda #-} - lambda = injC . HOLambda - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , IsHODomain dom p pVar - , p (Internal a -> Internal b) - , p (Internal a) - , pVar (Internal a) - ) => - Syntactic (a -> b) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , IsHODomain dom p pVar - , p (Internal a -> Internal b) - , p (Internal a) - , pVar (Internal a) - ) => Syntactic (a -> b) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a -> b) = Domain a - type Internal (a -> b) = Internal a -> Internal b - desugar f = lambda (desugar . f . sugar) - sugar = error "sugar not implemented for (a -> b)" - -- TODO An implementation of sugar would require dom to have some kind of - -- application. Perhaps use `Let` for this? - - - -reifyM :: forall dom p pVar m a - . MonadState VarId m - => AST (HODomain dom p pVar) a -> m (AST (FODomain dom p pVar) a) -reifyM (f :$ a) = liftM2 (:$) (reifyM f) (reifyM a) -reifyM (Sym (C' (InjR a))) = return $ Sym $ C' $ InjR a -reifyM (Sym (C' (InjL (HOLambda f)))) = do - v <- get; put (v+1) - body <- reifyM $ f $ injC $ symType pVar $ C' (Variable v) - return $ injC (symType pLam $ SubConstr2 (Lambda v)) :$ body - where - pVar = P::P (Variable :|| pVar) - pLam = P::P (CLambda pVar) - --- | Translating expressions with higher-order binding to corresponding --- expressions using first-order binding -reifyTop :: AST (HODomain dom p pVar) a -> AST (FODomain dom p pVar) a -reifyTop = flip evalState 0 . reifyM - -- It is assumed that there are no 'Variable' constructors (i.e. no free - -- variables) in the argument. This is guaranteed by the exported interface. - --- | Reify an n-ary syntactic function -reify :: (Syntactic a, Domain a ~ HODomain dom p pVar) => - a -> ASTF (FODomain dom p pVar) (Internal a) -reify = reifyTop . desugar diff --git a/src/Language/Syntactic/Constructs/Binding/Optimize.hs b/src/Language/Syntactic/Constructs/Binding/Optimize.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Binding/Optimize.hs +++ /dev/null @@ -1,165 +0,0 @@ --- | Basic optimization -module Language.Syntactic.Constructs.Binding.Optimize where - --- TODO This module should live somewhere else. - - - -import Control.Monad.Writer -import Data.Set as Set -import Data.Typeable - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding -import Language.Syntactic.Constructs.Binding.HigherOrder -import Language.Syntactic.Constructs.Condition -import Language.Syntactic.Constructs.Construct -import Language.Syntactic.Constructs.Identity -import Language.Syntactic.Constructs.Literal -import Language.Syntactic.Constructs.Tuple - - - --- | Constant folder --- --- Given an expression and the statically known value of that expression, --- returns a (possibly) new expression with the same meaning as the original. --- Typically, the result will be a 'Literal', if the relevant type constraints --- are satisfied. -type ConstFolder dom = forall a . ASTF dom a -> a -> ASTF dom a - --- | Basic optimization -class Optimize sym - where - -- | Bottom-up optimization of an expression. The optimization performed is - -- up to each instance, but the intention is to provide a sensible set of - -- \"always-appropriate\" optimizations. The default implementation - -- 'optimizeSymDefault' does only constant folding. This constant folding - -- uses the set of free variables to know when it's static evaluation is - -- possible. Thus it is possible to help constant folding of other - -- constructs by pruning away parts of the syntax tree that are known not to - -- be needed. For example, by replacing (using ordinary Haskell as an - -- example) - -- - -- > if True then a else b - -- - -- with @a@, we don't need to report the free variables in @b@. This, in - -- turn, can lead to more constant folding higher up in the expression. - optimizeSym - :: Optimize' dom - => ConstFolder dom - -> (sym sig -> AST dom sig) - -> sym sig - -> Args (AST dom) sig - -> Writer (Set VarId) (ASTF dom (DenResult sig)) - optimizeSym = optimizeSymDefault - {-# INLINABLE optimizeSym #-} - - -- The reason for having @dom@ as a class parameter is that many instances - -- need to put additional constraints on @dom@. - -type Optimize' dom = - ( Optimize dom - , EvalBind dom - , AlphaEq dom dom dom [(VarId,VarId)] - , ConstrainedBy dom Typeable - ) - -instance (Optimize sub1, Optimize sub2) => Optimize (sub1 :+: sub2) - where - {-# SPECIALIZE instance (Optimize sub1, Optimize sub2) => - Optimize (sub1 :+: sub2) #-} - {-# INLINABLE optimizeSym #-} - optimizeSym constFold injecter (InjL a) = optimizeSym constFold (injecter . InjL) a - optimizeSym constFold injecter (InjR a) = optimizeSym constFold (injecter . InjR) a - -optimizeM :: Optimize' dom - => ConstFolder dom - -> ASTF dom a - -> Writer (Set VarId) (ASTF dom a) -optimizeM constFold = matchTrans (optimizeSym constFold Sym) - --- | Optimize an expression -optimize :: Optimize' dom => ConstFolder dom -> ASTF dom a -> ASTF dom a -optimize constFold = fst . runWriter . optimizeM constFold - --- | Convenient default implementation of 'optimizeSym' (uses 'evalBind' to --- partially evaluate) -optimizeSymDefault :: Optimize' dom - => ConstFolder dom - -> (sym sig -> AST dom sig) - -> sym sig - -> Args (AST dom) sig - -> Writer (Set VarId) (ASTF dom (DenResult sig)) -optimizeSymDefault constFold injecter sym args = do - (args',vars) <- listen $ mapArgsM (optimizeM constFold) args - let result = appArgs (injecter sym) args' - value = evalBind result - if Set.null vars - then return $ constFold result value - else return result - -instance Optimize dom => Optimize (dom :| p) - where - {-# SPECIALIZE instance Optimize dom => Optimize (dom :| p) #-} - {-# INLINABLE optimizeSym #-} - optimizeSym cf i (C s) args = optimizeSym cf (i . C) s args - -instance Optimize dom => Optimize (dom :|| p) - where - {-# SPECIALIZE instance Optimize dom => Optimize (dom :|| p) #-} - {-# INLINABLE optimizeSym #-} - optimizeSym cf i (C' s) args = optimizeSym cf (i . C') s args - -instance Optimize Empty - where - {-# SPECIALIZE instance Optimize Empty #-} - {-# INLINABLE optimizeSym #-} - optimizeSym _ _ _ _ = error "Not implemented: optimizeSym for Empty" - -instance Optimize dom => Optimize (SubConstr1 c dom p) - where - {-# SPECIALIZE instance Optimize dom => Optimize (SubConstr1 c dom p) #-} - {-# INLINABLE optimizeSym #-} - optimizeSym cf i (SubConstr1 s) args = optimizeSym cf (i . SubConstr1) s args - -instance Optimize dom => Optimize (SubConstr2 c dom pa pb) - where - {-# SPECIALIZE instance Optimize dom => Optimize (SubConstr2 c dom pa pb) #-} - {-# INLINABLE optimizeSym #-} - optimizeSym cf i (SubConstr2 s) args = optimizeSym cf (i . SubConstr2) s args - -instance Optimize Identity where {-# SPECIALIZE instance Optimize Identity #-} -instance Optimize Construct where {-# SPECIALIZE instance Optimize Construct #-} -instance Optimize Literal where {-# SPECIALIZE instance Optimize Literal #-} -instance Optimize Tuple where {-# SPECIALIZE instance Optimize Tuple #-} -instance Optimize Select where {-# SPECIALIZE instance Optimize Select #-} -instance Optimize Let where {-# SPECIALIZE instance Optimize Let #-} - -instance Optimize Condition - where - {-# SPECIALIZE instance Optimize Condition #-} - {-# INLINABLE optimizeSym #-} - optimizeSym constFold injecter cond@Condition args@(c :* t :* e :* Nil) - | Set.null cVars = optimizeM constFold t_or_e - | alphaEq t e = optimizeM constFold t - | otherwise = optimizeSymDefault constFold injecter cond args - where - (c',cVars) = runWriter $ optimizeM constFold c - t_or_e = if evalBind c' then t else e - -instance Optimize Variable - where - {-# SPECIALIZE instance Optimize Variable #-} - {-# INLINABLE optimizeSym #-} - optimizeSym _ injecter var@(Variable v) Nil = do - tell (singleton v) - return (injecter var) - -instance Optimize Lambda - where - {-# SPECIALIZE instance Optimize Lambda #-} - {-# INLINABLE optimizeSym #-} - optimizeSym constFold injecter lam@(Lambda v) (body :* Nil) = do - body' <- censor (delete v) $ optimizeM constFold body - return $ injecter lam :$ body' diff --git a/src/Language/Syntactic/Constructs/Condition.hs b/src/Language/Syntactic/Constructs/Condition.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Condition.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Conditional expressions - -module Language.Syntactic.Constructs.Condition where - - - -import Language.Syntactic - - - -data Condition sig - where - Condition :: Condition (Bool :-> a :-> a :-> Full a) - -instance Constrained Condition - where - {-# SPECIALIZE instance Constrained Condition #-} - {-# INLINABLE exprDict #-} - type Sat Condition = Top - exprDict = const Dict - -instance Semantic Condition - where - {-# SPECIALIZE instance Semantic Condition #-} - {-# INLINABLE semantics #-} - semantics Condition = Sem "condition" (\c t e -> if c then t else e) - -semanticInstances ''Condition diff --git a/src/Language/Syntactic/Constructs/Construct.hs b/src/Language/Syntactic/Constructs/Construct.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Construct.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Provides a simple way to make syntactic constructs for prototyping. Note --- that 'Construct' is quite unsafe as it only uses 'String' to distinguish --- between different constructs. Also, 'Construct' has a very free type that --- allows any number of arguments. - -module Language.Syntactic.Constructs.Construct where - - - -import Language.Syntactic - - - -data Construct sig - where - Construct :: String -> Denotation sig -> Construct sig - -instance Constrained Construct - where - {-# SPECIALIZE instance Constrained Construct #-} - {-# INLINABLE exprDict #-} - type Sat Construct = Top - exprDict = const Dict - -instance Semantic Construct - where - {-# SPECIALIZE instance Semantic Construct #-} - {-# INLINABLE semantics #-} - semantics (Construct name den) = Sem name den - -semanticInstances ''Construct diff --git a/src/Language/Syntactic/Constructs/Decoration.hs b/src/Language/Syntactic/Constructs/Decoration.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Decoration.hs +++ /dev/null @@ -1,149 +0,0 @@ --- | Construct for decorating expressions with additional information - -module Language.Syntactic.Constructs.Decoration where - - - -import Data.Tree (Tree (..)) - -import Data.Tree.View - -import Language.Syntactic - - - --------------------------------------------------------------------------------- --- * Decoration --------------------------------------------------------------------------------- - --- | Decorating symbols with additional information --- --- One usage of 'Decor' is to decorate every node of a syntax tree. This is done --- simply by changing --- --- > AST dom sig --- --- to --- --- > AST (Decor info dom) sig -data Decor info expr sig - where - Decor - :: { decorInfo :: info (DenResult sig) - , decorExpr :: expr sig - } - -> Decor info expr sig - -instance Constrained expr => Constrained (Decor info expr) - where - {-# SPECIALIZE instance (Constrained expr) => Constrained (Decor info expr) #-} - {-# INLINABLE exprDict #-} - type Sat (Decor info expr) = Sat expr - exprDict (Decor _ a) = exprDict a - -instance Project sub sup => Project sub (Decor info sup) - where - {-# SPECIALIZE instance (Project sub sup) => Project sub (Decor info sup) #-} - {-# INLINABLE prj #-} - prj = prj . decorExpr - -instance Equality expr => Equality (Decor info expr) - where - {-# SPECIALIZE instance (Equality expr) => Equality (Decor info expr) #-} - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal a b = decorExpr a `equal` decorExpr b - exprHash = exprHash . decorExpr - -instance Render expr => Render (Decor info expr) - where - {-# SPECIALIZE instance (Render expr) => Render (Decor info expr) #-} - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym = renderSym . decorExpr - renderArgs args = renderArgs args . decorExpr - -instance StringTree expr => StringTree (Decor info expr) - where - {-# SPECIALIZE instance (StringTree expr) => StringTree (Decor info expr) #-} - {-# INLINABLE stringTreeSym #-} - stringTreeSym args = stringTreeSym args . decorExpr - -instance Eval expr => Eval (Decor info expr) - where - {-# SPECIALIZE instance (Eval expr) => Eval (Decor info expr) #-} - {-# INLINABLE evaluate #-} - evaluate = evaluate . decorExpr - - - --- | Get the decoration of the top-level node -getInfo :: AST (Decor info dom) sig -> info (DenResult sig) -getInfo (Sym (Decor info _)) = info -getInfo (f :$ _) = getInfo f -{-# INLINABLE getInfo #-} - --- | Update the decoration of the top-level node -updateDecor :: forall info dom a . - (info a -> info a) -> ASTF (Decor info dom) a -> ASTF (Decor info dom) a -updateDecor f = match update - where - update - :: (a ~ DenResult sig) - => Decor info dom sig - -> Args (AST (Decor info dom)) sig - -> ASTF (Decor info dom) a - update (Decor info a) args = appArgs (Sym sym) args - where - sym = Decor (f info) a - --- | Lift a function that operates on expressions with associated information to --- operate on an 'Decor' expression. This function is convenient to use together --- with e.g. 'queryNodeSimple' when the domain has the form --- @(`Decor` info dom)@. -liftDecor :: (expr s -> info (DenResult s) -> b) -> (Decor info expr s -> b) -liftDecor f (Decor info a) = f a info -{-# INLINABLE liftDecor #-} - --- | Collect the decorations of all nodes -collectInfo :: (forall sig . info sig -> b) -> AST (Decor info dom) a -> [b] -collectInfo coll (Sym (Decor info _)) = [coll info] -collectInfo coll (f :$ a) = collectInfo coll f ++ collectInfo coll a - --- | Rendering of decorated syntax trees -stringTreeDecor :: forall info dom a . (StringTree dom) => - (forall sig. info sig -> String) -> ASTF (Decor info dom) a -> Tree String -stringTreeDecor showInfo = mkTree [] - where - mkTree :: [Tree String] -> AST (Decor info dom) sig -> Tree String - mkTree args (Sym (Decor info expr)) = Node infoStr [stringTreeSym args expr] - where - infoStr = "<<" ++ showInfo info ++ ">>" - mkTree args (f :$ a) = mkTree (mkTree [] a : args) f - --- | Show an decorated syntax tree using ASCII art -showDecorWith :: StringTree dom - => (forall sig. info sig -> String) - -> ASTF (Decor info dom) a -> String -showDecorWith showInfo = showTree . stringTreeDecor showInfo - --- | Print an decorated syntax tree using ASCII art -drawDecorWith :: StringTree dom - => (forall sig. info sig -> String) - -> ASTF (Decor info dom) a -> IO () -drawDecorWith showInfo = putStrLn . showDecorWith showInfo - -writeHtmlDecorWith :: forall info sym a. (StringTree sym) - => (forall sig. info sig -> String) - -> FilePath -> ASTF (Decor info sym) a -> IO () -writeHtmlDecorWith showInfo file = writeHtmlTree Nothing file . mkTree [] - where - mkTree :: [Tree NodeInfo] -> AST (Decor info sym) sig -> Tree NodeInfo - mkTree args (f :$ a) = mkTree (mkTree [] a : args) f - mkTree args (Sym (Decor info expr)) = Node (NodeInfo InitiallyExpanded (renderSym expr) (showInfo info)) args - --- | Strip decorations from an 'AST' -stripDecor :: AST (Decor info dom) sig -> AST dom sig -stripDecor (Sym (Decor _ a)) = Sym a -stripDecor (f :$ a) = stripDecor f :$ stripDecor a -{-# INLINABLE stripDecor #-} diff --git a/src/Language/Syntactic/Constructs/Identity.hs b/src/Language/Syntactic/Constructs/Identity.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Identity.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Identity function - -module Language.Syntactic.Constructs.Identity where - - - -import Language.Syntactic - - - --- | Identity function -data Identity sig - where - Id :: Identity (a :-> Full a) - -instance Constrained Identity - where - {-# SPECIALIZE instance Constrained Identity #-} - {-# INLINABLE exprDict #-} - type Sat Identity = Top - exprDict = const Dict - -instance Semantic Identity - where - {-# SPECIALIZE instance Semantic Identity #-} - {-# INLINABLE semantics #-} - semantics Id = Sem "id" id - -semanticInstances ''Identity diff --git a/src/Language/Syntactic/Constructs/Literal.hs b/src/Language/Syntactic/Constructs/Literal.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Literal.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Literal expressions - -module Language.Syntactic.Constructs.Literal where - - - -import Data.Typeable - -import Data.Hash - -import Language.Syntactic - - - -data Literal sig - where - Literal :: (Eq a, Show a, Typeable a) => a -> Literal (Full a) - -instance Constrained Literal - where - {-# SPECIALIZE instance Constrained Literal #-} - {-# INLINABLE exprDict #-} - type Sat Literal = Eq :/\: Show :/\: Typeable :/\: Top - exprDict (Literal _) = Dict - -instance Equality Literal - where - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - Literal a `equal` Literal b = case cast a of - Just a' -> a'==b - Nothing -> False - - exprHash (Literal a) = hash (show a) - -instance Render Literal - where - {-# INLINABLE renderSym #-} - renderSym (Literal a) = show a - -instance StringTree Literal - -instance Eval Literal - where - {-# SPECIALIZE instance Eval Literal #-} - {-# INLINABLE evaluate #-} - evaluate (Literal a) = a diff --git a/src/Language/Syntactic/Constructs/Monad.hs b/src/Language/Syntactic/Constructs/Monad.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Monad.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | Monadic constructs --- --- This module is based on the paper --- /Generic Monadic Constructs for Embedded Languages/ (Persson et al., IFL 2011 --- ). - -module Language.Syntactic.Constructs.Monad where - - - -import Control.Monad - -import Language.Syntactic - - - -data MONAD m sig - where - Return :: MONAD m (a :-> Full (m a)) - Bind :: MONAD m (m a :-> (a -> m b) :-> Full (m b)) - Then :: MONAD m (m a :-> m b :-> Full (m b)) - When :: MONAD m (Bool :-> m () :-> Full (m ())) - -instance Constrained (MONAD m) - where - {-# SPECIALIZE instance Constrained (MONAD m) #-} - {-# INLINABLE exprDict #-} - type Sat (MONAD m) = Top - exprDict = const Dict - -instance Monad m => Semantic (MONAD m) - where - {-# SPECIALIZE instance (Monad m) => Semantic (MONAD m) #-} - {-# INLINABLE semantics #-} - semantics Return = Sem "return" return - semantics Bind = Sem "bind" (>>=) - semantics Then = Sem "then" (>>) - semantics When = Sem "when" when - -instance Monad m => Equality (MONAD m) where - {-# SPECIALIZE instance (Monad m) => Equality (MONAD m) #-} - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal = equalDefault - exprHash = exprHashDefault -instance Monad m => Render (MONAD m) where - {-# SPECIALIZE instance (Monad m) => Render (MONAD m) #-} - {-# INLINABLE renderSym #-} - renderSym = renderSymDefault -instance Monad m => Eval (MONAD m) where - {-# SPECIALIZE instance (Monad m) => Eval (MONAD m) #-} - {-# INLINABLE evaluate #-} - evaluate = evaluateDefault -instance Monad m => StringTree (MONAD m) where - {-# SPECIALIZE instance (Monad m) => StringTree (MONAD m) #-} - --- | Projection with explicit monad type -prjMonad :: Project (MONAD m) sup => P m -> sup sig -> Maybe (MONAD m sig) -prjMonad _ = prj -{-# INLINABLE prjMonad #-} diff --git a/src/Language/Syntactic/Constructs/Tuple.hs b/src/Language/Syntactic/Constructs/Tuple.hs deleted file mode 100644 --- a/src/Language/Syntactic/Constructs/Tuple.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Construction and elimination of tuples in the object language - -module Language.Syntactic.Constructs.Tuple where - - - -import Data.Tuple.Select - -import Language.Syntactic - - - --------------------------------------------------------------------------------- --- * Construction --------------------------------------------------------------------------------- - --- | Expressions for constructing tuples -data Tuple sig - where - Tup2 :: Tuple (a :-> b :-> Full (a,b)) - Tup3 :: Tuple (a :-> b :-> c :-> Full (a,b,c)) - Tup4 :: Tuple (a :-> b :-> c :-> d :-> Full (a,b,c,d)) - Tup5 :: Tuple (a :-> b :-> c :-> d :-> e :-> Full (a,b,c,d,e)) - Tup6 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> Full (a,b,c,d,e,f)) - Tup7 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> Full (a,b,c,d,e,f,g)) - Tup8 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> Full (a,b,c,d,e,f,g,h)) - Tup9 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> Full (a,b,c,d,e,f,g,h,i)) - Tup10 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> Full (a,b,c,d,e,f,g,h,i,j)) - Tup11 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> Full (a,b,c,d,e,f,g,h,i,j,k)) - Tup12 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> Full (a,b,c,d,e,f,g,h,i,j,k,l)) - Tup13 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> m :-> Full (a,b,c,d,e,f,g,h,i,j,k,l,m)) - Tup14 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> m :-> n :-> Full (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) - Tup15 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> h :-> i :-> j :-> k :-> l :-> m :-> n :-> o :-> Full (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) - -instance Constrained Tuple - where - {-# INLINABLE exprDict #-} - type Sat Tuple = Top - exprDict = const Dict - -instance Semantic Tuple - where - {-# INLINABLE semantics #-} - semantics Tup2 = Sem "tup2" (,) - semantics Tup3 = Sem "tup3" (,,) - semantics Tup4 = Sem "tup4" (,,,) - semantics Tup5 = Sem "tup5" (,,,,) - semantics Tup6 = Sem "tup6" (,,,,,) - semantics Tup7 = Sem "tup7" (,,,,,,) - semantics Tup8 = Sem "tup8" (,,,,,,,) - semantics Tup9 = Sem "tup9" (,,,,,,,,) - semantics Tup10 = Sem "tup10" (,,,,,,,,,) - semantics Tup11 = Sem "tup11" (,,,,,,,,,,) - semantics Tup12 = Sem "tup12" (,,,,,,,,,,,) - semantics Tup13 = Sem "tup13" (,,,,,,,,,,,,) - semantics Tup14 = Sem "tup14" (,,,,,,,,,,,,,) - semantics Tup15 = Sem "tup15" (,,,,,,,,,,,,,,) - -semanticInstances ''Tuple - - - --------------------------------------------------------------------------------- --- * Projection --------------------------------------------------------------------------------- - --- | These families ('Sel1'' - 'Sel15'') are needed because of the problem --- described in: --- --- -type family Sel1' a -type instance Sel1' (a,b) = a -type instance Sel1' (a,b,c) = a -type instance Sel1' (a,b,c,d) = a -type instance Sel1' (a,b,c,d,e) = a -type instance Sel1' (a,b,c,d,e,f) = a -type instance Sel1' (a,b,c,d,e,f,g) = a -type instance Sel1' (a,b,c,d,e,f,g,h) = a -type instance Sel1' (a,b,c,d,e,f,g,h,i) = a -type instance Sel1' (a,b,c,d,e,f,g,h,i,j) = a -type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k) = a -type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l) = a -type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l,m) = a -type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = a -type instance Sel1' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = a - -type family Sel2' a -type instance Sel2' (a,b) = b -type instance Sel2' (a,b,c) = b -type instance Sel2' (a,b,c,d) = b -type instance Sel2' (a,b,c,d,e) = b -type instance Sel2' (a,b,c,d,e,f) = b -type instance Sel2' (a,b,c,d,e,f,g) = b -type instance Sel2' (a,b,c,d,e,f,g,h) = b -type instance Sel2' (a,b,c,d,e,f,g,h,i) = b -type instance Sel2' (a,b,c,d,e,f,g,h,i,j) = b -type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k) = b -type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l) = b -type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l,m) = b -type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = b -type instance Sel2' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = b - -type family Sel3' a -type instance Sel3' (a,b,c) = c -type instance Sel3' (a,b,c,d) = c -type instance Sel3' (a,b,c,d,e) = c -type instance Sel3' (a,b,c,d,e,f) = c -type instance Sel3' (a,b,c,d,e,f,g) = c -type instance Sel3' (a,b,c,d,e,f,g,h) = c -type instance Sel3' (a,b,c,d,e,f,g,h,i) = c -type instance Sel3' (a,b,c,d,e,f,g,h,i,j) = c -type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k) = c -type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l) = c -type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l,m) = c -type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = c -type instance Sel3' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = c - -type family Sel4' a -type instance Sel4' (a,b,c,d) = d -type instance Sel4' (a,b,c,d,e) = d -type instance Sel4' (a,b,c,d,e,f) = d -type instance Sel4' (a,b,c,d,e,f,g) = d -type instance Sel4' (a,b,c,d,e,f,g,h) = d -type instance Sel4' (a,b,c,d,e,f,g,h,i) = d -type instance Sel4' (a,b,c,d,e,f,g,h,i,j) = d -type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k) = d -type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l) = d -type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l,m) = d -type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = d -type instance Sel4' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = d - -type family Sel5' a -type instance Sel5' (a,b,c,d,e) = e -type instance Sel5' (a,b,c,d,e,f) = e -type instance Sel5' (a,b,c,d,e,f,g) = e -type instance Sel5' (a,b,c,d,e,f,g,h) = e -type instance Sel5' (a,b,c,d,e,f,g,h,i) = e -type instance Sel5' (a,b,c,d,e,f,g,h,i,j) = e -type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k) = e -type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l) = e -type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l,m) = e -type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = e -type instance Sel5' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = e - -type family Sel6' a -type instance Sel6' (a,b,c,d,e,f) = f -type instance Sel6' (a,b,c,d,e,f,g) = f -type instance Sel6' (a,b,c,d,e,f,g,h) = f -type instance Sel6' (a,b,c,d,e,f,g,h,i) = f -type instance Sel6' (a,b,c,d,e,f,g,h,i,j) = f -type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k) = f -type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l) = f -type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l,m) = f -type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = f -type instance Sel6' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = f - -type family Sel7' a -type instance Sel7' (a,b,c,d,e,f,g) = g -type instance Sel7' (a,b,c,d,e,f,g,h) = g -type instance Sel7' (a,b,c,d,e,f,g,h,i) = g -type instance Sel7' (a,b,c,d,e,f,g,h,i,j) = g -type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k) = g -type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l) = g -type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l,m) = g -type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = g -type instance Sel7' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = g - -type family Sel8' a -type instance Sel8' (a,b,c,d,e,f,g,h) = h -type instance Sel8' (a,b,c,d,e,f,g,h,i) = h -type instance Sel8' (a,b,c,d,e,f,g,h,i,j) = h -type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k) = h -type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l) = h -type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l,m) = h -type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = h -type instance Sel8' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = h - -type family Sel9' a -type instance Sel9' (a,b,c,d,e,f,g,h,i) = i -type instance Sel9' (a,b,c,d,e,f,g,h,i,j) = i -type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k) = i -type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l) = i -type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l,m) = i -type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = i -type instance Sel9' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = i - -type family Sel10' a -type instance Sel10' (a,b,c,d,e,f,g,h,i,j) = j -type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k) = j -type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l) = j -type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l,m) = j -type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = j -type instance Sel10' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = j - -type family Sel11' a -type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k) = k -type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l) = k -type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l,m) = k -type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = k -type instance Sel11' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = k - -type family Sel12' a -type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l) = l -type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l,m) = l -type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = l -type instance Sel12' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = l - -type family Sel13' a -type instance Sel13' (a,b,c,d,e,f,g,h,i,j,k,l,m) = m -type instance Sel13' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = m -type instance Sel13' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = m - -type family Sel14' a -type instance Sel14' (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = n -type instance Sel14' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = n - -type family Sel15' a -type instance Sel15' (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = o - --- | Expressions for selecting elements of a tuple -data Select a - where - Sel1 :: (Sel1 a b, Sel1' a ~ b) => Select (a :-> Full b) - Sel2 :: (Sel2 a b, Sel2' a ~ b) => Select (a :-> Full b) - Sel3 :: (Sel3 a b, Sel3' a ~ b) => Select (a :-> Full b) - Sel4 :: (Sel4 a b, Sel4' a ~ b) => Select (a :-> Full b) - Sel5 :: (Sel5 a b, Sel5' a ~ b) => Select (a :-> Full b) - Sel6 :: (Sel6 a b, Sel6' a ~ b) => Select (a :-> Full b) - Sel7 :: (Sel7 a b, Sel7' a ~ b) => Select (a :-> Full b) - Sel8 :: (Sel8 a b, Sel8' a ~ b) => Select (a :-> Full b) - Sel9 :: (Sel9 a b, Sel9' a ~ b) => Select (a :-> Full b) - Sel10 :: (Sel10 a b, Sel10' a ~ b) => Select (a :-> Full b) - Sel11 :: (Sel11 a b, Sel11' a ~ b) => Select (a :-> Full b) - Sel12 :: (Sel12 a b, Sel12' a ~ b) => Select (a :-> Full b) - Sel13 :: (Sel13 a b, Sel13' a ~ b) => Select (a :-> Full b) - Sel14 :: (Sel14 a b, Sel14' a ~ b) => Select (a :-> Full b) - Sel15 :: (Sel15 a b, Sel15' a ~ b) => Select (a :-> Full b) - -instance Constrained Select - where - {-# INLINABLE exprDict #-} - type Sat Select = Top - exprDict = const Dict - -instance Semantic Select - where - {-# INLINABLE semantics #-} - semantics Sel1 = Sem "sel1" sel1 - semantics Sel2 = Sem "sel2" sel2 - semantics Sel3 = Sem "sel3" sel3 - semantics Sel4 = Sem "sel4" sel4 - semantics Sel5 = Sem "sel5" sel5 - semantics Sel6 = Sem "sel6" sel6 - semantics Sel7 = Sem "sel7" sel7 - semantics Sel8 = Sem "sel8" sel8 - semantics Sel9 = Sem "sel9" sel9 - semantics Sel10 = Sem "sel10" sel10 - semantics Sel11 = Sem "sel11" sel11 - semantics Sel12 = Sem "sel12" sel12 - semantics Sel13 = Sem "sel13" sel13 - semantics Sel14 = Sem "sel14" sel14 - semantics Sel15 = Sem "sel15" sel15 - -semanticInstances ''Select - --- | Return the selected position, e.g. --- --- > selectPos (Sel3 poly :: Select Poly ((Int,Int,Int,Int) :-> Full Int)) = 3 -selectPos :: Select a -> Int -selectPos Sel1 = 1 -selectPos Sel2 = 2 -selectPos Sel3 = 3 -selectPos Sel4 = 4 -selectPos Sel5 = 5 -selectPos Sel6 = 6 -selectPos Sel7 = 7 -selectPos Sel8 = 8 -selectPos Sel9 = 9 -selectPos Sel10 = 10 -selectPos Sel11 = 11 -selectPos Sel12 = 12 -selectPos Sel13 = 13 -selectPos Sel14 = 14 -selectPos Sel15 = 15 diff --git a/src/Language/Syntactic/Frontend/Monad.hs b/src/Language/Syntactic/Frontend/Monad.hs deleted file mode 100644 --- a/src/Language/Syntactic/Frontend/Monad.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Monadic constructs --- --- This module is based on the paper --- /Generic Monadic Constructs for Embedded Languages/ (Persson et al., IFL 2011 --- ). - -module Language.Syntactic.Frontend.Monad where - - - -import Control.Applicative -import Control.Monad.Cont -import Data.Typeable - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding.HigherOrder -import Language.Syntactic.Constructs.Monad - - - --- TODO Unfortunately, this module hard-codes the use of `Typeable`. The problem is this: Say we --- replace `Typeable` in the definition of `Mon` by a parameter `p`. Then `sugarMonad` will get --- a constraint `p (a -> m r)`. But `r` existentially quantified and can only be constrained in --- the definition of `Mon`. With `Typeable` this works because --- `(Typeable1 m, Typeable a, Typeable r)` implies `Typeable (a -> m r)`. - --- | User interface to embedded monadic programs -newtype Mon dom m a - where - Mon - :: { unMon - :: forall r . (Monad m, Typeable r, InjectC (MONAD m) dom (m r)) - => Cont (ASTF dom (m r)) a - } - -> Mon dom m a - -deriving instance Functor (Mon dom m) - -instance (Monad m) => Monad (Mon dom m) - where - return a = Mon $ return a - ma >>= f = Mon $ unMon ma >>= unMon . f - -instance (Monad m, Applicative m) => Applicative (Mon dom m) - where - pure = return - (<*>) = ap - --- | One-layer desugaring of monadic actions -desugarMonad - :: ( IsHODomain dom Typeable pVar - , InjectC (MONAD m) dom (m a) - , Monad m -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 - , Typeable m -#else - , Typeable1 m -#endif - , Typeable a - ) - => Mon dom m (ASTF dom a) -> ASTF dom (m a) -desugarMonad = flip runCont (sugarSymC Return) . unMon - --- | One-layer sugaring of monadic actions -sugarMonad - :: ( IsHODomain dom Typeable pVar - , Monad m -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 - , Typeable m -#else - , Typeable1 m -#endif - , Typeable a - , pVar a - ) - => ASTF dom (m a) -> Mon dom m (ASTF dom a) -sugarMonad ma = Mon $ cont $ sugarSymC Bind ma - -instance ( Syntactic a, Domain a ~ dom - , IsHODomain dom Typeable pVar - , InjectC (MONAD m) dom (m (Internal a)) - , Monad m -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 - , Typeable m -#else - , Typeable1 m -#endif - , Typeable (Internal a) - , pVar (Internal a) - ) => - Syntactic (Mon dom m a) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , IsHODomain dom Typeable pVar - , InjectC (MONAD m) dom (m (Internal a)) - , Monad m -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 - , Typeable m -#else - , Typeable1 m -#endif - , Typeable (Internal a) - , pVar (Internal a) - ) => Syntactic (Mon dom m a) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (Mon dom m a) = dom - type Internal (Mon dom m a) = m (Internal a) - desugar = desugarMonad . fmap desugar - sugar = fmap sugar . sugarMonad diff --git a/src/Language/Syntactic/Frontend/Tuple.hs b/src/Language/Syntactic/Frontend/Tuple.hs deleted file mode 100644 --- a/src/Language/Syntactic/Frontend/Tuple.hs +++ /dev/null @@ -1,1239 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} - --- | 'Syntactic' instances for Haskell tuples - -module Language.Syntactic.Frontend.Tuple where - - - -import Language.Syntactic -import Language.Syntactic.Constructs.Tuple -import Data.Tuple.Curry - - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , InjectC Tuple dom - ( Internal a - , Internal b - ) - , InjectC Select dom (Internal a) - , InjectC Select dom (Internal b) - ) => - Syntactic (a,b) - where -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , InjectC Tuple dom - ( Internal a - , Internal b - ) - , InjectC Select dom (Internal a) - , InjectC Select dom (Internal b) - ) => Syntactic (a,b) #-} -#endif -#endif - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b) = Domain a - type Internal (a,b) = - ( Internal a - , Internal b - ) - - -- desugar = uncurryN $ sugarSymC Tup2 - desugar (a,b) = sugarSymC Tup2 a b - sugar a = - ( sugarSymC Sel1 a - , sugarSymC Sel2 a - ) - --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- ) => --- Syntactic (a,b,c) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- ) => Syntactic (a,b,c) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c) = Domain a --- type Internal (a,b,c) = --- ( Internal a --- , Internal b --- , Internal c --- ) --- --- desugar = uncurryN $ sugarSymC Tup3 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- ) => --- Syntactic (a,b,c,d) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- ) => Syntactic (a,b,c,d) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d) = Domain a --- type Internal (a,b,c,d) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- ) --- --- desugar = uncurryN $ sugarSymC Tup4 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- ) => --- Syntactic (a,b,c,d,e) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- ) => Syntactic (a,b,c,d,e) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e) = Domain a --- type Internal (a,b,c,d,e) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- ) --- --- desugar = uncurryN $ sugarSymC Tup5 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- ) => --- Syntactic (a,b,c,d,e,f) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- ) => Syntactic (a,b,c,d,e,f) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f) = Domain a --- type Internal (a,b,c,d,e,f) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- ) --- --- desugar = uncurryN $ sugarSymC Tup6 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- ) => --- Syntactic (a,b,c,d,e,f,g) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- ) => Syntactic (a,b,c,d,e,f,g) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g) = Domain a --- type Internal (a,b,c,d,e,f,g) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- ) --- --- desugar = uncurryN $ sugarSymC Tup7 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- ) => --- Syntactic (a,b,c,d,e,f,g,h) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- ) => Syntactic (a,b,c,d,e,f,g,h) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h) = Domain a --- type Internal (a,b,c,d,e,f,g,h) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- ) --- --- desugar = uncurryN $ sugarSymC Tup8 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- ) => Syntactic (a,b,c,d,e,f,g,h,i) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h,i) = Domain a --- type Internal (a,b,c,d,e,f,g,h,i) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- ) --- --- desugar = uncurryN $ sugarSymC Tup9 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- , sugarSymC Sel9 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i,j) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i,j) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h,i,j) = Domain a --- type Internal (a,b,c,d,e,f,g,h,i,j) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- ) --- --- desugar = uncurryN $ sugarSymC Tup10 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- , sugarSymC Sel9 a --- , sugarSymC Sel10 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i,j,k) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h,i,j,k) = Domain a --- type Internal (a,b,c,d,e,f,g,h,i,j,k) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- ) --- --- desugar = uncurryN $ sugarSymC Tup11 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- , sugarSymC Sel9 a --- , sugarSymC Sel10 a --- , sugarSymC Sel11 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i,j,k,l) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h,i,j,k,l) = Domain a --- type Internal (a,b,c,d,e,f,g,h,i,j,k,l) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- ) --- --- desugar = uncurryN $ sugarSymC Tup12 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- , sugarSymC Sel9 a --- , sugarSymC Sel10 a --- , sugarSymC Sel11 a --- , sugarSymC Sel12 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , Syntactic m, Domain m ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- , InjectC Select dom (Internal m) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , Syntactic m, Domain m ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- , InjectC Select dom (Internal m) --- ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m) = Domain a --- type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- ) --- --- desugar = uncurryN $ sugarSymC Tup13 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- , sugarSymC Sel9 a --- , sugarSymC Sel10 a --- , sugarSymC Sel11 a --- , sugarSymC Sel12 a --- , sugarSymC Sel13 a --- ) --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , Syntactic m, Domain m ~ dom --- , Syntactic n, Domain n ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- , Internal n --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- , InjectC Select dom (Internal m) --- , InjectC Select dom (Internal n) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , Syntactic m, Domain m ~ dom --- , Syntactic n, Domain n ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- , Internal n --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- , InjectC Select dom (Internal m) --- , InjectC Select dom (Internal n) --- ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = Domain a --- type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- , Internal n --- ) --- --- desugar = uncurryN $ sugarSymC Tup14 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- , sugarSymC Sel9 a --- , sugarSymC Sel10 a --- , sugarSymC Sel11 a --- , sugarSymC Sel12 a --- , sugarSymC Sel13 a --- , sugarSymC Sel14 a --- ) --- --- --- instance --- ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , Syntactic m, Domain m ~ dom --- , Syntactic n, Domain n ~ dom --- , Syntactic o, Domain o ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- , Internal n --- , Internal o --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- , InjectC Select dom (Internal m) --- , InjectC Select dom (Internal n) --- , InjectC Select dom (Internal o) --- ) => --- Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) --- where --- {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom --- , Syntactic b, Domain b ~ dom --- , Syntactic c, Domain c ~ dom --- , Syntactic d, Domain d ~ dom --- , Syntactic e, Domain e ~ dom --- , Syntactic f, Domain f ~ dom --- , Syntactic g, Domain g ~ dom --- , Syntactic h, Domain h ~ dom --- , Syntactic i, Domain i ~ dom --- , Syntactic j, Domain j ~ dom --- , Syntactic k, Domain k ~ dom --- , Syntactic l, Domain l ~ dom --- , Syntactic m, Domain m ~ dom --- , Syntactic n, Domain n ~ dom --- , Syntactic o, Domain o ~ dom --- , InjectC Tuple dom --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- , Internal n --- , Internal o --- ) --- , InjectC Select dom (Internal a) --- , InjectC Select dom (Internal b) --- , InjectC Select dom (Internal c) --- , InjectC Select dom (Internal d) --- , InjectC Select dom (Internal e) --- , InjectC Select dom (Internal f) --- , InjectC Select dom (Internal g) --- , InjectC Select dom (Internal h) --- , InjectC Select dom (Internal i) --- , InjectC Select dom (Internal j) --- , InjectC Select dom (Internal k) --- , InjectC Select dom (Internal l) --- , InjectC Select dom (Internal m) --- , InjectC Select dom (Internal n) --- , InjectC Select dom (Internal o) --- ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) #-} --- {-# INLINABLE desugar #-} --- {-# INLINABLE sugar #-} --- type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = Domain a --- type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = --- ( Internal a --- , Internal b --- , Internal c --- , Internal d --- , Internal e --- , Internal f --- , Internal g --- , Internal h --- , Internal i --- , Internal j --- , Internal k --- , Internal l --- , Internal m --- , Internal n --- , Internal o --- ) --- --- desugar = uncurryN $ sugarSymC Tup15 --- sugar a = --- ( sugarSymC Sel1 a --- , sugarSymC Sel2 a --- , sugarSymC Sel3 a --- , sugarSymC Sel4 a --- , sugarSymC Sel5 a --- , sugarSymC Sel6 a --- , sugarSymC Sel7 a --- , sugarSymC Sel8 a --- , sugarSymC Sel9 a --- , sugarSymC Sel10 a --- , sugarSymC Sel11 a --- , sugarSymC Sel12 a --- , sugarSymC Sel13 a --- , sugarSymC Sel14 a --- , sugarSymC Sel15 a --- ) diff --git a/src/Language/Syntactic/Frontend/TupleConstrained.hs b/src/Language/Syntactic/Frontend/TupleConstrained.hs deleted file mode 100644 --- a/src/Language/Syntactic/Frontend/TupleConstrained.hs +++ /dev/null @@ -1,1812 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -#endif - --- | Constrained 'Syntactic' instances for Haskell tuples - -module Language.Syntactic.Frontend.TupleConstrained - ( TupleSat - ) where - - - -import Data.Constraint -import Data.Tuple.Curry - -import Language.Syntactic -import Language.Syntactic.Constructs.Tuple - - - --- | Type-level function computing the predicate attached to 'Tuple' or 'Select' --- (whichever appears first) in a domain. -class TupleSat (dom :: * -> *) (p :: * -> Constraint) | dom -> p - -instance TupleSat (Tuple :|| p) p where - {-# SPECIALIZE instance TupleSat (Tuple :|| p) p #-} -instance TupleSat ((Tuple :|| p) :+: dom2) p where - {-# SPECIALIZE instance TupleSat ((Tuple :|| p) :+: dom2) p #-} - -instance TupleSat (Select :|| p) p where - {-# SPECIALIZE instance TupleSat (Select :|| p) p #-} -instance TupleSat ((Select :|| p) :+: dom2) p where - {-# SPECIALIZE instance TupleSat ((Select :|| p) :+: dom2) p #-} - -instance TupleSat dom p => TupleSat (dom :| q) p where - {-# SPECIALIZE instance TupleSat dom p => TupleSat (dom :| q) p #-} -instance TupleSat dom p => TupleSat (dom :|| q) p where - {-# SPECIALIZE instance TupleSat dom p => TupleSat (dom :|| q) p #-} -instance TupleSat dom2 p => TupleSat (dom1 :+: dom2) p where - {-# SPECIALIZE instance TupleSat dom2 p => TupleSat (dom1 :+: dom2) p #-} - - - -sugarSymC' :: forall sym dom sig b c p - . ( TupleSat dom p - , p (DenResult sig) - , InjectC (sym :|| p) (AST dom) (DenResult sig) - , ApplySym sig b dom - , SyntacticN c b - ) - => sym sig -> c -sugarSymC' s = sugarSymC (C' s :: (sym :|| p) sig) -{-# INLINABLE sugarSymC' #-} - - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , TupleSat dom p - , p (Internal a, Internal b) - , p (Internal a) - , p (Internal b) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - ) => - Syntactic (a,b) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , TupleSat dom p - , p (Internal a, Internal b) - , p (Internal a) - , p (Internal b) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - ) => Syntactic (a,b) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b) = Domain a - type Internal (a,b) = - ( Internal a - , Internal b - ) - - desugar = uncurryN $ sugarSymC' Tup2 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - ) - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - ) => - Syntactic (a,b,c) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - ) => Syntactic (a,b,c) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c) = Domain a - type Internal (a,b,c) = - ( Internal a - , Internal b - , Internal c - ) - - desugar = uncurryN $ sugarSymC' Tup3 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - ) - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - ) => - Syntactic (a,b,c,d) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - ) => Syntactic (a,b,c,d) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d) = Domain a - type Internal (a,b,c,d) = - ( Internal a - , Internal b - , Internal c - , Internal d - ) - - desugar = uncurryN $ sugarSymC' Tup4 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - ) - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - ) => - Syntactic (a,b,c,d,e) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - ) => Syntactic (a,b,c,d,e) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e) = Domain a - type Internal (a,b,c,d,e) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - ) - - desugar = uncurryN $ sugarSymC' Tup5 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - ) - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - ) => - Syntactic (a,b,c,d,e,f) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - ) => Syntactic (a,b,c,d,e,f) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f) = Domain a - type Internal (a,b,c,d,e,f) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - ) - - desugar = uncurryN $ sugarSymC' Tup6 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - ) - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - ) => - Syntactic (a,b,c,d,e,f,g) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - ) => Syntactic (a,b,c,d,e,f,g) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g) = Domain a - type Internal (a,b,c,d,e,f,g) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - ) - - desugar = uncurryN $ sugarSymC' Tup7 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - ) => - Syntactic (a,b,c,d,e,f,g,h) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - ) => Syntactic (a,b,c,d,e,f,g,h) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h) = Domain a - type Internal (a,b,c,d,e,f,g,h) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - ) - - desugar = uncurryN $ sugarSymC' Tup8 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - ) => - Syntactic (a,b,c,d,e,f,g,h,i) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - ) => Syntactic (a,b,c,d,e,f,g,h,i) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h,i) = Domain a - type Internal (a,b,c,d,e,f,g,h,i) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - ) - - desugar = uncurryN $ sugarSymC' Tup9 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - , sugarSymC' Sel9 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - ) => - Syntactic (a,b,c,d,e,f,g,h,i,j) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - ) => Syntactic (a,b,c,d,e,f,g,h,i,j) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h,i,j) = Domain a - type Internal (a,b,c,d,e,f,g,h,i,j) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - ) - - desugar = uncurryN $ sugarSymC' Tup10 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - , sugarSymC' Sel9 a - , sugarSymC' Sel10 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - ) => - Syntactic (a,b,c,d,e,f,g,h,i,j,k) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h,i,j,k) = Domain a - type Internal (a,b,c,d,e,f,g,h,i,j,k) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - ) - - desugar = uncurryN $ sugarSymC' Tup11 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - , sugarSymC' Sel9 a - , sugarSymC' Sel10 a - , sugarSymC' Sel11 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - ) => - Syntactic (a,b,c,d,e,f,g,h,i,j,k,l) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h,i,j,k,l) = Domain a - type Internal (a,b,c,d,e,f,g,h,i,j,k,l) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - ) - - desugar = uncurryN $ sugarSymC' Tup12 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - , sugarSymC' Sel9 a - , sugarSymC' Sel10 a - , sugarSymC' Sel11 a - , sugarSymC' Sel12 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , Syntactic m, Domain m ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , p (Internal m) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - , InjectC (Select :|| p) dom (Internal m) - ) => - Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , Syntactic m, Domain m ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , p (Internal m) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - , InjectC (Select :|| p) dom (Internal m) - ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m) = Domain a - type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - ) - - desugar = uncurryN $ sugarSymC' Tup13 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - , sugarSymC' Sel9 a - , sugarSymC' Sel10 a - , sugarSymC' Sel11 a - , sugarSymC' Sel12 a - , sugarSymC' Sel13 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , Syntactic m, Domain m ~ dom - , Syntactic n, Domain n ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , p (Internal m) - , p (Internal n) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - , InjectC (Select :|| p) dom (Internal m) - , InjectC (Select :|| p) dom (Internal n) - ) => - Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , Syntactic m, Domain m ~ dom - , Syntactic n, Domain n ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , p (Internal m) - , p (Internal n) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - , InjectC (Select :|| p) dom (Internal m) - , InjectC (Select :|| p) dom (Internal n) - ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = Domain a - type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - ) - - desugar = uncurryN $ sugarSymC' Tup14 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - , sugarSymC' Sel9 a - , sugarSymC' Sel10 a - , sugarSymC' Sel11 a - , sugarSymC' Sel12 a - , sugarSymC' Sel13 a - , sugarSymC' Sel14 a - ) - - -instance - ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , Syntactic m, Domain m ~ dom - , Syntactic n, Domain n ~ dom - , Syntactic o, Domain o ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - , Internal o - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , p (Internal m) - , p (Internal n) - , p (Internal o) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - , Internal o - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - , InjectC (Select :|| p) dom (Internal m) - , InjectC (Select :|| p) dom (Internal n) - , InjectC (Select :|| p) dom (Internal o) - ) => - Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , Syntactic b, Domain b ~ dom - , Syntactic c, Domain c ~ dom - , Syntactic d, Domain d ~ dom - , Syntactic e, Domain e ~ dom - , Syntactic f, Domain f ~ dom - , Syntactic g, Domain g ~ dom - , Syntactic h, Domain h ~ dom - , Syntactic i, Domain i ~ dom - , Syntactic j, Domain j ~ dom - , Syntactic k, Domain k ~ dom - , Syntactic l, Domain l ~ dom - , Syntactic m, Domain m ~ dom - , Syntactic n, Domain n ~ dom - , Syntactic o, Domain o ~ dom - , TupleSat dom p - , p ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - , Internal o - ) - , p (Internal a) - , p (Internal b) - , p (Internal c) - , p (Internal d) - , p (Internal e) - , p (Internal f) - , p (Internal g) - , p (Internal h) - , p (Internal i) - , p (Internal j) - , p (Internal k) - , p (Internal l) - , p (Internal m) - , p (Internal n) - , p (Internal o) - , InjectC (Tuple :|| p) dom - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - , Internal o - ) - , InjectC (Select :|| p) dom (Internal a) - , InjectC (Select :|| p) dom (Internal b) - , InjectC (Select :|| p) dom (Internal c) - , InjectC (Select :|| p) dom (Internal d) - , InjectC (Select :|| p) dom (Internal e) - , InjectC (Select :|| p) dom (Internal f) - , InjectC (Select :|| p) dom (Internal g) - , InjectC (Select :|| p) dom (Internal h) - , InjectC (Select :|| p) dom (Internal i) - , InjectC (Select :|| p) dom (Internal j) - , InjectC (Select :|| p) dom (Internal k) - , InjectC (Select :|| p) dom (Internal l) - , InjectC (Select :|| p) dom (Internal m) - , InjectC (Select :|| p) dom (Internal n) - , InjectC (Select :|| p) dom (Internal o) - ) => Syntactic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) #-} - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - type Domain (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = Domain a - type Internal (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = - ( Internal a - , Internal b - , Internal c - , Internal d - , Internal e - , Internal f - , Internal g - , Internal h - , Internal i - , Internal j - , Internal k - , Internal l - , Internal m - , Internal n - , Internal o - ) - - desugar = uncurryN $ sugarSymC' Tup15 - sugar a = - ( sugarSymC' Sel1 a - , sugarSymC' Sel2 a - , sugarSymC' Sel3 a - , sugarSymC' Sel4 a - , sugarSymC' Sel5 a - , sugarSymC' Sel6 a - , sugarSymC' Sel7 a - , sugarSymC' Sel8 a - , sugarSymC' Sel9 a - , sugarSymC' Sel10 a - , sugarSymC' Sel11 a - , sugarSymC' Sel12 a - , sugarSymC' Sel13 a - , sugarSymC' Sel14 a - , sugarSymC' Sel15 a - ) diff --git a/src/Language/Syntactic/Interpretation.hs b/src/Language/Syntactic/Interpretation.hs deleted file mode 100644 --- a/src/Language/Syntactic/Interpretation.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Language.Syntactic.Interpretation where - -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -import Language.Syntactic.Interpretation.Equality -import Language.Syntactic.Interpretation.Render -import Language.Syntactic.Interpretation.Evaluation - --- | Derive instances for 'Semantic' related classes --- ('Equality', 'Render', 'StringTree', 'Eval') -semanticInstances :: Name -> DecsQ -semanticInstances n = - [d| - instance Equality $(typ) - instance Render $(typ) - instance StringTree $(typ) - instance Eval $(typ) where - {-# SPECIALIZE instance Eval $(typ) #-} - |] - where - typ = conT n diff --git a/src/Language/Syntactic/Interpretation/Equality.hs b/src/Language/Syntactic/Interpretation/Equality.hs deleted file mode 100644 --- a/src/Language/Syntactic/Interpretation/Equality.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} - -module Language.Syntactic.Interpretation.Equality where - - - -import Data.Hash - -import Language.Syntactic.Syntax -import Language.Syntactic.Interpretation.Semantics - - - --- | Equality for expressions -class Equality expr - where - -- | Equality for expressions - -- - -- Comparing expressions of different types is often needed when dealing - -- with expressions with existentially quantified sub-terms. - equal :: expr a -> expr b -> Bool - - -- | Computes a 'Hash' for an expression. Expressions that are equal - -- according to 'equal' must result in the same hash: - -- - -- @equal a b ==> exprHash a == exprHash b@ - exprHash :: expr a -> Hash - - default equal :: Semantic expr => expr a -> expr b -> Bool - equal = equalDefault - {-# INLINABLE equal #-} - - default exprHash :: Semantic expr => expr a -> Hash - exprHash = exprHashDefault - {-# INLINABLE exprHash #-} - - --- | Default implementation of 'equal' -equalDefault :: Semantic expr => expr a -> expr b -> Bool -equalDefault a b = equal (semantics a) (semantics b) -{-# INLINABLE equalDefault #-} - --- | Default implementation of 'exprHash' -exprHashDefault :: Semantic expr => expr a -> Hash -exprHashDefault = exprHash . semantics -{-# INLINABLE exprHashDefault #-} - - -instance Equality Semantics - where - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (Sem a _) (Sem b _) = a==b - exprHash (Sem name _) = hash name - -instance Equality dom => Equality (AST dom) - where - {-# SPECIALIZE instance (Equality dom) => Equality (AST dom) #-} - {-# INLINABLE equal #-} - equal (Sym a) (Sym b) = equal a b - equal (s1 :$ a1) (s2 :$ a2) = equal s1 s2 && equal a1 a2 - equal _ _ = False - - {-# INLINABLE exprHash #-} - exprHash (Sym a) = hashInt 0 `combine` exprHash a - exprHash (s :$ a) = hashInt 1 `combine` exprHash s `combine` exprHash a - -instance Equality dom => Eq (AST dom a) - where - {-# SPECIALIZE instance (Equality dom) => Eq (AST dom a) #-} - {-# INLINABLE (==) #-} - (==) = equal - -instance (Equality expr1, Equality expr2) => Equality (expr1 :+: expr2) - where - {-# SPECIALIZE instance (Equality expr1, Equality expr2) => Equality (expr1 :+: expr2) #-} - {-# INLINABLE equal #-} - equal (InjL a) (InjL b) = equal a b - equal (InjR a) (InjR b) = equal a b - equal _ _ = False - - {-# INLINABLE exprHash #-} - exprHash (InjL a) = hashInt 0 `combine` exprHash a - exprHash (InjR a) = hashInt 1 `combine` exprHash a - -instance (Equality expr1, Equality expr2) => Eq ((expr1 :+: expr2) a) - where - {-# SPECIALIZE instance (Equality expr1, Equality expr2) => Eq ((expr1 :+: expr2) a)#-} - (==) = equal diff --git a/src/Language/Syntactic/Interpretation/Evaluation.hs b/src/Language/Syntactic/Interpretation/Evaluation.hs deleted file mode 100644 --- a/src/Language/Syntactic/Interpretation/Evaluation.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} - -module Language.Syntactic.Interpretation.Evaluation where - - - -import Language.Syntactic.Syntax -import Language.Syntactic.Interpretation.Semantics - - - -class Eval expr - where - -- | Evaluation of expressions - evaluate :: expr a -> Denotation a - - default evaluate :: Semantic expr => expr a -> Denotation a - evaluate = evaluateDefault - {-# INLINABLE evaluate #-} - --- | Default implementation of 'evaluate' -evaluateDefault :: Semantic expr => expr a -> Denotation a -evaluateDefault = evaluate . semantics -{-# INLINABLE evaluateDefault #-} - -instance Eval Semantics - where - {-# INLINABLE evaluate #-} - evaluate (Sem _ a) = a - - -instance Eval dom => Eval (AST dom) - where - {-# SPECIALIZE instance (Eval dom) => Eval (AST dom) #-} - {-# INLINABLE evaluate #-} - evaluate (Sym a) = evaluate a - evaluate (s :$ a) = evaluate s $ evaluate a - -instance (Eval expr1, Eval expr2) => Eval (expr1 :+: expr2) - where - {-# SPECIALIZE instance (Eval expr1, Eval expr2) => Eval (expr1 :+: expr2) #-} - {-# INLINABLE evaluate #-} - evaluate (InjL a) = evaluate a - evaluate (InjR a) = evaluate a diff --git a/src/Language/Syntactic/Interpretation/Render.hs b/src/Language/Syntactic/Interpretation/Render.hs deleted file mode 100644 --- a/src/Language/Syntactic/Interpretation/Render.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} - -module Language.Syntactic.Interpretation.Render - ( Render (..) - , renderSymDefault - , renderArgsDefault - , render - , StringTree (..) - , stringTree - , showAST - , drawAST - , writeHtmlAST - ) where - - - -import Data.Tree (Tree (..)) - -import Data.Tree.View - -import Language.Syntactic.Syntax -import Language.Syntactic.Interpretation.Semantics - - --- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym' --- method. -class Render dom - where - -- | Show a symbol as a 'String' - renderSym :: dom sig -> String - - -- | Render a symbol given a list of rendered arguments - renderArgs :: [String] -> dom sig -> String - renderArgs [] a = renderSym a - renderArgs args a = "(" ++ unwords (renderSym a : args) ++ ")" - {-# INLINABLE renderArgs #-} - - default renderSym :: Semantic dom => dom sig -> String - renderSym = renderSymDefault - {-# INLINABLE renderSym #-} - --- | Default implementation of 'renderSym' -renderSymDefault :: Semantic expr => expr a -> String -renderSymDefault = renderSym . semantics -{-# INLINABLE renderSymDefault #-} - --- | Default implementation of 'renderArgs' -renderArgsDefault :: Semantic expr => [String] -> expr a -> String -renderArgsDefault args = renderArgs args . semantics -{-# INLINABLE renderArgsDefault #-} - -instance Render Semantics - where - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym (Sem name _) = name - renderArgs [] (Sem name _) = name - renderArgs args (Sem name _) - | isInfix = "(" ++ unwords [a,op,b] ++ ")" - | otherwise = "(" ++ unwords (name : args) ++ ")" - where - [a,b] = args - op = init $ tail name - isInfix - = not (null name) - && head name == '(' - && last name == ')' - && length args == 2 - -instance (Render expr1, Render expr2) => Render (expr1 :+: expr2) - where - {-# SPECIALIZE instance (Render expr1, Render expr2) => Render (expr1 :+: expr2) #-} - {-# INLINABLE renderSym #-} - {-# INLINABLE renderArgs #-} - renderSym (InjL a) = renderSym a - renderSym (InjR a) = renderSym a - renderArgs args (InjL a) = renderArgs args a - renderArgs args (InjR a) = renderArgs args a - --- | Render an expression as concrete syntax -render :: forall dom a. Render dom => ASTF dom a -> String -render = go [] - where - go :: [String] -> AST dom sig -> String - go args (Sym a) = renderArgs args a - go args (s :$ a) = go (render a : args) s -{-# INLINABLE render #-} - -instance Render dom => Show (ASTF dom a) - where - {-# SPECIALIZE instance Render dom => Show (ASTF dom a) #-} - show = render - - - --- | Convert a symbol to a 'Tree' of strings -class Render dom => StringTree dom - where - -- | Convert a symbol to a 'Tree' given a list of argument trees - stringTreeSym :: [Tree String] -> dom a -> Tree String - stringTreeSym args a = Node (renderSym a) args - {-# INLINABLE stringTreeSym #-} - -instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2) - where - {-# SPECIALIZE instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2) #-} - {-# INLINABLE stringTreeSym #-} - stringTreeSym args (InjL a) = stringTreeSym args a - stringTreeSym args (InjR a) = stringTreeSym args a - --- | Convert an expression to a 'Tree' of strings -stringTree :: forall dom a . StringTree dom => ASTF dom a -> Tree String -stringTree = go [] - where - go :: [Tree String] -> AST dom sig -> Tree String - go args (Sym a) = stringTreeSym args a - go args (s :$ a) = go (go [] a : args) s -{-# INLINABLE stringTree #-} - --- | Show a syntax tree using ASCII art -showAST :: StringTree dom => ASTF dom a -> String -showAST = showTree . stringTree -{-# INLINABLE showAST #-} - --- | Print a syntax tree using ASCII art -drawAST :: StringTree dom => ASTF dom a -> IO () -drawAST = putStrLn . showAST -{-# INLINABLE drawAST #-} - -writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO () -writeHtmlAST file = writeHtmlTree Nothing file . fmap (\n -> NodeInfo InitiallyExpanded n "") . stringTree -{-# INLINABLE writeHtmlAST #-} diff --git a/src/Language/Syntactic/Interpretation/Semantics.hs b/src/Language/Syntactic/Interpretation/Semantics.hs deleted file mode 100644 --- a/src/Language/Syntactic/Interpretation/Semantics.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Default implementations of some interpretation functions - -module Language.Syntactic.Interpretation.Semantics where - - - -import Language.Syntactic.Syntax - - --- | A representation of a syntactic construct as a 'String' and an evaluation --- function. It is not meant to be used as a syntactic symbol in an 'AST'. Its --- only purpose is to provide the default implementations of functions like --- `equal` via the `Semantic` class. -data Semantics a - where - Sem - :: { semanticName :: String - , semanticEval :: Denotation a - } - -> Semantics a - - --- | The denotation of a symbol with the given signature -type family Denotation sig -type instance Denotation (Full a) = a -type instance Denotation (a :-> sig) = a -> Denotation sig - - --- | Class of expressions that can be treated as constructs -class Semantic expr - where - semantics :: expr a -> Semantics a diff --git a/src/Language/Syntactic/Sharing/CodeMotion2.hs b/src/Language/Syntactic/Sharing/CodeMotion2.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sharing/CodeMotion2.hs +++ /dev/null @@ -1,682 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DoRec #-} -module Language.Syntactic.Sharing.CodeMotion2 - ( codeMotion2 - , reifySmart2 - ) where - -import Control.Arrow -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.RWS -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Array -import Data.List -import Data.Maybe (fromJust,fromMaybe) -import Data.Function -import Data.Hash -import Data.Typeable - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding -import Language.Syntactic.Constructs.Binding.HigherOrder -import Language.Syntactic.Sharing.SimpleCodeMotion - -typeEq :: forall dom a b. (Typeable a, Typeable b) => ASTF dom a -> ASTF dom b -> Bool -typeEq a b | Just _ <- (gcast b :: Maybe (ASTF dom a)) = True -typeEq _ _ = False - -isVariable :: PrjDict dom -> ASTF (NodeDomain dom) a -> Bool -isVariable pd (Sym (C' (InjR (prjVariable pd -> Just _)))) = True -isVariable pd _ = False - -newtype NodeId = NodeId { nodeInteger :: Integer } - deriving (Eq, Ord, Num, Real, Integral, Enum, Ix) - -instance Show NodeId - where - show (NodeId i) = show i - -showNode :: NodeId -> String -showNode n = "node:" ++ show n - -instance AlphaEq dom dom dom env => AlphaEq Node Node dom env - where - {-# SPECIALIZE instance AlphaEq dom dom dom env => - AlphaEq Node Node dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (Node n1) _ (Node n2) _ = return (n1 == n2) - -instance Constrained Node - where - {-# SPECIALIZE instance Constrained Node #-} - {-# INLINABLE exprDict #-} - type Sat Node = Top - exprDict _ = Dict - -instance Equality Node - where - {-# INLINABLE equal #-} - {-# INLINABLE exprHash #-} - equal (Node n1) (Node n2) = error "can't compare nodes for equality" - exprHash (Node n) = hash (nodeInteger n) - --- | Placeholder for a syntax tree. Similar to Node from Graph, but with the --- invariant that nodes with the same id are alpha-equivalent, given that they --- come from the same expression. -data Node a - where - Node :: NodeId -> Node (Full a) - -instance Render Node where - {-# INLINABLE renderSym #-} - renderSym (Node n) = showNode n - - -type NodeDomain dom = (Node :+: dom) :|| Sat dom - --- | A gathered sub-expression along with information used to decide where and --- if it should be shared. -data Gathered dom = Gathered - { geExpr :: ASTSAT (NodeDomain dom) - -- ^ The gathered expression. - , geNodeId :: NodeId - -- ^ The node id of the expression. - , geFreeVars :: Set.Set VarId - -- ^ Variables that occur free in the expression. - , geInfo :: [(NodeId, GatherInfo)] - -- ^ A list of nodes which the gathered expression occurs in, which it - -- should not be hoisted out of, along with the number of times it occurs - -- in it and the union of all the scopes where the variable occurs. - } - - --- | An occurence count and a union of scopes for a gathered expression. Used --- for the heuristic for when to share an expression. -data GatherInfo = GatherInfo - { giCount :: Int - , giScopes :: Set.Set VarId - } - deriving Show - - -newtype HashySet a = HashySet { unHashySet :: Map.Map Hash [a] } - -lookupWithHS :: ([a] -> b) -> Hash -> HashySet a -> b -lookupWithHS f h (HashySet m) = case Map.lookup h m of - Nothing -> f [] - Just as -> f as - -updateWithHS :: (Maybe [a] -> Maybe [a]) -> Hash -> HashySet a -> HashySet a -updateWithHS f h (HashySet m) = HashySet $ Map.alter f h m - -emptyHS = HashySet Map.empty - -toListHS (HashySet m) = concatMap snd $ Map.toList m - --- | A set of expressions used to keep track of gathered expression in `gather` -type GatherSet dom = HashySet (Gathered dom) - -lookupGS :: forall dom a - . ( AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] - , ConstrainedBy (NodeDomain dom) Typeable - , Equality dom) - => GatherSet dom - -> ASTF (NodeDomain dom) a - -> Maybe (Gathered dom) -lookupGS hs e = lookupWithHS look (exprHash e) hs - where - look :: [Gathered dom] -> Maybe (Gathered dom) - look [] = Nothing - look (g:gs) | ASTB ge <- geExpr g - , Dict <- exprDictSub pTypeable ge - , Dict <- exprDictSub pTypeable e - , alphaEq ge e - , typeEq ge e - = Just g - look (g:gs) = look gs - -updateGS :: forall dom - . ( AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] - , ConstrainedBy (NodeDomain dom) Typeable - , Equality dom) - => GatherSet dom - -> Gathered dom - -> GatherSet dom -updateGS hs g - | ASTB ge <- geExpr g - = updateWithHS alt (exprHash ge) hs - where - alt :: Maybe [Gathered dom] -> Maybe [Gathered dom] - alt (Just gs) = Just $ ins gs - alt Nothing = Just [g] - ins :: [Gathered dom] -> [Gathered dom] - ins [] = [g] - ins (x:xs) | ASTB xe <- geExpr x - , ASTB ge <- geExpr g - , Dict <- exprDictSub pTypeable xe - , Dict <- exprDictSub pTypeable ge - , alphaEq xe ge - , typeEq xe ge - = g : xs - ins (x:xs) = x : ins xs - -emptyGS :: GatherSet dom -emptyGS = emptyHS - -toListGS :: GatherSet dom -> [Gathered dom] -toListGS gs = toListHS gs - -type RebuildEnv dom = - ( Map.Map NodeId (ASTSAT dom) - -- associates node ids with the AST they should be substituted by - , Set.Set VarId - -- bound variables - , [NodeId] - -- nodes that have been encountered - ) - -type RebuildMonad dom m a = ReaderT (RebuildEnv dom) m a - -runRebuild :: (MonadState VarId m) => RebuildMonad dom m a -> m a -runRebuild m = runReaderT m (Map.empty, Set.empty, []) - -addBoundVar :: (Monad m) => VarId -> RebuildMonad dom m a -> RebuildMonad dom m a -addBoundVar v = local (\(nm,vs,sn) -> (nm, Set.insert v vs, sn)) - -getBoundVars :: (Monad m) => RebuildMonad dom m (Set.Set VarId) -getBoundVars = do - (_,bv,_) <- ask - return bv - -addNodeExpr :: (Monad m) => NodeId -> ASTSAT dom -> RebuildMonad dom m a -> RebuildMonad dom m a -addNodeExpr n a = local (\(nm,vs,sn) -> (Map.insert n a nm, vs, sn)) - -getNodeExprMap :: (Monad m) => RebuildMonad dom m (Map.Map NodeId (ASTSAT dom)) -getNodeExprMap = do - (nm,_,_) <- ask - return nm - -addSeenNode :: (Monad m) => NodeId -> RebuildMonad dom m a -> RebuildMonad dom m a -addSeenNode n = local (\(nm,vs,sn) -> (nm, vs, n:sn)) - -getSeenNodes :: (Monad m) => RebuildMonad dom m [NodeId] -getSeenNodes = do - (_,_,sn) <- ask - return sn - - - -codeMotion2 :: forall dom m a - . ( ConstrainedBy dom Typeable - , AlphaEq dom dom dom [(VarId,VarId)] - , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] - , Equality dom - , MonadState VarId m - ) - => (forall c. ASTF dom c -> Bool) -- ^ Control wether a sub-expression can be hoisted over the given expression - -> PrjDict dom - -> MkInjDict dom - -> ASTF dom a - -> m (ASTF dom a) -codeMotion2 hoistOver pd mkId a = rebuild pd mkId garr a' - where - (garr, a') = gather hoistOver pd a - -type ShareInfo dom = (NodeId, ASTSAT (NodeDomain dom), GatherInfo) - -rebuild :: forall dom m a - . ( ConstrainedBy dom Typeable - , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] - , Equality dom - , MonadState VarId m - ) - => PrjDict dom - -> MkInjDict dom - -> Array NodeId (Gathered dom) - -> ASTF (NodeDomain dom) a - -> m (ASTF dom a) -rebuild pd mkId nodes (Sym (C' (InjL _))) = error "rebuild: root is a node" -rebuild pd mkId nodes a = runRebuild $ rebuild' 0 a - where - nodeExpr :: NodeId -> ASTSAT (NodeDomain dom) - nodeExpr n = geExpr (nodes ! n) - - freeVars :: NodeId -> Set.Set VarId - freeVars n = geFreeVars (nodes ! n) - - nodeDeps :: Array NodeId (Set.Set NodeId) - nodeDeps = nodeDepsArray - where - nodeDepsArray = array (0,snd (bounds nodes)) [(n, nodeDepsNode n) | n <- 0 : indices nodes] - - nodeDepsNode :: NodeId -> Set.Set NodeId - nodeDepsNode 0 = nodeDepsExp a - nodeDepsNode n = liftASTB nodeDepsExp $ geExpr (nodes ! n) - - nodeDepsExp :: AST (NodeDomain dom) b -> Set.Set NodeId - nodeDepsExp (Sym (C' (InjR _))) = Set.empty - nodeDepsExp (Sym (C' (InjL (Node n)))) = Set.insert n (nodeDepsArray ! n) - nodeDepsExp (s :$ b) = Set.union (nodeDepsExp s) (nodeDepsExp b) - - -- | Computes a list of nodes that should be considered for sharing at a - -- particular node. Must return a ShareInfo corresponding to any node - -- that might be encounter in direct sub-expression of the node that has - -- not already been considered at a parent node. Otherwise we will not know - -- what to do with that node. - -- Implementation is pretty bizarre right now, but it should be replaced anyway. - nodesToConsider :: NodeId -> (NodeId -> Bool) -> Set.Set VarId -> [NodeId] -> [ShareInfo dom] - nodesToConsider n f bv seenNodes = concatMap mkShareInfo (map (\n -> (n, nodes ! n)) (Set.elems (nodeDeps ! n))) - where - maximumBy' f [] = [] - maximumBy' f xs = [maximumBy f xs] - - mkShareInfo (n,g) = map snd $ filter ((/=Nothing) . fst) $ maximumBy' (compare `on` fst) - [ (elemIndex il seenNodes, (n, geExpr g, gi)) - | (il,gi) <- geInfo g - , Set.null (freeVars n `Set.difference` bv) - -- any free variables in the sub-expression must be bound - , il /= n - -- this case handled separately - , f n - ] - - -- Nodes which has the given node as its inner limit. - unshareableNodes :: NodeId -> AST (NodeDomain dom) b -> [ShareInfo dom] - unshareableNodes n (Sym s) = [] - unshareableNodes n (s :$ Sym (C' (InjL (Node n')))) - | Just gi <- lookup n (geInfo (nodes ! n')) - = (n', geExpr (nodes ! n'), gi) : unshareableNodes n s - | Just gi <- lookup n' (geInfo (nodes ! n')) - = (n', geExpr (nodes ! n'), gi) : unshareableNodes n s - unshareableNodes n (b :$ s) = unshareableNodes n b - - unshareable2Nodes :: Maybe VarId -> ASTF (NodeDomain dom) b -> [ShareInfo dom] - unshareable2Nodes Nothing _ = [] - unshareable2Nodes (Just v) a = go a [] - where - go :: AST (NodeDomain dom) c -> [ShareInfo dom] -> [ShareInfo dom] - go (Sym s) l = l - go (s :$ Sym (C' (InjL (Node n')))) l - | Set.member v (freeVars n') = go s ((n', geExpr (nodes ! n'), undefined):l) - | otherwise = go s l - - rebuild' :: forall b - . NodeId - -> ASTF (NodeDomain dom) b - -> RebuildMonad dom m (ASTF dom b) - rebuild' n a@(Sym (C' (InjR lam)) :$ ns@(Sym (C' (InjL (Node nb))))) - | Just v <- prjLambda pd lam - = addSeenNode n $ shareExprsIn (Just v) n a - rebuild' n (Sym (C' (InjR s))) = return $ Sym s - rebuild' n a = addSeenNode n $ shareExprsIn Nothing n a - - shareExprsIn :: forall b - . Maybe VarId -- if the last argument is a lambda, this contains the lambda VarId, otherwise Nothing. - -> NodeId - -> ASTF (NodeDomain dom) b - -> RebuildMonad dom m (ASTF dom b) - shareExprsIn mlv n a = do - bv <- getBoundVars - seenNodes <- getSeenNodes - nodeMap <- getNodeExprMap - let considered = nodesToConsider n (\n' -> n' /= n && not (Map.member n' nodeMap) && Set.member n' (nodeDeps ! n)) bv seenNodes - let sorted = sortBy (compare `on` (\(n,_,_) -> n)) considered - let unshareable = nubBy ((==) `on` (\(n,_,_) -> n)) $ unshareableNodes n a ++ unshareable2Nodes mlv a - unshare mlv unshareable $ shareEm mlv sorted a - - unshare :: Maybe VarId -> [ShareInfo dom] -> RebuildMonad dom m b -> RebuildMonad dom m b - unshare mlv [] m = m - unshare mlv ((n, ASTB b, gi):sis) m = do - b' <- rebuildMaybeUnderLambda mlv n b - addNodeExpr n (ASTB b') $ unshare mlv sis m - - shareEm - :: Maybe VarId - -> [ShareInfo dom] - -> ASTF (NodeDomain dom) b - -> RebuildMonad dom m (ASTF dom b) - shareEm mlv [] a = fixNodeExprSub a - shareEm mlv ((n, ASTB b, gi) : sis) a = do - bv <- getBoundVars - case mkId (inlineAll nodeExpr b) (inlineAll nodeExpr a) of - Just id | heuristic bv gi b -> do - b' <- rebuild' n b - v <- get; put (v+1) - a' <- addNodeExpr n (ASTB (Sym (injVariable id v))) $ shareEm mlv sis a - return $ Sym (injLet id) :$ b' :$ (Sym (injLambda id v) :$ a') - _ -> do - b' <- rebuildMaybeUnderLambda mlv n b - a' <- addNodeExpr n (ASTB b') $ shareEm mlv sis a - return a' - - rebuildMaybeUnderLambda - :: Maybe VarId - -> NodeId - -> ASTF (NodeDomain dom) b - -> RebuildMonad dom m (ASTF dom b) - rebuildMaybeUnderLambda (Just lv) n a = addBoundVar lv $ rebuild' n a - rebuildMaybeUnderLambda Nothing n a = rebuild' n a - - fixNodeExprSub :: forall b - . ( ConstrainedBy dom Typeable - , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] - , Equality dom - ) - => AST (NodeDomain dom) b - -> RebuildMonad dom m (AST dom b) - fixNodeExprSub (Sym (C' (InjR s))) = return (Sym s) - fixNodeExprSub (s :$ b) = do - b' <- fixNodeExpr b - s' <- fixNodeExprSub s - return (s' :$ b') - - fixNodeExpr :: forall b - . ASTF (NodeDomain dom) b -> RebuildMonad dom m (ASTF dom b) - fixNodeExpr (ns@(Sym (C' (InjL (Node n))))) = do - nodeMap <- getNodeExprMap - let a = lookNode nodeMap - return a - where - lookNode nodeMap = case Map.lookup n nodeMap of - Just (ASTB a) - | Dict <- exprDictSub pTypeable ns - , Dict <- exprDictSub pTypeable a - -> case gcast a of - Nothing -> error "rebuild: type mismatch" - Just a -> a - Nothing -> error ("rebuild: lost node: " ++ show n) - - heuristic :: Set.Set VarId -> GatherInfo -> ASTF (NodeDomain dom) b -> Bool - heuristic bv gi b = not (isVariable pd b) && (giCount gi > 1 || not (Set.null (giScopes gi `Set.difference` bv))) - -inlineAll :: forall dom a - . ConstrainedBy dom Typeable - => (NodeId -> ASTSAT (NodeDomain dom)) - -> ASTF (NodeDomain dom) a - -> ASTF dom a -inlineAll nodes a = go a - where - go :: AST (NodeDomain dom) sig -> AST dom sig - go (s :$ a) = go s :$ go a - go (Sym (C' (InjR s))) = Sym s - go s@(Sym (C' (InjL (Node n)))) = case nodes n of - ASTB a - | Dict <- exprDictSub pTypeable s - , Dict <- exprDictSub pTypeable a - -> case gcast a of - Nothing -> error "inlineAll: type mismatch" - Just a -> go a - - -type GatherEnv = - ( [NodeId] - -- List of nodes upwards in the syntax tree that cannot be hoisted over - , Set.Set VarId - -- Varibles in scope - ) - -type Additional = Map.Map NodeId [(NodeId, GatherInfo)] - -data GatherState dom = GatherState - { gatherSet :: GatherSet dom -- Set of expressions that have been recorded - , nodeCounter :: NodeId - , lambdaTable :: LambdaTable dom - , additionals :: Map.Map NodeId [(NodeId, GatherInfo)] - } - -data LambdaInfo dom = LambdaInfo - { liExpr :: ASTSAT dom - , liLambdaNodeId :: NodeId - , liFreeVars :: Set.Set VarId - } - -type GatherMonad dom a = RWS GatherEnv (Set.Set VarId) (GatherState dom) a - -runGather :: GatherMonad dom a -> (GatherState dom, a) -runGather gather = (s', a) - where - (a,s',w) = runRWS gather ([0], Set.empty) (GatherState emptyGS 1 emptyHS Map.empty) - -type LambdaTable dom = HashySet (LambdaInfo dom) - -lookupLT :: forall dom a - . ( AlphaEq dom dom dom [(VarId,VarId)] - , Equality dom) - => Hash - -> ASTF dom a - -> LambdaTable dom - -> Maybe (LambdaInfo dom) -lookupLT h e t = lookupWithHS look h t - where - look :: [LambdaInfo dom] -> Maybe (LambdaInfo dom) - look [] = Nothing - look (li:xs) | liftASTB alphaEq (liExpr li) e - = Just li - look (x:xs) = look xs - --- | Note: Assumes the given lambda is not already in the map -insertLT :: forall dom a - . ( Sat dom a - , AlphaEq dom dom dom [(VarId,VarId)] - , Equality dom) - => Hash - -> ASTF dom a - -> NodeId - -> Set.Set VarId - -> LambdaTable dom - -> LambdaTable dom -insertLT h e n fv t = updateWithHS ins h t - where - ins :: Maybe [LambdaInfo dom] -> Maybe [LambdaInfo dom] - ins (Just xs) = Just (LambdaInfo (ASTB e) n fv : xs) - ins Nothing = Just [LambdaInfo (ASTB e) n fv] - - -getInnerLimit :: GatherMonad dom NodeId -getInnerLimit = liftM (head . fst) ask - -getScope :: GatherMonad dom (Set.Set VarId) -getScope = liftM snd ask - -getLambdaTable :: GatherMonad dom (LambdaTable dom) -getLambdaTable = liftM lambdaTable get - -putLambdaTable :: LambdaTable dom -> GatherMonad dom () -putLambdaTable lt = do - st <- get - put (st { lambdaTable = lt }) - -addInnerLimit :: NodeId -> GatherMonad dom a -> GatherMonad dom a -addInnerLimit n = local (\(ns,vs) -> (n:ns,vs)) - -addScopeVar :: VarId -> GatherMonad dom a -> GatherMonad dom a -addScopeVar v = censor (Set.delete v) . local (\(ns,vs) -> (ns, Set.insert v vs )) - --- | Convert an expression to a graph representation where each set of --- alpha-equivalent sub-expressions share a node. Occurence counts for the --- sub-expressions, and other information is also recorded. -gather :: forall dom a - . ( ConstrainedBy dom Typeable - , AlphaEq dom dom (NodeDomain dom) [(VarId,VarId)] - , AlphaEq dom dom dom [(VarId,VarId)] - , Equality dom - ) - => (forall c. ASTF dom c -> Bool) - -> PrjDict dom - -> ASTF dom a - -> (Array NodeId (Gathered dom), ASTF (NodeDomain dom) a) -gather hoistOver pd a@(Sym s) | Dict <- exprDict a = (array (1,0) [], Sym (C' (InjR s))) -gather hoistOver pd a = (gatheredArr, a') - where - (st,a') | Dict <- exprDict a = runGather (gatherRoot a) - - gatherRoot :: ASTF dom b -> GatherMonad dom (ASTF (NodeDomain dom) b) - gatherRoot a@(Sym lam :$ _) | Just v <- prjLambda pd lam - , Dict <- exprDict a - = addScopeVar v $ gatherRec (hoistOver a) a - gatherRoot a | Dict <- exprDict a = gatherRec (hoistOver a) a - - gths = toListGS (gatherSet st) - - idx = map geNodeId gths - - adArr :: Array NodeId [(NodeId, GatherInfo)] - adArr = accumArray (++) [] - (1, nodeCounter st - 1) - ((Map.assocs (additionals st)) ++ [(n, []) | n <- [1..(nodeCounter st - 1)]]) - - preGatheredArr :: Array NodeId (Gathered dom) - preGatheredArr = array - (1, nodeCounter st - 1) - (zip idx gths) - - gatheredArr :: Array NodeId (Gathered dom) - gatheredArr = array - (1, nodeCounter st - 1) - (zip idx (Prelude.map withAdditionals gths)) - - withAdditionals g = g { geInfo = info} - where - info = mergeInfos - (geInfo g) - (Map.findWithDefault [] (geNodeId g) propagateAdditionals) - - propagateAdditionals :: Additional - propagateAdditionals = foldr propAdditional (additionals st) $ Map.toDescList (additionals st) - where - propAdditional :: (NodeId, [(NodeId, GatherInfo)]) -> Additional -> Additional - propAdditional (n, gi) ad = propAdditionalNode n gi ad - - propAdditionalNode :: NodeId -> [(NodeId, GatherInfo)] -> Additional -> Additional - propAdditionalNode n gi ad = liftASTB (propAdditionalExpr n gi) (geExpr (preGatheredArr ! n)) ad - - propAdditionalExpr :: NodeId -> [(NodeId, GatherInfo)] -> AST (NodeDomain dom) b -> Additional -> Additional - propAdditionalExpr n gi (Sym s) ad = ad - propAdditionalExpr n gi (s :$ Sym (C' (InjL (Node n')))) ad = ad3 - where - ad1 = Map.insertWith mergeInfos n' gi ad - ad2 = propAdditionalNode n' gi ad1 - ad3 = propAdditionalExpr n gi s ad2 - - applyAdditionals :: [(NodeId, GatherInfo)] -> Gathered dom -> Gathered dom - applyAdditionals ad g = g { geInfo = mergeInfos ad (geInfo g) } - - varHash :: Map.Map VarId Hash - varHash = lambdaHashes pd a - - gather' - :: Bool - -> ASTF dom b - -> GatherMonad dom (ASTF (NodeDomain dom) b) - gather' h a@(Sym lam :$ _) | Just v <- prjLambda pd lam - , Dict <- exprDict a = do - lt <- getLambdaTable - let hash = fromJust (Map.lookup v varHash) - case lookupLT hash a lt of - Just li -> do - let n = liLambdaNodeId li - anotherCopyOf n - tell (liFreeVars li) - return $ Sym $ C' $ InjL $ Node $ n - Nothing -> do - rec - (a',fv) <- listen $ addInnerLimitIf (not h) n $ addScopeVar v $ gatherRec (hoistOver a) a - n <- addInnerLimitIf (not h) n $ recordExpr fv a' - putLambdaTable (insertLT hash a n fv lt) - return $ Sym $ C' $ InjL $ Node n - gather' h a | Dict <- exprDict a = do - rec - (a',fv) <- listen $ addInnerLimitIf (not h) n $ gatherRec (hoistOver a) a - n <- addInnerLimitIf (not h) n $ recordExpr fv a' - return $ Sym $ C' $ InjL $ Node n - - addInnerLimitIf True n m = addInnerLimit n m - addInnerLimitIf _ n m = m - - gatherRec - :: (Sat dom (DenResult b)) - => Bool - -> AST dom b - -> GatherMonad dom (AST (NodeDomain dom) b) - gatherRec h (Sym var) | Just v <- prjVariable pd var = do - tell (Set.singleton v) - return $ Sym $ C' $ InjR var - gatherRec h (Sym s) = return $ Sym $ C' $ InjR s - gatherRec h (s :$ b) | Dict <- exprDict b = do - b' <- gather' h b - s' <- gatherRec h s - return (s' :$ b') - - anotherCopyOf :: NodeId -> GatherMonad dom () - anotherCopyOf n = do - st <- get - let s = gatherSet st - let ad = additionals st - innerLimit <- getInnerLimit - scope <- getScope - put (st { additionals = Map.insertWith mergeInfos n [(innerLimit, GatherInfo 1 scope)] ad }) - - recordExpr :: Set.Set VarId -> ASTF (NodeDomain dom) b -> GatherMonad dom NodeId - recordExpr fv a | Dict <- exprDict a = do - st <- get - let s = gatherSet st - let n = nodeCounter st - innerLimit <- getInnerLimit - scope <- getScope - case lookupGS s a of - Just ge -> do - let ge' = ge { geInfo = updateInfo innerLimit (GatherInfo 1 scope) (geInfo ge) } - put (st { gatherSet = updateGS s ge' }) - return (geNodeId ge) - Nothing -> do - let ge = Gathered { geExpr = ASTB a , geNodeId = n , geFreeVars = fv , geInfo = [(innerLimit, GatherInfo { giCount = 1 , giScopes = scope })] } - put (st { gatherSet = updateGS s ge, nodeCounter = n+1 }) - return n - -mergeInfos :: [(NodeId, GatherInfo)] -> [(NodeId, GatherInfo)] -> [(NodeId, GatherInfo)] -mergeInfos [] ys = ys -mergeInfos (x:xs) ys = mergeInfos xs (uncurry updateInfo x ys) - -updateInfo :: NodeId -> GatherInfo -> [(NodeId, GatherInfo)] -> [(NodeId, GatherInfo)] -updateInfo il gi [] = [(il, gi)] -updateInfo il (GatherInfo c scope) ((n,gi):xs) | n == il = (n, gi') : xs - where - gi' = gi { giCount = giCount gi + c , giScopes = Set.union (giScopes gi) scope } -updateInfo il gi (x:xs) = x : updateInfo il gi xs - - -lambdaHashes :: forall dom a - . (Equality dom) - => PrjDict dom - -> ASTF dom a - -> Map.Map VarId Hash -lambdaHashes pd a = execWriter (lambdaHashes' a) - where - lambdaHashes' :: AST dom b -> Writer (Map.Map VarId Hash) Hash - lambdaHashes' (Sym lam :$ b) | Just v <- prjLambda pd lam = do - h' <- lambdaHashes' b - tell (Map.singleton v h') - return $ hashInt 1 `combine` exprHash (Sym lam) `combine` h' - lambdaHashes' (s :$ b) = do - hs <- lambdaHashes' s - hb <- lambdaHashes' b - return $ hashInt 1 `combine` hs `combine` hb - lambdaHashes' s = return $ hashInt 0 `combine` exprHash s - --- | Like 'reify' but with common sub-expression elimination and variable hoisting -reifySmart2 :: forall dom p pVar a - . ( AlphaEq dom dom (NodeDomain (FODomain dom p pVar)) [(VarId,VarId)] - , AlphaEq dom dom (FODomain dom p pVar) [(VarId,VarId)] - , Equality dom - , Syntactic a - , Domain a ~ HODomain dom p pVar - , p :< Typeable - ) - => (forall c. ASTF (FODomain dom p pVar) c -> Bool) - -> MkInjDict (FODomain dom p pVar) - -> a - -> ASTF (FODomain dom p pVar) (Internal a) -reifySmart2 hoistOver mkId = flip evalState 0 . (codeMotion2 hoistOver prjDictFO mkId <=< reifyM . desugar) diff --git a/src/Language/Syntactic/Sharing/Graph.hs b/src/Language/Syntactic/Sharing/Graph.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sharing/Graph.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | Representation and manipulation of abstract syntax graphs - -module Language.Syntactic.Sharing.Graph where - - - -import Control.Arrow ((***)) -import Control.Monad.Reader -import Data.Array -import Data.Function -import Data.List -import Data.Typeable - -import Data.Hash - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding -import Language.Syntactic.Sharing.Utils - - - --------------------------------------------------------------------------------- --- * Representation --------------------------------------------------------------------------------- - --- | Node identifier -newtype NodeId = NodeId { nodeInteger :: Integer } - deriving (Eq, Ord, Num, Real, Integral, Enum, Ix) - -instance Show NodeId - where - show (NodeId i) = show i - -showNode :: NodeId -> String -showNode n = "node:" ++ show n - - - --- | Placeholder for a syntax tree -data Node a - where - Node :: NodeId -> Node (Full a) - -instance Constrained Node - where - {-# SPECIALIZE instance Constrained Node #-} - {-# INLINABLE exprDict #-} - type Sat Node = Top - exprDict _ = Dict - -instance Render Node - where - {-# INLINABLE renderSym #-} - renderSym (Node a) = showNode a - -instance StringTree Node - - - --- | Environment for alpha-equivalence -class NodeEqEnv dom a - where - prjNodeEqEnv :: a -> NodeEnv dom (Sat dom) - modNodeEqEnv :: (NodeEnv dom (Sat dom) -> NodeEnv dom (Sat dom)) -> (a -> a) - -type EqEnv dom p = ([(VarId,VarId)], NodeEnv dom p) - -type NodeEnv dom p = - ( Array NodeId Hash - , Array NodeId (ASTB dom p) - ) - -instance (p ~ Sat dom) => NodeEqEnv dom (EqEnv dom p) - where - {-# SPECIALIZE instance (p ~ Sat dom) => NodeEqEnv dom (EqEnv dom p) #-} - {-# INLINABLE prjNodeEqEnv #-} - {-# INLINABLE modNodeEqEnv #-} - prjNodeEqEnv = snd - modNodeEqEnv f = (id *** f) - -instance VarEqEnv (EqEnv dom p) - where - {-# SPECIALIZE instance VarEqEnv (EqEnv dom p) #-} - {-# INLINABLE prjVarEqEnv #-} - {-# INLINABLE modVarEqEnv #-} - prjVarEqEnv = fst - modVarEqEnv f = (f *** id) - -instance (AlphaEq dom dom dom env, NodeEqEnv dom env) => - AlphaEq Node Node dom env - where - {-# SPECIALIZE instance (AlphaEq dom dom dom env, NodeEqEnv dom env) => - AlphaEq Node Node dom env #-} - {-# INLINABLE alphaEqSym #-} - alphaEqSym (Node n1) Nil (Node n2) Nil - | n1 == n2 = return True - | otherwise = do - (hTab,nTab) :: NodeEnv dom (Sat dom) <- asks prjNodeEqEnv - if hTab!n1 /= hTab!n2 - then return False - else case (nTab!n1, nTab!n2) of - (ASTB a, ASTB b) -> alphaEqM a b - -- TODO The result could be memoized in a - -- @Map (NodeId,NodeId) Bool@ - - -- TODO With only this instance, the result will be 'False' when one argument - -- is a 'Node' and the other one isn't. This is not really correct since - -- 'Node's are just meta-variables and shouldn't be part of the - -- comparison. But as long as equivalent expressions always have 'Node's - -- at the same position, it doesn't matter. This could probably be fixed - -- by adding two overlapping instances. - - - --- | \"Abstract Syntax Graph\" --- --- A representation of a syntax tree with explicit sharing. An 'ASG' is valid if --- and only if 'inlineAll' succeeds (and the 'numNodes' field is correct). -data ASG dom a = ASG - { topExpression :: ASTF (NodeDomain dom) a -- ^ Top-level expression - , graphNodes :: [(NodeId, ASTSAT (NodeDomain dom))] -- ^ Mapping from node id to sub-expression - , numNodes :: NodeId -- ^ Total number of nodes - } - -type NodeDomain dom = (Node :+: dom) :|| Sat dom - - - --- | Show syntax graph using ASCII art -showASG :: forall dom a. StringTree dom => ASG dom a -> String -showASG (ASG top nodes _) = - unlines ((line "top" ++ showAST top) : map showNode nodes) - where - line str = "---- " ++ str ++ " " ++ rest ++ "\n" - where - rest = replicate (40 - length str) '-' - - showNode :: (NodeId, ASTSAT (NodeDomain dom)) -> String - showNode (n, ASTB expr) = concat - [ line ("node:" ++ show n) - , showAST expr - ] - --- | Print syntax graph using ASCII art -drawASG :: StringTree dom => ASG dom a -> IO () -drawASG = putStrLn . showASG - --- | Update the node identifiers in an 'AST' using the supplied reindexing --- function -reindexNodesAST :: - (NodeId -> NodeId) -> AST (NodeDomain dom) a -> AST (NodeDomain dom) a -reindexNodesAST reix (Sym (C' (InjL (Node n)))) = injC $ Node $ reix n -reindexNodesAST reix (s :$ a) = reindexNodesAST reix s :$ reindexNodesAST reix a -reindexNodesAST reix a = a - --- | Reindex the nodes according to the given index mapping. The number of nodes --- is unchanged, so if the index mapping is not 1:1, the resulting graph will --- contain duplicates. -reindexNodes :: (NodeId -> NodeId) -> ASG dom a -> ASG dom a -reindexNodes reix (ASG top nodes n) = ASG top' nodes' n - where - top' = reindexNodesAST reix top - nodes' = - [ (reix n, ASTB $ reindexNodesAST reix a) - | (n, ASTB a) <- nodes - ] - --- | Reindex the nodes to be in the range @[0 .. l-1]@, where @l@ is the number --- of nodes in the graph -reindexNodesFrom0 :: ASG dom a -> ASG dom a -reindexNodesFrom0 graph = reindexNodes reix graph - where - reix = reindex $ map fst $ graphNodes graph - --- | Remove duplicate nodes from a graph. The function only looks at the --- 'NodeId' of each node. The 'numNodes' field is updated accordingly. -nubNodes :: ASG dom a -> ASG dom a -nubNodes (ASG top nodes n) = ASG top nodes' n' - where - nodes' = nubBy ((==) `on` fst) nodes - n' = genericLength nodes' - - - --------------------------------------------------------------------------------- --- * Folding --------------------------------------------------------------------------------- - --- | Pattern functor representation of an 'AST' with 'Node's -data SyntaxPF dom a - where - AppPF :: a -> a -> SyntaxPF dom a - NodePF :: NodeId -> a -> SyntaxPF dom a - DomPF :: dom b -> SyntaxPF dom a - -- NOTE: The important constructor is 'NodePF', which makes a 'Node' appear as - -- any other recursive constructor. - -instance Functor (SyntaxPF dom) - where - fmap f (AppPF g a) = AppPF (f g) (f a) - fmap f (NodePF n a) = NodePF n (f a) - fmap f (DomPF a) = DomPF a - - - --- | Folding over a graph --- --- The user provides a function to fold a single constructor (an \"algebra\"). --- The result contains the result of folding the whole graph as well as the --- result of each internal node, represented both as an array and an association --- list. Each node is processed exactly once. -foldGraph :: forall dom a b . - (SyntaxPF dom b -> b) -> ASG dom a -> (b, (Array NodeId b, [(NodeId,b)])) -foldGraph alg (ASG top ns nn) = (g top, (arr,nodes)) - where - nodes = [(n, g expr) | (n, ASTB expr) <- ns] - arr = array (0, nn-1) nodes - - g :: AST (NodeDomain dom) c -> b - g (h :$ a) = alg $ AppPF (g h) (g a) - g (Sym (C' (InjL (Node n)))) = alg $ NodePF n (arr!n) - g (Sym (C' (InjR a))) = alg $ DomPF a - - - --------------------------------------------------------------------------------- --- * Inlining --------------------------------------------------------------------------------- - --- | Convert an 'ASG' to an 'AST' by inlining all nodes -inlineAll :: forall dom a . ConstrainedBy dom Typeable => - ASG dom a -> ASTF dom a -inlineAll (ASG top nodes n) = inline top - where - nodeMap = array (0, n-1) nodes - - inline :: AST (NodeDomain dom) b -> AST dom b - inline (s :$ a) = inline s :$ inline a - inline s@(Sym (C' (InjL (Node n)))) = case nodeMap ! n of - ASTB a - | Dict <- exprDictSub pTypeable s - , Dict <- exprDictSub pTypeable a - -> case gcast a of - Nothing -> error "inlineAll: type mismatch" - Just a -> inline a - inline (Sym (C' (InjR a))) = Sym a - - - --- | Find the child nodes of each node in an expression. The child nodes of a --- node @n@ are the first nodes along all paths from @n@. -nodeChildren :: ASG dom a -> [(NodeId, [NodeId])] -nodeChildren = map (id *** fromDList) . snd . snd . foldGraph children - where - children :: SyntaxPF dom (DList NodeId) -> DList NodeId - children (AppPF ns1 ns2) = ns1 . ns2 - children (NodePF n _) = single n - children _ = empty - --- | Count the number of occurrences of each node in an expression -occurrences :: ASG dom a -> Array NodeId Int -occurrences graph - = count (0, numNodes graph - 1) - $ concatMap snd - $ nodeChildren graph - --- | Inline all nodes that are not shared -inlineSingle :: forall dom a . ConstrainedBy dom Typeable => - ASG dom a -> ASG dom a -inlineSingle graph@(ASG top nodes n) = ASG top' nodes' n' - where - nodeTab = array (0, n-1) nodes - occs = occurrences graph - - top' = inline top - nodes' = [(n, ASTB (inline a)) | (n, ASTB a) <- nodes, occs!n > 1] - n' = genericLength nodes' - - inline :: AST (NodeDomain dom) b -> AST (NodeDomain dom) b - inline (s :$ a) = inline s :$ inline a - inline s@(Sym (C' (InjL (Node n)))) - | occs!n > 1 = injC $ Node n - | otherwise = case nodeTab ! n of - ASTB a - | Dict <- exprDictSub pTypeable s - , Dict <- exprDictSub pTypeable a - -> case gcast a of - Nothing -> error "inlineSingle: type mismatch" - Just a -> inline a - inline (Sym (C' (InjR a))) = Sym $ C' $ InjR a - - - --------------------------------------------------------------------------------- --- * Sharing --------------------------------------------------------------------------------- - --- | Compute a table (both array and list representation) of hash values for --- each node -hashNodes :: Equality dom => ASG dom a -> (Array NodeId Hash, [(NodeId, Hash)]) -hashNodes = snd . foldGraph hashNode - where - hashNode (AppPF h1 h2) = hashInt 0 `combine` h1 `combine` h2 - hashNode (NodePF _ h) = h - hashNode (DomPF a) = hashInt 1 `combine` exprHash a - - - --- | Partitions the nodes such that two nodes are in the same sub-list if and --- only if they are alpha-equivalent. -partitionNodes :: forall dom a - . ( Equality dom - , AlphaEq dom dom (NodeDomain dom) (EqEnv (NodeDomain dom) (Sat dom)) - ) - => ASG dom a -> [[NodeId]] -partitionNodes graph = concatMap (fullPartition nodeEq) approxPartitioning - where - nTab = array (0, numNodes graph - 1) (graphNodes graph) - (hTab,hashes) = hashNodes graph - - -- | An approximate partitioning of the nodes: nodes in different partitions - -- are guaranteed to be inequivalent, while nodes in the same partition - -- might be equivalent. - approxPartitioning - = map (map fst) - $ groupBy ((==) `on` snd) - $ sortBy (compare `on` snd) - $ hashes - - nodeEq :: NodeId -> NodeId -> Bool - nodeEq n1 n2 = runReader - (liftASTB2 alphaEqM (nTab!n1) (nTab!n2)) - (([],(hTab,nTab)) :: EqEnv (NodeDomain dom) (Sat dom)) - - - --- | Common sub-expression elimination based on alpha-equivalence -cse - :: ( Equality dom - , AlphaEq dom dom (NodeDomain dom) (EqEnv (NodeDomain dom) (Sat dom)) - ) - => ASG dom a -> ASG dom a -cse graph@(ASG top nodes n) = nubNodes $ reindexNodes (reixTab!) graph - where - parts = partitionNodes graph - reixTab = array (0,n-1) [(n,p) | (part,p) <- parts `zip` [0..], n <- part] diff --git a/src/Language/Syntactic/Sharing/Reify.hs b/src/Language/Syntactic/Sharing/Reify.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sharing/Reify.hs +++ /dev/null @@ -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, ). - -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) - diff --git a/src/Language/Syntactic/Sharing/ReifyHO.hs b/src/Language/Syntactic/Sharing/ReifyHO.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sharing/ReifyHO.hs +++ /dev/null @@ -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, ). - -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 - diff --git a/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs b/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs +++ /dev/null @@ -1,243 +0,0 @@ --- | Simple code motion transformation performing common sub-expression elimination and variable --- hoisting. Note that the implementation is very inefficient. --- --- The code is based on an implementation by Gergely Dévai. - -module Language.Syntactic.Sharing.SimpleCodeMotion - ( PrjDict (..) - , InjDict (..) - , MkInjDict - , codeMotion - , prjDictFO - , reifySmart - , mkInjDictFO - ) where - - - -import Control.Monad.State -import Data.Set as Set -import Data.Typeable - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding -import Language.Syntactic.Constructs.Binding.HigherOrder - - - --- | Interface for projecting binding constructs -data PrjDict dom = PrjDict - { prjVariable :: forall sig . dom sig -> Maybe VarId - , prjLambda :: forall sig . dom sig -> Maybe VarId - } - --- | Interface for injecting binding constructs -data InjDict dom a b = InjDict - { injVariable :: VarId -> dom (Full a) - , injLambda :: VarId -> dom (b :-> Full (a -> b)) - , injLet :: dom (a :-> (a -> b) :-> Full b) - } - --- | A function that, if possible, returns an 'InjDict' for sharing a specific sub-expression. The --- first argument is the expression to be shared, and the second argument the expression in which it --- will be shared. --- --- This function makes the caller of 'codeMotion' responsible for making sure that the necessary --- type constraints are fulfilled (otherwise 'Nothing' is returned). It also makes it possible to --- transfer information, e.g. from the shared expression to the introduced variable. -type MkInjDict dom = forall a b . ASTF dom a -> ASTF dom b -> Maybe (InjDict dom a b) - - - --- | Substituting a sub-expression. Assumes no variable capturing in the --- expressions involved. -substitute :: forall dom a b - . (ConstrainedBy dom Typeable, AlphaEq dom dom dom [(VarId,VarId)]) - => ASTF dom a -- ^ Sub-expression to be replaced - -> ASTF dom a -- ^ Replacing sub-expression - -> ASTF dom b -- ^ Whole expression - -> ASTF dom b -substitute x y a - | Dict <- exprDictSub pTypeable y - , Dict <- exprDictSub pTypeable a - , Just y' <- gcast y, alphaEq x a = y' - | otherwise = subst a - where - subst :: AST dom c -> AST dom c - subst (f :$ a) = subst f :$ substitute x y a - subst a = a - -- Note: Since `codeMotion` only uses `substitute` to replace sub-expressions - -- with fresh variables, there's no risk of capturing. - --- | Count the number of occurrences of a sub-expression -count :: forall dom a b - . AlphaEq dom dom dom [(VarId,VarId)] - => ASTF dom a -- ^ Expression to count - -> ASTF dom b -- ^ Expression to count in - -> Int -count a b - | alphaEq a b = 1 - | otherwise = cnt b - where - cnt :: AST dom c -> Int - cnt (f :$ b) = cnt f + count a b - cnt _ = 0 - --- | Environment for the expression in the 'choose' function -data Env dom = Env - { inLambda :: Bool -- ^ Whether the current expression is inside a lambda - , counter :: ASTE dom -> Int - -- ^ Counting the number of occurrences of an expression in the - -- environment - , dependencies :: Set VarId - -- ^ The set of variables that are not allowed to occur in the chosen - -- expression - } - -isVariable :: PrjDict dom -> ASTF dom a -> Bool -isVariable pd (Sym (prjVariable pd -> Just _)) = True -isVariable pd _ = False - --- | Get the set of free variables in an expression -freeVars :: PrjDict dom -> AST dom sig -> Set VarId -freeVars pd (Sym var) - | Just v <- prjVariable pd var = Set.singleton v -freeVars pd (Sym lam :$ body) - | Just v <- prjLambda pd lam = Set.delete v (freeVars pd body) -freeVars pd (s :$ a) = Set.union (freeVars pd s) (freeVars pd a) -freeVars _ _ = Set.empty - --- | Checks whether a sub-expression in a given environment can be lifted out -liftable :: PrjDict dom -> Env dom -> ASTF dom a -> Bool -liftable pd env a = independent && not (isVariable pd a) && heuristic - -- Lifting dependent expressions is semantically incorrect - -- Lifting variables would cause `codeMotion` to loop - where - independent = Set.null $ Set.intersection (freeVars pd a) (dependencies env) - heuristic = inLambda env || (counter env (ASTE a) > 1) - - - --- | A sub-expression chosen to be shared together with an evidence that it can actually be shared --- in the whole expression under consideration -data Chosen dom a - where - Chosen :: InjDict dom b a -> ASTF dom b -> Chosen dom a - --- | Choose a sub-expression to share -choose :: forall dom a - . AlphaEq dom dom dom [(VarId,VarId)] - => (forall c. ASTF dom c -> Bool) - -> PrjDict dom - -> MkInjDict dom - -> ASTF dom a - -> Maybe (Chosen dom a) -choose hoistOver pd mkId a = chooseEnvSub initEnv a - where - initEnv = Env - { inLambda = False - , counter = \(ASTE b) -> count b a - , dependencies = empty - } - - chooseEnv :: Env dom -> ASTF dom b -> Maybe (Chosen dom a) - chooseEnv env b - | liftable pd env b - , Just id <- mkId b a - = Just $ Chosen id b - chooseEnv env b - | hoistOver b = chooseEnvSub env b - | otherwise = Nothing - - -- | Like 'chooseEnv', but does not consider the top expression for sharing - chooseEnvSub :: Env dom -> AST dom b -> Maybe (Chosen dom a) - chooseEnvSub env (Sym lam :$ b) - | Just v <- prjLambda pd lam - = chooseEnv (env' v) b - where - env' v = env - { inLambda = True - , dependencies = insert v (dependencies env) - } - chooseEnvSub env (s :$ b) = chooseEnvSub env s `mplus` chooseEnv env b - chooseEnvSub _ _ = Nothing - - - --- | Perform common sub-expression elimination and variable hoisting -codeMotion :: forall dom m a - . ( ConstrainedBy dom Typeable - , AlphaEq dom dom dom [(VarId,VarId)] - , MonadState VarId m - ) - => (forall c. ASTF dom c -> Bool) -- ^ Control wether a sub-expression can be hoisted over the given expression - -> PrjDict dom - -> MkInjDict dom - -> ASTF dom a - -> m (ASTF dom a) -codeMotion hoistOver pd mkId a - | Just (Chosen id b) <- choose hoistOver pd mkId a = share id b - | otherwise = descend a - where - share :: InjDict dom b a -> ASTF dom b -> m (ASTF dom a) - share id b = do - b' <- codeMotion hoistOver pd mkId b - v <- get; put (v+1) - let x = Sym (injVariable id v) - body <- codeMotion hoistOver pd mkId $ substitute b x a - return - $ Sym (injLet id) - :$ b' - :$ (Sym (injLambda id v) :$ body) - - descend :: AST dom b -> m (AST dom b) - descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId a) - descend a = return a - - - --- | A 'PrjDict' implementation for 'FODomain' -prjDictFO :: forall dom p pVar . PrjDict (FODomain dom p pVar) -prjDictFO = PrjDict - { prjVariable = fmap (\(C' (Variable v)) -> v) . prjP (P::P (Variable :|| pVar)) - , prjLambda = fmap (\(SubConstr2 (Lambda v)) -> v) . prjP (P::P (CLambda pVar)) - } - --- | Like 'reify' but with common sub-expression elimination and variable hoisting -reifySmart :: forall dom p pVar a - . ( AlphaEq dom dom (FODomain dom p pVar) [(VarId,VarId)] - , Syntactic a - , Domain a ~ HODomain dom p pVar - , p :< Typeable - ) - => (forall c. ASTF (FODomain dom p pVar) c -> Bool) - -> MkInjDict (FODomain dom p pVar) - -> a - -> ASTF (FODomain dom p pVar) (Internal a) -reifySmart hoistOver mkId = flip evalState 0 . (codeMotion hoistOver prjDictFO mkId <=< reifyM . desugar) - - - --- | An 'MkInjDict' implementation for 'FODomain' --- --- The supplied function determines whether or not an expression can be shared by returning a --- witness that the type of the expression satisfies the predicate @pVar@. -mkInjDictFO :: forall dom pVar . (Let :<: dom) - => (forall a . ASTF (FODomain dom Typeable pVar) a -> Maybe (Dict (pVar a))) - -> (forall b . ASTF (FODomain dom Typeable pVar) b -> Bool) - -> MkInjDict (FODomain dom Typeable pVar) -mkInjDictFO canShare canShareIn a b - | Dict <- exprDict a - , Dict <- exprDict b - , Just Dict <- canShare a - , canShareIn b - = Just $ InjDict - { injVariable = \v -> injC (symType pVar $ C' (Variable v)) - , injLambda = \v -> injC (symType pLam $ SubConstr2 (Lambda v)) - , injLet = C' $ inj Let - } - where - pVar = P::P (Variable :|| pVar) - pLam = P::P (CLambda pVar) -mkInjDictFO _ _ _ _ = Nothing - diff --git a/src/Language/Syntactic/Sharing/StableName.hs b/src/Language/Syntactic/Sharing/StableName.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sharing/StableName.hs +++ /dev/null @@ -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 - -- - - -- 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 - diff --git a/src/Language/Syntactic/Sharing/Utils.hs b/src/Language/Syntactic/Sharing/Utils.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sharing/Utils.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Syntactic/Sugar.hs b/src/Language/Syntactic/Sugar.hs deleted file mode 100644 --- a/src/Language/Syntactic/Sugar.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -#endif - --- | \"Syntactic sugar\" - -module Language.Syntactic.Sugar where - - - -import Language.Syntactic.Syntax -import Language.Syntactic.Constraint - - - --- | It is usually assumed that @(`desugar` (`sugar` a))@ has the same meaning --- as @a@. -class Syntactic a - where - type Domain a :: * -> * - type Internal a - desugar :: a -> ASTF (Domain a) (Internal a) - sugar :: ASTF (Domain a) (Internal a) -> a - -instance Syntactic (ASTF dom a) - where - {-# SPECIALIZE instance Syntactic (ASTF dom a) #-} - type Domain (ASTF dom a) = dom - type Internal (ASTF dom a) = a - desugar = id - sugar = id - {-# INLINABLE desugar #-} - {-# INLINABLE sugar #-} - --- | Syntactic type casting -resugar :: (Syntactic a, Syntactic b, Domain a ~ Domain b, Internal a ~ Internal b) => a -> b -resugar = sugar . desugar -{-# INLINABLE resugar #-} - --- | N-ary syntactic functions --- --- 'desugarN' has any type of the form: --- --- > desugarN :: --- > ( Syntactic a --- > , Syntactic b --- > , ... --- > , Syntactic x --- > , Domain a ~ dom --- > , Domain b ~ dom --- > , ... --- > , Domain x ~ dom --- > ) => (a -> b -> ... -> x) --- > -> ( ASTF dom (Internal a) --- > -> ASTF dom (Internal b) --- > -> ... --- > -> ASTF dom (Internal x) --- > ) --- --- ...and vice versa for 'sugarN'. -class SyntacticN a internal | a -> internal - where - desugarN :: a -> internal - sugarN :: internal -> a - -instance {-# OVERLAPPABLE #-} - (Syntactic a, Domain a ~ dom, ia ~ AST dom (Full (Internal a))) => SyntacticN a ia - where - {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom - , ia ~ AST dom (Full (Internal a)) - ) => SyntacticN a ia #-} - desugarN = desugar - sugarN = sugar - {-# INLINABLE desugarN #-} - {-# INLINABLE sugarN #-} - -instance {-# OVERLAPPABLE #-} - ( Syntactic a - , Domain a ~ dom - , ia ~ Internal a - , SyntacticN b ib - ) => - SyntacticN (a -> b) (AST dom (Full ia) -> ib) - where - {-# SPECIALIZE instance ( Syntactic a - , Domain a ~ dom - , ia ~ Internal a - , SyntacticN b ib - ) => SyntacticN (a -> b) (AST dom (Full ia) -> ib) #-} - desugarN f = desugarN . f . sugar - sugarN f = sugarN . f . desugar - {-# INLINABLE desugarN #-} - {-# INLINABLE sugarN #-} - - - --- | \"Sugared\" symbol application --- --- 'sugarSym' has any type of the form: --- --- > sugarSym :: --- > ( expr :<: AST dom --- > , Syntactic a dom --- > , Syntactic b dom --- > , ... --- > , Syntactic x dom --- > ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x)) --- > -> (a -> b -> ... -> x) -sugarSym :: (sym :<: AST dom, ApplySym sig b dom, SyntacticN c b) => - sym sig -> c -sugarSym = sugarN . appSym -{-# INLINABLE sugarSym #-} - --- | \"Sugared\" symbol application --- --- 'sugarSymC' has any type of the form: --- --- > sugarSymC :: --- > ( InjectC expr (AST dom) (Internal x) --- > , Syntactic a dom --- > , Syntactic b dom --- > , ... --- > , Syntactic x dom --- > ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x)) --- > -> (a -> b -> ... -> x) -sugarSymC - :: ( InjectC sym (AST dom) (DenResult sig) - , ApplySym sig b dom - , SyntacticN c b - ) - => sym sig -> c -sugarSymC = sugarN . appSymC -{-# INLINABLE sugarSymC #-} diff --git a/src/Language/Syntactic/Syntax.hs b/src/Language/Syntactic/Syntax.hs deleted file mode 100644 --- a/src/Language/Syntactic/Syntax.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -#endif -{-# LANGUAGE UndecidableInstances #-} - --- | Generic representation of typed syntax trees --- --- For details, see: A Generic Abstract Syntax Model for Embedded Languages --- (ICFP 2012, ). - -module Language.Syntactic.Syntax - ( -- * Syntax trees - AST (..) - , ASTF - , Full (..) - , (:->) (..) - , size - , ApplySym (..) - , DenResult - -- * Symbol domains - , (:+:) (..) - , Project (..) - , (:<:) (..) - , appSym - -- * Type inference - , symType - , prjP - ) where - - -#if (__GLASGOW_HASKELL__ <= 704) -import Control.Monad.Instances () -#endif -import Data.Typeable - -import Data.PolyProxy - - - --------------------------------------------------------------------------------- --- * Syntax trees --------------------------------------------------------------------------------- - --- | Generic abstract syntax tree, parameterized by a symbol domain --- --- @(`AST` dom (a `:->` b))@ represents a partially applied (or unapplied) --- symbol, missing at least one argument, while @(`AST` dom (`Full` a))@ --- represents a fully applied symbol, i.e. a complete syntax tree. -data AST dom sig - where - Sym :: dom sig -> AST dom sig - (:$) :: AST dom (a :-> sig) -> AST dom (Full a) -> AST dom sig - -infixl 1 :$ - --- | Fully applied abstract syntax tree -type ASTF dom a = AST dom (Full a) - -instance Functor dom => Functor (AST dom) - where - fmap f (Sym s) = Sym (fmap f s) - fmap f (s :$ a) = fmap (fmap f) s :$ a - --- | Signature of a fully applied symbol -newtype Full a = Full { result :: a } - deriving (Eq, Show, Typeable, Functor) - --- | Signature of a partially applied (or unapplied) symbol -newtype a :-> sig = Partial (a -> sig) - deriving (Typeable, Functor) - -infixr :-> - --- | Count the number of symbols in an expression -size :: AST dom sig -> Int -size (Sym _) = 1 -size (s :$ a) = size s + size a - --- | Class for the type-level recursion needed by 'appSym' -class ApplySym sig f dom | sig dom -> f, f -> sig dom - where - appSym' :: AST dom sig -> f - -instance ApplySym (Full a) (ASTF dom a) dom - where - {-# SPECIALIZE instance ApplySym (Full a) (ASTF dom a) dom #-} - {-# INLINABLE appSym' #-} - appSym' = id - -instance ApplySym sig f dom => ApplySym (a :-> sig) (ASTF dom a -> f) dom - where - {-# SPECIALIZE instance ApplySym sig f dom => ApplySym (a :-> sig) (ASTF dom a -> f) dom #-} - {-# INLINABLE appSym' #-} - appSym' sym a = appSym' (sym :$ a) - --- | The result type of a symbol with the given signature -type family DenResult sig -type instance DenResult (Full a) = a -type instance DenResult (a :-> sig) = DenResult sig - - - --------------------------------------------------------------------------------- --- * Symbol domains --------------------------------------------------------------------------------- - --- | Direct sum of two symbol domains -data (dom1 :+: dom2) a - where - InjL :: dom1 a -> (dom1 :+: dom2) a - InjR :: dom2 a -> (dom1 :+: dom2) a - deriving (Functor) - -infixr :+: - --- | Symbol projection -class Project sub sup - where - -- | Partial projection from @sup@ to @sub@ - prj :: sup a -> Maybe (sub a) - -instance Project sub sup => Project sub (AST sup) - where - {-# SPECIALIZE instance Project sub sup => Project sub (AST sup) #-} - {-# INLINABLE prj #-} - prj (Sym a) = prj a - prj _ = Nothing - -instance Project expr expr - where - {-# SPECIALIZE instance Project expr expr #-} - {-# INLINABLE prj #-} - prj = Just - -instance {-# OVERLAPPING #-} Project expr1 (expr1 :+: expr2) - where - {-# SPECIALIZE instance Project expr1 (expr1 :+: expr2) #-} - {-# INLINABLE prj #-} - prj (InjL a) = Just a - prj _ = Nothing - -instance {-# OVERLAPPING #-} Project expr1 expr3 => Project expr1 (expr2 :+: expr3) - where - {-# SPECIALIZE instance Project expr1 expr3 => Project expr1 (expr2 :+: expr3) #-} - {-# INLINABLE prj #-} - prj (InjR a) = prj a - prj _ = Nothing - --- | Symbol subsumption -class Project sub sup => sub :<: sup - where - -- | Injection from @sub@ to @sup@ - inj :: sub a -> sup a - -instance (sub :<: sup) => (sub :<: AST sup) - where - {-# SPECIALIZE instance (sub :<: sup) => (sub :<: AST sup) #-} - {-# INLINABLE inj #-} - inj = Sym . inj - -instance (expr :<: expr) - where - {-# SPECIALIZE instance (expr :<: expr) #-} - {-# INLINABLE inj #-} - inj = id - -instance {-# OVERLAPPING #-} (expr1 :<: (expr1 :+: expr2)) - where - {-# SPECIALIZE instance (expr1 :<: (expr1 :+: expr2)) #-} - {-# INLINABLE inj #-} - inj = InjL - -instance {-# OVERLAPPING #-} (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3)) - where - {-# SPECIALIZE instance (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3)) #-} - {-# INLINABLE inj #-} - inj = InjR . inj - --- The reason for separating the `Project` and `(:<:)` classes is that there are --- types that can be instances of the former but not the latter due to type --- constraints on the `a` type. - --- | Generic symbol application --- --- 'appSym' has any type of the form: --- --- > appSym :: (expr :<: AST dom) --- > => expr (a :-> b :-> ... :-> Full x) --- > -> (ASTF dom a -> ASTF dom b -> ... -> ASTF dom x) -appSym :: (ApplySym sig f dom, sym :<: AST dom) => sym sig -> f -appSym = appSym' . inj -{-# INLINABLE appSym #-} - - - --------------------------------------------------------------------------------- --- * Type inference --------------------------------------------------------------------------------- - --- | Constrain a symbol to a specific type -symType :: P sym -> sym sig -> sym sig -symType = const id -{-# INLINABLE symType #-} - --- | Projection to a specific symbol type -prjP :: Project sub sup => P sub -> sup sig -> Maybe (sub sig) -prjP = const prj -{-# INLINABLE prjP #-} diff --git a/src/Language/Syntactic/Traversal.hs b/src/Language/Syntactic/Traversal.hs deleted file mode 100644 --- a/src/Language/Syntactic/Traversal.hs +++ /dev/null @@ -1,204 +0,0 @@ --- | Generic traversals of 'AST' terms - -module Language.Syntactic.Traversal - ( gmapQ - , gmapT - , everywhereUp - , everywhereDown - , Args (..) - , listArgs - , mapArgs - , mapArgsA - , mapArgsM - , appArgs - , foldrArgs - , listFold - , match - , query - , simpleMatch - , fold - , simpleFold - , matchTrans - , WrapFull (..) - , toTree - ) where - - - -import Control.Applicative -import Data.Tree - -import Language.Syntactic.Syntax - - - --- | Map a function over all immediate sub-terms (corresponds to the function --- with the same name in Scrap Your Boilerplate) -gmapT :: forall dom - . (forall a . ASTF dom a -> ASTF dom a) - -> (forall a . ASTF dom a -> ASTF dom a) -gmapT f = go - where - go :: forall a . AST dom a -> AST dom a - go (s :$ a) = go s :$ f a - go s = s - --- | Map a function over all immediate sub-terms, collecting the results in a --- list (corresponds to the function with the same name in Scrap Your --- Boilerplate) -gmapQ :: forall dom b - . (forall a . ASTF dom a -> b) - -> (forall a . ASTF dom a -> [b]) -gmapQ f = go - where - go :: forall a . AST dom a -> [b] - go (s :$ a) = f a : go s - go _ = [] - --- | Apply a transformation bottom-up over an expression (corresponds to --- @everywhere@ in Scrap Your Boilerplate) -everywhereUp - :: (forall a . ASTF dom a -> ASTF dom a) - -> (forall a . ASTF dom a -> ASTF dom a) -everywhereUp f = f . gmapT (everywhereUp f) - --- | Apply a transformation top-down over an expression (corresponds to --- @everywhere'@ in Scrap Your Boilerplate) -everywhereDown - :: (forall a . ASTF dom a -> ASTF dom a) - -> (forall a . ASTF dom a -> ASTF dom a) -everywhereDown f = gmapT (everywhereDown f) . f - --- | List of symbol arguments -data Args c sig - where - Nil :: Args c (Full a) - (:*) :: c (Full a) -> Args c sig -> Args c (a :-> sig) - -infixr :* - --- | Map a function over an 'Args' list and collect the results in an ordinary --- list -listArgs :: (forall a . c (Full a) -> b) -> Args c sig -> [b] -listArgs _ Nil = [] -listArgs f (a :* as) = f a : listArgs f as - --- | Map a function over an 'Args' list -mapArgs - :: (forall a . c1 (Full a) -> c2 (Full a)) - -> (forall sig . Args c1 sig -> Args c2 sig) -mapArgs _ Nil = Nil -mapArgs f (a :* as) = f a :* mapArgs f as - --- | Map an applicative function over an 'Args' list -mapArgsA :: Applicative f - => (forall a . c1 (Full a) -> f (c2 (Full a))) - -> (forall sig . Args c1 sig -> f (Args c2 sig)) -mapArgsA _ Nil = pure Nil -mapArgsA f (a :* as) = (:*) <$> f a <*> mapArgsA f as - --- | Map a monadic function over an 'Args' list -mapArgsM :: Monad m - => (forall a . c1 (Full a) -> m (c2 (Full a))) - -> (forall sig . Args c1 sig -> m (Args c2 sig)) -mapArgsM f = unwrapMonad . mapArgsA (WrapMonad . f) - --- | Right fold for an 'Args' list -foldrArgs - :: (forall a . c (Full a) -> b -> b) - -> b - -> (forall sig . Args c sig -> b) -foldrArgs _ b Nil = b -foldrArgs f b (a :* as) = f a (foldrArgs f b as) - --- | Apply a (partially applied) symbol to a list of argument terms -appArgs :: AST dom sig -> Args (AST dom) sig -> ASTF dom (DenResult sig) -appArgs a Nil = a -appArgs s (a :* as) = appArgs (s :$ a) as - --- | \"Pattern match\" on an 'AST' using a function that gets direct access to --- the top-most symbol and its sub-trees -match :: forall dom a c - . ( forall sig . (a ~ DenResult sig) => - dom sig -> Args (AST dom) sig -> c (Full a) - ) - -> ASTF dom a - -> c (Full a) -match f = flip go Nil - where - go :: (a ~ DenResult sig) => AST dom sig -> Args (AST dom) sig -> c (Full a) - go (Sym a) as = f a as - go (s :$ a) as = go s (a :* as) -{-# INLINABLE match #-} - -query :: forall dom a c - . ( forall sig . (a ~ DenResult sig) => - dom sig -> Args (AST dom) sig -> c (Full a) - ) - -> ASTF dom a - -> c (Full a) -query = match -{-# DEPRECATED query "Please use `match` instead." #-} - --- | A version of 'match' with a simpler result type -simpleMatch :: forall dom a b - . (forall sig . (a ~ DenResult sig) => dom sig -> Args (AST dom) sig -> b) - -> ASTF dom a - -> b -simpleMatch f = getConst . match (\s -> Const . f s) -{-# INLINABLE simpleMatch #-} - --- | Fold an 'AST' using an 'Args' list to hold the results of sub-terms -fold :: forall dom c - . (forall sig . dom sig -> Args c sig -> c (Full (DenResult sig))) - -> (forall a . ASTF dom a -> c (Full a)) -fold f = match (\s -> f s . mapArgs (fold f)) -{-# INLINABLE fold #-} - --- | Simplified version of 'fold' for situations where all intermediate results --- have the same type -simpleFold :: forall dom b - . (forall sig . dom sig -> Args (Const b) sig -> b) - -> (forall a . ASTF dom a -> b) -simpleFold f = getConst . fold (\s -> Const . f s) -{-# INLINABLE simpleFold #-} - --- | Fold an 'AST' using a list to hold the results of sub-terms -listFold :: forall dom b - . (forall sig . dom sig -> [b] -> b) - -> (forall a . ASTF dom a -> b) -listFold f = simpleFold (\s -> f s . listArgs getConst) -{-# INLINABLE listFold #-} - -newtype WrapAST c dom sig = WrapAST { unWrapAST :: c (AST dom sig) } - -- Only used in the definition of 'matchTrans' - --- | A version of 'match' where the result is a transformed syntax tree, --- wrapped in a type constructor @c@ -matchTrans :: forall dom dom' c a - . ( forall sig . (a ~ DenResult sig) => - dom sig -> Args (AST dom) sig -> c (ASTF dom' a) - ) - -> ASTF dom a - -> c (ASTF dom' a) -matchTrans f = unWrapAST . match (\s -> WrapAST . f s) -{-# INLINABLE matchTrans #-} - --- | Can be used to make an arbitrary type constructor indexed by @(`Full` a)@. --- This is useful as the type constructor parameter of 'Args'. That is, use --- --- > Args (WrapFull c) ... --- --- instead of --- --- > Args c ... --- --- if @c@ is not indexed by @(`Full` a)@. -data WrapFull c a - where - WrapFull :: { unwrapFull :: c a } -> WrapFull c (Full a) - --- | Convert an 'AST' to a 'Tree' -toTree :: forall dom a b . (forall sig . dom sig -> b) -> ASTF dom a -> Tree b -toTree f = listFold (Node . f) -{-# INLINABLE toTree #-} diff --git a/syntactic.cabal b/syntactic.cabal --- a/syntactic.cabal +++ b/syntactic.cabal @@ -1,23 +1,11 @@ Name: syntactic -Version: 1.17 -Synopsis: Generic abstract syntax, and utilities for embedded languages -Description: This library provides: - . - * Generic representation and manipulation of abstract syntax - . - * Composable AST representations (partly based on Data Types à - la Carte [1]) - . - * A collection of common syntactic constructs, including - variable binding constructs - . - * Utilities for analyzing and transforming generic abstract - syntax - . - * Utilities for building extensible embedded languages based - on generic syntax +Version: 2.0 +Synopsis: Generic representation and manipulation of abstract syntax +Description: The library provides a generic representation of type-indexed abstract syntax trees + (or indexed data types in general). It also permits the definition of open syntax + trees based on the technique in Data Types à la Carte [1]. . - For more information about the core functionality, see + For more information, see \"A Generic Abstract Syntax Model for Embedded Languages\" (ICFP 2012): . @@ -27,20 +15,11 @@ * Slides: . - For a practical example of how to use the library, see the - proof-of-concept implementation Feldspar EDSL in the @examples@ - directory. (The real Feldspar [2] is also implemented using - Syntactic.) - . - The maturity of this library varies between different modules. - The core part ("Language.Syntactic") is rather stable, but many - of the other modules are in a much more experimental state. + Example EDSL can be found in the @examples@ folder. . \[1\] W. Swierstra. Data Types à la Carte. /Journal of Functional Programming/, 18(4):423-436, 2008, . - . - \[2\] License: BSD3 License-file: LICENSE Author: Emil Axelsson @@ -48,15 +27,19 @@ Copyright: Copyright (c) 2011-2014, Emil Axelsson Homepage: https://github.com/emilaxelsson/syntactic Bug-reports: https://github.com/emilaxelsson/syntactic/issues +Stability: experimental Category: Language Build-type: Simple -Cabal-version: >=1.10 -Tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.*, GHC==7.11.* +Cabal-version: >=1.16 +Tested-with: GHC==7.6.2, GHC==7.8.2 extra-source-files: CONTRIBUTORS - examples/NanoFeldspar/*.hs + examples/*.hs + tests/*.hs tests/gold/*.txt + extras/*.hs + benchmarks/*.hs source-repository head type: git @@ -64,189 +47,106 @@ library exposed-modules: - Data.PolyProxy - Data.DynamicAlt - Language.Syntactic - Language.Syntactic.Syntax - Language.Syntactic.Traversal - Language.Syntactic.Constraint - Language.Syntactic.Sugar - Language.Syntactic.Interpretation - Language.Syntactic.Interpretation.Equality - Language.Syntactic.Interpretation.Evaluation - Language.Syntactic.Interpretation.Render - Language.Syntactic.Interpretation.Semantics - Language.Syntactic.Constructs.Binding - Language.Syntactic.Constructs.Binding.HigherOrder - Language.Syntactic.Constructs.Binding.Optimize - Language.Syntactic.Constructs.Condition - Language.Syntactic.Constructs.Construct - Language.Syntactic.Constructs.Decoration - Language.Syntactic.Constructs.Identity - Language.Syntactic.Constructs.Literal - Language.Syntactic.Constructs.Monad - Language.Syntactic.Constructs.Tuple - Language.Syntactic.Frontend.Monad - Language.Syntactic.Frontend.Tuple - Language.Syntactic.Frontend.TupleConstrained - Language.Syntactic.Sharing.SimpleCodeMotion - Language.Syntactic.Sharing.CodeMotion2 - Language.Syntactic.Sharing.Utils - Language.Syntactic.Sharing.Graph - Language.Syntactic.Sharing.StableName - Language.Syntactic.Sharing.Reify - Language.Syntactic.Sharing.ReifyHO - - other-modules: + Data.Syntactic + Data.Syntactic.Syntax + Data.Syntactic.Traversal + Data.Syntactic.Interpretation + Data.Syntactic.Sugar + Data.Syntactic.Decoration + Data.Syntactic.Functional + Data.Syntactic.Sugar.Binding + Data.Syntactic.Sugar.BindingT + Data.Syntactic.Sugar.Monad + Data.Syntactic.Sugar.MonadT build-depends: - array, - base >= 4 && < 5.9, + base >= 4 && < 5, containers, constraints, data-hash, - ghc-prim, mtl >= 2 && < 3, + safe, + tagged, template-haskell, - transformers >= 0.2, - tree-view >= 0.5, - tuple >= 0.2 + tree-view hs-source-dirs: src default-language: Haskell2010 default-extensions: - ConstraintKinds DeriveDataTypeable DeriveFunctor + DeriveFoldable + DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving - Rank2Types + RankNTypes ScopedTypeVariables - StandaloneDeriving TypeFamilies TypeOperators - ViewPatterns other-extensions: - -- Not understood by Cabal: PolyKinds OverlappingInstances + TemplateHaskell UndecidableInstances -test-suite NanoFeldsparEval +test-suite examples type: exitcode-stdio-1.0 hs-source-dirs: tests examples - main-is: NanoFeldsparEval.hs - - other-modules: - NanoFeldspar.Core - NanoFeldspar.Extra - NanoFeldspar.Test - NanoFeldspar.Vector + main-is: Tests.hs default-language: Haskell2010 default-extensions: - FlexibleContexts - FlexibleInstances - GADTs - MultiParamTypeClasses - ScopedTypeVariables - TypeFamilies - TypeOperators - UndecidableInstances - ViewPatterns other-extensions: - TemplateHaskell - - build-depends: - syntactic, - base, - mtl >= 2 && < 3, - QuickCheck >= 2.4 && < 3, - tasty, - tasty-th, - tasty-quickcheck - -test-suite NanoFeldsparEval2 - type: exitcode-stdio-1.0 - - hs-source-dirs: tests examples - - main-is: NanoFeldsparEval2.hs - - other-modules: - NanoFeldspar.Core - NanoFeldspar.Extra - NanoFeldspar.Test - NanoFeldspar.Vector - - default-language: Haskell2010 - - default-extensions: FlexibleContexts FlexibleInstances GADTs MultiParamTypeClasses ScopedTypeVariables + TemplateHaskell TypeFamilies TypeOperators UndecidableInstances - ViewPatterns - other-extensions: - TemplateHaskell - build-depends: syntactic, base, - mtl >= 2 && < 3, - QuickCheck >= 2.4 && < 3, + containers, + QuickCheck, + tagged, tasty, + tasty-golden, + tasty-quickcheck, tasty-th, - tasty-quickcheck + utf8-string -test-suite NanoFeldsparTree +benchmark syntactic-bench type: exitcode-stdio-1.0 - hs-source-dirs: tests examples + hs-source-dirs: benchmarks - main-is: NanoFeldsparTree.hs + main-is: MainBenchmark.hs - other-modules: - NanoFeldspar.Core - NanoFeldspar.Extra - NanoFeldspar.Test - NanoFeldspar.Vector + build-depends: + base, + criterion, + syntactic default-language: Haskell2010 default-extensions: - FlexibleContexts FlexibleInstances GADTs MultiParamTypeClasses - ScopedTypeVariables - TypeFamilies TypeOperators - UndecidableInstances - ViewPatterns other-extensions: TemplateHaskell - - build-depends: - syntactic, - base, - bytestring, - mtl >= 2 && < 3, - tasty, - tasty-golden, - utf8-string diff --git a/tests/MonadTests.hs b/tests/MonadTests.hs new file mode 100644 --- /dev/null +++ b/tests/MonadTests.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module MonadTests where + + + +import Test.Tasty +import Test.Tasty.Golden + +import Data.ByteString.Lazy.UTF8 (fromString) + +import Data.Syntactic +import Data.Syntactic.Functional +import qualified Monad + + + +mkGold_ex1 = writeFile "tests/gold/ex1_Monad.txt" $ showAST $ desugar Monad.ex1 + +tests = testGroup "MonadTests" + [ goldenVsString "ex1 tree" "tests/gold/ex1_Monad.txt" $ return $ fromString $ showAST $ desugar Monad.ex1 + ] + +main = defaultMain tests + diff --git a/tests/NanoFeldsparEval.hs b/tests/NanoFeldsparEval.hs deleted file mode 100644 --- a/tests/NanoFeldsparEval.hs +++ /dev/null @@ -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) - diff --git a/tests/NanoFeldsparEval2.hs b/tests/NanoFeldsparEval2.hs deleted file mode 100644 --- a/tests/NanoFeldsparEval2.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -import Test.Tasty -import Test.Tasty.TH -import Test.Tasty.QuickCheck - -import NanoFeldspar.Core (eval2) -import NanoFeldspar.Test - - - -prop_scProd a b = eval2 scProd a' b' == ref a' b' - where - a' = take 20 a - b' = take 20 b - ref a b = sum (zipWith (*) a b) - -prop_1 a b = eval2 prog1 a' b == ref a' b - where - a' = a `mod` 20 - ref a b = [min (i+3) b | i <- [0..a-1]] - -prop_2 a = eval2 prog2 a == ref a - where - ref a = max (min a a) (min a a) - -prop_3 a b = eval2 prog3 a b' == ref a b' - where - b' = a - (b `mod` 20) - ref a b = sum [l .. u] - where - l = min a b - u = max a b - -prop_4 a = eval2 prog4 a' == ref a' - where - a' = a `mod` 20 - ref a = [(a+a)*i | i <- [0..a-1]] - -prop_5 a = eval2 prog5 a == ref a - where - ref a = let (b,c) = (a*2,a*3) in (b-c)*(c-b) - -prop_6 = eval2 prog6 == ref - where - ref = as!!1 + sum as + sum as - where - as = map (*2) [1..20] - -prop_8 a = eval2 prog8 a == ref a - where - ref a = [a .. a+9] - - - -main = $(defaultMainGenerator) - diff --git a/tests/NanoFeldsparTests.hs b/tests/NanoFeldsparTests.hs new file mode 100644 --- /dev/null +++ b/tests/NanoFeldsparTests.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module NanoFeldsparTests where + + + +import Control.Monad +import Data.List + +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.QuickCheck + +import Data.ByteString.Lazy.UTF8 (fromString) + +import Data.Syntactic +import Data.Syntactic.Functional +import qualified NanoFeldspar as Nano + + + +scProd :: [Float] -> [Float] -> Float +scProd as bs = sum $ zipWith (*) as bs + +prop_scProd as bs = scProd as bs == Nano.eval Nano.scProd as bs + +genMat :: Gen [[Float]] +genMat = sized $ \s -> do + x <- liftM succ $ choose (0, s `mod` 10) + y <- liftM succ $ choose (0, s `mod` 10) + replicateM y $ vector x + +forEach = flip map + +matMul :: [[Float]] -> [[Float]] -> [[Float]] +matMul a b = forEach a $ \a' -> + forEach (transpose b) $ \b' -> + scProd a' b' + +prop_matMul = + forAll genMat $ \a -> + forAll genMat $ \b -> + matMul a b == Nano.eval Nano.matMul a b + +mkGold_scProd = writeFile "tests/gold/scProd.txt" $ Nano.showAST Nano.scProd +mkGold_matMul = writeFile "tests/gold/matMul.txt" $ Nano.showAST Nano.matMul + +alphaRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a +alphaRename = mapAST rename + where + rename :: Nano.FeldDomain a -> Nano.FeldDomain a + rename s + | Just (VarT v) <- prj s = inj (VarT (v+1)) + | Just (LamT v) <- prj s = inj (LamT (v+1)) + | otherwise = s + +badRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a +badRename = mapAST rename + where + rename :: Nano.FeldDomain a -> Nano.FeldDomain a + rename s + | Just (VarT v) <- prj s = inj (VarT (v+1)) + | Just (LamT v) <- prj s = inj (LamT (v-1)) + | otherwise = s + +prop_alphaEq a = alphaEq a (alphaRename a) + +prop_alphaEqBad a = alphaEq a (badRename a) + +tests = testGroup "NanoFeldsparTests" + [ goldenVsString "scProd tree" "tests/gold/scProd.txt" $ return $ fromString $ Nano.showAST Nano.scProd + , goldenVsString "matMul tree" "tests/gold/matMul.txt" $ return $ fromString $ Nano.showAST Nano.matMul + + , testProperty "scProd eval" prop_scProd + , testProperty "matMul eval" prop_matMul + + , testProperty "alphaEq scProd" (prop_alphaEq (desugar Nano.scProd)) + , testProperty "alphaEq matMul" (prop_alphaEq (desugar Nano.matMul)) + , testProperty "alphaEq scProd matMul" (not (alphaEq (desugar Nano.scProd) (desugar Nano.matMul))) + , testProperty "alphaEqBad scProd" (not (prop_alphaEqBad (desugar Nano.scProd))) + , testProperty "alphaEqBad matMul" (not (prop_alphaEqBad (desugar Nano.matMul))) + ] + +main = defaultMain tests + diff --git a/tests/NanoFeldsparTree.hs b/tests/NanoFeldsparTree.hs deleted file mode 100644 --- a/tests/NanoFeldsparTree.hs +++ /dev/null @@ -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 - diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,14 @@ +import Test.Tasty + +import qualified NanoFeldsparTests +import qualified WellScopedTests +import qualified MonadTests + +tests = testGroup "AllTests" + [ NanoFeldsparTests.tests + , WellScopedTests.tests + , MonadTests.tests + ] + +main = defaultMain tests + diff --git a/tests/WellScopedTests.hs b/tests/WellScopedTests.hs new file mode 100644 --- /dev/null +++ b/tests/WellScopedTests.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module WellScopedTests where + + + +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.QuickCheck + +import Data.ByteString.Lazy.UTF8 (fromString) + +import Data.Syntactic +import Data.Syntactic.Functional +import qualified WellScoped as WS + + + +ex1 a = let b = a+4 in let c = a+b in a+b+c + +prop_ex1 a = ex1 a == evalClosedWS WS.ex1 a + +mkGold_ex1 = writeFile "tests/gold/ex1_WS.txt" $ showAST $ fromWS WS.ex1 + +tests = testGroup "WellScopedTests" + [ goldenVsString "ex1 tree" "tests/gold/ex1_WS.txt" $ return $ fromString $ showAST $ fromWS WS.ex1 + , testProperty "ex1" prop_ex1 + ] + +main = defaultMain tests + diff --git a/tests/gold/ex1_Monad.txt b/tests/gold/ex1_Monad.txt new file mode 100644 --- /dev/null +++ b/tests/gold/ex1_Monad.txt @@ -0,0 +1,18 @@ +Lam v3 + └╴(>>=) + ├╴iter + │ ├╴v3 + │ └╴(>>=) + │ ├╴getDigit + │ └╴Lam v2 + │ └╴(>>=) + │ ├╴putDigit + │ │ └╴(+) + │ │ ├╴v2 + │ │ └╴v2 + │ └╴Lam v1 + │ └╴return + │ └╴v1 + └╴Lam v1 + └╴return + └╴v1 diff --git a/tests/gold/ex1_WS.txt b/tests/gold/ex1_WS.txt new file mode 100644 --- /dev/null +++ b/tests/gold/ex1_WS.txt @@ -0,0 +1,14 @@ +Lam v3 + └╴Let v2 + ├╴(+) + │ ├╴v3 + │ └╴4 + └╴Let v1 + ├╴(+) + │ ├╴v3 + │ └╴v2 + └╴(+) + ├╴(+) + │ ├╴v3 + │ └╴v2 + └╴v1 diff --git a/tests/gold/matMul.txt b/tests/gold/matMul.txt --- a/tests/gold/matMul.txt +++ b/tests/gold/matMul.txt @@ -1,44 +1,36 @@ -Lambda 0 - └╴Lambda 1 - └╴Let 6 +Lam v6 + └╴Lam v5 + └╴parallel ├╴arrLength - │ └╴getIx - │ ├╴var:1 - │ └╴0 - └╴Let 7 - ├╴arrLength - │ └╴var:1 + │ └╴v6 + └╴Lam v4 └╴parallel ├╴arrLength - │ └╴var:0 - └╴Lambda 2 - └╴Let 8 + │ └╴getIx + │ ├╴v5 + │ └╴0 + └╴Lam v3 + └╴forLoop ├╴min │ ├╴arrLength │ │ └╴getIx - │ │ ├╴var:0 - │ │ └╴var:2 - │ └╴var:7 - └╴Let 9 - ├╴getIx - │ ├╴var:0 - │ └╴var:2 - └╴parallel - ├╴var:6 - └╴Lambda 3 - └╴forLoop - ├╴var:8 - ├╴0.0 - └╴Lambda 4 - └╴Lambda 5 - └╴(+) - ├╴(*) - │ ├╴getIx - │ │ ├╴var:9 - │ │ └╴var:4 - │ └╴getIx - │ ├╴getIx - │ │ ├╴var:1 - │ │ └╴var:4 - │ └╴var:3 - └╴var:5 + │ │ ├╴v6 + │ │ └╴v4 + │ └╴arrLength + │ └╴v5 + ├╴0.0 + └╴Lam v2 + └╴Lam v1 + └╴(+) + ├╴(*) + │ ├╴getIx + │ │ ├╴getIx + │ │ │ ├╴v6 + │ │ │ └╴v4 + │ │ └╴v2 + │ └╴getIx + │ ├╴getIx + │ │ ├╴v5 + │ │ └╴v2 + │ └╴v3 + └╴v1 diff --git a/tests/gold/prog1.txt b/tests/gold/prog1.txt deleted file mode 100644 --- a/tests/gold/prog1.txt +++ /dev/null @@ -1,10 +0,0 @@ -Lambda 0 - └╴Lambda 1 - └╴parallel - ├╴var:0 - └╴Lambda 2 - └╴min - ├╴(+) - │ ├╴var:2 - │ └╴3 - └╴var:1 diff --git a/tests/gold/prog2.txt b/tests/gold/prog2.txt deleted file mode 100644 --- a/tests/gold/prog2.txt +++ /dev/null @@ -1,8 +0,0 @@ -Lambda 0 - └╴Let 1 - ├╴min - │ ├╴var:0 - │ └╴var:0 - └╴max - ├╴var:1 - └╴var:1 diff --git a/tests/gold/prog3.txt b/tests/gold/prog3.txt deleted file mode 100644 --- a/tests/gold/prog3.txt +++ /dev/null @@ -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 diff --git a/tests/gold/prog4.txt b/tests/gold/prog4.txt deleted file mode 100644 --- a/tests/gold/prog4.txt +++ /dev/null @@ -1,11 +0,0 @@ -Lambda 0 - └╴Let 2 - ├╴(+) - │ ├╴var:0 - │ └╴var:0 - └╴parallel - ├╴var:0 - └╴Lambda 1 - └╴(*) - ├╴var:2 - └╴var:1 diff --git a/tests/gold/prog5.txt b/tests/gold/prog5.txt deleted file mode 100644 --- a/tests/gold/prog5.txt +++ /dev/null @@ -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 diff --git a/tests/gold/prog6.txt b/tests/gold/prog6.txt deleted file mode 100644 --- a/tests/gold/prog6.txt +++ /dev/null @@ -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 diff --git a/tests/gold/prog7.txt b/tests/gold/prog7.txt deleted file mode 100644 --- a/tests/gold/prog7.txt +++ /dev/null @@ -1,13 +0,0 @@ -Lambda 0 - └╴Let 1 - ├╴max - │ ├╴5 - │ └╴(+) - │ ├╴6 - │ └╴7 - └╴condition - ├╴(==) - │ ├╴var:0 - │ └╴10 - ├╴var:1 - └╴var:1 diff --git a/tests/gold/prog8.txt b/tests/gold/prog8.txt deleted file mode 100644 --- a/tests/gold/prog8.txt +++ /dev/null @@ -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 diff --git a/tests/gold/scProd.txt b/tests/gold/scProd.txt --- a/tests/gold/scProd.txt +++ b/tests/gold/scProd.txt @@ -1,20 +1,20 @@ -Lambda 0 - └╴Lambda 1 +Lam v4 + └╴Lam v3 └╴forLoop ├╴min │ ├╴arrLength - │ │ └╴var:0 + │ │ └╴v4 │ └╴arrLength - │ └╴var:1 + │ └╴v3 ├╴0.0 - └╴Lambda 2 - └╴Lambda 3 + └╴Lam v2 + └╴Lam v1 └╴(+) ├╴(*) │ ├╴getIx - │ │ ├╴var:0 - │ │ └╴var:2 + │ │ ├╴v4 + │ │ └╴v2 │ └╴getIx - │ ├╴var:1 - │ └╴var:2 - └╴var:3 + │ ├╴v3 + │ └╴v2 + └╴v1