syntactic 1.8 → 1.9

raw patch · 13 files changed

+136/−105 lines, 13 filesdep +tastydep +tasty-goldendep +tasty-quickcheckdep −test-frameworkdep −test-framework-goldendep −test-framework-quickcheck2

Dependencies added: tasty, tasty-golden, tasty-quickcheck, tasty-th

Dependencies removed: test-framework, test-framework-golden, test-framework-quickcheck2, test-framework-th

Files

• examples/NanoFeldspar/Core.hs +1/−1
• src/Language/Syntactic/Constraint.hs +27/−13
• src/Language/Syntactic/Constructs/Binding.hs +9/−7
• src/Language/Syntactic/Constructs/Decoration.hs +12/−12
• src/Language/Syntactic/Constructs/Literal.hs +2/−2
• src/Language/Syntactic/Constructs/Monad.hs +5/−4
• src/Language/Syntactic/Interpretation/Render.hs +42/−47
• src/Language/Syntactic/Interpretation/Semantics.hs +15/−3
• src/Language/Syntactic/Sharing/Graph.hs +4/−4
• src/Language/Syntactic/Traversal.hs +6/−0
• syntactic.cabal +7/−6
• tests/NanoFeldsparEval.hs +3/−3
• tests/NanoFeldsparTree.hs +3/−3

@@ -169,7 +169,7 @@  -- | Print the expression printExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()-printExpr = Syntactic.printExpr . reifySmart (const True) canShareDict+printExpr = print . reifySmart (const True) canShareDict  -- | Draw the syntax tree using ASCII showAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String

