1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Perm (tests) where
{-
This module illustrates permutation phrases.
Disclaimer: this is a perhaps naive, certainly undebugged example.
-}
import Test.Tasty.HUnit
import Control.Applicative (Alternative(..), Applicative(..))
import Control.Monad
import Data.Generics
---------------------------------------------------------------------------
-- We want to read terms of type T3 regardless of the order T1 and T2.
---------------------------------------------------------------------------
data T1 = T1 deriving (Show, Eq, Typeable, Data)
data T2 = T2 deriving (Show, Eq, Typeable, Data)
data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data)
---------------------------------------------------------------------------
-- A silly monad that we use to read lists of constructor strings.
---------------------------------------------------------------------------
-- Type constructor
newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) }
-- Run a computation
runReadT x y = case unReadT x y of
Just ([],y) -> Just y
_ -> Nothing
-- Read one string
readT :: ReadT String
readT = ReadT (\x -> if null x
then Nothing
else Just (tail x, head x)
)
instance Functor ReadT where
fmap = liftM
instance Applicative ReadT where
pure x = ReadT (\y -> Just (y,x))
(<*>) = ap
instance Alternative ReadT where
(<|>) = mplus
empty = mzero
-- ReadT is a monad!
instance Monad ReadT where
return = pure
c >>= f = ReadT (\x -> case unReadT c x of
Nothing -> Nothing
Just (x', a) -> unReadT (f a) x'
)
-- ReadT also accommodates mzero and mplus!
instance MonadPlus ReadT where
mzero = ReadT (const Nothing)
f `mplus` g = ReadT (\x -> case unReadT f x of
Nothing -> unReadT g x
y -> y
)
---------------------------------------------------------------------------
-- A helper type to appeal to predicative type system.
---------------------------------------------------------------------------
newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a }
---------------------------------------------------------------------------
-- The function that reads and copes with all permutations.
---------------------------------------------------------------------------
buildT :: forall a. Data a => ReadT a
buildT = result
where
result = do str <- readT
con <- string2constr str
ske <- return $ fromConstr con
fs <- return $ gmapQ buildT' ske
perm [] fs ske
-- Determine type of data to be constructed
myType = myTypeOf result
where
myTypeOf :: forall a. ReadT a -> a
myTypeOf = undefined
-- Turn string into constructor
string2constr str = maybe mzero
return
(readConstr (dataTypeOf myType) str)
-- Specialise buildT per kid type
buildT' :: forall a. Data a => a -> GenM
buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a))
-- The permutation exploration function
perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a
perm [] [] a = return a
perm fs [] a = perm [] fs a
perm fs (f:fs') a = (
do a' <- gmapMo (unGenM f) a
perm fs fs' a'
)
`mplus`
(
do guard (not (null fs'))
perm (f:fs) fs' a
)
---------------------------------------------------------------------------
-- The main function for testing
---------------------------------------------------------------------------
tests =
( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine
, ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine
, ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine
, ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine
, ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail
))))) @=? output
output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing))))
|
