summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE30
-rw-r--r--README.md7
-rw-r--r--Setup.hs2
-rw-r--r--boop.cabal45
-rw-r--r--src/Control/OOP.hs31
-rw-r--r--src/Control/OOP/Base.hs76
-rw-r--r--src/Control/OOP/Interfaces/ToString.hs51
-rw-r--r--src/Control/OOP/MonadVar.hs47
-rw-r--r--test/Spec.hs2
9 files changed, 291 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..d117b1d
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Tobias Dammers (c) 2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Author name here nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..f9366fe
--- /dev/null
+++ b/README.md
@@ -0,0 +1,7 @@
+# boop
+
+BOOP is Basic Object-Oriented Programming. Given just a few relatively simple
+primitives, BOOP enables fully fledged object-oriented programming in Haskell.
+
+For details, refer to
+https://programming.tobiasdammers.nl/blog/2017-10-17-object-oriented-haskell.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/boop.cabal b/boop.cabal
new file mode 100644
index 0000000..19a204a
--- /dev/null
+++ b/boop.cabal
@@ -0,0 +1,45 @@
+name: boop
+category: OOP
+synopsis: OOP primitives for Haskell
+version: 0.1.0.0
+homepage: https://github.com/tdammers/boop
+bug-reports: https://github.com/tdammers/boop/issues
+author: Tobias Dammers
+maintainer: tdammers@gmail.com
+copyright: 2017 Tobias Dammers
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+cabal-version: >= 1.10
+
+extra-source-files:
+ README.md
+
+source-repository head
+ type: git
+ location: https://github.com/tdammers/boop
+
+library
+ hs-source-dirs:
+ src
+ build-depends:
+ base >= 4.7 && < 5
+ , text
+ , mtl
+ exposed-modules:
+ Control.OOP
+ , Control.OOP.Base
+ , Control.OOP.Interfaces.ToString
+ , Control.OOP.MonadVar
+ default-language: Haskell2010
+
+test-suite boop-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs:
+ test
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ base >= 4.7 && < 5
+ , boop
+ default-language: Haskell2010
diff --git a/src/Control/OOP.hs b/src/Control/OOP.hs
new file mode 100644
index 0000000..91e40cc
--- /dev/null
+++ b/src/Control/OOP.hs
@@ -0,0 +1,31 @@
+{-#LANGUAGE MultiParamTypeClasses #-}
+{-#LANGUAGE FlexibleContexts #-}
+{-#LANGUAGE FlexibleInstances #-}
+{-#LANGUAGE TypeOperators #-}
+{-#LANGUAGE RankNTypes #-}
+
+module Control.OOP
+(
+-- * Classes, Methods, and Interfaces
+ (:>) (..)
+
+-- * Properties / Fields / Methods
+, member
+, imember
+, pureMember
+, mapMember
+, (-->)
+, (==>)
+
+-- * Mutable State
+, MonadConstVar (..)
+, MonadVar (..)
+
+-- * Standard interfaces
+, ToString (..)
+)
+where
+
+import Control.OOP.Base
+import Control.OOP.MonadVar
+import Control.OOP.Interfaces.ToString
diff --git a/src/Control/OOP/Base.hs b/src/Control/OOP/Base.hs
new file mode 100644
index 0000000..eda92b3
--- /dev/null
+++ b/src/Control/OOP/Base.hs
@@ -0,0 +1,76 @@
+{-#LANGUAGE MultiParamTypeClasses #-}
+{-#LANGUAGE FlexibleContexts #-}
+{-#LANGUAGE FlexibleInstances #-}
+{-#LANGUAGE TypeOperators #-}
+{-#LANGUAGE RankNTypes #-}
+
+module Control.OOP.Base
+where
+
+-- | The instance-of typeclass. @a :> b@ means that @a@ is an instance of @b@.
+class a :> b where
+ cast :: a -> b
+
+-- | Every interface is trivially an instance of itself.
+instance a :> a where
+ cast = id
+
+-- | Member accessor: get an object member through an interface.
+member :: cls :> inst
+ => (inst -> inst -> a)
+ -> cls
+ -> a
+member p obj =
+ imember p (cast obj)
+
+imember :: (inst -> inst -> a)
+ -> inst
+ -> a
+imember p vt =
+ p vt vt
+
+-- | Applicative accessor for a pure member.
+pureMember :: (cls :> inst, Applicative m)
+ => (inst -> inst -> a)
+ -> cls
+ -> m a
+pureMember p = pure . member p
+
+-- | Accessing a pure member through a 'Functor'
+mapMember :: (cls :> inst, Functor m)
+ => (inst -> inst -> a)
+ -> m cls
+ -> m a
+mapMember p = fmap (member p)
+
+-- | Flipped operator alias for 'member'.
+(-->) :: cls :> inst
+ => cls
+ -> (inst -> inst -> a)
+ -> a
+(-->) = flip member
+infixl 8 -->
+
+-- | Flipped operator alias for 'imember'.
+(==>) :: inst
+ -> (inst -> inst -> a)
+ -> a
+(==>) = flip imember
+infixl 8 ==>
+
+-- | Flipped operator alias for 'pureMember'.
+(-->>) :: (cls :> inst, Applicative m)
+ => cls
+ -> (inst -> inst -> a)
+ -> m a
+(-->>) = flip pureMember
+infixl 8 -->>
+
+-- | Flipped operator alias for 'mapMember'.
+(>-->) :: (cls :> inst, Functor m)
+ => m cls
+ -> (inst -> inst -> a)
+ -> m a
+(>-->) = flip mapMember
+infixl 8 >-->
+
diff --git a/src/Control/OOP/Interfaces/ToString.hs b/src/Control/OOP/Interfaces/ToString.hs
new file mode 100644
index 0000000..050aecd
--- /dev/null
+++ b/src/Control/OOP/Interfaces/ToString.hs
@@ -0,0 +1,51 @@
+{-#LANGUAGE TypeOperators #-}
+{-#LANGUAGE TypeSynonymInstances #-}
+{-#LANGUAGE FlexibleInstances #-}
+{-#LANGUAGE MultiParamTypeClasses #-}
+
+module Control.OOP.Interfaces.ToString
+where
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LText
+import Control.Monad.Identity (Identity, runIdentity)
+
+import Control.OOP.Base
+
+type LText = LText.Text
+
+-- | Objects that can be converted to string
+data ToString m
+ = ToString
+ { -- | Monadically cast an object to `Text`.
+ toStringM :: ToString m -> m Text
+ }
+
+-- | Cast an object to `Text` in a pure context.
+toString :: ToString Identity -> ToString Identity -> Text
+toString a b = runIdentity $ toStringM a b
+
+castShow :: (Applicative m, Show a) => a -> ToString m
+castShow = cast . show
+
+instance Applicative m => Text :> ToString m where
+ cast x = ToString (const . pure $ x)
+
+instance Applicative m => LText :> ToString m where
+ cast x = ToString (const . pure $ LText.toStrict x)
+
+instance Applicative m => String :> ToString m where
+ cast x = ToString (const . pure $ Text.pack x)
+
+instance Applicative m => Int :> ToString m where
+ cast = castShow
+
+instance Applicative m => Integer :> ToString m where
+ cast = castShow
+
+instance Applicative m => Double :> ToString m where
+ cast = castShow
+
+instance Applicative m => Rational :> ToString m where
+ cast = castShow
diff --git a/src/Control/OOP/MonadVar.hs b/src/Control/OOP/MonadVar.hs
new file mode 100644
index 0000000..5dea4e1
--- /dev/null
+++ b/src/Control/OOP/MonadVar.hs
@@ -0,0 +1,47 @@
+{-#LANGUAGE MultiParamTypeClasses #-}
+{-#LANGUAGE FlexibleContexts #-}
+{-#LANGUAGE FlexibleInstances #-}
+{-#LANGUAGE TypeOperators #-}
+{-#LANGUAGE FunctionalDependencies #-}
+
+module Control.OOP.MonadVar
+where
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Proxy
+
+-- | Generalized read-only access to mutable variables
+class Monad m => MonadConstVar v m | m -> v where
+ readVar :: v a -> m a
+
+-- | Generalized mutable variables
+class (Monad m, MonadConstVar v m) => MonadVar v m | m -> v where
+ newVar :: a -> m (v a)
+ writeVar :: a -> v a -> m ()
+
+ modifyVar :: (a -> a) -> v a -> m ()
+ swapVar :: a -> v a -> m a
+ modifySwapVar :: (a -> a) -> v a -> m a
+
+ transaction :: Proxy v -> m a -> m a
+
+ modifyVar f var =
+ modifySwapVar f var >> return ()
+
+ swapVar val' =
+ modifySwapVar (const val')
+
+ modifySwapVar f var = do
+ val <- readVar var
+ writeVar (f val) var
+ return val
+
+instance MonadIO m => MonadConstVar IORef m where
+ readVar = liftIO . readIORef
+
+instance MonadIO m => MonadVar IORef m where
+ newVar = liftIO . newIORef
+ writeVar v = liftIO . flip writeIORef v
+ transaction _ = id
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..cd4753f
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"