Commits

Paweł Wieczorek committed 6f849a0

Ugly solution for overlaping instances

Comments (0)

Files changed (3)

 default-extensions:
 other-extensions:
 extensions: NoMonomorphismRestriction FlexibleInstances
-            GeneralizedNewtypeDeriving
+            GeneralizedNewtypeDeriving MultiParamTypeClasses
 extra-libraries:
 extra-lib-dirs:
 includes:
 ghc-options: -Wall -O2
 hugs-options:
 nhc98-options:
-jhc-options:
+jhc-options:

src/Selen/Compiler/CPS/Analysis/Basic.hs

     trans _ _               = fail "No match"
 
 
-

src/Selen/Compiler/CPS/Monad.hs

     tick            = lift tick
     getRoundNo      = lift getRoundNo
 
+instance TransformationMonad m => TransformationMonad (StateT s m) where
+    varUsedCount    = lift . varUsedCount
+    varEscapes      = lift . varEscapes
+    varBoundBy      = lift . varBoundBy
+    getFunc         = lift . getFunc
+    translog        = lift . translog
+    isIrreducible   = lift . isIrreducible
+    markIrreducible = lift . markIrreducible
+    tick            = lift tick
+    getRoundNo      = lift getRoundNo
+
 varIsUsed :: TransformationMonad m => VarName -> m Bool
 varIsUsed v = do
     uc <- varUsedCount v
  -- Compiler
  -}
 
-type Compiler a = StateT CompilerState (FreshT IO) a
+-- bad design, problem with overlapping instances TransformationMonad (StateT s m)
+newtype Compiler a = MkCompiler (StateT CompilerState (FreshT IO) a)
+
+instance Monad Compiler where
+    return x   = MkCompiler (return x)
+    fail   x   = MkCompiler (fail x)
+    -- Compiler a -> (b -> Compiler b) -> Compiler b
+    (MkCompiler m) >>= f = MkCompiler $ do
+        x <- m
+        let (MkCompiler m') = f x
+        m'
+
+instance MonadState CompilerState Compiler where
+    put = undefined
+    get = undefined
+
 
 runCompiler :: Int -> Compiler a -> IO a
-runCompiler s m = do
+runCompiler s (MkCompiler m) = do
     ((a,_),_) <- runFreshT (runStateT m defaultCompilerState) s
     return a
 
 getTicks :: Compiler Integer
 getTicks = get >>= return . ticks
 
-instance TransformationMonad (StateT CompilerState (FreshT IO)) where
+instance FreshMonad Compiler where
+    freshString = MkCompiler freshString
+
+instance MonadIO Compiler where
+    liftIO = MkCompiler . liftIO
+
+--instance TransformationMonad (StateT CompilerState (FreshT IO)) where
+instance TransformationMonad Compiler where
     varUsedCount v = do
         st <- getIrInfo
         case (Map.lookup v (infUsedCount st)) of