From 505d5f8f45ca99098ba4867164384e2b3ece3283 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Fri, 10 Sep 2021 14:48:41 +0200 Subject: [PATCH] . --- datatype/Language/GenDSL.hs | 24 +++++++++++----------- datatype/Language/Quote.hs | 22 +++++++++----------- datatype/Printer.hs | 40 ++++++++++++++++++------------------- 3 files changed, 41 insertions(+), 45 deletions(-) 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 -- 2.20.1