never executed always true always false

    1 {-# LANGUAGE GADTs      #-}
    2 {-# LANGUAGE RankNTypes #-}
    3 
    4 module HelVM.HelMA.Automaton.Eff.GADTEff (
    5   interpretGADTEffDebug,
    6   interpretGADTEff,
    7   GADTEff,
    8   GADTEffF(..),
    9 ) where
   10 
   11 import           HelVM.HelMA.Automaton.Eff.MonadEff
   12 
   13 import           Control.Monad.Logger
   14 
   15 import           Prelude                            hiding (getLine, putLTextLn, putText, putTextLn)
   16 
   17 newtype GADTEff a = GADTEff { runGADTEff :: forall m. Monad m => (forall x. GADTEffF x -> m x) -> m a }
   18 
   19 instance Functor GADTEff where
   20   fmap f m = GADTEff $ \k -> fmap f (runGADTEff m k)
   21 
   22 instance Applicative GADTEff where
   23   pure a  = GADTEff $ \_ -> pure a
   24   f <*> a = GADTEff $ \k -> runGADTEff f k <*> runGADTEff a k
   25 
   26 instance Monad GADTEff where
   27   return = pure
   28   m >>= f = GADTEff $ \k -> runGADTEff m k >>= \a -> runGADTEff (f a) k
   29 
   30 liftF :: GADTEffF a -> GADTEff a
   31 liftF fa = GADTEff $ \k -> k fa
   32 
   33 --------------------------------------------------------------------------------
   34 -- Interpretacja
   35 
   36 interpretGADTEffDebug :: MonadLoggerEff m => GADTEff a -> m a
   37 interpretGADTEffDebug eff = runGADTEff eff interpretGADTEffFDebug
   38 
   39 interpretGADTEff :: MonadEff m => GADTEff a -> m a
   40 interpretGADTEff eff = runGADTEff eff interpretGADTEffF
   41 
   42 --------------------------------------------------------------------------------
   43 -- Interpreter dla pojedynczych instrukcji (bez fmap/kontynuacji!)
   44 
   45 interpretGADTEffFDebug :: MonadLoggerEff m => GADTEffF a -> m a
   46 interpretGADTEffFDebug GetContentsBS   = logDebugN "GetContentsBS"   *> getContentsBS
   47 interpretGADTEffFDebug GetContentsText = logDebugN "GetContentsText" *> getContentsText
   48 interpretGADTEffFDebug GetChar         = logAndCont =<< getChar where logAndCont c = logDebugN ("GetChar: " <> one c) $> c
   49 interpretGADTEffFDebug GetLine         = logAndCont =<< getLine where logAndCont l = logDebugN ("GetLine: " <>     l) $> l
   50 interpretGADTEffFDebug (PutChar c)     = logDebugN ("PutChar: " <> one c) *> putChar c
   51 interpretGADTEffFDebug (PutText s)     = logDebugN ("PutText: " <>     s) *> putLine s
   52 interpretGADTEffFDebug Flush           = logDebugN "Flush"                *> flush
   53 
   54 interpretGADTEffF :: MonadEff m => GADTEffF a -> m a
   55 interpretGADTEffF GetContentsBS   = getContentsBS
   56 interpretGADTEffF GetContentsText = getContentsText
   57 interpretGADTEffF GetChar         = getChar
   58 interpretGADTEffF GetLine         = getLine
   59 interpretGADTEffF (PutChar c)     = putChar c
   60 interpretGADTEffF (PutText s)     = putLine s
   61 interpretGADTEffF Flush           = flush
   62 
   63 --------------------------------------------------------------------------------
   64 
   65 instance MonadEff GADTEff where
   66   getContentsBS   = gadtGetContentsBS
   67   getContentsText = gadtGetContentsText
   68   getChar         = gadtGetChar
   69   getLine         = gadtGetLine
   70   putChar         = gadtPutChar
   71   putLine         = gadtPutLine
   72   flush           = gadtFlush
   73 
   74 gadtGetContentsBS :: GADTEff LByteString
   75 gadtGetContentsBS = liftF GetContentsBS
   76 
   77 gadtGetContentsText :: GADTEff LText
   78 gadtGetContentsText = liftF GetContentsText
   79 
   80 gadtGetChar :: GADTEff Char
   81 gadtGetChar = liftF GetChar
   82 
   83 gadtGetLine :: GADTEff Text
   84 gadtGetLine = liftF GetLine
   85 
   86 gadtPutChar :: Char -> GADTEff ()
   87 gadtPutChar = liftF . PutChar
   88 
   89 gadtPutLine :: Text -> GADTEff ()
   90 gadtPutLine = liftF . PutText
   91 
   92 gadtFlush :: GADTEff ()
   93 gadtFlush = liftF Flush
   94 
   95 --------------------------------------------------------------------------------
   96 
   97 data GADTEffF a where
   98   GetContentsBS   :: GADTEffF LByteString
   99   GetContentsText :: GADTEffF LText
  100   GetChar         :: GADTEffF Char
  101   GetLine         :: GADTEffF Text
  102   PutChar         :: Char -> GADTEffF ()
  103   PutText         :: Text -> GADTEffF ()
  104   Flush           :: GADTEffF ()