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.Eff.MonadEff
   14 import           HelVM.HelMA.Automaton.Types.DumpType
   15 
   16 import           HelVM.HelIO.Containers.MTIndexSafe
   17 
   18 import           Control.Type.Operator
   19 
   20 evalSource ∷ (AppSafeEff m , Symbol e) ⇒ Source → FullTape e → DumpType → m ()
   21 evalSource source tape dt = logDump dt =<< flip runVector tape =<< parseAsVector source
   22 
   23 runVector ∷ (AppSafeEff m , Symbol e) ⇒ TreeInstructionVector → FullTape e → m $ Memory e
   24 runVector iv = nextStep (IM iv 0)
   25 
   26 nextStep ∷ (AppSafeEff 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 ∷ (AppSafeEff 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 ∷ (AppSafeEff 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 ∷ (AppSafeEff m , Symbol e) ⇒ Memory e → m $ Memory e
   43   doWhileWithTape = doWhile iv table . memoryTape
   44 
   45 -- | IO instructions
   46 doOutputChar ∷ (AppSafeEff m , Symbol e) ⇒ InstructionMemory → FullTape e → m $ Memory e
   47 doOutputChar _          (_ ,  []) = error "Illegal State"
   48 doOutputChar table tape@(_ , e:_) = putChar (toChar e) *> nextStep table tape
   49 
   50 doInputChar  ∷ (AppSafeEff m , Symbol e) ⇒ InstructionMemory → FullTape e → m $ Memory e
   51 doInputChar table tape = (nextStep table . flip writeSymbol tape) =<< getChar
   52 
   53 -- | Terminate instruction
   54 doEnd ∷ AppSafeEff m ⇒ InstructionMemory → FullTape e → m $ Memory e
   55 doEnd im tape = pure $ Memory im tape
   56 
   57 -- | Types
   58 data Memory e
   59   = Memory
   60       { memoryIM   :: InstructionMemory
   61       , memoryTape :: FullTape e
   62       }
   63   deriving stock (Eq, Show)
   64 
   65 data InstructionMemory
   66   = IM !TreeInstructionVector !InstructionCounter
   67   deriving stock (Eq, Show)
   68 
   69 type InstructionCounter = Int