From e84175c501cb4acb0ed7d7a90dad5ba3215132bc Mon Sep 17 00:00:00 2001
From: Adam Wick <awick@uhsure.com>
Date: Wed, 22 Jun 2016 22:26:57 -0700
Subject: [PATCH] Monadic shenanigans beginning.

---
 bang.cabal               |   4 +-
 src/Bang/Monad.hs        | 107 +++++++++++++++++++++++++++++++++++++++
 src/Bang/Syntax/Parser.y |   1 -
 src/Bang/TypeInfer.hs    |   7 ++-
 src/Bang/Utils/Pretty.hs |  12 +++++
 src/Main.hs              |   1 +
 6 files changed, 129 insertions(+), 3 deletions(-)
 create mode 100644 src/Bang/Monad.hs
 create mode 100644 src/Bang/Utils/Pretty.hs

diff --git a/bang.cabal b/bang.cabal
index f40a984..cfed566 100644
--- a/bang.cabal
+++ b/bang.cabal
@@ -32,11 +32,13 @@ executable bang
   other-extensions:    CPP,
                        DeriveDataTypeable,
                        DeriveFunctor,
+                       FlexibleInstances,
                        GeneralizedNewtypeDeriving,
                        MagicHash,
                        MultiParamTypeClasses,
                        OverloadedStrings,
-                       TemplateHaskell
+                       TemplateHaskell,
+                       UndecidableInstances
   other-modules:
                        Bang.CommandLine,
                        Bang.Syntax.Lexer,
diff --git a/src/Bang/Monad.hs b/src/Bang/Monad.hs
new file mode 100644
index 0000000..0ce797c
--- /dev/null
+++ b/src/Bang/Monad.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE UndecidableInstances       #-}
+module Bang.Monad(
+         Compiler
+       , (==>), (==>|)
+       , genName, genTypeRef, genVarRef
+       , warn, err
+       )
+ where
+
+import Bang.Syntax.AST
+import Bang.Syntax.Location(unknownLocation)
+import Bang.Utils.Pretty(BangDoc)
+import Data.Text.Lazy(pack)
+import MonadLib
+import Text.PrettyPrint.Annotated(Doc)
+
+class BangError e where
+  ppError :: e -> BangDoc
+
+class BangWarning w where
+  ppWarning :: w -> BangDoc
+
+instance BangWarning w => BangError w where
+  ppError = ppWarning
+
+data CompilerState state = CompilerState {
+       csNextIdent       :: Word
+     , csPromoteWarnings :: Bool
+     , csWarnings        :: [BangDoc]
+     , csPassState       :: state
+     }
+
+initialState :: CompilerState ()
+initialState = CompilerState 1 False [] ()
+
+newtype Compiler s a =
+  Compiler { unCompiler :: CompilerState s -> IO (CompilerState s, a) }
+
+instance Applicative (Compiler s) where
+  pure a = Compiler (\ st -> return (st, a))
+  mf <*> ma = Compiler (\ st ->
+                          do (st', f) <- unCompiler mf st 
+                             (st'', a) <- unCompiler ma st'
+                             return (st'', f a))
+
+instance Functor (Compiler s) where
+  fmap f m = return f <*> m
+
+instance Monad (Compiler s) where
+  return a = Compiler (\ st -> return (st, a))
+  m >>= k  = Compiler (\ st ->
+                         do (st', a) <- unCompiler m st
+                            unCompiler (k a) st')
+
+class PassTransition s1 s2 where
+  transition :: s1 -> s2
+
+(==>) :: PassTransition s1 s2 =>
+         Compiler s1 a ->
+         (a -> Compiler s2 b) ->
+         Compiler s1 b
+m1 ==> k = Compiler (\ st ->
+                        do (st', a) <- unCompiler m1 st
+                           let next = k a
+                               ps'  = transition (csPassState st')
+                               st'' = st'{ csPassState = ps' }
+                           (_, b) <- unCompiler next st''
+                           return (st', b))
+
+(==>|) :: PassTransition s1 s2 =>
+          Compiler s1 a ->
+          Compiler s2 b ->
+          Compiler s1 b
+m1 ==>| m2 = m1 ==> (const m2)
+
+genName :: NameEnvironment -> Compiler s Name
+genName env = Compiler (\ st ->
+                         do let current = csNextIdent st
+                                str = "gen:" ++ show current
+                                res = Name unknownLocation env current (pack str)
+                            return (st{ csNextIdent = current + 1 }, res))
+
+genTypeRef :: Kind -> Compiler s Type
+genTypeRef k = TypeRef unknownLocation k `fmap` genName TypeEnv
+
+genVarRef :: Compiler s Expression
+genVarRef = ReferenceExp unknownLocation `fmap` genName VarEnv
+
+warn :: BangWarning w => w -> Compiler s ()
+warn w = Compiler (\ st ->
+                     if csPromoteWarnings st
+                        then runError w
+                        else runWarning w >> return (st, ()))
+
+err :: BangError w => w -> Compiler s a
+err w = Compiler (\ _ -> runError w)
+
+runWarning :: BangWarning w => w -> IO ()
+runWarning = undefined
+
+runError :: BangError w => w -> IO a
+runError = undefined
+
diff --git a/src/Bang/Syntax/Parser.y b/src/Bang/Syntax/Parser.y
index 3bb120e..65a08fe 100644
--- a/src/Bang/Syntax/Parser.y
+++ b/src/Bang/Syntax/Parser.y
@@ -302,7 +302,6 @@ initialState tokenStream = ParserState {
   , psNextIdent    = 1
   }
 
-
 instance StateM Parser ParserState where
   get = Parser   get
   set = Parser . set
diff --git a/src/Bang/TypeInfer.hs b/src/Bang/TypeInfer.hs
index 4ab7e5a..adbea9d 100644
--- a/src/Bang/TypeInfer.hs
+++ b/src/Bang/TypeInfer.hs
@@ -180,7 +180,12 @@ inferConstant c =
                     | ConstantFloat    _ <- c = IsIn "FloatLike" v
      return ([constraint], v)
 
-inferExpression :: ClassEnvironment -> [Assumptions] ->
+data ClassEnvironment = [Predicate] :=> Type
+
+freshInst :: Scheme -> Infer ClassEnvironment
+freshInst = undefined
+
+inferExpression :: ClassEnvironment -> [Assumption] ->
                    Expression ->
                    Infer ([Predicate], Type)
 inferExpression classEnv assumpts expr =
diff --git a/src/Bang/Utils/Pretty.hs b/src/Bang/Utils/Pretty.hs
new file mode 100644
index 0000000..b15f205
--- /dev/null
+++ b/src/Bang/Utils/Pretty.hs
@@ -0,0 +1,12 @@
+module Bang.Utils.Pretty(
+         BangDoc
+       , Annotation(..)
+       )
+ where
+
+import Text.PrettyPrint.Annotated(Doc)
+
+type BangDoc = Doc Annotation
+
+data Annotation = KeywordAnnotation
+
diff --git a/src/Main.hs b/src/Main.hs
index e661540..572be08 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,6 @@
 import           Bang.CommandLine
 import           Bang.Error(exit)
+import           Bang.Monad
 import           Bang.Syntax.AST(Module)
 import           Bang.Syntax.Lexer(lexer)
 import           Bang.Syntax.Location