{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, NoMonomorphismRestriction, FlexibleContexts, ExistentialQuantification, FunctionalDependencies, ScopedTypeVariables, UndecidableInstances, TypeOperators #-} -- Test for multiple arity functions. import Control import Data import Array import Struct import Type import Term import Control.Monad.Identity import Control.Monad.ST import Data.Array.ST import Data.Array.MArray import Data.Array.Base import Code import Value import PrettyC import qualified Text.Show.Pretty pp = putStr . Text.Show.Pretty.ppShow ctop t = code \$ termTopdef t -- TODO: probably pack / unpack can be combined with lam / app to -- make this multiple arity juggling invisible. -- TODO: write generic unpack / pack in terms of _uncons / _cons -- To fix the return type of a Loop expression. n = 0 :: Tint exit = do ln <- lit n ret \$ ln t1 = do { v <- lit 123 ; ret v } t2 = do t <- true zero <- lit (0 :: Tint) one <- lit (1 :: Tint) ifte t (ret one) (ret zero) -- Single recursion -- f1 :: (Args r as ras, Loop m r) => r (as -> m t) f1 = lam \$ \a -> do f <- f1 app f a f2 = lam \$ \((,) (L a) (L b)) -> do f <- f2 app f ((,) (L b) (L a)) -- Mutual recursion f3 = lam \$ \a -> do f <- f4 app f a f4 = lam \$ \a -> do f <- f3 app f a -- Simple functions f5 = lam \$ \(L a) -> ret a f6 = lam \$ \(L a) -> do square <- mul a a ret square -- Simple function, tuple input f7 = lam \$ \((,) (L a) (L b)) -> do { v <- add a b ; ret v } f7' = \(a,b) -> do {v <- add a b; ret v} -- Casting seems necessary type V1 = MValue (Value (L Tint -> MValue Tint)) type VI = MValue (Value (L Tint)) t3 = do f <- (f1 :: V1) l1 <- lit 1 app f \$ L l1 t4 = do f <- (f5 :: V1) l1 <- lit 1 app f \$ L l1 t5 = do l2 <- lit 2 f <- (f6 :: V1) app f \$ L l2 type C1 = MCode (Code (L Tint -> MCode Tint)) type CI = MCode (Code Tint) t6 = do l1 <- lit 1 f <- (f1 :: C1) app f \$ L l1 t7 = do l1 <- lit 1 f <- (f5 :: C1) app f \$ L l1 t8 = do l2 <- lit 2 f <- (f6 :: C1) app f \$ L l2 -- test Lambda t9 = term (f5 :: C1) t10 = term (f6 :: C1) -- Multi-arg type V2 = MValue (Value ((Tint, Tint) -> MValue Tint)) type C2 = MCode (Code (((,) (L Tint) (L Tint)) -> MCode Tint)) t11 = term (f2 :: C2) t12 = do f <- (f2 :: C2) l1 <- lit 1 l2 <- lit 2 app f \$ ((,) (L l1) (L l2)) t13 = term (f7 :: C2) t15 = term \$ do l1 <- lit 1 l2 <- lit 2 f <- (f7 :: C2) app f \$ ((,) (L \$ l1) (L \$ l2)) t16 = term \$ do f <- (f7 :: C2) l1 <- lit 1 l2 <- lit 2 app f \$ ((,) (L \$ l1) (L \$ l2)) {- I think this needs a signature because the return value is not specified, and since it's a loop that seems quite plausible. -} t17def :: (Repr r, StructVar (L (r Tint)), StructRepr r, Control m r, Data m r) => r (L Tint -> m Tint) -> m (r (L Tint -> m Tint)) t17def = \f -> lam \$ (\(L x) -> do x2 <- mul x x app f \$ L x2) t17exp = \f -> do l123 <- lit 123 app f \$ L \$ l123 t17 = term \$ letrec t17def t17exp t18 = term \$ letrec t17def \$ \f -> do l3 <- lit 3 l4 <- lit 4 x <- mul l3 l4 y <- mul x x app f (L y) a1 inArray outArray = do -- (inFirst, inLast, inStride) <- _bounds inArray -- (outFirst, outLast, outStride) <- _bounds outArray -- We assume that output and input dims are compatible, ignoring -- inLast (or equivalently outLast). i <- lit 1 v <- get inArray i set outArray i v exit int n = Lit (Type AInt 0) (show n) varArr :: String -> Code (Tint -> Tint) varArr name = Code \$ Ref \$ Var (Type AInt 1) name t19 = term \$ a1 (varArr "in") (varArr "out") -- Arrays t20 = runSTUArray \$ newArray ((1 :: Int), (10 :: Int)) (0 :: Int) f8 arr = \f -> lam \$ (\((,) (L accu) (L index)) -> do l1 <- lit 1 l10 <- lit 10 v <- get arr index index' <- add index l1 accu' <- add accu v cond <- eq index' l10 ifte cond (ret accu') (app f \$ (,) (L accu') (L index'))) -- t21 :: Array m r a Tint => m (r Tint) t21 = do arr <- (undefined :: m (r (a Tint))) letrec (f8 arr) (\f -> do l0 <- lit 0 app f \$ ((,) (L \$ l0) (L \$ l0))) t22' = lam \$ (\(L ix) -> letrec (\f -> lam \$ (\(L x) -> do x2 <- mul x x ltt <- lit (10000 :: Tint) cond <- lt x2 ltt ifte cond (app f \$ L x2) (ret x) )) (\f -> app f \$ L \$ ix)) t22 = term t22' t23 :: MValue (Value Tint) t23 = do f <- t22' l3 <- lit 3 app f \$ L l3 t24' = lam1 \$ (\ix -> letrec (\f -> lam1 \$ (\x -> do x2 <- mul x x ltt <- lit (10000 :: Tint) cond <- lt x2 ltt ifte cond (app1 f x2) (ret x) )) (\f -> app1 f ix)) t24 = do {f <- t24'; l3 <- lit 3; app1 f l3} :: MValue (Value Tint) t25 = term \$ do l1 <- lit (1 :: Tint) l2 <- lit (2 :: Tint) l3 <- lit (3 :: Tint) pack (L \$ l1, (L \$ l2, L \$ l3)) t26 = term \$ do l1 <- lit (1 :: Tint) l2 <- lit (2 :: Tint) l3 <- lit (3 :: Tint) p <- pack (L \$ l1, (L \$ l2, L \$ l3)) (L a, (L b, L c)) <- unpack p ret b {- s27 arr = lam body where body s = do l <- lit (0 :: Tint) v <- get arr n ... -} main = putStrLn \$ show \$ t26