packages feed

syntactic 0.2.0.1 → 0.3

raw patch · 13 files changed

+458/−372 lines, 13 files

Files

Examples/ALaCarte.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE ViewPatterns #-}  -- | Demonstration of the fact that "Language.Syntactic" has the same--- functionality as /Data types a la carte/ (Wouter Swierstra, in+-- functionality as /Data types á la carte/ (Wouter Swierstra, in -- /Journal of Functional Programming/, 2008)  module ALaCarte where
Examples/MuFeldspar/Core.hs view
@@ -15,6 +15,12 @@ import qualified Prelude import Data.Typeable +import Language.Syntactic+import Language.Syntactic.Features.Literal+import Language.Syntactic.Features.PrimFunc+import Language.Syntactic.Features.Condition+import Language.Syntactic.Features.Tuple+import Language.Syntactic.Features.TupleSyntactic import Language.Syntactic.Features.Binding import Language.Syntactic.Features.Binding.HigherOrder @@ -53,7 +59,7 @@  instance Eval Parallel   where-    evaluate Parallel = consEval $ \len ixf -> Prelude.map ixf [0 .. len-1]+    evaluate Parallel = fromEval $ \len ixf -> Prelude.map ixf [0 .. len-1]   @@ -77,7 +83,7 @@  instance Eval ForLoop   where-    evaluate ForLoop = consEval $ \len init body -> foldr body init [0 .. len-1]+    evaluate ForLoop = fromEval $ \len init body -> foldr body init [0 .. len-1]   @@ -143,7 +149,7 @@ --------------------------------------------------------------------------------  value :: Syntax a => Internal a -> a-value = litSyn+value = sugar . lit  -- | For types containing some kind of \"thunk\", this function can be used to -- force computation@@ -164,8 +170,8 @@ instance (Type a, Num a) => Num (Data a)   where     fromInteger = value . fromInteger-    abs         = sugarN $ primFunc "abs" abs-    signum      = sugarN $ primFunc "signum" signum+    abs         = sugarN $ primFunc1 "abs" abs+    signum      = sugarN $ primFunc1 "signum" signum     (+)         = sugarN $ primFunc2 "(+)" (+)     (-)         = sugarN $ primFunc2 "(-)" (-)     (*)         = sugarN $ primFunc2 "(*)" (*)@@ -186,7 +192,7 @@     :$: lambdaN (desugarN body)  arrLength :: Type a => Data [a] -> Data Length-arrLength = sugarN $ primFunc "arrLength" Prelude.length+arrLength = sugarN $ primFunc1 "arrLength" Prelude.length  getIx :: Type a => Data [a] -> Data Index -> Data a getIx = sugarN $ primFunc2 "getIx" eval
Language/Syntactic.hs view
@@ -9,10 +9,6 @@     , module Language.Syntactic.Analysis.Render     , module Language.Syntactic.Analysis.Evaluation     , module Language.Syntactic.Analysis.Hash-    , module Language.Syntactic.Features.Literal-    , module Language.Syntactic.Features.PrimFunc-    , module Language.Syntactic.Features.Condition-    , module Language.Syntactic.Features.Tuple     , module Language.Syntactic.Features.Annotate     ) where @@ -23,9 +19,5 @@ import Language.Syntactic.Analysis.Render import Language.Syntactic.Analysis.Evaluation import Language.Syntactic.Analysis.Hash-import Language.Syntactic.Features.Literal-import Language.Syntactic.Features.PrimFunc-import Language.Syntactic.Features.Condition-import Language.Syntactic.Features.Tuple import Language.Syntactic.Features.Annotate
Language/Syntactic/Features/Annotate.hs view
@@ -27,29 +27,35 @@ -- 'injectAnn' / 'projectAnn'. data Ann info expr a   where-    Ann :: info (EvalResult a) -> expr a -> Ann info expr a+    Ann+        :: { annInfo :: info (EvalResult a)+           , annExpr :: expr a+           }+        -> Ann info expr a +type AnnSTF info dom a = ASTF (Ann info dom) a  + instance ExprEq expr => ExprEq (Ann info expr)   where-    Ann _ a `exprEq` Ann _ b = exprEq a b+    exprEq a b = annExpr a `exprEq` annExpr b  instance Render expr => Render (Ann info expr)   where-    render (Ann _ a) = render a+    render = render . annExpr  instance ToTree expr => ToTree (Ann info expr)   where-    toTreePart args (Ann _ a) = toTreePart args a+    toTreePart args = toTreePart args . annExpr  instance Eval expr => Eval (Ann info expr)   where-    evaluate (Ann _ a) = evaluate a+    evaluate = evaluate . annExpr  instance ExprHash expr => ExprHash (Ann info expr)   where-    exprHash (Ann _ a) = exprHash a+    exprHash = exprHash . annExpr
Language/Syntactic/Features/Binding.hs view
@@ -190,7 +190,7 @@  instance Eval Let   where-    evaluate Let = consEval (flip ($))+    evaluate Let = fromEval (flip ($))  instance ExprHash Let   where
Language/Syntactic/Features/Binding/HigherOrder.hs view
@@ -6,8 +6,7 @@ -- translation.  module Language.Syntactic.Features.Binding.HigherOrder-    ( module Language.Syntactic-    , Variable+    ( Variable     , evalLambda     , Let (..)     , HOLambda (..)
Language/Syntactic/Features/Condition.hs view
@@ -6,11 +6,7 @@  import Data.Hash -import Language.Syntactic.Syntax-import Language.Syntactic.Analysis.Equality-import Language.Syntactic.Analysis.Render-import Language.Syntactic.Analysis.Evaluation-import Language.Syntactic.Analysis.Hash+import Language.Syntactic   @@ -30,7 +26,7 @@  instance Eval Condition   where-    evaluate Condition = consEval $+    evaluate Condition = fromEval $         \cond tHEN eLSE -> if cond then tHEN else eLSE  instance ExprHash Condition@@ -39,6 +35,7 @@   +-- | Conditional expression condition :: (Condition :<: dom, Syntactic a dom) =>     ASTF dom Bool -> a -> a -> a condition cond tHEN eLSE = sugar $ inject Condition
Language/Syntactic/Features/Literal.hs view
@@ -8,11 +8,7 @@  import Data.Hash -import Language.Syntactic.Syntax-import Language.Syntactic.Analysis.Equality-import Language.Syntactic.Analysis.Render-import Language.Syntactic.Analysis.Evaluation-import Language.Syntactic.Analysis.Hash+import Language.Syntactic   @@ -34,7 +30,7 @@  instance Eval Literal   where-    evaluate (Literal a) = consEval a+    evaluate (Literal a) = fromEval a  instance ExprHash Literal   where@@ -42,15 +38,12 @@   +-- | Literal lit :: (Eq a, Show a, Typeable a, Literal :<: dom) => a -> ASTF dom a lit = inject . Literal -litSyn-    :: ( Eq (Internal a)-       , Show (Internal a)-       , Syntactic a dom-       , Literal :<: dom-       )-    => Internal a -> a-litSyn = sugar . inject . Literal+-- | Annotated literal+litAnn :: (Eq a, Show a, Typeable a, Literal :<: dom) =>+    info a -> a -> AnnSTF info dom a+litAnn info = injectAnn info . Literal
Language/Syntactic/Features/PrimFunc.hs view
@@ -8,11 +8,7 @@  import Data.Hash -import Language.Syntactic.Syntax-import Language.Syntactic.Analysis.Equality-import Language.Syntactic.Analysis.Render-import Language.Syntactic.Analysis.Evaluation-import Language.Syntactic.Analysis.Hash+import Language.Syntactic   @@ -44,7 +40,7 @@  instance Eval PrimFunc   where-    evaluate (PrimFunc _ f) = consEval f+    evaluate (PrimFunc _ f) = fromEval f  instance ExprHash PrimFunc   where@@ -52,14 +48,21 @@   -primFunc :: (Typeable a, PrimFunc :<: dom)+primFunc1+    :: ( Typeable a+       , PrimFunc :<: dom+       )     => String     -> (a -> b)     -> ASTF dom a     -> ASTF dom b-primFunc name f a = inject (PrimFunc name f) :$: a+primFunc1 name f a = inject (PrimFunc name f) :$: a -primFunc2 :: (Typeable a, Typeable b, PrimFunc :<: dom)+primFunc2+    :: ( Typeable a+       , Typeable b+       , PrimFunc :<: dom+       )     => String     -> (a -> b -> c)     -> ASTF dom a@@ -67,7 +70,12 @@     -> ASTF dom c primFunc2 name f a b = inject (PrimFunc name f) :$: a :$: b -primFunc3 :: (Typeable a, Typeable b, Typeable c, PrimFunc :<: dom)+primFunc3+    :: ( Typeable a+       , Typeable b+       , Typeable c+       , PrimFunc :<: dom+       )     => String     -> (a -> b -> c -> d)     -> ASTF dom a@@ -76,7 +84,13 @@     -> ASTF dom d primFunc3 name f a b c = inject (PrimFunc name f) :$: a :$: b :$: c -primFunc4 :: (Typeable a, Typeable b, Typeable c, Typeable d, PrimFunc :<: dom)+primFunc4+    :: ( Typeable a+       , Typeable b+       , Typeable c+       , Typeable d+       , PrimFunc :<: dom+       )     => String     -> (a -> b -> c -> d -> e)     -> ASTF dom a@@ -85,4 +99,85 @@     -> ASTF dom d     -> ASTF dom e primFunc4 name f a b c d = inject (PrimFunc name f) :$: a :$: b :$: c :$: d++primFuncAnn1+    :: ( Typeable a+       , PrimFunc :<: dom+       )+    => String+    -> (a -> b)+    -> info b+    -> AnnSTF info dom a+    -> AnnSTF info dom b+primFuncAnn1 name f ib a = injectAnn ib (PrimFunc name f) :$: a++primFuncAnn2+    :: ( Typeable a+       , Typeable b+       , PrimFunc :<: dom+       )+    => String+    -> (a -> b -> c)+    -> info c+    -> AnnSTF info dom a+    -> AnnSTF info dom b+    -> AnnSTF info dom c+primFuncAnn2 name f ic a b = injectAnn ic (PrimFunc name f) :$: a :$: b++primFuncAnn3+    :: ( Typeable a+       , Typeable b+       , Typeable c+       , PrimFunc :<: dom+       )+    => String+    -> (a -> b -> c -> d)+    -> info d+    -> AnnSTF info dom a+    -> AnnSTF info dom b+    -> AnnSTF info dom c+    -> AnnSTF info dom d+primFuncAnn3 name f id a b c =+    injectAnn id (PrimFunc name f) :$: a :$: b :$: c++primFuncAnn4+    :: ( Typeable a+       , Typeable b+       , Typeable c+       , Typeable d+       , PrimFunc :<: dom+       )+    => String+    -> (a -> b -> c -> d -> e)+    -> info e+    -> AnnSTF info dom a+    -> AnnSTF info dom b+    -> AnnSTF info dom c+    -> AnnSTF info dom d+    -> AnnSTF info dom e+primFuncAnn4 name f ie a b c d =+    injectAnn ie (PrimFunc name f) :$: a :$: b :$: c :$: d++++-- | Class of expressions that can be treated as primitive functions+class IsFunction expr+  where+    toFunction :: expr a -> PrimFunc a++-- | Default implementation of 'exprEq'+exprEqFunc :: IsFunction expr => expr a -> expr b -> Bool+exprEqFunc a b = exprEq (toFunction a) (toFunction b)++-- | Default implementation of 'renderPart'+renderPartFunc :: IsFunction expr => [String] -> expr a -> String+renderPartFunc args = renderPart args . toFunction++-- | Default implementation of 'evaluate'+evaluateFunc :: IsFunction expr => expr a -> a+evaluateFunc = evaluate . toFunction++-- | Default implementation of 'exprHash'+exprHashFunc :: IsFunction expr => expr a -> Hash+exprHashFunc = exprHash . toFunction
Language/Syntactic/Features/Tuple.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE UndecidableInstances #-}- -- | Construction and selection of tuples  module Language.Syntactic.Features.Tuple where@@ -9,11 +7,8 @@ import Data.Hash import Data.Tuple.Select -import Language.Syntactic.Syntax-import Language.Syntactic.Analysis.Equality-import Language.Syntactic.Analysis.Render-import Language.Syntactic.Analysis.Evaluation-import Language.Syntactic.Analysis.Hash+import Language.Syntactic+import Language.Syntactic.Features.PrimFunc   @@ -27,44 +22,20 @@     Tup6 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> Full (a,b,c,d,e,f))     Tup7 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> Full (a,b,c,d,e,f,g)) -instance ExprEq Tuple-  where-    Tup2 `exprEq` Tup2 = True-    Tup3 `exprEq` Tup3 = True-    Tup4 `exprEq` Tup4 = True-    Tup5 `exprEq` Tup5 = True-    Tup6 `exprEq` Tup6 = True-    Tup7 `exprEq` Tup7 = True-    exprEq _ _ = False--instance Render Tuple-  where-    render Tup2 = "tup2"-    render Tup3 = "tup3"-    render Tup4 = "tup4"-    render Tup5 = "tup5"-    render Tup6 = "tup6"-    render Tup7 = "tup7"--instance ToTree Tuple--instance Eval Tuple+instance IsFunction Tuple   where-    evaluate Tup2 = consEval (,)-    evaluate Tup3 = consEval (,,)-    evaluate Tup4 = consEval (,,,)-    evaluate Tup5 = consEval (,,,,)-    evaluate Tup6 = consEval (,,,,,)-    evaluate Tup7 = consEval (,,,,,,)+    toFunction Tup2 = PrimFunc "tup2" (,)+    toFunction Tup3 = PrimFunc "tup3" (,,)+    toFunction Tup4 = PrimFunc "tup4" (,,,)+    toFunction Tup5 = PrimFunc "tup5" (,,,,)+    toFunction Tup6 = PrimFunc "tup6" (,,,,,)+    toFunction Tup7 = PrimFunc "tup7" (,,,,,,) -instance ExprHash Tuple-  where-    exprHash Tup2 = hashInt 0-    exprHash Tup3 = hashInt 1-    exprHash Tup4 = hashInt 2-    exprHash Tup5 = hashInt 3-    exprHash Tup6 = hashInt 4-    exprHash Tup7 = hashInt 5+instance ExprEq   Tuple where exprEq     = exprEqFunc+instance Render   Tuple where renderPart = renderPartFunc+instance Eval     Tuple where evaluate   = evaluateFunc+instance ExprHash Tuple where exprHash   = exprHashFunc+instance ToTree   Tuple  -- | Expressions for selecting elements of a tuple data Select a@@ -77,48 +48,21 @@     Sel6 :: Sel6 a b => Select (a :-> Full b)     Sel7 :: Sel7 a b => Select (a :-> Full b) -instance ExprEq Select-  where-    Sel1 `exprEq` Sel1 = True-    Sel2 `exprEq` Sel2 = True-    Sel3 `exprEq` Sel3 = True-    Sel4 `exprEq` Sel4 = True-    Sel5 `exprEq` Sel5 = True-    Sel6 `exprEq` Sel6 = True-    Sel7 `exprEq` Sel7 = True-    exprEq _ _ = False--instance Eval Select-  where-    evaluate Sel1 = consEval sel1-    evaluate Sel2 = consEval sel2-    evaluate Sel3 = consEval sel3-    evaluate Sel4 = consEval sel4-    evaluate Sel5 = consEval sel5-    evaluate Sel6 = consEval sel6-    evaluate Sel7 = consEval sel7--instance Render Select+instance IsFunction Select   where-    render Sel1 = "sel1"-    render Sel2 = "sel2"-    render Sel3 = "sel3"-    render Sel4 = "sel4"-    render Sel5 = "sel5"-    render Sel6 = "sel6"-    render Sel7 = "sel7"--instance ToTree Select+    toFunction Sel1 = PrimFunc "sel1" sel1+    toFunction Sel2 = PrimFunc "sel2" sel2+    toFunction Sel3 = PrimFunc "sel3" sel3+    toFunction Sel4 = PrimFunc "sel4" sel4+    toFunction Sel5 = PrimFunc "sel5" sel5+    toFunction Sel6 = PrimFunc "sel6" sel6+    toFunction Sel7 = PrimFunc "sel7" sel7 -instance ExprHash Select-  where-    exprHash Sel1 = hashInt 0-    exprHash Sel2 = hashInt 1-    exprHash Sel3 = hashInt 2-    exprHash Sel4 = hashInt 3-    exprHash Sel5 = hashInt 4-    exprHash Sel6 = hashInt 5-    exprHash Sel7 = hashInt 6+instance ExprEq   Select where exprEq     = exprEqFunc+instance Render   Select where renderPart = renderPartFunc+instance Eval     Select where evaluate   = evaluateFunc+instance ExprHash Select where exprHash   = exprHashFunc+instance ToTree   Select  -- | Return the selected position, e.g. --@@ -131,198 +75,4 @@ selectPos Sel5 = 5 selectPos Sel6 = 6 selectPos Sel7 = 7----instance-    ( Syntactic a dom-    , Syntactic b dom-    , Tuple  :<: dom-    , Select :<: dom-    ) =>-      Syntactic (a,b) dom-  where-    type Internal (a,b) =-        ( Internal a-        , Internal b-        )--    desugar (a,b) = inject Tup2-        :$: desugar a-        :$: desugar b--    sugar a =-        ( sugar $ inject Sel1 :$: a-        , sugar $ inject Sel2 :$: a-        )--instance-    ( Syntactic a dom-    , Syntactic b dom-    , Syntactic c dom-    , Tuple  :<: dom-    , Select :<: dom-    ) =>-      Syntactic (a,b,c) dom-  where-    type Internal (a,b,c) =-        ( Internal a-        , Internal b-        , Internal c-        )--    desugar (a,b,c) = inject Tup3-        :$: desugar a-        :$: desugar b-        :$: desugar c--    sugar a =-        ( sugar $ inject Sel1 :$: a-        , sugar $ inject Sel2 :$: a-        , sugar $ inject Sel3 :$: a-        )--instance-    ( Syntactic a dom-    , Syntactic b dom-    , Syntactic c dom-    , Syntactic d dom-    , Tuple  :<: dom-    , Select :<: dom-    ) =>-      Syntactic (a,b,c,d) dom-  where-    type Internal (a,b,c,d) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        )--    desugar (a,b,c,d) = inject Tup4-        :$: desugar a-        :$: desugar b-        :$: desugar c-        :$: desugar d--    sugar a =-        ( sugar $ inject Sel1 :$: a-        , sugar $ inject Sel2 :$: a-        , sugar $ inject Sel3 :$: a-        , sugar $ inject Sel4 :$: a-        )--instance-    ( Syntactic a dom-    , Syntactic b dom-    , Syntactic c dom-    , Syntactic d dom-    , Syntactic e dom-    , Tuple  :<: dom-    , Select :<: dom-    ) =>-      Syntactic (a,b,c,d,e) dom-  where-    type Internal (a,b,c,d,e) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        )--    desugar (a,b,c,d,e) = inject Tup5-        :$: desugar a-        :$: desugar b-        :$: desugar c-        :$: desugar d-        :$: desugar e--    sugar a =-        ( sugar $ inject Sel1 :$: a-        , sugar $ inject Sel2 :$: a-        , sugar $ inject Sel3 :$: a-        , sugar $ inject Sel4 :$: a-        , sugar $ inject Sel5 :$: a-        )--instance-    ( Syntactic a dom-    , Syntactic b dom-    , Syntactic c dom-    , Syntactic d dom-    , Syntactic e dom-    , Syntactic f dom-    , Tuple  :<: dom-    , Select :<: dom-    ) =>-      Syntactic (a,b,c,d,e,f) dom-  where-    type Internal (a,b,c,d,e,f) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        )--    desugar (a,b,c,d,e,f) = inject Tup6-        :$: desugar a-        :$: desugar b-        :$: desugar c-        :$: desugar d-        :$: desugar e-        :$: desugar f--    sugar a =-        ( sugar $ inject Sel1 :$: a-        , sugar $ inject Sel2 :$: a-        , sugar $ inject Sel3 :$: a-        , sugar $ inject Sel4 :$: a-        , sugar $ inject Sel5 :$: a-        , sugar $ inject Sel6 :$: a-        )--instance-    ( Syntactic a dom-    , Syntactic b dom-    , Syntactic c dom-    , Syntactic d dom-    , Syntactic e dom-    , Syntactic f dom-    , Syntactic g dom-    , Tuple  :<: dom-    , Select :<: dom-    ) =>-      Syntactic (a,b,c,d,e,f,g) dom-  where-    type Internal (a,b,c,d,e,f,g) =-        ( Internal a-        , Internal b-        , Internal c-        , Internal d-        , Internal e-        , Internal f-        , Internal g-        )--    desugar (a,b,c,d,e,f,g) = inject Tup7-        :$: desugar a-        :$: desugar b-        :$: desugar c-        :$: desugar d-        :$: desugar e-        :$: desugar f-        :$: desugar g--    sugar a =-        ( sugar $ inject Sel1 :$: a-        , sugar $ inject Sel2 :$: a-        , sugar $ inject Sel3 :$: a-        , sugar $ inject Sel4 :$: a-        , sugar $ inject Sel5 :$: a-        , sugar $ inject Sel6 :$: a-        , sugar $ inject Sel7 :$: a-        )
+ Language/Syntactic/Features/TupleSyntactic.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE UndecidableInstances #-}++-- | 'Syntactic' instances for tuples+module Language.Syntactic.Features.TupleSyntactic where++++import Language.Syntactic.Syntax+import Language.Syntactic.Features.Tuple++++instance+    ( Syntactic a dom+    , Syntactic b dom+    , Tuple  :<: dom+    , Select :<: dom+    ) =>+      Syntactic (a,b) dom+  where+    type Internal (a,b) =+        ( Internal a+        , Internal b+        )++    desugar (a,b) = inject Tup2+        :$: desugar a+        :$: desugar b++    sugar a =+        ( sugar $ inject Sel1 :$: a+        , sugar $ inject Sel2 :$: a+        )++instance+    ( Syntactic a dom+    , Syntactic b dom+    , Syntactic c dom+    , Tuple  :<: dom+    , Select :<: dom+    ) =>+      Syntactic (a,b,c) dom+  where+    type Internal (a,b,c) =+        ( Internal a+        , Internal b+        , Internal c+        )++    desugar (a,b,c) = inject Tup3+        :$: desugar a+        :$: desugar b+        :$: desugar c++    sugar a =+        ( sugar $ inject Sel1 :$: a+        , sugar $ inject Sel2 :$: a+        , sugar $ inject Sel3 :$: a+        )++instance+    ( Syntactic a dom+    , Syntactic b dom+    , Syntactic c dom+    , Syntactic d dom+    , Tuple  :<: dom+    , Select :<: dom+    ) =>+      Syntactic (a,b,c,d) dom+  where+    type Internal (a,b,c,d) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        )++    desugar (a,b,c,d) = inject Tup4+        :$: desugar a+        :$: desugar b+        :$: desugar c+        :$: desugar d++    sugar a =+        ( sugar $ inject Sel1 :$: a+        , sugar $ inject Sel2 :$: a+        , sugar $ inject Sel3 :$: a+        , sugar $ inject Sel4 :$: a+        )++instance+    ( Syntactic a dom+    , Syntactic b dom+    , Syntactic c dom+    , Syntactic d dom+    , Syntactic e dom+    , Tuple  :<: dom+    , Select :<: dom+    ) =>+      Syntactic (a,b,c,d,e) dom+  where+    type Internal (a,b,c,d,e) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        , Internal e+        )++    desugar (a,b,c,d,e) = inject Tup5+        :$: desugar a+        :$: desugar b+        :$: desugar c+        :$: desugar d+        :$: desugar e++    sugar a =+        ( sugar $ inject Sel1 :$: a+        , sugar $ inject Sel2 :$: a+        , sugar $ inject Sel3 :$: a+        , sugar $ inject Sel4 :$: a+        , sugar $ inject Sel5 :$: a+        )++instance+    ( Syntactic a dom+    , Syntactic b dom+    , Syntactic c dom+    , Syntactic d dom+    , Syntactic e dom+    , Syntactic f dom+    , Tuple  :<: dom+    , Select :<: dom+    ) =>+      Syntactic (a,b,c,d,e,f) dom+  where+    type Internal (a,b,c,d,e,f) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        , Internal e+        , Internal f+        )++    desugar (a,b,c,d,e,f) = inject Tup6+        :$: desugar a+        :$: desugar b+        :$: desugar c+        :$: desugar d+        :$: desugar e+        :$: desugar f++    sugar a =+        ( sugar $ inject Sel1 :$: a+        , sugar $ inject Sel2 :$: a+        , sugar $ inject Sel3 :$: a+        , sugar $ inject Sel4 :$: a+        , sugar $ inject Sel5 :$: a+        , sugar $ inject Sel6 :$: a+        )++instance+    ( Syntactic a dom+    , Syntactic b dom+    , Syntactic c dom+    , Syntactic d dom+    , Syntactic e dom+    , Syntactic f dom+    , Syntactic g dom+    , Tuple  :<: dom+    , Select :<: dom+    ) =>+      Syntactic (a,b,c,d,e,f,g) dom+  where+    type Internal (a,b,c,d,e,f,g) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        , Internal e+        , Internal f+        , Internal g+        )++    desugar (a,b,c,d,e,f,g) = inject Tup7+        :$: desugar a+        :$: desugar b+        :$: desugar c+        :$: desugar d+        :$: desugar e+        :$: desugar f+        :$: desugar g++    sugar a =+        ( sugar $ inject Sel1 :$: a+        , sugar $ inject Sel2 :$: a+        , sugar $ inject Sel3 :$: a+        , sugar $ inject Sel4 :$: a+        , sugar $ inject Sel5 :$: a+        , sugar $ inject Sel6 :$: a+        , sugar $ inject Sel7 :$: a+        )+
Language/Syntactic/Syntax.hs view
@@ -50,7 +50,7 @@ -- > conv12 :: (Num2 :<: dom, Add2 :<: dom) => Expr1 a -> ASTF dom a -- > conv21 :: (Num2 :<: dom, Add2 :<: dom) => ASTF dom a -> Expr1 a ----- This way of encoding open data types is taken from /Data types a la carte/,+-- This way of encoding open data types is taken from /Data types à la carte/, -- by Wouter Swierstra, in /Journal of Functional Programming/, 2008. However, -- we do not need Swierstra's fixed-point machinery for recursive data types. -- Instead we rely on 'AST' being recursive.@@ -59,10 +59,15 @@     ( -- * Syntax trees       Full (..)     , (:->) (..)+    , HList (..)     , ConsType     , ConsEval     , EvalResult-    , consEval+    , fromEval+    , toEval+    , listHList+    , listHListM+    , mapHList     , ($:)     , AST (..)     , ASTF@@ -74,8 +79,8 @@     , resugar     , SyntacticN (..)       -- * AST processing-    , SubTrees (..)-    , processNode+    , queryNode+    , transformNode     ) where  @@ -92,8 +97,14 @@ newtype a :-> b = Partial (a -> b)   deriving (Typeable) -infixr :->+-- | Heterogeneous list, indexed by a container type and a 'ConsType'+data family HList (c :: * -> *) a +data instance HList c (Full a)  = Nil+data instance HList c (a :-> b) = c (Full a) :*: HList c b++infixr :->, :*:+ -- | Fully or partially applied constructor -- -- This class is private to the module to guarantee that all members of the@@ -109,20 +120,35 @@   where     type ConsEval' a     type EvalResult' a-    consEval' :: ConsEval' a -> a +    fromEval'   :: ConsEval' a -> a+    toEval'     :: a -> ConsEval' a+    listHList'  :: (forall a . c (Full a) -> b) -> HList c a -> [b]+    listHListM' :: Monad m => (forall a . c (Full a) -> m b) -> HList c a -> m [b]+    mapHList'   :: (forall a . c1 a -> c2 a) -> HList c1 a -> HList c2 a+ instance ConsType' (Full a)   where     type ConsEval'   (Full a) = a     type EvalResult' (Full a) = a-    consEval' = Full +    fromEval'         = Full+    toEval'           = result+    listHList'  f Nil = []+    listHListM' f Nil = return []+    mapHList'   f Nil = Nil+ instance ConsType' b => ConsType' (a :-> b)   where     type ConsEval'   (a :-> b) = a -> ConsEval' b     type EvalResult' (a :-> b) = EvalResult' b-    consEval' = Partial . (consEval' .) +    fromEval'                = Partial . (fromEval' .)+    toEval' (Partial f)      = toEval' . f+    listHList'  f (a :*: as) = f a : listHList' f as+    listHListM' f (a :*: as) = sequence (f a : listHList' f as)+    mapHList'   f (a :*: as) = f a :*: mapHList' f as+ -- | Fully or partially applied constructor -- -- This is a public alias for the hidden class 'ConsType''. The only instances@@ -143,9 +169,27 @@ type EvalResult a = EvalResult' a  -- | Make a constructor evaluation from a 'ConsEval' representation-consEval :: ConsType a => ConsEval a -> a-consEval = consEval'+fromEval :: ConsType a => ConsEval a -> a+fromEval = fromEval' +toEval :: ConsType a => a -> ConsEval a+toEval = toEval'++-- | Convert a heterogeneous list to a normal list+listHList :: ConsType a =>+    (forall a . c (Full a) -> b) -> HList c a -> [b]+listHList = listHList'++-- | Convert a heterogeneous list to a normal list+listHListM :: (Monad m, ConsType a) =>+    (forall a . c (Full a) -> m b) -> HList c a -> m [b]+listHListM = listHListM'++-- | Change the container of each element in a heterogeneous list+mapHList :: ConsType a =>+    (forall a . c1 a -> c2 a) -> HList c1 a -> HList c2 a+mapHList = mapHList'+ -- | Semantic constructor application ($:) :: (a :-> b) -> a -> b Partial f $: a = f a@@ -282,23 +326,7 @@   --- | Data family for collecting the children of a constructor, for example:------ > subTrees :: forall dom . SubTrees dom (Int :-> Bool :-> Full [Int])--- > subTrees = a :*: b :*: Nil--- >   where--- >     a = undefined :: ASTF dom Int--- >     b = undefined :: ASTF dom Bool------ @(`SubTrees` a)@ is meaningful iff. @(`ConsType` a)@-data family SubTrees (dom :: * -> *) a--data instance SubTrees dom (Full a)  = Nil-data instance SubTrees dom (a :-> b) = ASTF dom a :*: SubTrees dom b--infixr :*:---- | Process an 'AST' using a function that gets direct access to the top-most+-- | Query an 'AST' using a function that gets direct access to the top-most -- constructor and its sub-trees -- -- This function can be used to create 'AST' traversal functions indexed by the@@ -306,7 +334,7 @@ -- -- > class Count subDomain -- >   where--- >     count' :: Count domain => subDomain a -> SubTrees domain a -> Int+-- >     count' :: Count domain => subDomain a -> HList (AST domain) a -> Int -- > -- > instance (Count sub1, Count sub2) => Count (sub1 :+: sub2) -- >   where@@ -314,10 +342,10 @@ -- >     count' (InjectR a) args = count' a args -- > -- > count :: Count dom => ASTF dom a -> Int--- > count = processNode count'+-- > count = queryNode count' -- -- Here, @count@ represents some static analysis on an 'AST'. Each constructor--- in the tree will be processed by @count'@ indexed by the corresponding symbol+-- in the tree will be queried by @count'@ indexed by the corresponding symbol -- type. That way, @count'@ can be seen as an open-ended function on an open -- data type. The @(Count domain)@ constraint on @count'@ is to allow recursion -- over sub-trees.@@ -333,12 +361,28 @@ -- > instance Count Add -- >   where -- >     count' Add (a :*: b :*: Nil) = 1 + count a + count b-processNode :: forall dom a b-    .  (forall a . ConsType a => dom a -> SubTrees dom a -> b)+queryNode :: forall dom a b+    .  (forall a . ConsType a => dom a -> HList (AST dom) a -> b)     -> ASTF dom a -> b-processNode f a = process a Nil+queryNode f a = query a Nil   where-    process :: AST dom c -> SubTrees dom c -> b-    process (Symbol a) args = f a args-    process (c :$: a)  args = process c (a :*: args)+    query :: AST dom c -> HList (AST dom) c -> b+    query (Symbol a) args = f a args+    query (c :$: a)  args = query c (a :*: args)++++-- | Transform an 'AST' using a function that gets direct access to the top-most+-- constructor and its sub-trees. This function is similar to 'queryNode', but+-- returns a transformed 'AST' rather than abstract interpretation.+transformNode :: forall dom dom' a+    .  (  forall a . ConsType a+       => dom a -> HList (AST dom) a -> ASTF dom' (EvalResult a)+       )+    -> ASTF dom a -> ASTF dom' a+transformNode f a = transform a Nil+  where+    transform :: AST dom b -> HList (AST dom) b -> ASTF dom' (EvalResult b)+    transform (Symbol a) args = f a args+    transform (c :$: a)  args = transform c (a :*: args)
syntactic.cabal view
@@ -1,5 +1,5 @@ Name:           syntactic-Version:        0.2.0.1+Version:        0.3 Synopsis:       Generic abstract syntax, and utilities for embedded languages Description:    This library provides:                 .@@ -21,7 +21,7 @@                 languages, such as Feldspar. Currently, it does not support                 cyclic programs.                 .-                \[1\] /Data types a la carte/, by Wouter Swierstra, in+                \[1\] /Data types à la carte/, by Wouter Swierstra, in                 /Journal of Functional Programming/, 2008                 .                 \[2\] <http://hackage.haskell.org/package/feldspar-language>@@ -53,14 +53,14 @@     Language.Syntactic.Analysis.Render     Language.Syntactic.Analysis.Evaluation     Language.Syntactic.Analysis.Hash+    Language.Syntactic.Features.Annotate     Language.Syntactic.Features.Literal     Language.Syntactic.Features.PrimFunc     Language.Syntactic.Features.Condition     Language.Syntactic.Features.Tuple-    Language.Syntactic.Features.Annotate+    Language.Syntactic.Features.TupleSyntactic     Language.Syntactic.Features.Binding     Language.Syntactic.Features.Binding.HigherOrder-   Other-modules:    Build-depends: