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 $
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
| Str Int | Ldr Int
| Sth Int | Ldh Int
| Jsr Int | Ret Int | Arg Int
- | Halt
+ | Halt | Error String
deriving Show
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
(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
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
>>= 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
--- /dev/null
+{-# 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
(-.) :: 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
(<=.) :: 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)
{-# LANGUAGE TemplateHaskell #-}
-module MkCons where
+module Language.GenDSL where
import Language.Haskell.TH.Syntax
import Language.Haskell.TH
-> sequence
[ mkDerivation tyvars
, mkConstructorClasses tyvars constructors
- , mkPrinterInstances tyvars constructors
- , mkCompilerInstances tyvars constructors
+ , mkPrinterInstances constructors
+ , mkCompilerInstances constructors
]
_
-> fail "mkConsClass only supports data types"
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"
= 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
$ 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)
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
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]
--- /dev/null
+{-# 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
+{-# 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
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))}
)
(>.) = 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 $
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
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
import Printer
import Compiler
import Serialise
-import MkCons
+import Language.GenDSL
data Tuple a b = Tuple a b
deriving Generic
repositories / clean-tests.git / commitdiff