packages feed

syntactic 3.0 → 3.1

raw patch · 22 files changed

+541/−114 lines, 22 filesdep ~mtl

Dependency ranges changed: mtl

Files

benchmarks/JoiningTypes.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- module JoiningTypes (main) where  import Criterion.Main@@ -39,7 +37,8 @@   renderSym (EEq)   = "EEq"   renderSym (EIf)   = "EIf" -interpretationInstances ''Expr1+instance Equality   Expr1+instance StringTree Expr1  instance Eval Expr1 where   evalSym (EI n)  = n@@ -91,8 +90,10 @@   renderSym (EEqJ)   = "EEq"   renderSym (EIfJ)   = "EIf" -interpretationInstances ''ExprI-interpretationInstances ''ExprB+instance Equality   ExprI+instance StringTree ExprI+instance Equality   ExprB+instance StringTree ExprB  instance Eval ExprI where   evalSym (EIJ n) = n@@ -158,11 +159,14 @@ instance Render Expr4J5 where   renderSym (E4JIf)   = "EIf" -interpretationInstances ''Expr4J1-interpretationInstances ''Expr4J2-interpretationInstances ''Expr4J3-interpretationInstances ''Expr4J4-interpretationInstances ''Expr4J5+instance Equality   Expr4J1+instance StringTree Expr4J1+instance Equality   Expr4J2+instance StringTree Expr4J2+instance Equality   Expr4J3+instance StringTree Expr4J3+instance Equality   Expr4J5+instance StringTree Expr4J5  instance Eval Expr4J1 where   evalSym (E4JI n)  = n
benchmarks/Normal.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- module Normal (main) where  import Criterion.Main@@ -110,7 +108,8 @@   renderSym EEq    = "EEq"   renderSym EIf    = "EIf" -interpretationInstances ''ExprS+instance Equality   ExprS+instance StringTree ExprS  instance Eval ExprS where   evalSym (EI n) = n
benchmarks/WithArity.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- module WithArity (main) where  import Criterion.Main@@ -104,7 +102,8 @@     renderSym T5     = "T5"     renderSym T10    = "T10" -interpretationInstances ''T+instance Equality   T+instance StringTree T  instance Eval T   where
examples/NanoFeldspar.hs view
@@ -29,6 +29,7 @@ import Language.Syntactic.Functional.Tuple import Language.Syntactic.Sugar.BindingT () import Language.Syntactic.Sugar.TupleT ()+import Language.Syntactic.TH   @@ -55,12 +56,12 @@     Sub :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a)     Mul :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a) -instance Symbol Arithmetic-  where-    symSig Add = signature-    symSig Sub = signature-    symSig Mul = signature+deriveSymbol   ''Arithmetic+deriveEquality ''Arithmetic +instance StringTree Arithmetic+instance EvalEnv Arithmetic env+ instance Render Arithmetic   where     renderSym Add = "(+)"@@ -68,56 +69,42 @@     renderSym Mul = "(*)"     renderArgs = renderArgsSmart -interpretationInstances ''Arithmetic- instance Eval Arithmetic   where     evalSym Add = (+)     evalSym Sub = (-)     evalSym Mul = (*) -instance EvalEnv Arithmetic env- data Parallel sig   where     Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a]) -instance Symbol Parallel-  where-    symSig Parallel = signature--instance Render Parallel-  where-    renderSym Parallel = "parallel"+deriveSymbol    ''Parallel+deriveRender id ''Parallel+deriveEquality  ''Parallel -interpretationInstances ''Parallel+instance StringTree Parallel+instance EvalEnv Parallel env  instance Eval Parallel   where     evalSym Parallel = \len ixf -> Prelude.map ixf [0 .. len-1] -instance EvalEnv Parallel env- data ForLoop sig   where     ForLoop :: Type st => ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st) -instance Symbol ForLoop-  where-    symSig ForLoop = signature--instance Render ForLoop-  where-    renderSym ForLoop = "forLoop"+deriveSymbol    ''ForLoop+deriveRender id ''ForLoop+deriveEquality  ''ForLoop -interpretationInstances ''ForLoop+instance StringTree ForLoop+instance EvalEnv ForLoop env  instance Eval ForLoop   where     evalSym ForLoop = \len init body -> foldl (flip body) init [0 .. len-1] -instance EvalEnv ForLoop env- type FeldDomain = Typed     (   BindingT     :+: Let@@ -157,6 +144,7 @@ -- * "Backends" -------------------------------------------------------------------------------- +-- | Interface for controlling code motion cmInterface :: CodeMotionInterface FeldDomain cmInterface = defaultInterfaceT sharable (const True)   where
+ examples/NanoFeldsparComp.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++-- Note GADTs needed by GHC 7.6. In later GHCs is works with just TypeFamilies.++-- | A simple compiler for NanoFeldspar++module NanoFeldsparComp where++++import Control.Monad.State+import Control.Monad.Writer++import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Sharing+import Language.Syntactic.Functional.Tuple++import NanoFeldspar hiding ((==))++++--------------------------------------------------------------------------------+-- * Imperative programs+--------------------------------------------------------------------------------++type Var = String++varName :: Name -> Var+varName v = 'v' : show v++varNameE :: Name -> Exp+varNameE v = App (varName v) []++data Exp = App String [Exp]+  deriving (Eq, Show)++data Stmt+    = Assign Exp Exp+    | If Exp Prog Prog+    | For Exp Var Prog+  deriving (Eq, Show)++type Prog = [Stmt]++viewOp :: String -> Maybe String+viewOp op@(_:_:_)+    | head op == '(' && last op == ')' = Just $ tail $ init op+    | otherwise = Nothing++renderExp :: Exp -> String+renderExp (App f []) = f+renderExp (App f@(_:_) [a,b])+    | Just op <- viewOp f = concat ["(", renderExp a, " ", op, " ", renderExp b, ")"]+renderExp (App f args) = "(" ++ unwords (f : Prelude.map renderExp args) ++ ")"++indent :: [String] -> [String]+indent = Prelude.map ("    " ++)++renderProg :: Prog -> String+renderProg = unlines . concatMap render+  where+    render (Assign l r) = [unwords [renderExp l, "=", renderExp r]]+    render (If c t f) = concat+        [ [unwords ["if", renderExp c]]+        , indent (concatMap render t)+        , ["else"]+        , indent (concatMap render f)+        ]+    render (For l v body) = concat+        [ [unwords ["for",v,"<", renderExp l]]+        , indent (concatMap render body)+        ]++++--------------------------------------------------------------------------------+-- * Code generation+--------------------------------------------------------------------------------++type CodeGen = WriterT Prog (State Name)++type Dom = BindingT+       :+: Let+       :+: Tuple+       :+: Arithmetic+       :+: Parallel+       :+: ForLoop+       :+: Construct++fresh :: CodeGen Exp+fresh = do+    v <- get; put (v+1)+    return (varNameE v)++confiscate :: CodeGen Exp -> CodeGen (Exp,Prog)+confiscate = censor (const mempty) . listen++compileExp :: ASTF Dom a -> CodeGen Exp+compileExp var+    | Just (Var v) <- prj var = return (varNameE v)+compileExp (lett :$ a :$ (lam :$ body))+    | Just Let      <- prj lett+    , Just (LamT v) <- prj lam+    = do+        a' <- compileExp a+        tell [Assign (varNameE v) a']+        compileExp body+compileExp (par :$ len :$ (lam :$ body))+    | Just Parallel <- prj par+    , Just (LamT v) <- prj lam+    = do+        len' <- compileExp len+        (e,body') <- confiscate $ compileExp body+        arr <- fresh+        let arrPos = App "(!)" [arr, varNameE v]+        tell+            [ For len' (varName v)+                (  body'+                ++ [Assign arrPos e]+                )+            ]+        return arr+compileExp (for :$ len :$ init :$ (lam1 :$ (lam2 :$ body)))+    | Just ForLoop  <- prj for+    , Just (LamT i) <- prj lam1+    , Just (LamT s) <- prj lam2+    = do+        len'  <- compileExp len+        init' <- compileExp init+        (e,body') <- confiscate $ compileExp body+        next <- fresh+        tell+            [ Assign (varNameE s) init'+            , For len' (varName i)+                (  body'+                ++ [ Assign next e+                   , Assign (varNameE s) next+                   ]+                )+            ]+        return next+compileExp (cond :$ c :$ t :$ f)+    | Just (Construct "cond" _) <- prj cond+    = do+        c' <- compileExp c+        (t',tProg) <- confiscate $ compileExp t+        (f',fProg) <- confiscate $ compileExp f+        res <- fresh+        tell+            [ If c'+                (  tProg+                ++ [Assign res  t']+                )+                (  fProg+                ++ [Assign res  f']+                )+            ]+        return res+compileExp (arrIx :$ arr :$ ix)+    | Just (Construct "arrIx" _) <- prj arrIx = do+        arr' <- compileExp arr+        ix'  <- compileExp ix+        return $ App "(!)" [arr',ix']+-- Generic case for all other constructs+compileExp a = simpleMatch+  (\s as -> fmap (App (renderSym s)) $ sequence (listArgs compileExp as)) a++compileTop :: ASTF Dom a -> CodeGen ()+compileTop = go 0+  where+    go :: Int -> ASTF Dom a -> CodeGen ()+    go n (lam :$ body)+        | Just (LamT v) <- prj lam = do+            tell [Assign (varNameE v) (App ("inp" ++ show n) [])]+            go (n+1) body+    go _ a = do+        a' <- compileExp a+        tell [Assign (App "out" []) a']++++compile :: (Syntactic a, Domain a ~ Typed Dom) => a -> String+compile+    = renderProg+    . fst+    . flip runState 0+    . execWriterT+    . compileTop+    . mapAST (\(Typed s) -> s)+    . codeMotion cmInterface+    . desugar++icompile :: (Syntactic a, Domain a ~ Typed Dom) => a -> IO ()+icompile = putStrLn . compile++++--------------------------------------------------------------------------------+-- * Code generation+--------------------------------------------------------------------------------++test_matMul = icompile matMul+
src/Language/Syntactic/Decoration.hs view
@@ -34,8 +34,11 @@  instance Symbol sym => Symbol (sym :&: info)   where-    rnfSym = rnfSym . decorExpr     symSig = symSig . decorExpr++instance (NFData1 sym, NFData1 info) => NFData1 (sym :&: info)+  where+    rnf1 (s :&: i) = rnf1 s `seq` rnf1 i `seq` ()  instance Project sub sup => Project sub (sup :&: info)   where
src/Language/Syntactic/Functional.hs view
@@ -92,11 +92,13 @@ data Construct sig   where     Construct :: Signature sig => String -> Denotation sig -> Construct sig+  -- There is no `NFData1` instance for `Construct` because that would give rise+  -- to a constraint `NFData (Denotation sig)`, which easily spreads to other+  -- functions.  instance Symbol Construct   where-    rnfSym (Construct name den) = rnf name `seq` den `seq` ()-    symSig (Construct _ _)      = signature+    symSig (Construct _ _) = signature  instance Render Construct   where@@ -126,11 +128,14 @@  instance Symbol Binding   where-    rnfSym (Var v) = rnf v-    rnfSym (Lam v) = rnf v     symSig (Var _) = signature     symSig (Lam _) = signature +instance NFData1 Binding+  where+    rnf1 (Var v) = rnf v+    rnf1 (Lam v) = rnf v+ -- | 'equal' does strict identifier comparison; i.e. no alpha equivalence. -- -- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation@@ -211,11 +216,14 @@  instance Symbol BindingT   where-    rnfSym (VarT v) = rnf v-    rnfSym (LamT v) = rnf v     symSig (VarT _) = signature     symSig (LamT _) = signature +instance NFData1 BindingT+  where+    rnf1 (VarT v) = rnf v+    rnf1 (LamT v) = rnf v+ -- | 'equal' does strict identifier comparison; i.e. no alpha equivalence. -- -- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation@@ -284,8 +292,7 @@     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.+  -- `(Project Binding s, Project BindingT s)`  instance {-# OVERLAPPING #-}          (BindingDomain sym1, BindingDomain sym2) => BindingDomain (sym1 :+: sym2)
src/Language/Syntactic/Functional/Tuple.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- -- | Construction and elimination of tuples  module Language.Syntactic.Functional.Tuple where@@ -118,7 +116,8 @@     renderSym Sel4 = "sel4"     renderArgs = renderArgsSmart -interpretationInstances ''Tuple+instance Equality   Tuple+instance StringTree Tuple  instance Eval Tuple   where
src/Language/Syntactic/Functional/WellScoped.hs view
@@ -63,10 +63,13 @@  instance Symbol BindingWS   where-    rnfSym (VarWS Proxy) = ()-    rnfSym LamWS         = ()-    symSig (VarWS _)     = signature-    symSig LamWS         = signature+    symSig (VarWS _) = signature+    symSig LamWS     = signature++instance NFData1 BindingWS+  where+    rnf1 (VarWS Proxy) = ()+    rnf1 LamWS         = ()  instance Eval BindingWS   where
src/Language/Syntactic/Interpretation.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DefaultSignatures #-}  -- | Equality and rendering of 'AST's @@ -17,13 +17,11 @@       -- * 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@@ -45,12 +43,16 @@     -- Comparing elements of different types is often needed when dealing with expressions with     -- existentially quantified sub-terms.     equal :: e a -> e b -> Bool+    default equal :: Render e => e a -> e b -> Bool+    equal = equalDefault      -- | Higher-kinded hashing. Elements that are equal according to 'equal' must result in the same     -- hash:     --     -- @equal a b  ==>  hash a == hash b@     hash :: e a -> Hash+    default hash :: Render e => e a -> Hash+    hash = hashDefault  instance Equality sym => Equality (AST sym)   where@@ -204,16 +206,3 @@ -- | Default implementation of 'hash' hashDefault :: Render sym => sym a -> Hash hashDefault = Hash.hash . renderSym---- | Derive instances for 'Equality' and 'StringTree'-interpretationInstances :: Name -> DecsQ-interpretationInstances n =-    [d|-        instance Equality $(typ) where-          equal = equalDefault-          hash  = hashDefault-        instance StringTree $(typ)-    |]-  where-    typ = conT n-
src/Language/Syntactic/Syntax.hs view
@@ -50,7 +50,8 @@     , Typed (..)     , injT     , castExpr-      -- * Type inference+      -- * Misc.+    , NFData1 (..)     , symType     , prjP     ) where@@ -129,16 +130,12 @@ -- | Valid symbols to use in an 'AST' class Symbol sym   where-    -- | Force a symbol to normal form-    rnfSym :: sym sig -> ()-    rnfSym s = s `seq` ()-     -- | Reify the signature of a symbol     symSig :: sym sig -> SigRep sig -instance Symbol sym => NFData (AST sym sig)+instance NFData1 sym => NFData (AST sym sig)   where-    rnf (Sym s)  = rnfSym s+    rnf (Sym s)  = rnf1 s     rnf (s :$ a) = rnf s `seq` rnf a  -- | Count the number of symbols in an 'AST'@@ -206,11 +203,14 @@  instance (Symbol sym1, Symbol sym2) => Symbol (sym1 :+: sym2)   where-    rnfSym (InjL s) = rnfSym s-    rnfSym (InjR s) = rnfSym s     symSig (InjL s) = symSig s     symSig (InjR s) = symSig s +instance (NFData1 sym1, NFData1 sym2) => NFData1 (sym1 :+: sym2)+  where+    rnf1 (InjL s) = rnf1 s+    rnf1 (InjR s) = rnf1 s+ -- | Symbol projection -- -- The class is defined for /all pairs of types/, but 'prj' can only succeed if @sup@ is of the form@@ -387,8 +387,15 @@   ----------------------------------------------------------------------------------- * Type inference+-- * Misc. --------------------------------------------------------------------------------++-- | Higher-kinded version of 'NFData'+class NFData1 c+  where+    -- | Force a symbol to normal form+    rnf1 :: c a -> ()+    rnf1 s = s `seq` ()  -- | Constrain a symbol to a specific type symType :: Proxy sym -> sym sig -> sym sig
+ src/Language/Syntactic/TH.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Syntactic.TH where++++import Language.Haskell.TH++import Data.Hash (hashInt, combine)+import qualified Data.Hash as Hash++import Language.Syntactic++++-- | Get the name and arity of a constructor+conName :: Con -> (Name, Int)+conName (NormalC name args) = (name, length args)+conName (RecC name args)    = (name, length args)+conName (InfixC _ name _)   = (name, 2)+conName (ForallC _ _ c)     = conName c++-- | Description of class methods+data Method+    = DefaultMethod Name Name+        -- ^ rhs = lhs+    | MatchingMethod Name (Con -> Int -> Name -> Int -> Clause) [Clause]+        -- ^ @MatchingMethod methodName mkClause extraClauses@+        --+        -- @mkClause@ takes as arguments (1) a description of the constructor,+        -- (2) the constructor's index, (3) the constructor's name, and (4) its+        -- arity.++-- | General method for class deriving+deriveClass+    :: Cxt       -- ^ Instance context+    -> Name      -- ^ Type constructor name+    -> Type      -- ^ Class head (e.g. @Render Con@)+    -> [Method]  -- ^ Methods+    -> DecsQ+deriveClass cxt ty clHead methods = do+    t@(TyConI (DataD _ _ _ cs _)) <- reify ty+    return+      [ InstanceD cxt clHead $+          [ FunD method (clauses ++ extra)+            | MatchingMethod method mkClause extra <- methods+            , let clauses = [ mkClause c i nm ar | (i,c) <- zip [0..] cs+                            , let (nm,ar) = conName c+                            ]+          ] +++          [ FunD rhs [Clause [] (NormalB (VarE lhs)) []]+            | DefaultMethod rhs lhs <- methods+          ]+      ]++-- | General method for class deriving+deriveClassSimple+    :: Name      -- ^ Class name+    -> Name      -- ^ Type constructor name+    -> [Method]  -- ^ Methods+    -> DecsQ+deriveClassSimple cl ty = deriveClass [] ty (AppT (ConT cl) (ConT ty))++varSupply :: [Name]+varSupply = map mkName $ tail $ concat $ iterate step [[]]+  where+    step :: [String] -> [String]+    step vars = concatMap (\c -> map (c:) vars) ['a' .. 'z']++-- | Derive 'Symbol' instance for a type+deriveSymbol+    :: Name  -- ^ Type name+    -> DecsQ+deriveSymbol ty =+    deriveClassSimple ''Symbol ty [MatchingMethod 'symSig  symSigClause []]+  where+    symSigClause _ _ con arity =+      Clause [ConP con (replicate arity WildP)] (NormalB (VarE 'signature)) []++-- | Derive 'Equality' instance for a type+--+-- > equal Con1 Con1 = True+-- > equal (Con2 a1 ... x1) (Con2 a2 ... x2) = and [a1==a2, ... x1==x2]+-- > equal _ _ = False+--+-- > hash Con1           = hashInt 0+-- > hash (Con2 a ... x) = foldr1 combine [hashInt 1, hash a, ... hash x]+deriveEquality+    :: Name  -- ^ Type name+    -> DecsQ+deriveEquality ty = do+    TyConI (DataD _ _ _ cs _) <- reify ty+    let equalFallThrough = if length cs > 1+          then [Clause [WildP, WildP] (NormalB $ ConE 'False) []]+          else []+    deriveClassSimple ''Equality ty+      [ MatchingMethod 'equal equalClause equalFallThrough+      , MatchingMethod 'hash hashClause []+      ]+  where+    equalClause _ _ con arity = Clause+        [ ConP con [VarP v | v <- vs1]+        , ConP con [VarP v | v <- vs2]+        ]+        (NormalB body)+        []+      where+        vs1 = take arity varSupply+        vs2 = take arity $ drop arity varSupply++        body = case arity of+          0 -> ConE 'True+          _ -> AppE (VarE 'and)+                 ( ListE+                     [ InfixE (Just (VarE v1)) (VarE '(==)) (Just (VarE v2))+                       | (v1,v2) <- zip vs1 vs2+                     ]+                 )++    hashClause _ i con arity = Clause+        [ConP con [VarP v | v <- vs]]+        (NormalB body)+        []+      where+        vs = take arity varSupply+        body = case arity of+          0 -> AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))+          _ -> foldl1 AppE+                [ VarE 'foldr1+                , VarE 'combine+                , ListE+                    $ AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))+                    : [ AppE (VarE 'Hash.hash) (VarE v)+                        | v <- vs+                      ]+                ]++-- | Derive 'Render' instance for a type+--+-- > renderSym Con1           = "Con1"+-- > renderSym (Con2 a ... x) = concat ["(", unwords ["Con2", show a, ... show x], ")"]+deriveRender+    :: (String -> String)  -- ^ Constructor name modifier+    -> Name                -- ^ Type name+    -> DecsQ+deriveRender modify ty =+    deriveClassSimple ''Render ty [MatchingMethod 'renderSym renderClause []]+  where+    conName = modify . nameBase++    renderClause _ _ con arity = Clause+        [ConP con [VarP v | v <- take arity varSupply]]+        (NormalB body)+        []+      where+        body = case arity of+            0 -> LitE $ StringL $ conName con+            _ -> renderRHS con $ take arity varSupply++    renderRHS :: Name -> [Name] -> Exp+    renderRHS con args =+      AppE (VarE 'concat)+        ( ListE+            [ LitE (StringL "(")+            , AppE (VarE 'unwords)+                (ListE (LitE (StringL (conName con)) : map showArg args))+            , LitE (StringL ")")+            ]+        )++    showArg :: Name -> Exp+    showArg arg = AppE (VarE 'show) (VarE arg)+
syntactic.cabal view
@@ -1,5 +1,5 @@ Name:           syntactic-Version:        3.0+Version:        3.1 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@@ -46,6 +46,11 @@   type:     git   location: https://github.com/emilaxelsson/syntactic +flag th+  description: Include the module Language.Syntactic.TH, which uses Template+               Haskell+  default:     True+ library   exposed-modules:     Language.Syntactic@@ -64,6 +69,9 @@     Language.Syntactic.Sugar.MonadT     Language.Syntactic.Sugar.Tuple     Language.Syntactic.Sugar.TupleT+  if flag(th)+    exposed-modules:+      Language.Syntactic.TH    build-depends:     base >= 4 && < 5,@@ -71,9 +79,11 @@     data-hash,     deepseq,     mtl >= 2 && < 3,-    tagged,-    template-haskell,     tree-view+  if impl(ghc < 7.8)+    build-depends: tagged+  if flag(th)+    build-depends: template-haskell    hs-source-dirs: src @@ -97,7 +107,6 @@    other-extensions:     OverlappingInstances-    TemplateHaskell     UndecidableInstances  test-suite examples@@ -111,21 +120,11 @@    default-extensions: -  other-extensions:-    FlexibleContexts-    FlexibleInstances-    GADTs-    MultiParamTypeClasses-    ScopedTypeVariables-    TemplateHaskell-    TypeFamilies-    TypeOperators-    UndecidableInstances-   build-depends:     syntactic,     base,     containers,+    mtl,     QuickCheck,     tagged,     tasty,
tests/MonadTests.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}  module MonadTests where
tests/NanoFeldsparTests.hs view
@@ -19,6 +19,7 @@ import Language.Syntactic.Functional import Language.Syntactic.Functional.Sharing import qualified NanoFeldspar as Nano+import qualified NanoFeldsparComp as Nano   @@ -70,9 +71,6 @@       forAll genMat $ \b ->         matMul a b == evalCM 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@@ -100,6 +98,11 @@     , goldenVsString "spanVec tree" "tests/gold/spanVec.txt" $ return $ fromString $ Nano.showAST Nano.spanVec     , goldenVsString "scProd tree"  "tests/gold/scProd.txt"  $ return $ fromString $ Nano.showAST Nano.scProd     , goldenVsString "matMul tree"  "tests/gold/matMul.txt"  $ return $ fromString $ Nano.showAST Nano.matMul++    , goldenVsString "fib comp"     "tests/gold/fib.comp"     $ return $ fromString $ Nano.compile Nano.fib+    , goldenVsString "spanVec comp" "tests/gold/spanVec.comp" $ return $ fromString $ Nano.compile Nano.spanVec+    , goldenVsString "scProd comp"  "tests/gold/scProd.comp"  $ return $ fromString $ Nano.compile Nano.scProd+    , goldenVsString "matMul comp"  "tests/gold/matMul.comp"  $ return $ fromString $ Nano.compile Nano.matMul      , testProperty "fib eval"     prop_fib     , testProperty "spanVec eval" prop_spanVec
+ tests/TH.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module TH where++++import Data.List (nub)++import Language.Syntactic+import Language.Syntactic.TH++++data Sym sig+  where+    A :: Int -> Bool -> Sym (a :-> a :-> Full a)+    B :: Sym (Full Bool)+    C :: String -> Sym (a :-> Int :-> Full a)++deriveSymbol    ''Sym+deriveEquality  ''Sym+deriveRender id ''Sym++tests =+    [ equal B B+    , equal (A 5 True) (A 5 True)+    , equal (C "syntactic") (C "syntactic")+    , not $ equal (A 5 True) (A 6 True)+    , not $ equal (A 5 True) (C "c")+    , hashes == nub hashes+    , renderSym (A 5 True) == "(A 5 True)"+    ]+  where+    hashes =+        [ hash $ A 5 True+        , hash $ B+        , hash $ C "a"+        , hash $ A 6 True+        , hash $ C "b"+        ]++main :: IO ()+main = if and tests+    then return ()+    else error "TH tests failed"+
tests/Tests.hs view
@@ -3,6 +3,7 @@ import qualified NanoFeldsparTests import qualified WellScopedTests import qualified MonadTests+import qualified TH  tests = testGroup "AllTests"     [ NanoFeldsparTests.tests@@ -10,5 +11,7 @@     , MonadTests.tests     ] -main = defaultMain tests+main = do+    TH.main+    defaultMain tests
tests/WellScopedTests.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}  module WellScopedTests where
tests/gold/fib.txt view
@@ -1,6 +1,6 @@ Lam v3  └╴sel1-    └╴forLoop+    └╴ForLoop        ├╴v3        ├╴tup2        │  ├╴0
tests/gold/matMul.txt view
@@ -1,6 +1,6 @@ Lam v6  └╴Lam v5-    └╴parallel+    └╴Parallel        ├╴arrLen        │  └╴v6        └╴Lam v4@@ -12,13 +12,13 @@              │  │     └╴v4              │  └╴arrLen              │     └╴v5-             └╴parallel+             └╴Parallel                 ├╴arrLen                 │  └╴arrIx                 │     ├╴v5                 │     └╴0                 └╴Lam v3-                   └╴forLoop+                   └╴ForLoop                       ├╴v7                       ├╴0.0                       └╴Lam v2
tests/gold/scProd.txt view
@@ -1,6 +1,6 @@ Lam v4  └╴Lam v3-    └╴forLoop+    └╴ForLoop        ├╴min        │  ├╴arrLen        │  │  └╴v4
tests/gold/spanVec.txt view
@@ -1,6 +1,6 @@ Lam v3  └╴Let v4-    ├╴forLoop+    ├╴ForLoop     │  ├╴arrLen     │  │  └╴v3     │  ├╴tup2