never executed always true always false

    1 module HelVM.HelMA.Automata.BrainFuck.Impl.Fast.Evaluator
    2   ( evalSource
    3   ) where
    4 
    5 import           HelVM.HelMA.Automata.BrainFuck.Impl.Fast.Instruction
    6 
    7 import           HelVM.HelMA.Automata.BrainFuck.Impl.Fast.Parser
    8 
    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 runList tape =<< parseWithOptimize source
   22 
   23 runList ∷ (AppSafeEff m , Symbol e) ⇒ FastInstructionList → FullTape e → m $ Memory e
   24 runList il = nextStep (IM il 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 FastInstruction → InstructionMemory → FullTape e → m $ Memory e
   30 doInstruction (Just (Move   i       )) table tape       = nextStep     table (moveHead          i        tape)
   31 doInstruction (Just (Inc    i       )) table tape       = nextStep     table (incSymbol         i        tape)
   32 doInstruction (Just  Output          ) table tape       = doOutputChar table                             tape
   33 doInstruction (Just  Input           ) table tape       = doInputChar  table                             tape
   34 doInstruction (Just (While  iv      )) table tape       = doWhile iv   table                             tape
   35 doInstruction (Just (Set    i       )) table tape       = nextStep     table (setSymbol         i        tape)
   36 
   37 doInstruction (Just (SubClr          f    )) table tape = nextStep table (subAndClearSymbol          f     tape)
   38 doInstruction (Just (AddClr          f    )) table tape = nextStep table (addAndClearSymbol          f     tape)
   39 doInstruction (Just (MulAddClr m     f    )) table tape = nextStep table (mulAddAndClearSymbol m     f     tape)
   40 
   41 doInstruction (Just (DupClr          f1 f2)) table tape = nextStep table (dupAndClearSymbol          f1 f2 tape)
   42 doInstruction (Just (MulDupClr m1 m2 f1 f2)) table tape = nextStep table (mulDupAndClearSymbol m1 m2 f1 f2 tape)
   43 
   44 doInstruction (Just (TriClr i1 i2 i3)) table tape       = nextStep     table (triAndClearSymbol i1 i2 i3 tape)
   45 doInstruction  Nothing           table tape             = doEnd        table                             tape
   46 
   47 doWhile ∷ (AppSafeEff m , Symbol e) ⇒ FastInstructionList → InstructionMemory → FullTape e → m $ Memory e
   48 doWhile _  table tape@(_ , 0:_) = nextStep table tape
   49 doWhile iv table tape           = doWhileWithTape =<< runList iv tape where
   50   doWhileWithTape ∷ (AppSafeEff m , Symbol e) ⇒ Memory e → m $ Memory e
   51   doWhileWithTape = doWhile iv table . memoryTape
   52 
   53 -- | IO instructions
   54 doOutputChar ∷ (AppSafeEff m , Symbol e) ⇒ InstructionMemory → FullTape e → m $ Memory e
   55 doOutputChar _          (_ ,  []) = error "Illegal State"
   56 doOutputChar table tape@(_ , e:_) = putChar (toChar e) *> nextStep table tape
   57 
   58 doInputChar  ∷ (AppSafeEff m , Symbol e) ⇒ InstructionMemory → FullTape e → m $ Memory e
   59 doInputChar table tape = (nextStep table . flip writeSymbol tape) =<< getChar
   60 
   61 -- | Terminate instruction
   62 doEnd ∷ AppSafeEff m ⇒ InstructionMemory → FullTape e → m $ Memory e
   63 doEnd iu tape = pure $ Memory iu tape
   64 
   65 -- | Types
   66 data Memory e
   67   = Memory
   68       { memoryIM   :: InstructionMemory
   69       , memoryTape :: FullTape e
   70       }
   71   deriving stock (Eq, Show)
   72 
   73 data InstructionMemory
   74   = IM !FastInstructionList !InstructionCounter
   75   deriving stock (Eq, Show)
   76 
   77 type InstructionCounter = Int