From: Mart Lubbers Date: Thu, 26 Aug 2021 14:20:08 +0000 (+0200) Subject: quasiquoting for patterns X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=5e43332b50f7706c8813ad83a1e271fe583729c6;p=clean-tests.git quasiquoting for patterns --- diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs index 1070ecb..482bcee 100644 --- a/datatype/Compiler.hs +++ b/datatype/Compiler.hs @@ -91,6 +91,7 @@ instance Expression Compiler where p >> instr [Brf elselabel] >> t >> instr [Bra endiflabel, Lbl elselabel] >> e >> instr [Lbl endiflabel] + bottom msg = instr [Error msg] instance Function () Compiler where fun def = Main $ @@ -123,7 +124,7 @@ liftFunction lbl nargs body = do modify (\s->s { functions=DM.insert lbl instructions $ functions s }) data Instr - = Push Int | Pop Int | Dup | Roll Int Int + = Push Int | Pop Int -- | Dup | Roll Int Int | Add | Sub | Mul | Div | Neg | Pow | And | Or | Not | Eq | Neq | Le | Ge | Leq | Geq @@ -131,7 +132,7 @@ data Instr | Str Int | Ldr Int | Sth Int | Ldh Int | Jsr Int | Ret Int | Arg Int - | Halt + | Halt | Error String deriving Show data Registers = Registers @@ -143,12 +144,15 @@ data Registers = Registers } deriving Show -interpret :: Int -> [Instr] -> Array Int Int -interpret memsize prog = runSTArray $ do - program <- newListArray (0, length prog) prog - mem <- newArray (0, memsize-1) 0 - int program mem (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty}) +interpret :: Int -> [Instr] -> Int +interpret memsize prog = runSTArray resultStack ! (memsize-1) where + resultStack :: ST s (STArray s Int Int) + resultStack = join $ int + <$> newListArray (0, length prog) prog + <*> newArray (0, memsize-1) 0 + <*> pure (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty}) + pushh :: STArray s Int Int -> Int -> Registers -> ST s Registers pushh memory value reg = do writeArray memory (hp reg) value @@ -195,19 +199,19 @@ interpret memsize prog = runSTArray $ do (reg', v) <- pop memory reg int program memory $ reg' { gp = DM.insert r v (gp reg')} Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory - Roll 0 _ -> int program memory reg - Roll 1 _ -> int program memory reg - Roll _ 0 -> int program memory reg - Roll depth num -> do - (reg', vs) <- popn memory depth reg - foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory - where - roll 0 acc vs = vs ++ reverse acc - roll n acc [] = roll n [] $ reverse acc - roll n acc (v:vs) = roll (n-1) (v:acc) vs +-- Roll 0 _ -> int program memory reg +-- Roll 1 _ -> int program memory reg +-- Roll _ 0 -> int program memory reg +-- Roll depth num -> do +-- (reg', vs) <- popn memory depth reg +-- foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory +-- where +-- roll 0 acc vs = vs ++ reverse acc +-- roll n acc [] = roll n [] $ reverse acc +-- roll n acc (v:vs) = roll (n-1) (v:acc) vs Pop n -> popn memory n reg >>= int program memory . fst Push v -> push memory v reg >>= int program memory - Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory +-- Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory Add -> bop (+) memory reg >>= int program memory Sub -> bop (-) memory reg >>= int program memory Mul -> bop (*) memory reg >>= int program memory @@ -215,12 +219,12 @@ interpret memsize prog = runSTArray $ do Neg -> uop negate memory reg >>= int program memory Pow -> bop (^) memory reg >>= int program memory And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory - Or -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory + Or -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory - Eq -> bop ((b2i .) . (==)) memory reg >>= int program memory + Eq -> bop ((b2i .) . (==)) memory reg >>= int program memory Neq -> bop ((b2i .) . (/=)) memory reg >>= int program memory - Le -> bop ((b2i .) . (<)) memory reg >>= int program memory - Ge -> bop ((b2i .) . (>)) memory reg >>= int program memory + Le -> bop ((b2i .) . (<)) memory reg >>= int program memory + Ge -> bop ((b2i .) . (>)) memory reg >>= int program memory Leq -> bop ((b2i .) . (<=)) memory reg >>= int program memory Geq -> bop ((b2i .) . (>=)) memory reg >>= int program memory Lbl _ -> int program memory reg @@ -241,16 +245,14 @@ interpret memsize prog = runSTArray $ do >>= branch i program >>= \r->int program memory (r { mp = sp r}) Ret n -> do - (reg1, rval) <- pop memory reg - (reg2, omp) <- pop memory reg1 - (reg3, ra) <- pop memory reg2 - (reg4, _) <- popn memory n reg3 - reg5 <- push memory rval reg4 - int program memory $ reg5 { pc=ra, mp=omp } + (reg1, rval:omp:ra:_) <- popn memory (3+n) reg + reg2 <- push memory rval reg1 + int program memory $ reg2 { pc=ra, mp=omp } Arg n -> do v <- readArray memory (mp reg + 3 + n) push memory v reg >>= int program memory Halt -> pure memory + Error msg -> fail msg branch :: Int -> STArray s Int Instr -> Registers -> ST s Registers branch label program reg = case pc reg of diff --git a/datatype/Interpreter.hs b/datatype/Interpreter.hs new file mode 100644 index 0000000..cf41d9a --- /dev/null +++ b/datatype/Interpreter.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Interpreter where + +import Language +import Control.Monad + +newtype Interpreter a = I {runInterpreter :: Maybe a} + deriving (Functor, Applicative, Monad) + +instance Expression Interpreter where + lit = pure + (+.) = liftM2 (+) + (-.) = liftM2 (-) + (/.) = liftM2 (/) + (*.) = liftM2 (*) + (^.) = liftM2 (^) + neg = fmap negate + (&.) = liftM2 (&&) + (|.) = liftM2 (||) + not = fmap Prelude.not + (==.) = liftM2 (==) + (/=.) = liftM2 (/=) + (<.) = liftM2 (<) + (>.) = liftM2 (>) + (<=.) = liftM2 (<=) + (>=.) = liftM2 (>=) + if' p t e = p >>= \b->if b then t else e + +instance Function a Interpreter where + fun def = Main $ + let g :- m = def g + in unmain m diff --git a/datatype/Language.hs b/datatype/Language.hs index 64c5ea8..eaa3703 100644 --- a/datatype/Language.hs +++ b/datatype/Language.hs @@ -13,7 +13,7 @@ class Expression v where (-.) :: Num a => v a -> v a -> v a (/.) :: Fractional a => v a -> v a -> v a (*.) :: Num a => v a -> v a -> v a - (^.) :: Num a => v a -> v a -> v a + (^.) :: Integral a => v a -> v a -> v a neg :: Num a => v a -> v a (&.) :: v Bool -> v Bool -> v Bool (|.) :: v Bool -> v Bool -> v Bool @@ -25,6 +25,7 @@ class Expression v where (<=.) :: Ord a => v a -> v a -> v Bool (>=.) :: Ord a => v a -> v a -> v Bool if' :: v Bool -> v a -> v a -> v a + bottom :: String -> v a class Function a v where fun :: ( (a -> v s) -> In (a -> v s) (Main (v u)) ) -> Main (v u) diff --git a/datatype/MkCons.hs b/datatype/Language/GenDSL.hs similarity index 65% rename from datatype/MkCons.hs rename to datatype/Language/GenDSL.hs index 57b14c6..374469d 100644 --- a/datatype/MkCons.hs +++ b/datatype/Language/GenDSL.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -module MkCons where +module Language.GenDSL where import Language.Haskell.TH.Syntax import Language.Haskell.TH @@ -26,8 +26,8 @@ mkConsClass typename = reify typename >>= \info->case info of -> sequence [ mkDerivation tyvars , mkConstructorClasses tyvars constructors - , mkPrinterInstances tyvars constructors - , mkCompilerInstances tyvars constructors + , mkPrinterInstances constructors + , mkCompilerInstances constructors ] _ -> fail "mkConsClass only supports data types" @@ -45,7 +45,8 @@ mkConsClass typename = reify typename >>= \info->case info of mkConstructorClasses tyvars constructors = do cclasses <- mapM mkConstructorClassMember constructors sclasses <- concat <$> mapM mkSelectorClassMember constructors - pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses) + pclasses <- mapM mkPredicateClassMember constructors + pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses ++ pclasses) where view = mkName "m" @@ -58,15 +59,15 @@ mkConsClass typename = reify typename >>= \info->case info of = fail $ "mkConsClass not supported for types such as: " ++ show t mkConstructorClassMemberForName :: Name -> [Type] -> DecQ - mkConstructorClassMemberForName consname fs - = pure $ SigD (constructorName consname) + mkConstructorClassMemberForName consName fs + = pure $ SigD (constructorName consName) $ foldr (AppT . AppT ArrowT) resultT $ map (AppT $ VarT view) fs mkSelectorClassMember :: Con -> DecsQ - mkSelectorClassMember (NormalC _ fs) + mkSelectorClassMember (NormalC consName fs) = mapM (uncurry mkSelectorClassMemberForField) - $ zipWith (\(_, t) i->(mkName $ map toLower (stringName typename) ++ "f" ++ show i, t)) fs [0 :: Int ..] + $ zipWith (\(_, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..] mkSelectorClassMember (RecC _ fs) = mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs] mkSelectorClassMember t @@ -78,31 +79,45 @@ mkConsClass typename = reify typename >>= \info->case info of $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars] $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t) + mkPredicateClassMember :: Con -> DecQ + mkPredicateClassMember (NormalC consName _) + = mkPredicateClassMemberForName consName + mkPredicateClassMember (RecC consName _) + = mkPredicateClassMemberForName consName + mkPredicateClassMember t + = fail $ "mkConsClass not supported for types such as: " ++ show t + + mkPredicateClassMemberForName :: Name -> DecQ + mkPredicateClassMemberForName n = pure + $ SigD (mkName $ "is" ++ stringName n) + $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars] + $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` ConT (mkName "Bool")) + resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars) - mkPrinterInstances :: [TyVarBndr] -> [Con] -> DecQ - mkPrinterInstances _ constructors + mkPrinterInstances :: [Con] -> DecQ + mkPrinterInstances constructors = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) . concat - <$> mapM mkPrinterInstance constructors + <$> ((:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors) where mkPrinterInstance :: Con -> DecsQ - mkPrinterInstance (NormalC name fs) - | null fs = pure [FunD (constructorName name) - [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName name)) [] ]] + mkPrinterInstance (NormalC consName fs) + | null fs = pure [FunD (constructorName consName) + [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName consName)) [] ]] | otherwise = let args = map mkName $ numberedArgs fs - in (:) <$> pure (FunD (constructorName name) + in (:) <$> pure (FunD (constructorName consName) [Clause (map VarP args) (NormalB $ - (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName name)) + (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName)) (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args) ) ) [] ]) <*> mapM mkPrinterSelector - (zipWith (\_ i->map toLower (stringName typename) ++ "f" ++ show i) fs [0 :: Int ..]) + (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..]) mkPrinterInstance (RecC name fs) = let args = map mkName $ numberedArgs fs in (:) <$> pure (FunD (constructorName name) @@ -124,17 +139,29 @@ mkConsClass typename = reify typename >>= \info->case info of body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|] pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []] - mkCompilerInstances :: [TyVarBndr] -> [Con] -> DecQ - mkCompilerInstances _ constructors + mkPrinterPredicate :: Con -> Q Dec + mkPrinterPredicate (NormalC consName _) + = mkPrinterPredicateForName consName + mkPrinterPredicate (RecC consName _) + = mkPrinterPredicateForName consName + mkPrinterPredicate t = fail $ "mkConsClass not supported for types such as: " ++ show t + + mkPrinterPredicateForName :: Name -> Q Dec + mkPrinterPredicateForName consName = do + body <- [| \d->printLit $(pure $ LitE $ StringL $ "is" ++ stringName consName ++ " ") >>> d|] + pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []] + + mkCompilerInstances :: [Con] -> DecQ + mkCompilerInstances constructors = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat - <$> mapM (uncurry mkCompilerInstance) (zip constructors [0..]) + <$> ((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..])) where mkCompilerInstance :: Con -> Int -> DecsQ - mkCompilerInstance (NormalC name fs) consnum = (:) - <$> mkCompilerInstanceForName name consnum (numberedArgs fs) - <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName typename) ++ f | f<-numberedArgs fs]) - mkCompilerInstance (RecC name fs) consnum = (:) - <$> mkCompilerInstanceForName name consnum [occString occ | (Name occ _, _, _) <- fs] + mkCompilerInstance (NormalC consName fs) consnum = (:) + <$> mkCompilerInstanceForName consName consnum (numberedArgs fs) + <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs]) + mkCompilerInstance (RecC consName fs) consnum = (:) + <$> mkCompilerInstanceForName consName consnum [occString occ | (Name occ _, _, _) <- fs] <*> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs]) mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t @@ -156,6 +183,18 @@ mkConsClass typename = reify typename >>= \info->case info of pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) [] ] + mkCompilerPredicate :: Int -> Con -> Q Dec + mkCompilerPredicate idx (NormalC consName _) + = mkCompilerPredicateForName idx consName + mkCompilerPredicate idx (RecC consName _) + = mkCompilerPredicateForName idx consName + mkCompilerPredicate _ t = fail $ "mkConsClass not supported for types such as: " ++ show t + + mkCompilerPredicateForName :: Int -> Name -> Q Dec + mkCompilerPredicateForName i consName = do + body <- [| \d->d >> instr [Ldh (-1), Push $(pure $ LitE $ IntegerL $ toInteger i), Eq] |] + pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []] + instrE :: Exp -> Exp instrE e = VarE (mkName "instr") `AppE` ListE [e] diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs new file mode 100644 index 0000000..cd464bc --- /dev/null +++ b/datatype/Language/Quote.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ParallelListComp #-} +module Language.Quote where + +import Data.Char +import Data.List +import Debug.Trace + +import Control.Applicative +import Control.Monad +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Language.Haskell.TH + +import Language +import Language.GenDSL + +cp :: QuasiQuoter +cp = QuasiQuoter + { quoteExp = quoteCPExp + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +appFst f (a, b) = (f a, b) + +newtype Parser t a = Parser {runParser :: [t] -> Maybe (a, [t])} +instance Functor (Parser t) where + fmap f m = Parser $ fmap (appFst f) . runParser m +instance Applicative (Parser t) where + pure a = Parser $ Just . (a,) + l <*> r = Parser $ \ts->runParser l ts >>= \(a, ts')->runParser r ts' >>= \(b, ts'')->pure (a b, ts'') +instance Monad (Parser t) where + ma >>= a2mb = Parser $ \ts->runParser ma ts >>= \(a, ts')->runParser (a2mb a) ts' +instance Alternative (Parser t) where + empty = Parser $ \_->Nothing + l <|> r = Parser $ \ts->runParser l ts <|> runParser r ts + +pTop :: Parser t t +pTop = Parser uncons + +pFail :: Parser t a +pFail = Parser $ \_->Nothing + +pSatisfy :: (t -> Bool) -> Parser t t +pSatisfy pred = pTop >>= \v->if pred v then pure v else pFail + +pToken :: Eq t => t -> Parser t t +pToken t = pSatisfy (t==) + +pChainl :: Parser t (a -> a -> a) -> Parser t a -> Parser t a +pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p) + +pChainr :: Parser t (a -> a -> a) -> Parser t a -> Parser t a +pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p + +pNonfix :: Parser t (a -> a -> a) -> Parser t a -> Parser t a +pNonfix op p = (\l op r->l `op` r) <$> p <*> op <*> p <|> p + +pSepBy :: Parser t s -> Parser t a -> Parser t [a] +pSepBy sep el = (:) <$> el <*> many (sep *> el) <|> pure [] + +pBrack :: Parser String s -> Parser String s +pBrack p = pToken "(" *> p <* pToken ")" + +pCase :: Parser String Exp +pCase = mkCase <$ pToken "case" <*> pExp <* pToken "of" <*> some pCaseMatch + where + mkCase :: Exp -> [(Pat, Exp)] -> Exp + mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases + where + mkCaseMatch :: Pat -> Exp -> Exp -> Exp + mkCaseMatch (VarP v) e _ = LetE [FunD v [Clause [] (NormalB name) []]] e + mkCaseMatch WildP e _ = e + mkCaseMatch (ConP consName fields) e rest + = VarE (mkName "if'") + `AppE` (VarE (mkName $ "is" ++ stringName consName) `AppE` name) --Predicate + `AppE` LetE [mkFieldMatch idx f | f <- fields | idx <- [0..]] e + `AppE` rest + where + mkFieldMatch idx (VarP v) = FunD v [Clause [] (NormalB $ VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` name) []] + +pCaseMatch :: Parser String (Pat, Exp) +pCaseMatch = (,) <$> pPat <* pToken "->" <*> pExp + +pExp :: Parser String Exp +pExp + = foldr ($) (pChainl (pure AppE) pBasic) + [ pChainr $ parseOps ["^."] + , pChainl $ parseOps ["*.", "/."] + , pChainl $ parseOps ["+.", "-."] + , pNonfix $ parseOps ["==.", "/=.", "<.", ">.", "<=.", ">=."] + , pChainr $ parseOps ["&."] + , pChainr $ parseOps ["|."] + ] + where + parseOps = foldr1 (<|>) . map (\op->ifx op <$ pToken op) + + pBasic :: Parser String Exp + pBasic + = VarE <$> pVar + <|> AppE (VarE (mkName "lit")) . LitE <$> pLit + <|> pBrack pExp + +pLit :: Parser String Lit +pLit +-- = CharL <$ pToken '\'' <*> pTop <* pToken '\'' + = (IntegerL . read) <$> pSatisfy (all isDigit) + +pVar :: Parser String Name +pVar = mkName <$> pSatisfy (\x->isLower (head x) && all isAlpha x && Prelude.not (x `elem` kw)) + +pCon :: Parser String Name +pCon = mkName <$> pSatisfy (\x->isUpper (head x) && all isAlpha x && Prelude.not (x `elem` kw)) + +kw = ["case", "of"] + +pPat :: Parser String Pat +pPat + = ConP <$> pCon <*> many pPat + <|> VarP <$> pVar + <|> WildP <$ pToken "_" + +parseCP (file, line, col) s = + case runParser pCase (let ts = lexer s in trace (show ts) ts) of + Nothing -> fail "Parsing failed" + Just (_, _:_) -> fail "Non-exhaustive parse found" + Just (e, []) -> pure e + +lexer :: [Char] -> [String] +lexer ('c':'a':'s':'e':rest) = "case":lexer rest +lexer ('o':'f':rest) = "of":lexer rest +lexer ('-':'>':rest) = "->":lexer rest +lexer ('^':'.':rest) = "^.":lexer rest +lexer ('*':'.':rest) = "*.":lexer rest +lexer ('/':'.':rest) = "/.":lexer rest +lexer ('+':'.':rest) = "+.":lexer rest +lexer ('-':'.':rest) = "-.":lexer rest +lexer ('|':'.':rest) = "|.":lexer rest +lexer ('&':'.':rest) = "&.":lexer rest +lexer ('=':'=':'.':rest) = "==.":lexer rest +lexer ('/':'=':'.':rest) = "/=.":lexer rest +lexer ('<':'=':'.':rest) = "<=.":lexer rest +lexer ('>':'=':'.':rest) = ">=.":lexer rest +lexer ('<':'.':rest) = "<.":lexer rest +lexer ('>':'.':rest) = ">.":lexer rest +lexer ('(':rest) = "(":lexer rest +lexer (')':rest) = ")":lexer rest +lexer ('_':rest) = "_":lexer rest +lexer (d:rest) + | isAlpha d = case span isAlpha (d:rest) of + (s, rest') -> s:lexer rest' + | isDigit d = case span isDigit (d:rest) of + (s, rest') -> s:lexer rest' +lexer (_:rest) = lexer rest + -- | isSpace d = lexer rest +lexer [] = [] + +quoteCPExp :: String -> Q Exp +quoteCPExp s = do + loc <- location + let pos = (loc_filename loc, fst (loc_start loc), snd (loc_start loc)) + parseCP pos s + +quoteCPPat :: String -> Q Pat +quoteCPPat _ = undefined diff --git a/datatype/Main b/datatype/Main new file mode 100755 index 0000000..9e7021c Binary files /dev/null and b/datatype/Main differ diff --git a/datatype/Main.hs b/datatype/Main.hs index 3b8c1f4..a0e9362 100644 --- a/datatype/Main.hs +++ b/datatype/Main.hs @@ -1,40 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} module Main where import Language import Compiler import Printer +import Interpreter +import Language.Quote import Tuple main :: IO () main --- = putStrLn (runPrint e0) --- >> putStrLn (runPrint e1) --- >> putStrLn (runPrint e2) --- >> putStrLn (runPrint e3) --- >> putStrLn (show $ runCompiler e0) --- = putStrLn (show $ interpret 10 <$> runCompiler e0) --- = putStrLn (show $ interpret 10 <$> runCompiler e1'') - = putStrLn (show $ interpret 10 <$> runCompiler (e1)) - >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef0' e1)) - >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' e1)) - >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' $ second' e3)) - >> putStrLn (runPrint $ lit (42 :: Int) `cons` (lit (10 :: Int) `cons` nil)) - >> putStrLn (show $ interpret 20 <$> runCompiler (lit (42 :: Int) `cons` (lit (10 :: Int) `cons` nil))) - >> putStrLn (runPrint $ unmain $ f0) - >> putStrLn (show $ runCompiler (unmain f0)) - >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f0)) - >> putStrLn (show $ runCompiler (unmain f1)) - >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f1)) - >> putStrLn (show $ runCompiler (unmain f2)) - >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f2)) - >> putStrLn (show $ runCompiler (unmain f3)) - >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f3)) --- >> putStrLn (show $ interpret <$> runCompiler e1) --- >> putStrLn (show $ interpret <$> runCompiler e1') --- >> putStrLn (show $ interpret <$> runCompiler e1'') + = putStrLn (show $ interpret 10 <$> runCompiler (e1)) +-- >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef0' e1)) +-- >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' e1)) +-- >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' $ second' e3)) +-- >> putStrLn (runPrint $ lit (42 :: Int) `cons` (lit (10 :: Int) `cons` nil)) +-- >> putStrLn (show $ interpret 20 <$> runCompiler (isNil $ lit (38 :: Int) `cons` nil)) +-- >> putStrLn (runPrint $ unmain $ f0) +-- >> putStrLn (show $ runCompiler (unmain f0)) +-- >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f0)) +-- >> putStrLn (show $ runCompiler (unmain f1)) +-- >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f1)) +-- >> putStrLn (show $ runCompiler (unmain f2)) +-- >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f2)) +-- >> putStrLn (show $ runCompiler (unmain f3)) +-- >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f3)) +-- >> putStrLn (show $ runCompiler (unmain f4)) +-- >> putStrLn (show $ interpret 100 <$> runCompiler (unmain f4)) +-- >> putStrLn (show $ runInterpreter (unmain f2)) +-- >> putStrLn (show $ runInterpreter (unmain f4)) + >> putStrLn (runPrint $ unmain f5) + >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f5)) e0 :: Expression v => v Int e0 = lit 2 ^. lit 8 @@ -81,6 +81,15 @@ f3 f4 :: (Expression v, Function (v Int) v) => Main (v Int) f4 - = fun ( \fac->(\x->x) - :- Main {unmain=tuple (idfun (lit 42)) (idfun (lit 4)) } + = fun ( \fac->(\i->if' (i ==. lit 0) (lit 1) (i *. fac (i -. lit 1))) + :- Main {unmain=fac (lit 10)} + ) + +f5 :: (List' v, Expression v, Function (v (List Int)) v) => Main (v Int) +f5 + = fun ( \sum->(\l->[cp|case l of + Cons e rest -> e +. sum rest + _ -> 0 + |]) + :- Main {unmain=sum $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} ) diff --git a/datatype/Printer.hs b/datatype/Printer.hs index 8668b91..873d381 100644 --- a/datatype/Printer.hs +++ b/datatype/Printer.hs @@ -88,22 +88,23 @@ instance Expression Printer where (>.) = printBinOp (nonectx 4) ">" (<=.) = printBinOp (nonectx 4) "<" (>=.) = printBinOp (nonectx 4) ">" - if' p t e = printLit "if" >> p >> printLit "then" >> t >> printLit "else" >> e + if' p t e = paren' CtxNonfix $ printLit "if " >> p >> printLit " then " >> local (\_->CtxNonfix) t >> printLit " else " >> local (\_->CtxNonfix) e + bottom msg = printLit $ "error " ++ show msg freshLabel :: MonadState PS m => String -> m String freshLabel prefix = gets fresh >>= \(f:fs)->modify (\s->s {fresh=fs}) >> pure (prefix ++ show f) instance Function () Printer where fun def = Main $ freshLabel "f" >>= \f-> - let g :- m = def (\()->printLit (f ++ " ()")) + let g :- m = def (\()->paren' CtxNonfix $ printLit (f ++ " ()")) in printLit ("let " ++ f ++ " () = ") >> g () >> printLit "\n in " >> unmain m instance Function (Printer a) Printer where fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a-> - let g :- m = def (\arg->printLit (f ++ " ") >>> arg) + let g :- m = def (\arg->paren' CtxNonfix $ printLit (f ++ " ") >>> arg) in printLit (concat ["let ", f, " ", a, " = "]) >> g (printLit a) >> printLit " in\n" >> unmain m instance Function (Printer a, Printer b) Printer where fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2-> - let g :- m = def (\(arg1, arg2)->printLit (f ++ " ") >> arg1 >> printLit " " >>> arg2) + let g :- m = def (\(arg1, arg2)->paren' CtxNonfix $ printLit (f ++ " ") >> arg1 >> printLit " " >>> arg2) in printLit (concat ["let ", f, " ", a1, " ", a2, " = "]) >> g (printLit a1, printLit a2) >> printLit " in\n" >> unmain m instance Function (Printer a, Printer b, Printer c) Printer where fun def = Main $ @@ -111,7 +112,7 @@ instance Function (Printer a, Printer b, Printer c) Printer where freshLabel "a" >>= \a1-> freshLabel "a" >>= \a2-> freshLabel "a" >>= \a3-> - let g :- m = def (\(arg1, arg2, arg3)->printLit (f ++ " ") >> arg1 >> printLit " " >> arg2 >> printLit " " >>> arg3) + let g :- m = def (\(arg1, arg2, arg3)->paren' CtxNonfix $ printLit (f ++ " ") >> arg1 >> printLit " " >> arg2 >> printLit " " >>> arg3) in printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "]) >> g (printLit a1, printLit a2, printLit a3) >> printLit " in\n" >> unmain m (>>>) :: Printer a1 -> Printer a2 -> Printer a3 @@ -120,13 +121,12 @@ l >>> r = l >> r >> pure undefined printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3 printBinOp thisctx op l r = paren' thisctx $ local (\_->setBranch thisctx CtxLeft) l - >> printLit op - >> local (\_->setBranch thisctx CtxRight) r - >> pure undefined + >> printLit (' ':op ++ " ") + >>> local (\_->setBranch thisctx CtxRight) r printUnOp :: Ctx -> String -> Printer a -> Printer a printUnOp thisctx op l = paren' thisctx $ - printLit op + printLit (' ':op ++ " ") >> local (\_->setBranch thisctx CtxRight) l printCons :: String -> Printer a -> Printer a diff --git a/datatype/Tuple.hs b/datatype/Tuple.hs index 6c6a3d7..abd0104 100644 --- a/datatype/Tuple.hs +++ b/datatype/Tuple.hs @@ -7,7 +7,7 @@ import GHC.Generics import Printer import Compiler import Serialise -import MkCons +import Language.GenDSL data Tuple a b = Tuple a b deriving Generic