never executed always true always false

    1 {-# LANGUAGE DeriveFunctor #-}
    2 module HelVM.HelMA.Automaton.Eff.FreeEff
    3   ( FreeEff
    4   , FreeEffF (..)
    5   , interpretFreeEff
    6   , interpretFreeEffDebug
    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 ∷ AppEff 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 ∷ AppEff 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)