From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 10 Sep 2021 12:48:41 +0000 (+0200)
Subject: .
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=505d5f8f45ca99098ba4867164384e2b3ece3283;p=clean-tests.git

.
---

diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs
index a93f68a..a6e0d35 100644
--- a/datatype/Language/GenDSL.hs
+++ b/datatype/Language/GenDSL.hs
@@ -33,19 +33,17 @@ getConsName c = fail $ "Unsupported constructor type: " ++ show c
 ifx :: String -> ExpQ -> ExpQ -> ExpQ
 ifx op a b = infixE (Just a) (varE $ mkName op) (Just b)
 
-getNameTyVarBndr :: TyVarBndr -> Name
-getNameTyVarBndr (PlainTV name) = name
-getNameTyVarBndr (KindedTV name _) = name
-
 fun :: Name -> [PatQ] -> ExpQ -> DecQ
 fun name args body = funD name [clause args (normalB body) []]
 
-genDSL :: Name -> DecsQ
-genDSL typename = reify typename >>= \info->case info of
-    TyConI (DataD _ _ tyvars _ constructors _)
-        -> mapM getConsName constructors >>= mkDSL typename tyvars
-    t
-        -> fail $ "mkConsClass only supports simple datatypes and not: " ++ show t
+class GenDSL a where genDSL :: a -> DecsQ
+instance GenDSL a => GenDSL [a] where genDSL = fmap concat . mapM genDSL
+instance GenDSL Name where
+    genDSL typename = reify typename >>= \info->case info of
+        TyConI (DataD _ _ tyvars _ constructors _)
+            -> mapM getConsName constructors >>= mkDSL typename tyvars
+        t
+            -> fail $ "mkConsClass only supports simple datatypes and not: " ++ show t
 
 mkDSL :: Name -> [TyVarBndr] -> [(Name, [(Name, TypeQ)])] -> DecsQ
 mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ]
@@ -72,7 +70,9 @@ mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler
         mkPredicate n = sigD (predicateName n) [t|$resultT -> $v Bool|]
 
         resultT :: TypeQ
-        resultT = appT v $ foldl appT (conT typeName) $ map (varT . getNameTyVarBndr) $ typeVars
+        resultT = appT v $ foldl appT (conT typeName) $ map (varT . getName) $ typeVars
+          where getName (PlainTV name) = name
+                getName (KindedTV name _) = name
 
     mkPrinter :: DecQ
     mkPrinter = instanceD (pure []) [t|$(conT $ className typeName) Printer|]
@@ -134,7 +134,7 @@ mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler
         mkSelector consName ftotal fnum n = do
             fresh <- newName "f"
             fun (selectorName n) [varP fresh] $
-                ifx ">>=" (varE fresh) $ lamCaseE (mkMatch:wilds)
+                [|$(varE fresh) >>= $(lamCaseE $ mkMatch:wilds)|]
           where
             mkMatch = do
                 fresh <- newName "e"
diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs
index afa5bde..29c2da9 100644
--- a/datatype/Language/Quote.hs
+++ b/datatype/Language/Quote.hs
@@ -21,20 +21,16 @@ import Text.Parsec.Language (haskell)
 import Language.GenDSL as L
 
 dsl :: QuasiQuoter
-dsl = QuasiQuoter
-    { quoteExp = \s->location >>= parseExpr s
-    , quotePat = undefined
-    , quoteType = undefined
-    , quoteDec = undefined
-    }
+dsl = QuasiQuoter { quoteExp = parseDSL expr }
   where
-    parseExpr :: String -> Loc -> ExpQ
-    parseExpr s loc = either (fail . show) id $ runParser p () file s
-      where
-        file = loc_filename loc
-        (line, col) = loc_start loc
-        p = getPosition >>= setPosition . mPos >> whiteSpace *> expr <* eof
-        mPos p = setSourceName (setSourceLine (setSourceColumn p col) line) file
+    parseDSL :: Parser (Q e) -> String -> Q e
+    parseDSL ps s = do
+        loc <- location
+        let file = loc_filename loc
+            (line, col) = loc_start loc
+            p = getPosition >>= setPosition . mPos >> whiteSpace *> ps <* eof
+            mPos p = setSourceName (setSourceLine (setSourceColumn p col) line) file
+        either (fail . show) id $ runParser p () file s
 
 -- Lexer
 identifier,operator :: Parser String
