never executed always true always false

    1 {-# LANGUAGE DeriveFunctor #-}
    2 module HelVM.HelMA.Automaton.IO.FreeIO (
    3   interpretFreeIOToBusinessIO,
    4   logInput,
    5   logOutput,
    6   FreeIO,
    7 ) where
    8 
    9 import           HelVM.HelMA.Automaton.IO.BusinessIO
   10 
   11 import           HelVM.HelIO.Control.Control
   12 import           HelVM.HelIO.Control.Safe
   13 
   14 import           Control.Monad.Free
   15 import           Control.Natural
   16 
   17 import qualified Data.ByteString.Lazy                as LBS
   18 
   19 import qualified Data.Text.Lazy                      as LT
   20 
   21 interpretFreeIOToBusinessIO :: BusinessIO m => FreeIO a -> m a
   22 interpretFreeIOToBusinessIO = foldFree interpretFreeIOFToBusinessIO
   23 
   24 logInput :: FreeIO ~> FreeIO
   25 logInput = foldFree logInputF
   26 
   27 logOutput :: FreeIO ~> FreeIO
   28 logOutput = foldFree logOutputF
   29 
   30 ----
   31 
   32 interpretFreeIOFToBusinessIO :: BusinessIO m => FreeIOF a -> m a
   33 interpretFreeIOFToBusinessIO (GetContentsBS   cd) = cd <$> wGetContentsBS
   34 interpretFreeIOFToBusinessIO (GetContentsText cd) = cd <$> wGetContentsText
   35 interpretFreeIOFToBusinessIO (GetContents     cd) = cd <$> wGetContents
   36 interpretFreeIOFToBusinessIO (GetChar         cd) = cd <$> wGetChar
   37 interpretFreeIOFToBusinessIO (GetLine         cd) = cd <$> wGetLine
   38 interpretFreeIOFToBusinessIO (PutChar        c v) = wPutChar  c $> v
   39 interpretFreeIOFToBusinessIO (PutStr         s v) = wPutStr   s $> v
   40 interpretFreeIOFToBusinessIO (PutStrLn       s v) = wPutStrLn s $> v
   41 interpretFreeIOFToBusinessIO (LogStr         s v) = wLogStr   s $> v
   42 interpretFreeIOFToBusinessIO (LogStrLn       s v) = wLogStrLn s $> v
   43 interpretFreeIOFToBusinessIO (Flush            v) = wFlush      $> v
   44 
   45 ----
   46 
   47 logInputF :: FreeIOF a -> FreeIO a
   48 logInputF (GetChar     cd) = freeGetChar     >>= (\c -> liftF $ LogStr (one      c) (cd c))
   49 logInputF (GetLine     cd) = freeGetLine     >>= (\l -> liftF $ LogStr           l  (cd l))
   50 logInputF               f  =                            liftF f
   51 
   52 logOutputF :: FreeIOF a -> FreeIO a
   53 logOutputF f@(PutChar c v) = liftF (LogStr (one c) v) *> liftF f
   54 logOutputF f@(PutStr  s v) = liftF (LogStr       s v) *> liftF f
   55 logOutputF f               =                             liftF f
   56 
   57 -- | Instances
   58 instance BusinessIO FreeIO where
   59   wGetContentsBS   = freeGetContentsBS
   60   wGetContentsText = freeGetContentsText
   61   wGetContents     = freeGetContents
   62   wGetChar         = freeGetChar
   63   wGetLine         = freeGetLine
   64   wPutChar         = freePutChar
   65   wPutStr          = freePutStr
   66   wPutStrLn        = freePutStrLn
   67   wLogStr          = freeLogStr
   68   wLogStrLn        = freeLogStrLn
   69   wFlush           = freeFlush
   70 
   71 instance BusinessIO (SafeT FreeIO) where
   72   wGetContentsBS   = safeT   freeGetContentsBS
   73   wGetContentsText = safeT   freeGetContentsText
   74   wGetContents     = safeT   freeGetContents
   75   wGetChar         = safeT   freeGetChar
   76   wGetLine         = safeT   freeGetLine
   77   wPutChar         = safeT . freePutChar
   78   wPutStr          = safeT . freePutStr
   79   wPutStrLn        = safeT . freePutStrLn
   80   wLogStr          = safeT . freeLogStr
   81   wLogStrLn        = safeT . freeLogStrLn
   82   wFlush           = safeT   freeFlush
   83 
   84 instance BusinessIO (ControlT FreeIO) where
   85   wGetContentsBS    = controlT   freeGetContentsBS
   86   wGetContentsText  = controlT   freeGetContentsText
   87   wGetContents      = controlT   freeGetContents
   88   wGetChar          = controlT   freeGetChar
   89   wGetLine          = controlT   freeGetLine
   90   wPutChar          = controlT . freePutChar
   91   wPutStr           = controlT . freePutStr
   92   wPutStrLn         = controlT . freePutStrLn
   93   wLogStr           = controlT . freeLogStr
   94   wLogStrLn         = controlT . freeLogStrLn
   95   wFlush            = controlT   freeFlush
   96 
   97 -- | Low level functions
   98 freeGetContentsBS :: FreeIO LBS.ByteString
   99 freeGetContentsBS = liftF $ GetContentsBS id
  100 
  101 freeGetContentsText :: FreeIO LT.Text
  102 freeGetContentsText = liftF $ GetContentsText id
  103 
  104 freeGetContents :: FreeIO String
  105 freeGetContents = liftF $ GetContents id
  106 
  107 freeGetChar :: FreeIO Char
  108 freeGetChar = liftF $ GetChar id
  109 
  110 freeGetLine :: FreeIO Text
  111 freeGetLine = liftF $ GetLine id
  112 
  113 freePutChar :: Char -> FreeIO ()
  114 freePutChar = liftF . flip PutChar ()
  115 
  116 freePutStr :: Text -> FreeIO ()
  117 freePutStr = liftF . flip PutStr ()
  118 
  119 freePutStrLn :: Text -> FreeIO ()
  120 freePutStrLn = liftF . flip PutStrLn ()
  121 
  122 freeLogStr :: Text -> FreeIO ()
  123 freeLogStr = liftF . flip LogStr ()
  124 
  125 freeLogStrLn :: Text -> FreeIO ()
  126 freeLogStrLn = liftF . flip LogStrLn ()
  127 
  128 freeFlush :: FreeIO ()
  129 freeFlush = liftF $ Flush ()
  130 
  131 -- | Types
  132 type FreeIO = Free FreeIOF
  133 
  134 data FreeIOF a
  135  = GetContentsBS   (LBS.ByteString -> a)
  136  | GetContentsText (LT.Text        -> a)
  137  | GetContents     (String         -> a)
  138  | GetChar         (Char           -> a)
  139  | GetLine         (Text           -> a)
  140  | PutChar          Char a
  141  | PutStr           Text a
  142  | PutStrLn         Text a
  143  | LogStr           Text a
  144  | LogStrLn         Text a
  145  | Flush                 a
  146  deriving stock (Functor)