never executed always true always false

    1 {-# LANGUAGE GADTs      #-}
    2 {-# LANGUAGE RankNTypes #-}
    3 module HelVM.HelMA.Automaton.Eff.GADTEff
    4   ( GADTEff
    5   , GADTEffF (..)
    6   , interpretGADTEff
    7   , interpretGADTEffDebug
    8   ) where
    9 
   10 import           HelVM.HelMA.Automaton.Eff.MonadEff
   11 
   12 import           Control.Monad.Logger
   13 
   14 import           Prelude                            hiding ( getLine, putLTextLn, putText, putTextLn )
   15 
   16 newtype GADTEff a
   17   = 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 ∷ AppEff 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 ∷ AppEff 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 ()