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
|
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Derive.DSL.HSE(module Data.Derive.DSL.HSE, module Language.Haskell) where
import Language.Haskell hiding (List, App, String, Int)
import Data.Data
import Data.Generics.Uniplate.DataOnly
import Data.Maybe
import Data.List
import Data.Function
import Control.Monad.Trans.State
---------------------------------------------------------------------
-- EXAMPLES
{-
-- data List a = Nil | Cons a (List a)
list :: Input
list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]
-}
-- data Sample a = First | Second a a | Third a
sample :: Input
sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs []
where
ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]
ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ UnBangedTy $ tyVar "a"
---------------------------------------------------------------------
-- UTILITIES
outEq :: Out -> Out -> Bool
outEq = (==) `on` transformBi (const sl)
---------------------------------------------------------------------
showOut x = unlines $ map prettyPrint x
type Input = DataDecl
type Ctor = CtorDecl
dataName = dataDeclName
dataVars = length . dataDeclVars
dataCtors = dataDeclCtors
ctorName = ctorDeclName
ctorArity = fromIntegral . ctorDeclArity
ctorIndex :: Input -> Ctor -> Integer
ctorIndex dat ctor = fromIntegral $ fromMaybe (error "fromJust: ctorIndex") $ findIndex (== ctor) $ dataCtors dat
toInput :: DataDecl -> Input
toInput x = x
type Out = [Decl]
data Output = OString String
| OInt Integer
| OApp String [Output]
| OList [Output]
| OIgnore
| OCustom String
deriving (Eq,Show,Data,Typeable)
toOutput :: Data a => a -> Output
toOutput x
| t == typeOf "" = OString $ coerce x
| c == "[]" = OList $ fList x
| t == typeOf sl = OIgnore
| t == typeOf (1 :: Integer) = OInt $ coerce x
| otherwise = OApp (showConstr $ toConstr x) (filter (/= OIgnore) $ gmapQ toOutput x)
where
t = typeOf x
c = show $ fst $ splitTyConApp t
fList :: Data a => a -> [Output]
fList = gmapQl (++) [] $ \x -> if typeOf x == t then fList x else [toOutput x]
fromOutput :: Data a => Output -> a
fromOutput (OList xs) = res
where res = f xs
f [] = fromConstr $ readCon dat "[]"
f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"
dat = dataTypeOf res
g :: (Data a, Data b) => Output -> a -> b
g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x
fromOutput (OApp str args) = res
where dat = dataTypeOf res
res = evalState (fromConstrM f $ readCon dat str) args
f :: Data a => State [Output] a
f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else
do x:xs <- get; put xs; return $ fromOutput x
fromOutput (OString x) = coerce x
fromOutput (OInt x) = coerce x
coerce x = fromMaybe (error "Error in coerce") $ cast x
readCon dat x = fromMaybe (error $ "Error in readCon, " ++ x) $ readConstr dat x
out x = toOutput x
fromState :: State a x -> x
fromState = undefined
|
