From 4beea4536a36322e15665de74c96926f0cf5fe7b Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Fri, 25 Nov 2016 06:35:55 +0300
Subject: Initial commit

---
 Coalpit.hs | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 88 insertions(+)
 create mode 100644 Coalpit.hs

(limited to 'Coalpit.hs')

diff --git a/Coalpit.hs b/Coalpit.hs
new file mode 100644
index 0000000..f36f581
--- /dev/null
+++ b/Coalpit.hs
@@ -0,0 +1,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]]
-- 
cgit v1.2.3