@@ -95,15 +95,16 @@  instance Render dom => Render (dom :| pred)   where+    renderSym (C a) = renderSym a     renderArgs args (C a) = renderArgs args a  instance Eval dom => Eval (dom :| pred)   where     evaluate (C a) = evaluate a -instance ToTree dom => ToTree (dom :| pred)+instance StringTree dom => StringTree (dom :| pred)   where-    toTreeArgs args (C a) = toTreeArgs args a+    stringTreeSym args (C a) = stringTreeSym args a   @@ -131,15 +132,16 @@  instance Render dom => Render (dom :|| pred)   where+    renderSym (C' a) = renderSym a     renderArgs args (C' a) = renderArgs args a  instance Eval dom => Eval (dom :|| pred)   where     evaluate (C' a) = evaluate a -instance ToTree dom => ToTree (dom :|| pred)+instance StringTree dom => StringTree (dom :|| pred)   where-    toTreeArgs args (C' a) = toTreeArgs args a+    stringTreeSym args (C' a) = stringTreeSym args a   @@ -258,11 +260,12 @@  instance Render dom => Render (SubConstr1 c dom p)   where+    renderSym (SubConstr1 s) = renderSym s     renderArgs args (SubConstr1 s) = renderArgs args s -instance ToTree dom => ToTree (SubConstr1 c dom p)+instance StringTree dom => StringTree (SubConstr1 c dom p)   where-    toTreeArgs args (SubConstr1 a) = toTreeArgs args a+    stringTreeSym args (SubConstr1 a) = stringTreeSym args a  instance Eval dom => Eval (SubConstr1 c dom p)   where@@ -292,11 +295,12 @@  instance Render dom => Render (SubConstr2 c dom pa pb)   where+    renderSym (SubConstr2 s) = renderSym s     renderArgs args (SubConstr2 s) = renderArgs args s -instance ToTree dom => ToTree (SubConstr2 c dom pa pb)+instance StringTree dom => StringTree (SubConstr2 c dom pa pb)   where-    toTreeArgs args (SubConstr2 a) = toTreeArgs args a+    stringTreeSym args (SubConstr2 a) = stringTreeSym args a  instance Eval dom => Eval (SubConstr2 c dom pa pb)   where@@ -374,9 +378,19 @@     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 renderArgs = error "Not implemented: renderArgs for Empty"-instance ToTree   Empty+instance Equality   Empty where equal      = error "Not implemented: equal for Empty"+                                exprHash   = error "Not implemented: exprHash for Empty"+instance Eval       Empty where evaluate   = error "Not implemented: equal for Empty"+instance Render     Empty where renderSym  = error "Not implemented: renderSym for Empty"+                                renderArgs = error "Not implemented: renderArgs for Empty"+instance StringTree Empty++++universe :: ASTF dom a -> [ASTE dom]+universe a = ASTE a : go a+  where+    go :: AST dom a -> [ASTE dom]+    go (Sym s)  = []+    go (s :$ a) = go s ++ universe a 

@@ -67,11 +67,11 @@  instance Render Variable   where-    render (Variable v) = showVar v+    renderSym (Variable v) = showVar v -instance ToTree Variable+instance StringTree Variable   where-    toTreeArgs [] (Variable v) = Node ("var:" ++ show v) []+    stringTreeSym [] (Variable v) = Node ("var:" ++ show v) []   @@ -102,11 +102,12 @@  instance Render Lambda   where+    renderSym (Lambda v) = "Lambda " ++ show v     renderArgs [body] (Lambda v) = "(\\" ++ showVar v ++ " -> "  ++ body ++ ")" -instance ToTree Lambda+instance StringTree Lambda   where-    toTreeArgs [body] (Lambda v) = Node ("Lambda " ++ show v) [body]+    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))@@ -138,12 +139,13 @@  instance Render Let   where+    renderSym Let = "Let"     renderArgs []    Let = "Let"     renderArgs [f,a] Let = "(" ++ unwords ["letBind",f,a] ++ ")" -instance ToTree Let+instance StringTree Let   where-    toTreeArgs [a,body] Let = case splitAt 7 node of+    stringTreeSym [a,body] Let = case splitAt 7 node of         ("Lambda ", var) -> Node ("Let " ++ var) [a,body']         _                -> Node "Let" [a,body]       where

@@ -48,12 +48,12 @@  instance Render expr => Render (Decor info expr)   where+    renderSym = renderSym . decorExpr     renderArgs args = renderArgs args . decorExpr-    render = render . decorExpr -instance ToTree expr => ToTree (Decor info expr)+instance StringTree expr => StringTree (Decor info expr)   where-    toTreeArgs args = toTreeArgs args . decorExpr+    stringTreeSym args = stringTreeSym args . decorExpr  instance Eval expr => Eval (Decor info expr)   where@@ -93,23 +93,23 @@ collectInfo coll (f :$ a) = collectInfo coll f ++ collectInfo coll a  -- | Rendering of decorated syntax trees-toTreeDecor :: forall info dom a . (Render info, ToTree dom) =>-    ASTF (Decor info dom) a -> Tree String-toTreeDecor a = mkTree [] a+stringTreeDecor :: forall info dom a . (StringTree dom) =>+    (forall a. info a -> String) -> ASTF (Decor info dom) a -> Tree String+stringTreeDecor showInfo a = mkTree [] a   where     mkTree :: [Tree String] -> AST (Decor info dom) sig -> Tree String-    mkTree args (Sym (Decor info expr)) = Node infoStr [toTreeArgs args expr]+    mkTree args (Sym (Decor info expr)) = Node infoStr [stringTreeSym args expr]       where-        infoStr = "<<" ++ render info ++ ">>"+        infoStr = "<<" ++ showInfo info ++ ">>"     mkTree args (f :$ a) = mkTree (mkTree [] a : args) f  -- | Show an decorated syntax tree using ASCII art-showDecor :: (Render info, ToTree dom) => ASTF (Decor info dom) a -> String-showDecor = drawTree . toTreeDecor+showDecorWith :: StringTree dom => (forall a. info a -> String) -> ASTF (Decor info dom) a -> String+showDecorWith showInfo = drawTree . stringTreeDecor showInfo  -- | Print an decorated syntax tree using ASCII art-drawDecor :: (Render info, ToTree dom) => ASTF (Decor info dom) a -> IO ()-drawDecor = putStrLn . showDecor+drawDecorWith :: StringTree dom => (forall a. info a -> String) -> ASTF (Decor info dom) a -> IO ()+drawDecorWith showInfo = putStrLn . showDecorWith showInfo  -- | Strip decorations from an 'AST' stripDecor :: AST (Decor info dom) sig -> AST dom sig

@@ -31,9 +31,9 @@  instance Render Literal   where-    render (Literal a) = show a+    renderSym (Literal a) = show a -instance ToTree Literal+instance StringTree Literal  instance Eval Literal   where

@@ -33,10 +33,11 @@     semantics Then   = Sem "then"   (>>)     semantics When   = Sem "when"   when -instance Monad m => Equality (MONAD m) where equal = equalDefault; exprHash = exprHashDefault-instance Monad m => Render   (MONAD m) where renderArgs = renderArgsDefault-instance Monad m => Eval     (MONAD m) where evaluate   = evaluateDefault-instance Monad m => ToTree   (MONAD m)+instance Monad m => Equality   (MONAD m) where equal      = equalDefault; exprHash = exprHashDefault+instance Monad m => Render     (MONAD m) where renderSym  = renderSymDefault+                                               renderArgs = renderArgsDefault+instance Monad m => Eval       (MONAD m) where evaluate   = evaluateDefault+instance Monad m => StringTree (MONAD m)  -- | Projection with explicit monad type prjMonad :: Project (MONAD m) sup => P m -> sup sig -> Maybe (MONAD m sig)

@@ -1,7 +1,8 @@ module Language.Syntactic.Interpretation.Render     ( Render (..)-    , printExpr-    , ToTree (..)+    , render+    , StringTree (..)+    , stringTree     , showAST     , drawAST     ) where@@ -14,70 +15,64 @@   --- | Render an expression as concrete syntax. A complete instance must define--- either of the methods 'render' and 'renderArgs'.-class Render expr-  where-    -- | Render an expression as a 'String'-    render :: expr a -> String-    render = renderArgs []--    -- | Render a partially applied expression given a list of rendered missing-    -- arguments-    renderArgs :: [String] -> expr a -> String-    renderArgs []   a = render a-    renderArgs args a = "(" ++ unwords (render a : args) ++ ")"--instance Render dom => Render (AST dom)+-- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym'+-- method.+class Render dom   where-    renderArgs args (Sym a)  = renderArgs args a-    renderArgs args (s :$ a) = renderArgs (render a : args) s+    -- | Show a symbol as a 'String'+    renderSym :: dom sig -> String -instance Render dom => Show (AST dom a)-  where-    show = render+    -- | Render a symbol given a list of rendered arguments+    renderArgs :: [String] -> dom sig -> String+    renderArgs []   a = renderSym a+    renderArgs args a = "(" ++ unwords (renderSym a : args) ++ ")"  instance (Render expr1, Render expr2) => Render (expr1 :+: expr2)   where+    renderSym (InjL a) = renderSym a+    renderSym (InjR a) = renderSym a     renderArgs args (InjL a) = renderArgs args a     renderArgs args (InjR a) = renderArgs args a -instance (Render expr1, Render expr2) => Show ((expr1 :+: expr2) a)+-- | Render an expression as concrete syntax+render :: forall dom a. Render dom => ASTF dom a -> String+render = go []   where-    show = render+    go :: [String] -> AST dom sig -> String+    go args (Sym a)  = renderArgs args a+    go args (s :$ a) = go (render a : args) s --- | Print an expression-printExpr :: Render expr => expr a -> IO ()-printExpr = putStrLn . render+instance Render dom => Show (ASTF dom a)+  where+    show = render   -class Render expr => ToTree expr+-- | Convert a symbol to a 'Tree' of strings+class Render dom => StringTree dom   where-    -- | Convert a partially applied expression to a syntax tree given a list of-    -- rendered missing arguments-    toTreeArgs :: [Tree String] -> expr a -> Tree String-    toTreeArgs args a = Node (render a) args+    -- | Convert a symbol to a 'Tree' given a list of argument trees+    stringTreeSym :: [Tree String] -> dom a -> Tree String+    stringTreeSym args a = Node (renderSym a) args -instance ToTree dom => ToTree (AST dom)+instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2)   where-    toTreeArgs args (Sym a)  = toTreeArgs args a-    toTreeArgs args (s :$ a) = toTreeArgs (toTree a : args) s+    stringTreeSym args (InjL a) = stringTreeSym args a+    stringTreeSym args (InjR a) = stringTreeSym args a -instance (ToTree expr1, ToTree expr2) => ToTree (expr1 :+: expr2)+-- | Convert an expression to a 'Tree' of strings+stringTree :: forall dom a . StringTree dom => ASTF dom a -> Tree String+stringTree = go []   where-    toTreeArgs args (InjL a) = toTreeArgs args a-    toTreeArgs args (InjR a) = toTreeArgs args a---- | Convert an expression to a syntax tree-toTree :: ToTree expr => expr a -> Tree String-toTree = toTreeArgs []+    go :: [Tree String] -> AST dom sig -> Tree String+    go args (Sym a)  = stringTreeSym args a+    go args (s :$ a) = go (stringTree a : args) s --- | Show syntax tree using ASCII art-showAST :: ToTree dom => AST dom a -> String-showAST = drawTree . toTree+-- | Show a syntax tree using ASCII art+showAST :: StringTree dom => ASTF dom a -> String+showAST = drawTree . stringTree --- | Print syntax tree using ASCII art-drawAST :: ToTree dom => AST dom a -> IO ()+-- | Print a syntax tree using ASCII art+drawAST :: StringTree dom => ASTF dom a -> IO () drawAST = putStrLn . showAST 

@@ -39,6 +39,7 @@  instance Render Semantics   where+    renderSym (Sem name _) = name     renderArgs [] (Sem name _) = name     renderArgs args (Sem name _)         | isInfix   = "(" ++ unwords [a,op,b] ++ ")"@@ -71,6 +72,10 @@ exprHashDefault :: Semantic expr => expr a -> Hash exprHashDefault = exprHash . semantics +-- | Default implementation of 'renderSym'+renderSymDefault :: Semantic expr => expr a -> String+renderSymDefault = renderSym . semantics+ -- | Default implementation of 'renderArgs' renderArgsDefault :: Semantic expr => [String] -> expr a -> String renderArgsDefault args = renderArgs args . semantics@@ -79,13 +84,20 @@ evaluateDefault :: Semantic expr => expr a -> Denotation a evaluateDefault = evaluate . semantics +-- | Derive instances for 'Semantic' related classes+-- ('Equality', 'Render', 'StringTree', 'Eval') semanticInstances :: Name -> DecsQ semanticInstances n =     [d|-        instance Equality $(typ) where equal = equalDefault ; exprHash = exprHashDefault-        instance Render $(typ) where renderArgs = renderArgsDefault-        instance ToTree $(typ)+        instance Equality $(typ) where+          equal    = equalDefault+          exprHash = exprHashDefault+        instance Render $(typ) where+          renderSym  = renderSymDefault+          renderArgs = renderArgsDefault+        instance StringTree $(typ)         instance Eval $(typ) where evaluate = evaluateDefault     |]   where     typ = conT n+

@@ -50,9 +50,9 @@  instance Render Node   where-    render (Node a) = showNode a+    renderSym (Node a) = showNode a -instance ToTree Node+instance StringTree Node   @@ -117,7 +117,7 @@   -- | Show syntax graph using ASCII art-showASG :: ToTree dom => ASG dom a -> String+showASG :: StringTree dom => ASG dom a -> String showASG (ASG top nodes _) =     unlines ((line "top" ++ showAST top) : map showNode nodes)   where@@ -131,7 +131,7 @@       ]  -- | Print syntax graph using ASCII art-drawASG :: ToTree dom => ASG dom a -> IO ()+drawASG :: StringTree dom => ASG dom a -> IO () drawASG = putStrLn . showASG  -- | Update the node identifiers in an 'AST' using the supplied reindexing