diff --git a/datatype/Printer.hs b/datatype/Printer.hs
index 9e25c5b..d19a314 100644
--- a/datatype/Printer.hs
+++ b/datatype/Printer.hs
@@ -16,7 +16,7 @@ newtype Printer a = P { runPrinter :: RWS PR [String] PS a }
     , MonadState PS
     , MonadReader PR
     )
-data PS = PS {fresh :: [Int]}
+newtype PS = PS {fresh :: [Int]}
 data PR = PR {context :: Ctx, indent :: Int}
 data Ctx = CtxNo | CtxNullary | CtxNonfix | CtxInfix {assoc :: CtxAssoc, prio :: Int, branch :: CtxAssoc}
   deriving Eq
@@ -72,20 +72,20 @@ needsParen _ CtxNullary = error "shouldn't occur"
 instance DSL Printer
 instance Expression Printer where
     lit = printLit . show
-    (+.) = printBinOp (leftctx 6) "+"
-    (-.) = printBinOp (leftctx 6) "-"
-    (*.) = printBinOp (leftctx 7) "*"
-    (/.) = printBinOp (leftctx 7) "/"
-    neg = printUnOp (nonectx 7) "!"
-    (&.) = printBinOp (rightctx 3) "&"
-    (|.) = printBinOp (rightctx 2) "|"
-    not = printUnOp (nonectx 7) "!"
-    (==.) = printBinOp (nonectx 4) "=="
-    (/=.) = printBinOp (nonectx 4) "/="
-    (<.) = printBinOp (nonectx 4) "<"
-    (>.) = printBinOp (nonectx 4) ">"
-    (<=.) = printBinOp (nonectx 4) "<"
-    (>=.) = printBinOp (nonectx 4) ">"
+    (+.) = printBinOp "+" (leftctx 6)
+    (-.) = printBinOp "-" (leftctx 6)
+    (*.) = printBinOp "*" (leftctx 7)
+    (/.) = printBinOp "/" (leftctx 7)
+    neg = printUnOp "!" (nonectx 7)
+    (&.) = printBinOp "&" (rightctx 3)
+    (|.) = printBinOp "|" (rightctx 2)
+    not = printUnOp "!" (nonectx 7)
+    (==.) = printBinOp "==" (nonectx 4)
+    (/=.) = printBinOp "/=" (nonectx 4)
+    (<.) = printBinOp "<" (nonectx 4)
+    (>.) = printBinOp ">" (nonectx 4)
+    (<=.) = printBinOp "<" (nonectx 4)
+    (>=.) = printBinOp ">" (nonectx 4)
     if' p t e = paren' CtxNonfix
         $   printLit "if" >-> p
         >^> printLit "then" >^> iindent (localctx CtxNonfix t)
@@ -144,14 +144,14 @@ printIndent :: Printer a
 printIndent = asks (flip replicate '\t' . indent) >>= printLit
 infixl 1 >>>, >->, >^>
 
-printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3
-printBinOp thisctx op l r = paren' thisctx $
+printBinOp :: String -> Ctx -> Printer a1 -> Printer a2 -> Printer a3
+printBinOp op thisctx l r = paren' thisctx $
         localctx (setBranch thisctx CtxLeft) l
     >-> printLit op
     >-> localctx (setBranch thisctx CtxRight) r
 
-printUnOp :: Ctx -> String -> Printer a -> Printer a
-printUnOp thisctx op l = paren' thisctx $
+printUnOp :: String -> Ctx -> Printer a -> Printer a
+printUnOp op thisctx l = paren' thisctx $
         printLit (' ':op)
     >-> localctx (setBranch thisctx CtxRight) l
 
@@ -159,4 +159,4 @@ printCons :: String -> Printer a -> Printer a
 printCons cons l = paren' CtxNonfix $ printLit cons >-> l
 
 printRec :: String -> Printer a -> Printer a
-printRec op l = printUnOp CtxNo op $ accol l
+printRec op l = printUnOp op CtxNo $ accol l