never executed always true always false

    1 {-# LANGUAGE DeriveFunctor #-}
    2 module HelVM.HelMA.Automaton.Eff.FreeEff (
    3   interpretFreeEffDebug,
    4   interpretFreeEff,
    5   FreeEff,
    6   FreeEffF(..),
    7 ) where
    8 
    9 import           HelVM.HelMA.Automaton.Eff.MonadEff
   10 
   11 import           Control.Monad.Free.Church          (F, foldF, liftF)
   12 import           Control.Monad.Logger
   13 
   14 import           Prelude                            hiding (getLine, putLTextLn, putText, putTextLn)
   15 --------------------------------------------------------------------------------
   16 
   17 interpretFreeEffDebug :: MonadLoggerEff m => FreeEff a -> m a
   18 interpretFreeEffDebug = foldF interpretFreeEffFDebug
   19 
   20 interpretFreeEff :: MonadEff m => FreeEff a -> m a
   21 interpretFreeEff = foldF interpretFreeEffF
   22 
   23 --------------------------------------------------------------------------------
   24 
   25 interpretFreeEffFDebug :: MonadLoggerEff m => FreeEffF a -> m a
   26 interpretFreeEffFDebug (GetContentsBS    cd) = cd <$> (logDebugN "GetContentsBS"   *> getContentsBS)
   27 interpretFreeEffFDebug (GetContentsText  cd) = cd <$> (logDebugN "GetContentsText" *> getContentsText)
   28 interpretFreeEffFDebug (GetChar          cd) = logAndCont =<< getChar where logAndCont c = logDebugN ("GetChar: " <> one c) $> cd c
   29 interpretFreeEffFDebug (GetLine          cd) = logAndCont =<< getLine where logAndCont l = logDebugN ("GetLine: " <>     l) $> cd l
   30 interpretFreeEffFDebug (PutChar        c v ) = logDebugN ("PutChar: " <> one c) *> putChar    c $> v
   31 interpretFreeEffFDebug (PutText        s v ) = logDebugN ("PutText: " <>     s) *> putLine s $> v
   32 interpretFreeEffFDebug (Flush            v ) = logDebugN "Flush"                *> flush        $> v
   33 
   34 interpretFreeEffF :: MonadEff m => FreeEffF a -> m a
   35 interpretFreeEffF (GetContentsBS    cd) = cd <$> getContentsBS
   36 interpretFreeEffF (GetContentsText  cd) = cd <$> getContentsText
   37 interpretFreeEffF (GetChar          cd) = cd <$> getChar
   38 interpretFreeEffF (GetLine          cd) = cd <$> getLine
   39 interpretFreeEffF (PutChar        c v ) = putChar      c $> v
   40 interpretFreeEffF (PutText        s v ) = putLine   s $> v
   41 interpretFreeEffF (Flush            v ) = flush          $> v
   42 
   43 --------------------------------------------------------------------------------
   44 
   45 instance MonadEff FreeEff where
   46   getContentsBS   = freeGetContentsBS
   47   getContentsText = freeGetContentsText
   48   getChar         = freeGetChar
   49   getLine         = freeGetLine
   50   putChar         = freePutChar
   51   putLine         = freePutLine
   52   flush           = freeFlush
   53 
   54 freeGetContentsBS :: FreeEff LByteString
   55 freeGetContentsBS = liftF $ GetContentsBS id
   56 
   57 freeGetContentsText :: FreeEff LText
   58 freeGetContentsText = liftF $ GetContentsText id
   59 
   60 freeGetChar :: FreeEff Char
   61 freeGetChar = liftF $ GetChar id
   62 
   63 freeGetLine :: FreeEff Text
   64 freeGetLine = liftF $ GetLine id
   65 
   66 freePutChar :: Char -> FreeEff ()
   67 freePutChar = liftF . flip PutChar ()
   68 
   69 freePutLine :: Text -> FreeEff ()
   70 freePutLine = liftF . flip PutText ()
   71 
   72 freeFlush :: FreeEff ()
   73 freeFlush = liftF $ Flush ()
   74 
   75 --------------------------------------------------------------------------------
   76 
   77 type FreeEff = F FreeEffF
   78 
   79 data FreeEffF a
   80  = GetContentsBS             (LByteString -> a)
   81  | GetContentsText           (LText       -> a)
   82  | GetChar                   (Char        -> a)
   83  | GetLine                   (Text        -> a)
   84  | PutChar          Char                     a
   85  | PutText          Text                     a
   86  | Flush                                     a
   87  deriving stock (Functor)