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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
{-# LANGUAGE PatternGuards #-}
-- NOTE: Cannot be guessed as it relies on type information
-- | Derive Uniplate and Biplate using the Direct combinators.
-- You must request monomorphic instances, i.e:
--
-- > data Foo a = Foo a (Bool, a)
-- >
-- > {-!
-- > deriving instance UniplateDirect (Foo Int)
-- > deriving instance UniplateDirect (Bool, Int) Int
-- > deriving instance UniplateDirect (Foo Int) Int
-- > !-}
--
-- This will generate the instances @Uniplate (Foo Int)@,
-- @Biplate (Bool, Int) Int@ and @Biplate (Foo Int) Int@.
-- Generally, start with the instance you are after (e.g. @UniplateDirect (Foo Int)@),
-- try to compile and add further instances as necessary. @UniplateDirect@ with
-- one argument derives Uniplate, and with two arguments derives Biplate.
--
-- @deriving UniplateDirect@ on a data type with no arguments derives Uniplate
-- with all type parameters defaulting to @()@.
module Data.Derive.UniplateDirect(makeUniplateDirect) where
{-
import "uniplate" Data.Generics.Uniplate.Direct
-- test tuples
test :: UniplateDirect ((), Maybe ()) ()
instance Biplate ((), Maybe ()) () where
{-# INLINE biplate #-}
biplate (x1, x2) = plate (,) |* x1 |+ x2
test :: UniplateDirect (Sample Int)
instance Uniplate (Sample Int) where
{-# INLINE uniplate #-}
uniplate x = plate x
test :: UniplateDirect (Sample Int) Int
instance Biplate (Sample Int) Int where
{-# INLINE biplate #-}
biplate (Second x1 x2) = plate Second |* x1 |* x2
biplate (Third x1) = plate Third |* x1
biplate x = plate x
test :: UniplateDirect Computer
instance Uniplate Computer where
{-# INLINE uniplate #-}
uniplate x = plate x
test :: UniplateDirect Computer Computer
instance Biplate Computer Computer where
{-# INLINE biplate #-}
biplate = plateSelf
test :: UniplateDirect Computer Double
instance Biplate Computer Double where
{-# INLINE biplate #-}
biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2
biplate x = plate x
test :: UniplateDirect (Assoced (Maybe Bool)) Char
instance Biplate (Assoced (Maybe Bool)) Char where
{-# INLINE biplate #-}
biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2
-- test following external declarations
test :: UniplateDirect (Either Bool Computer) Int
instance Biplate (Either Bool Computer) Int where
{-# INLINE biplate #-}
biplate (Right x1) = plate Right |+ x1
biplate x = plate x
-- test recursive bits
test :: UniplateDirect (List Int) Bool
instance Biplate (List Int) Bool where
{-# INLINE biplate #-}
biplate x = plate x
-}
import Language.Haskell
import Data.Generics.Uniplate.DataOnly
import Data.Derive.Internal.Derivation
import Data.Maybe
import qualified Data.Map as Map
import Control.Arrow
import Control.Monad.Trans.State
makeUniplateDirect :: Derivation
makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $
let known = map (declName &&& id) knownCtors
grab2 x = fromMaybe (grab x) $ lookup x known
in case args of
_ | not $ null [() | TyVar _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"
[] -> make True grab2 x x
where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon $ Special UnitCon
[x] -> make True grab2 x x
[x,y] -> make False grab2 x y
_ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)
make :: Bool -> (String -> DataDecl) -> Type -> Type -> Either String [Decl]
make uni grab from to = Right [InstDecl sl [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni])
[InsDecl $ InlineSig sl True AlwaysActive (qname $ if uni then "uniplate" else "biplate"), InsDecl ms]]
where
ty = grab $ tyRoot from
match pat bod = Match sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) (BDecls [])
ms = if uni || from /= to
then FunBind $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (var "plate" `App` var "x") | any isNothing bods]
else PatBind sl (pVar "biplate") Nothing (UnGuardedRhs $ var "plateSelf") (BDecls [])
bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty
make1 :: (String -> DataDecl) -> (String,[Type]) -> S (Maybe (Pat, Exp))
make1 grab (name,tys) = do
ops <- mapM (fmap show . operator grab) tys
let vars = ['x':show i | i <- [1..length tys]]
pat = PParen $ PApp (qname name) $ map pVar vars
(good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars
bod = foldl (\x (y,z) -> InfixApp x (QVarOp $ UnQual $ Symbol y) z) (App (var "plate") $ paren $ apps (con name) (map snd good)) bad
return $ if all (== "|-") ops then Nothing else Just (pat,bod)
data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq
instance Show Ans where
show Hit = "|*"
show Miss = "|-"
show Try = "|+"
show ListHit = "||*"
show ListTry = "||+"
ansList Hit = ListHit
ansList Miss = Miss
ansList _ = ListTry
ansJoin (Miss:xs) = ansJoin xs
ansJoin [] = Miss
ansJoin _ = Try
type S a = State (Map.Map Type Ans) a
run :: Type -> S a -> a
run to act = evalState act (Map.singleton to Hit)
operator :: (String -> DataDecl) -> Type -> S Ans
operator grab from = do
mp <- get
case Map.lookup from mp of
Just y -> return y
Nothing -> do
fix Miss
where
fix ans = do
s <- get
modify $ Map.insert from ans
ans2 <- operator2 grab from
if ans == ans2
then return ans
else put s >> fix ans2
operator2 :: (String -> DataDecl) -> Type -> S Ans
operator2 grab from
| isTyFun from = return Try
| Just from2 <- fromTyList from = fmap ansList $ operator grab from2
| otherwise = case subst from $ grab $ tyRoot from of
Left from2 -> operator grab from2
Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs
subst :: Type -> Decl -> Either Type [(String,[Type])]
subst ty x@TypeDecl{} = Left $ substType ty x
subst ty x = Right $ substData ty x
substData :: Type -> Decl -> [(String,[Type])]
substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . fromBangType . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]
where
rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)
f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
f x = x
substType :: Type -> Decl -> Type
substType ty (TypeDecl _ _ vars d) = fromTyParens $ transform f d
where
rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)
f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
f x = x
knownCtors :: [Decl]
knownCtors = map (fromParseResult . parseDecl)
["data Int = Int"
,"data Bool = Bool"
,"data Char = Char"
,"data Double = Double"
,"data Float = Float"
,"data Integer = Integer"
,"data Maybe a = Nothing | Just a"
,"data Either a b = Left a | Right b"
,"type Rational = Ratio Integer"
,"data (Integral a) => Ratio a = !a :% !a"
,"type String = [Char]"
] ++
listCtor :
map tupleDefn (0:[2..32])
listCtor = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
[QualConDecl sl [] [] $ ConDecl (Ident "[]") []
,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [UnBangedTy $ tyVar "a", UnBangedTy $ TyList $ tyVar "a"]] []
tupleDefn :: Int -> Decl
tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map (UnBangedTy . tyVar) vars)] []
where s = "(" ++ replicate (n - 1) ',' ++ ")"
vars = ['v':show i | i <- [1..n]]
|
