summaryrefslogtreecommitdiff
path: root/Coalpit.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Coalpit.hs')
-rw-r--r--Coalpit.hs88
1 files changed, 88 insertions, 0 deletions
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]]