Ticket #6065: MWE.hs

File MWE.hs, 2.1 KB (added by tvynr, 3 years ago)

Example Source

Line 
1{-# LANGUAGE  MultiParamTypeClasses
2            , FlexibleContexts
3            , FlexibleInstances
4            , UndecidableInstances
5            , ScopedTypeVariables
6            #-}
7
8module MWE () where
9
10data SumsPart t
11    = IntLit Int
12    | Add t t
13    | Sub t t
14  deriving (Eq, Ord, Show)
15data MultPart t
16    = Mul t t
17  deriving (Eq, Ord, Show)
18
19type SumsAst = Ast1 SumsPart
20type MultAst = Ast2 SumsPart MultPart
21
22data Ast1 p1 = Ast1p1 (p1 (Ast1 p1))
23data Ast2 p1 p2 = Ast2p1 (p1 (Ast2 p1 p2)) | Ast2p2 (p2 (Ast2 p1 p2))
24
25class AstOp op ast result where
26  astop :: op -> ast -> result
27class AstStep op part ast result where
28  aststep :: op -> part ast -> result
29class AstWrap part ast where
30  astwrap :: part ast -> ast
31
32instance AstStep op p1 (Ast1 p1) result =>
33         AstOp op (Ast1 p1) result where
34    astop op ast = case ast of Ast1p1 p -> aststep op p
35instance (AstStep op p1 (Ast2 p1 p2) result,
36          AstStep op p2 (Ast2 p1 p2) result) =>
37         AstOp op (Ast2 p1 p2) result where
38    astop op ast
39        = case ast of
40            Ast2p1 p -> aststep op p
41            Ast2p2 p -> aststep op p
42instance AstWrap p1 (Ast1 p1) where
43     astwrap = Ast1p1 
44instance AstWrap p1 (Ast2 p1 p2) where
45     astwrap = Ast2p1 
46instance AstWrap p2 (Ast2 p1 p2) where
47     astwrap = Ast2p2 
48
49data HomOp = HomOp
50instance (AstOp HomOp ast1 ((ast1 -> ast2) -> ast2)
51         ,AstWrap SumsPart ast2)
52      => AstStep HomOp SumsPart ast1 ((ast1 -> ast2) -> ast2) where
53  aststep HomOp p = \f -> astwrap $
54    case p of
55      IntLit n -> IntLit n
56      Add e1 e2 -> Add (f e1) (f e2)
57      Sub e1 e2 -> Sub (f e1) (f e2)
58instance (AstOp HomOp ast1 ((ast1 -> ast2) -> ast2)
59         ,AstWrap MultPart ast2)
60      => AstStep HomOp MultPart ast1 ((ast1 -> ast2) -> ast2) where
61  aststep HomOp p = \f -> astwrap $
62    case p of
63      Mul e1 e2 -> Mul (f e1) (f e2)
64--upcast :: (AstOp HomOp ast1 ((ast1 -> ast2) -> ast2)) => ast1 -> ast2
65--upcast :: forall t ast. AstOp HomOp ast ((ast -> t) -> t) => ast -> t
66upcast ast = astop HomOp ast upcast
67example :: MultAst
68example = upcast $ Ast1p1 $ IntLit 3
69
70