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
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Coalpit where
import Language.Haskell.TH
import Data.Char
import Data.List
class Args a where
toArgs :: a -> [String]
fromArgs :: [String] -> (a, [String])
instance {-#OVERLAPPING#-} Args String where
toArgs = pure . show
fromArgs (x:xs) = (read x, xs)
instance Args Int where
toArgs = pure . show
fromArgs (x:xs) = (read x, xs)
instance Args Bool where
toArgs True = ["t"]
toArgs False = ["f"]
fromArgs ("t":xs) = (True, xs)
fromArgs ("f":xs) = (False, xs)
instance Args a => Args (Maybe a) where
toArgs Nothing = ["n"]
toArgs (Just x) = "j" : toArgs x
fromArgs ("n":xs) = (Nothing, xs)
fromArgs ("j":xs) = let (y, ys) = fromArgs xs in (Just y, ys)
instance Args a => Args [a] where
toArgs = pure . intercalate "," . concatMap toArgs
fromArgs (arg:args) = (map (fst . fromArgs . pure) $ splitOn ',' arg, args)
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn sep l = case break (== sep) l of
(x, []) -> [x]
(x, _:xs) -> x : splitOn sep xs
printCon :: Name -> String
printCon = map toLower . reverse . takeWhile (/= '.') . reverse . show
printClause :: Con -> Q Clause
printClause (NormalC cn bts) = do
let ts = map snd bts
vars = (map (mkName . ("x_" ++) . show) [1..length ts])
args = map (\v -> AppE (VarE 'toArgs) (VarE v)) vars
pure $ Clause [ConP cn (map VarP vars)]
(NormalB (AppE (VarE 'concat) $ ListE
(ListE [LitE (StringL $ printCon cn)] : args)))
[]
parseClause :: Con -> Q Clause
parseClause (NormalC cn bts) = do
let ts = map snd bts
vars = map (mkName . ("x_" ++) . show) [1..length ts]
vals = map (\x -> mkName (show x ++ "_val")) vars
fin = (TupE [foldl AppE (ConE cn) (map VarE vals)
, VarE (mkName $ (if length vars > 0
then show (last vars)
else "xs") ++ "_rest")
])
pure $ Clause [InfixP (LitP (StringL $ printCon cn))
(mkName ":")
(VarP (mkName "xs_rest"))]
(NormalB $ foldr parseArg fin (zip (mkName "xs" : vars) vars))
[]
where
parseArg :: (Name, Name) -> Exp -> Exp
parseArg (np, nc) e = LetE
[ValD (TupP [VarP (mkName (show nc ++ "_val")),
VarP (mkName (show nc ++ "_rest"))])
(NormalB $ AppE (VarE 'fromArgs) (VarE (mkName (show np ++ "_rest"))))
[]]
e
deriveArgs :: Name -> Q [Dec]
deriveArgs ty = do
let var = mkName "x"
(TyConI d@(DataD _ nm tyVars mk cs _)) <- reify ty
to <- mapM printClause cs
from <- mapM parseClause cs
pure [InstanceD Nothing [] (AppT (ConT ''Args) (ConT ty))
[FunD 'toArgs to, FunD 'fromArgs from]]
|
