packages feed

cmonad (empty) → 0.1.0.0

raw patch · 9 files changed

+388/−0 lines, 9 filesdep +arraydep +basesetup-changed

Dependencies added: array, base

Files

+ Setup.hs view
@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple+main = defaultMain
+ cmonad.cabal view
@@ -0,0 +1,22 @@+Name:		cmonad+Version:	0.1.0.0+License:	BSD3+Author:		Lennart Augustsson+Maintainer:	Lennart Augustsson+Category:	Language+Synopsis:	A library for C-like programming+Stability:      experimental+Build-type:	Simple+Description:	A library for C-like programming+Hs-Source-Dirs: src+Build-Depends:	base, array+Exposed-modules:+	Language.CMonad+Other-modules:+	Language.CMonad.CPrelude+	Language.CMonad.MonadRef+	Language.CMonad.Prim+	Language.CMonad.Ops+Extra-source-files:+	examples/Makefile+	examples/Inf.hs
+ examples/Inf.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Inf where+import Prelude()+import Language.CMonad++inf :: forall m r . (MonadRef m r) =>+       m Double+inf = runE $ do+    s <- auto 0+    i <- auto 0+    for (i =: 1, (i :: E m Double) <= 1e3, i+=1) $ do+        s += 1/i+    retrn s++main = do+    x <- inf+    putStrLn $ "Almost infinity is " ++ show x
+ examples/Makefile view
@@ -0,0 +1,22 @@+GHC=ghc+GHCFLAGS= -O --make -i../src -odir build -hidir build++run:	Inf.run QSort.run++build:+	mkdir -p build++Inf.run:	Inf.exe+	./Inf.exe++Inf.exe:	build Inf.hs+	$(GHC) $(GHCFLAGS) -main-is Inf.main Inf.hs -o Inf.exe++QSort.run:	QSort.exe+	./QSort.exe++QSort.exe:	build QSort.hs+	$(GHC) $(GHCFLAGS) -main-is QSort.main QSort.hs -o QSort.exe++clean:+	rm -rf *.exe* build
+ src/Language/CMonad.hs view
@@ -0,0 +1,11 @@+module Language.CMonad(+ module	Language.CMonad.CPrelude,+ module	Language.CMonad.MonadRef,+ module	Language.CMonad.Prim,+ module	Language.CMonad.Ops,+  ) where+import	qualified Prelude+import	Language.CMonad.CPrelude+import	Language.CMonad.MonadRef+import	Language.CMonad.Prim+import	Language.CMonad.Ops
+ src/Language/CMonad/CPrelude.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Language.CMonad.CPrelude(module Prelude, Boolean(..), Eq(..), Ord(..), Cond(..)) where+import qualified Prelude as P+import Prelude hiding (Eq(..), Ord(..), (&&), (||), not, until)++infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||++class Boolean b where+    false, true :: b+    (&&), (||) :: b -> b -> b+    not :: b -> b++instance Boolean Bool where+    {-# INLINE false #-}+    false = False+    {-# INLINE true #-}+    true = True+    {-# INLINE (&&) #-}+    (&&) = (P.&&)+    {-# INLINE (||) #-}+    (||) = (P.||)+    {-# INLINE not #-}+    not = P.not++class (Boolean b) => Eq a b {- | a -> b -} where+    (==), (/=) :: a -> a -> b+    x /= y  =  not (x == y)++class (Eq a b) => Ord a b {- | a -> b -} where+    (<), (<=), (>), (>=) :: a -> a -> b++instance (P.Eq a) => Eq a Bool where+    {-# INLINE (==) #-}+    (==) = (P.==)+    {-# INLINE (/=) #-}+    (/=) = (P./=)++instance (P.Ord a) => Ord a Bool where+    {-# INLINE (<) #-}+    (<)  = (P.<)+    {-# INLINE (<=) #-}+    (<=) = (P.<=)+    {-# INLINE (>) #-}+    (>)  = (P.>)+    {-# INLINE (>=) #-}+    (>=) = (P.>=)++-------------------------------------------++class (Boolean b) => Cond a b | a -> b where+    cond :: b -> a -> a -> a++instance Cond Int Bool where+    {-# INLINE cond #-}+    cond x y z = if x then y else z++instance Cond Bool Bool where+    {-# INLINE cond #-}+    cond x y z = if x then y else z
+ src/Language/CMonad/MonadRef.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module Language.CMonad.MonadRef where+import Data.IORef+import Data.STRef+import Control.Monad.ST(ST)++class (Monad m) => MonadRef m r | m -> r, r -> m where+    newRef :: a -> m (r a)+    readRef :: r a -> m a+    writeRef :: r a -> a -> m ()++instance MonadRef IO IORef where+    {-# INLINE newRef #-}+    newRef = newIORef+    {-# INLINE readRef #-}+    readRef = readIORef+    {-# INLINE writeRef #-}+    writeRef = writeIORef++instance MonadRef (ST s) (STRef s) where+    {-# INLINE newRef #-}+    newRef = newSTRef+    {-# INLINE readRef #-}+    readRef = readSTRef+    {-# INLINE writeRef #-}+    writeRef = writeSTRef
+ src/Language/CMonad/Ops.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE GADTs, ScopedTypeVariables, EmptyDataDecls, FlexibleInstances, ImpredicativeTypes, NoMonoPatBinds #-}+-- XXX Despite what I think should be enough LANGUAGE options I still need -fglasgow-exts.+module Language.CMonad.Ops(module Language.CMonad.Ops) where+import qualified Prelude as P+import Language.CMonad.CPrelude+import Language.CMonad.MonadRef(MonadRef)+import Language.CMonad.Prim++{-# INLINE liftE0 #-}+liftE0 :: (Monad m) => a -> E m a+liftE0 op = embed $ return op++{-# INLINE liftE1 #-}+liftE1 :: (Monad m) => (a -> b) -> E' v m a -> E m b+liftE1 op x = embed $ do+    x' <- runE x+    return (op x')++{-# INLINE liftE2 #-}+liftE2 :: (Monad m) => (a -> b -> c) -> E' va m a -> E' vb m b -> E m c+liftE2 op x y = embed $ do+    x' <- runE x+    y' <- runE y+    return (x' `op` y')+++{-# INLINE pure0 #-}+pure0 :: (Monad m) => a -> E m a+pure0 = return++-----------------------------++instance P.Eq (E m a)+instance Show (E m a)++instance (Monad m, Num a) => Num (E m a) where+    (+) = liftE2 (+)+    (-) = liftE2 (-)+    (*) = liftE2 (*)+    negate = liftE1 negate+    abs = liftE1 abs+    signum = liftE1 signum+    fromInteger = liftE0 . fromInteger++instance (Monad m, Fractional a) => Fractional (E m a) where+    (/) = liftE2 (/)+    recip = liftE1 recip+    fromRational = liftE0 . fromRational++instance (Monad m) => Boolean (E m Bool) where+    false = pure0 False+    true = pure0 True+    not = liftE1 not+    x && y = embed $ do+        x' <- runE x+        if x' then runE y else return False+    x || y = embed $ do+        x' <- runE x+        if x' then return True else runE y++instance (Monad m, Eq a Bool) => Eq (E m a) (E m Bool) where+    (==) = liftE2 (==)+    (/=) = liftE2 (/=)++instance (Monad m, Ord a Bool) => Ord (E m a) (E m Bool) where+    (<) = liftE2 (<)+    (<=) = liftE2 (<=)+    (>) = liftE2 (>)+    (>=) = liftE2 (>=)++-----------------------------++infix 0 *=, -=, +=+(*=), (-=), (+=) :: (Monad m, Num (E m a)) => (forall v . E' v m a) -> E m a -> E m a+{-# INLINE (*=) #-}+v *= x = v =: v * x+{-# INLINE (+=) #-}+v += x = v =: v + x+{-# INLINE (-=) #-}+v -= x = v =: v - x++infix 0 =:=+{-# INLINE (=:=) #-}+(=:=) :: (MonadRef m r) => (forall v . E' v m a) -> (forall v . E' v m a) -> E m ()+x =:= y = do+    t <- auto x+    x =: y+    y =: t+    return ()++-----------------------------++while :: (Monad m) => E m Bool -> E m a -> E m ()+while c a = if1 c $ do a; while c a++until :: (Monad m) => E m Bool -> E m a -> E m ()+until c a = do+    a+    if1 (not c) $ until c a++repeatUntil :: (Monad m) => E m a -> E m Bool -> E m a -> E m ()+repeatUntil a1 c a2 = do+    a1+    if1 (not c) $ do a2; repeatUntil a1 c a2++{-# INLINE if1 #-}+if1 :: (Monad m) => E m Bool -> E m a -> E m ()+if1 c a = do+    c' <- c+    if c' then do a; skip else skip++{-# INLINE if2 #-}+if2 :: (Monad m) => E m Bool -> E m a -> E m b -> E m ()+if2 c a b = do+    c' <- c+    if c' then do a; skip else do b; skip++{-# INLINE for #-}+for :: (Monad m) => (E m a, E m Bool, E m b) -> E m c -> E m ()+for (init, cmp, inc) body = do+    init+    while cmp $ do body; inc++{-# INLINE skip #-}+skip :: (Monad m) => m ()+skip = return ()++{-# INLINE retrn #-}+retrn :: E m a -> E m a+retrn x = x
+ src/Language/CMonad/Prim.hs view
@@ -0,0 +1,94 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE GADTs, ScopedTypeVariables, EmptyDataDecls, FlexibleInstances, ImpredicativeTypes, NoMonoPatBinds #-}+-- XXX Despite what I think should be enough LANGUAGE options I still need -fglasgow-exts.+module Language.CMonad.Prim(E', E, V, runE, embed, auto, arrayU, liftArray, (=:), RValue) where+import Control.Monad+import Data.Array+import Data.Array.MArray++import Language.CMonad.MonadRef++-- |Generic value type, both l-values and r-values.+data E' v m a where+    E :: m a -> E' RValue m a              -- ^compound expressions, only r-values+    V :: m a -> (a -> m ()) -> E' v m a    -- ^variables, l-value or r-value++data LValue -- ^l-value tag+data RValue -- ^r-value tag++type E m a = E' RValue m a                 -- ^Type of r-values in monad /m/+type V m a = E' LValue m a                 -- ^Type of l-values in monad /m/++-- |Evaluate an expression to an expression in the corresponding monad.+{-# INLINE runE #-}+runE :: E' v m a -> m a+runE (E t) = t+runE (V t _) = t++-- |r-values form a monad.+instance (Monad m) => Monad (E' RValue m) where+    {-# INLINE return #-}+    return x = E $ return x+    {-# INLINE (>>=) #-}+    x >>= f = E $ do+        x' <- runE x+        runE (f x')++-- |Any expression in the underlying monad can be lifted to a C expression.+{-# INLINE embed #-}+embed :: m a -> E m a+embed = E++-- |A variable with a initial value.+{-# INLINE auto #-}+auto :: (MonadRef m r) => E m a -> E m (forall v . E' v m a)+auto x = E (do+    x' <- runE x+    r  <- newRef x'+    return (V (readRef r) (writeRef r))+  )++{-# INLINE liftArray #-}+liftArray :: forall arr m a i . (Ix i, MArray arr a m) =>+             arr i a -> E m (forall v . [E m i] -> E' v m a)+liftArray a = E ( do+    let ix :: [E m i] -> m i+        ix [i] = runE i+	{-# INLINE f #-}+	f is = V (ix is >>= readArray a) (\ x -> ix is >>= \ i -> writeArray a i x)+    return f+  )++-- |A un-initialized multi-dimensional array.  E.g., @arrayU [2,3]@ is a 2x3 array.+arrayU :: forall arr m a i . (Ix i, Num i, MArray arr a m) =>+       [E m i] -> E m (forall v . [E m i] -> E' v m a)+arrayU ss = E ( do+    ss' <- mapM runE ss+    let sz = product ss'+        ix :: [E m i] -> m i+        ix is = do+                    is' <- mapM runE is+                    when (length is' /= length ss') $+                        error "wrong number of indicies"+                    return $ foldr (\ (i, s) r -> r * s + i) 0 (zip is' ss')+    a <- newArray (0, product ss' - 1) undefined :: m (arr i a)+    return (\ is -> V (ix is >>= readArray a)+                      (\ x -> ix is >>= \ i -> writeArray a i x))+  )++-- |An C array initialized with a normal array.+arrayA :: forall arr m a i . (Ix i, MArray arr a m) =>+       Array i a -> E m (forall v . [E m i] -> E' v m a)+arrayA aa = E ( do+    a <- thaw aa :: m (arr i a)+    runE (liftArray a)+  )++-- |Assignment operator.+infix 0 =:+{-# INLINE (=:) #-}+(=:) :: (Monad m) => V m a -> E m a -> E m a+V _ asg =: e = do+    e' <- e+    E (asg e')+    return e'