never executed always true always false

    1 module HelVM.HelMA.Automaton.Instruction.Groups.SMInstruction where
    2 
    3 import           HelVM.HelMA.Automaton.Instruction.Extras.Common
    4 import           HelVM.HelMA.Automaton.Instruction.Extras.TextExtra
    5 import           HelVM.HelMA.Automaton.Instruction.Groups.IOInstruction
    6 
    7 import           HelVM.HelIO.Containers.Extra
    8 
    9 -- | Constructors
   10 
   11 blAnd :: OperatorType -> BinaryOperation
   12 blAnd Bitwise = BAnd
   13 blAnd Logical = LAnd
   14 
   15 blOr :: OperatorType -> BinaryOperation
   16 blOr Bitwise = BOr
   17 blOr Logical = LOr
   18 
   19 blXor :: OperatorType -> BinaryOperation
   20 blXor Bitwise = BXor
   21 blXor Logical = LXor
   22 
   23 blEQ :: OperatorType -> BinaryOperation
   24 blEQ Bitwise = BEQ
   25 blEQ Logical = LEQ
   26 
   27 blGT :: OperatorType -> BinaryOperation
   28 blGT Bitwise = BGT
   29 blGT Logical = LGT
   30 
   31 -- | Other functions
   32 
   33 calculateOps :: Integral a => a -> a -> [BinaryOperation] -> [a]
   34 calculateOps operand operand' = map (calculateOp operand operand')
   35 
   36 calculateOp :: Integral a => a -> a -> BinaryOperation -> a
   37 calculateOp operand operand' operation = doBinary operation operand' operand
   38 
   39 doBinary :: Integral a => BinaryOperation -> a -> a -> a
   40 doBinary Add = (+)
   41 doBinary Sub = (-)
   42 doBinary Mul = (*)
   43 doBinary Div = div
   44 doBinary Mod = mod
   45 doBinary LGT = lGT
   46 doBinary o   = error $ show o
   47 
   48 lGT :: (Integral a1) => a1 -> a1 -> a1
   49 lGT a b = fromBool $ a > b
   50 
   51 fromBool :: Integral a => Bool -> a
   52 fromBool False = 0
   53 fromBool True  = 1
   54 
   55 toBool :: Integral a => a -> Bool
   56 toBool a = a /= 0
   57 
   58 -- | Types
   59 data SMInstruction =
   60     SPure    !SPureInstruction
   61   | SIO      !IOInstruction
   62   deriving stock (Eq , Read , Show)
   63 
   64 data SPureInstruction =
   65     Cons     !Integer
   66   | Unary    !UnaryOperation
   67   | Binary   !BinaryOperation
   68   | Binaries [BinaryOperation]
   69   | Indexed  !IndexOperand !IndexedOperation
   70   | Halibut
   71   | Pick
   72   | Discard
   73   deriving stock (Eq , Read , Show)
   74 
   75 data IndexOperand = ITop | IImmediate !ImmediateIndex
   76   deriving stock (Eq , Read , Show)
   77 
   78 data UnaryOperation = Neg | BNot | LNot | UImmediate Integer BinaryOperation
   79   deriving stock (Eq , Read , Show)
   80 
   81 data BinaryOperation =
   82      Add | Sub | Mul | Div | Mod
   83   | BAnd | BOr | BXor | BEQ | BGT
   84   | LAnd | LOr | LXor | LEQ | LGT
   85   deriving stock (Eq , Read , Show)
   86 
   87 data IndexedOperation = Copy | Move | Slide
   88   deriving stock (Eq , Read , Show)
   89 
   90 data OperatorType = Bitwise | Logical
   91 
   92 -- | Internal
   93 
   94 printSM :: SMInstruction -> Text
   95 printSM (SPure i) = printSPure i
   96 printSM (SIO   i) = printIO i <> "S"
   97 
   98 printSPure :: SPureInstruction -> Text
   99 printSPure (Unary    i  ) = printUnary i
  100 printSPure (Indexed  i o) = toLowerShow o <> printIndexOperand i
  101 printSPure (Binary   i  ) = toLowerShow i
  102 printSPure (Binaries i  ) = printBinaries i
  103 printSPure           i    = toLowerShow i
  104 
  105 printBinaries :: (Foldable c, Functor c, Show i) => c i -> Text
  106 printBinaries il = fmconcat $ toLowerShow <$> il
  107 
  108 printUnary :: UnaryOperation -> Text
  109 printUnary (UImmediate i o) = toLowerShow o <> "I " <> show i
  110 printUnary             i    = toLowerShow i
  111 
  112 printIndexOperand :: IndexOperand -> Text
  113 printIndexOperand ITop           = ""
  114 printIndexOperand (IImmediate i) = "I " <> show i