never executed always true always false

    1 module HelVM.HelMA.Automata.BrainFuck.Impl.Tree.Evaluator (
    2   evalSource,
    3 ) where
    4 
    5 import           HelVM.HelMA.Automata.BrainFuck.Impl.Tree.Instruction
    6 import           HelVM.HelMA.Automata.BrainFuck.Impl.Tree.Parser
    7 
    8 import           HelVM.HelMA.Automata.BrainFuck.Common.SimpleInstruction
    9 import           HelVM.HelMA.Automata.BrainFuck.Common.Symbol
   10 import           HelVM.HelMA.Automata.BrainFuck.Common.TapeOfSymbols
   11 
   12 import           HelVM.HelMA.Automaton.API.IOTypes
   13 import           HelVM.HelMA.Automaton.IO.BusinessIO
   14 import           HelVM.HelMA.Automaton.Types.DumpType
   15 
   16 import           HelVM.HelIO.Containers.LLIndexSafe
   17 
   18 import           Control.Type.Operator
   19 
   20 evalSource :: (BIO m , Symbol e) => Source -> FullTape e -> DumpType -> m ()
   21 evalSource source tape dt = logDump dt =<< flip runVector tape =<< parseAsVector source
   22 
   23 runVector :: (BIO m , Symbol e) => TreeInstructionVector -> FullTape e -> m $ Memory e
   24 runVector iv = nextStep (IM iv 0)
   25 
   26 nextStep :: (BIO m , Symbol e) => InstructionMemory -> FullTape e -> m $ Memory e
   27 nextStep (IM iv ic) = doInstruction (iv `indexMaybe` ic) (IM iv $ ic + 1)
   28 
   29 doInstruction :: (BIO m , Symbol e) => Maybe TreeInstruction -> InstructionMemory -> FullTape e -> m $ Memory e
   30 doInstruction (Just (Simple MoveR     )) table tape = nextStep     table (moveHeadRight tape)
   31 doInstruction (Just (Simple MoveL     )) table tape = nextStep     table  (moveHeadLeft tape)
   32 doInstruction (Just (Simple Inc       )) table tape = nextStep     table    (nextSymbol tape)
   33 doInstruction (Just (Simple Dec       )) table tape = nextStep     table    (prevSymbol tape)
   34 doInstruction (Just (Simple Output    )) table tape = doOutputChar table                tape
   35 doInstruction (Just (Simple Input     )) table tape = doInputChar  table                tape
   36 doInstruction (Just (While  iv        )) table tape = doWhile iv   table                tape
   37 doInstruction  Nothing                   table tape = doEnd        table                tape
   38 
   39 doWhile :: (BIO m , Symbol e) => TreeInstructionVector -> InstructionMemory -> FullTape e -> m $ Memory e
   40 doWhile _  table tape@(_ , 0:_) = nextStep table tape
   41 doWhile iv table tape           = doWhileWithTape =<< runVector iv tape where
   42   doWhileWithTape :: (BIO m , Symbol e) => Memory e -> m $ Memory e
   43   doWhileWithTape = doWhile iv table . memoryTape
   44 
   45 -- | IO instructions
   46 doOutputChar :: (BIO m , Symbol e) => InstructionMemory -> FullTape e -> m $ Memory e
   47 doOutputChar _          (_ ,  []) = error "Illegal State"
   48 doOutputChar table tape@(_ , e:_) = wPutChar (toChar e) *> nextStep table tape
   49 
   50 doInputChar  :: (BIO m , Symbol e) => InstructionMemory -> FullTape e -> m $ Memory e
   51 doInputChar table tape = (nextStep table . flip writeSymbol tape) =<< wGetChar
   52 
   53 -- | Terminate instruction
   54 doEnd :: BIO m => InstructionMemory -> FullTape e -> m $ Memory e
   55 doEnd im tape = pure $ Memory im tape
   56 
   57 -- | Types
   58 data Memory e = Memory
   59   { memoryIM   :: InstructionMemory
   60   , memoryTape :: FullTape e
   61   }
   62   deriving stock (Eq , Show)
   63 
   64 data InstructionMemory = IM !TreeInstructionVector !InstructionCounter
   65   deriving stock (Eq , Show)
   66 
   67 type InstructionCounter = Int