-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
mv TTree to A, update related test modules
- Loading branch information
Showing
5 changed files
with
200 additions
and
192 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,164 @@ | ||
| ----------------------------------------------------------------------------- | ||
| -- | | ||
| -- Module : A | ||
| -- Copyright : (c) 2008 - 2010 Universiteit Utrecht | ||
| -- License : BSD3 | ||
| -- | ||
| -- Maintainer : generics@haskell.org | ||
| -- | ||
| -- An example type representation. | ||
| ----------------------------------------------------------------------------- | ||
|
|
||
| -- {-# OPTIONS_GHC -Wall #-} | ||
|
|
||
| {-# LANGUAGE TypeOperators #-} | ||
| {-# LANGUAGE TypeSynonymInstances #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE MultiParamTypeClasses #-} | ||
| {-# LANGUAGE DeriveDataTypeable #-} | ||
| {-# LANGUAGE OverlappingInstances #-} | ||
| {-# LANGUAGE UndecidableInstances #-} | ||
|
|
||
| module A where | ||
|
|
||
| import Prelude hiding (Read, Show) | ||
| import qualified Prelude as P (Read, Show) | ||
| import Data.Generics (Data, Typeable) | ||
|
|
||
| import Generics.EMGM.Base | ||
| import Generics.EMGM.Functions.Collect | ||
| import Generics.EMGM.Functions.Everywhere | ||
|
|
||
| data A a | ||
| = A1 a | ||
| | A2 Integer (A a) | ||
| | A3 { unA3 :: Double } | ||
| | A4 { unA4a :: A a, unA4b :: Int } | ||
| | A5 { unA5a :: Char, unA5b :: A a, unA5c :: a } | ||
| | A a :^: Float | ||
| | (:<>:) { unA7a :: A a, unA7b :: A a } | ||
| deriving (P.Show, P.Read, Eq, Ord, Data, Typeable) | ||
|
|
||
| infixr 6 :^: | ||
| infixl 5 :<>: | ||
|
|
||
| type A' a | ||
| {- A1 -} = a | ||
| {- A2 -} :+: Integer :*: A a | ||
| {- A3 -} :+: Double | ||
| {- A4 -} :+: A a :*: Int | ||
| {- A5 -} :+: Char :*: A a :*: a | ||
| {- :^: -} :+: A a :*: Float | ||
| {- :<>: -} :+: A a :*: A a | ||
|
|
||
| fromA :: A a -> A' a | ||
| fromA t = case t of | ||
| A1 x1 -> L x1 | ||
| A2 x1 x2 -> R (L (x1 :*: x2)) | ||
| A3 x1 -> R (R (L x1)) | ||
| A4 x1 x2 -> R (R (R (L (x1 :*: x2)))) | ||
| A5 x1 x2 x3 -> R (R (R (R (L (x1 :*: x2 :*: x3))))) | ||
| x1 :^: x2 -> R (R (R (R (R (L (x1 :*: x2)))))) | ||
| x1 :<>: x2 -> R (R (R (R (R (R (x1 :*: x2)))))) | ||
|
|
||
| toA :: A' a -> A a | ||
| toA s = case s of | ||
| L x1 -> A1 x1 | ||
| R (L (x1 :*: x2)) -> A2 x1 x2 | ||
| R (R (L x1)) -> A3 x1 | ||
| R (R (R (L (x1 :*: x2)))) -> A4 x1 x2 | ||
| R (R (R (R (L (x1 :*: x2 :*: x3))))) -> A5 x1 x2 x3 | ||
| R (R (R (R (R (L (x1 :*: x2)))))) -> x1 :^: x2 | ||
| R (R (R (R (R (R (x1 :*: x2)))))) -> x1 :<>: x2 | ||
|
|
||
| epA :: EP (A a) (A' a) | ||
| epA = EP fromA toA | ||
|
|
||
| instance Representable (A a) (A' a) where | ||
| epOf _ = epA | ||
|
|
||
| conA1 = ConDescr "A1" 1 False Prefix | ||
| conA2 = ConDescr "A2" 2 False Prefix | ||
| conA3 = ConDescr "A3" 1 True Prefix | ||
| conA4 = ConDescr "A4" 2 True Prefix | ||
| conA5 = ConDescr "A5" 3 True Prefix | ||
| conA6 = ConDescr ":^:" 2 False (Infix RightAssoc 6) | ||
| conA7 = ConDescr ":<>:" 2 True (Infix LeftAssoc 5) | ||
|
|
||
| lblUnA3 = LblDescr "unA3" | ||
| lblUnA4a = LblDescr "unA4a" | ||
| lblUnA4b = LblDescr "unA4b" | ||
| lblUnA5a = LblDescr "unA5a" | ||
| lblUnA5b = LblDescr "unA5b" | ||
| lblUnA5c = LblDescr "unA5c" | ||
| lblUnA7a = LblDescr "unA7a" | ||
| lblUnA7b = LblDescr "unA7b" | ||
|
|
||
| instance (Generic g, Rep g a, Rep g Char, Rep g Double, Rep g Float, Rep g Integer, Rep g Int) => Rep g (A a) where | ||
| rep = rtype epA | ||
| $ rcon conA1 rep | ||
| `rsum` rcon conA2 (rep `rprod` rep) | ||
| `rsum` rcon conA3 (rlabel lblUnA3 rep) | ||
| `rsum` rcon conA4 (rlabel lblUnA4a rep `rprod` rlabel lblUnA4b rep) | ||
| `rsum` rcon conA5 (rlabel lblUnA5a rep `rprod` rlabel lblUnA5b rep `rprod` rlabel lblUnA5c rep) | ||
| `rsum` rcon conA6 (rep `rprod` rep) | ||
| `rsum` rcon conA7 (rlabel lblUnA7a rep `rprod` rlabel lblUnA7b rep) | ||
|
|
||
| instance (Generic g) => FRep g A where | ||
| frep ra = rtype epA | ||
| $ rcon conA1 ra | ||
| `rsum` rcon conA2 (rinteger `rprod` frep ra) | ||
| `rsum` rcon conA3 (rlabel lblUnA3 rdouble) | ||
| `rsum` rcon conA4 (rlabel lblUnA4a (frep ra) `rprod` rlabel lblUnA4b rint) | ||
| `rsum` rcon conA5 (rlabel lblUnA5a rchar `rprod` rlabel lblUnA5b (frep ra) `rprod` rlabel lblUnA5c ra) | ||
| `rsum` rcon conA6 (frep ra `rprod` rfloat) | ||
| `rsum` rcon conA7 (rlabel lblUnA7a (frep ra) `rprod` rlabel lblUnA7b (frep ra)) | ||
|
|
||
| instance (Generic2 g) => FRep2 g A where | ||
| frep2 ra = rtype2 epA epA | ||
| $ rcon2 conA1 ra | ||
| `rsum2` rcon2 conA2 (rinteger2 `rprod2` frep2 ra) | ||
| `rsum2` rcon2 conA3 (rlabel2 lblUnA3 rdouble2) | ||
| `rsum2` rcon2 conA4 (rlabel2 lblUnA4a (frep2 ra) `rprod2` rlabel2 lblUnA4b rint2) | ||
| `rsum2` rcon2 conA5 (rlabel2 lblUnA5a rchar2 `rprod2` rlabel2 lblUnA5b (frep2 ra) `rprod2` rlabel2 lblUnA5c ra) | ||
| `rsum2` rcon2 conA6 (frep2 ra `rprod2` rfloat2) | ||
| `rsum2` rcon2 conA7 (rlabel2 lblUnA7a (frep2 ra) `rprod2` rlabel2 lblUnA7b (frep2 ra)) | ||
|
|
||
| instance (Generic3 g) => FRep3 g A where | ||
| frep3 ra = rtype3 epA epA epA | ||
| $ rcon3 conA1 ra | ||
| `rsum3` rcon3 conA2 (rinteger3 `rprod3` frep3 ra) | ||
| `rsum3` rcon3 conA3 (rlabel3 lblUnA3 rdouble3) | ||
| `rsum3` rcon3 conA4 (rlabel3 lblUnA4a (frep3 ra) `rprod3` rlabel3 lblUnA4b rint3) | ||
| `rsum3` rcon3 conA5 (rlabel3 lblUnA5a rchar3 `rprod3` rlabel3 lblUnA5b (frep3 ra) `rprod3` rlabel3 lblUnA5c ra) | ||
| `rsum3` rcon3 conA6 (frep3 ra `rprod3` rfloat3) | ||
| `rsum3` rcon3 conA7 (rlabel3 lblUnA7a (frep3 ra) `rprod3` rlabel3 lblUnA7b (frep3 ra)) | ||
|
|
||
| instance Rep (Collect (A a)) (A a) where | ||
| rep = Collect (:[]) | ||
|
|
||
| instance (Rep (Everywhere (A a)) a) => Rep (Everywhere (A a)) (A a) where | ||
| rep = Everywhere app | ||
| where | ||
| app f x = | ||
| case x of | ||
| A1 x1 -> f (A1 (selEverywhere rep f x1)) | ||
| A2 x1 x2 -> f (A2 (selEverywhere rep f x1) (selEverywhere rep f x2)) | ||
| A3 x1 -> f (A3 (selEverywhere rep f x1)) | ||
| A4 x1 x2 -> f (A4 (selEverywhere rep f x1) (selEverywhere rep f x2)) | ||
| A5 x1 x2 x3 -> f (A5 (selEverywhere rep f x1) (selEverywhere rep f x2) (selEverywhere rep f x3)) | ||
| x1 :^: x2 -> f (selEverywhere rep f x1 :^: selEverywhere rep f x2) | ||
| x1 :<>: x2 -> f (selEverywhere rep f x1 :<>: selEverywhere rep f x2) | ||
|
|
||
| instance Rep (Everywhere' (A a)) (A a) where | ||
| rep = Everywhere' ($) | ||
|
|
||
| v1 = A1 (5 :: Int) | ||
| v2 = A2 37 v1 | ||
| v3 = A3 9999.9999 :: A Float | ||
| v4 = A4 v3 79 | ||
| v5 = A5 'a' v4 5.0 | ||
| v6 = v5 :^: 0.12345 | ||
| v7 = v6 :<>: v6 | ||
|
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.