@@ -19,11 +19,13 @@     , simpleFold     , matchTrans     , WrapFull (..)+    , toTree     ) where    import Control.Applicative+import Data.Tree  import Language.Syntactic.Syntax @@ -188,4 +190,8 @@ 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) 

@@ -1,5 +1,5 @@ Name:           syntactic-Version:        1.8+Version:        1.9 Synopsis:       Generic abstract syntax, and utilities for embedded languages Description:    This library provides:                 .@@ -164,9 +164,9 @@     base,     mtl >= 2 && < 3,     QuickCheck >= 2.4 && < 3,-    test-framework >= 0.6,-    test-framework-th >= 0.2,-    test-framework-quickcheck2 >= 0.2+    tasty,+    tasty-th,+    tasty-quickcheck  test-suite NanoFeldsparTree   type: exitcode-stdio-1.0@@ -196,6 +196,7 @@     base,     bytestring,     mtl >= 2 && < 3,-    test-framework >= 0.6,-    test-framework-golden >= 1.1+    tasty,+    tasty-golden+ 

@@ -1,8 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} -import Test.Framework-import Test.Framework.TH-import Test.Framework.Providers.QuickCheck2+import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.QuickCheck  import NanoFeldspar.Core (eval) import NanoFeldspar.Test

@@ -1,5 +1,5 @@-import Test.Framework-import Test.Golden+import Test.Tasty+import Test.Tasty.Golden  import qualified Data.ByteString.Lazy.Char8 as B @@ -32,5 +32,5 @@     , goldenVsString "prog8"  "tests/gold/prog8.txt"  $ return $ B.pack $ showAST prog8     ] -main = defaultMain [tests]+main = defaultMain tests