never executed always true always false

    1 module HelVM.HelMA.Automata.WhiteSpace.Parser
    2   ( flipParseVisible
    3   , flipParseWhite
    4   , parse
    5   , parseForTest
    6   , parseFromTL
    7   , parseVisible
    8   , parseWhite
    9   ) where
   10 
   11 import           HelVM.HelMA.Automata.WhiteSpace.API.TokenType
   12 import           HelVM.HelMA.Automata.WhiteSpace.Lexer
   13 import           HelVM.HelMA.Automata.WhiteSpace.OperandParsers
   14 import           HelVM.HelMA.Automata.WhiteSpace.Token
   15 
   16 import           HelVM.HelMA.Automaton.API.IOTypes
   17 
   18 import           HelVM.HelMA.Automaton.Instruction
   19 import           HelVM.HelMA.Automaton.Instruction.Extras.Constructors
   20 
   21 import           HelVM.HelMA.Automaton.Types.LabelType
   22 
   23 import           HelVM.HelIO.Control.Safe
   24 import           HelVM.HelIO.Extra
   25 
   26 parseForTest ∷ LabelType → TokenType → Source → Safe InstructionList
   27 parseForTest formatType tokenType s = parse tokenType s formatType
   28 
   29 flipParseVisible ∷ LabelType → Source → Safe InstructionList
   30 flipParseVisible = flip parseVisible
   31 
   32 flipParseWhite ∷ LabelType → Source → Safe InstructionList
   33 flipParseWhite = flip parseWhite
   34 
   35 parseVisible ∷ Source → LabelType → Safe InstructionList
   36 parseVisible = parse VisibleTokenType
   37 
   38 parseWhite ∷ Source → LabelType → Safe InstructionList
   39 parseWhite = parse WhiteTokenType
   40 
   41 parse ∷ MonadSafe m ⇒ TokenType → Source → LabelType → m InstructionList
   42 parse tokenType = flip parseFromTL . tokenize tokenType
   43 
   44 parseFromTL ∷ MonadSafe m ⇒ LabelType → TokenList → m InstructionList
   45 parseFromTL ascii = repeatedlyM (parseInstruction ascii)
   46 
   47 parseInstruction ∷ MonadSafe m ⇒ LabelType → InstructionParser m
   48 parseInstruction     _ (S :     tl) = parseInstructionStackManipulation tl
   49 parseInstruction     _ (T : S : tl) = parseInstructionArithmetic        tl
   50 parseInstruction     _ (T : T : tl) = parseInstructionHeadAccess        tl
   51 parseInstruction ascii (N :     tl) = parseInstructionFlowControl ascii tl
   52 parseInstruction     _ (T : N : tl) = parseInstructionIO                tl
   53 parseInstruction     _          tl  = unrecognisedTokensIn "parseInstruction" tl
   54 
   55 parseInstructionStackManipulation ∷ MonadSafe m ⇒ InstructionParser m
   56 parseInstructionStackManipulation (S :     tl) = build <$> parseSymbol tl where build (symbol , tl') = (consI symbol  , tl')
   57 parseInstructionStackManipulation (T : S : tl) = build <$> parseIndex  tl where build (index  , tl') = (copyII  index , tl')
   58 parseInstructionStackManipulation (T : N : tl) = build <$> parseIndex  tl where build (index  , tl') = (slideII index , tl')
   59 parseInstructionStackManipulation (N : S : tl) = pure (dupI     , tl)
   60 parseInstructionStackManipulation (N : T : tl) = pure (swapI    , tl)
   61 parseInstructionStackManipulation (N : N : tl) = pure (discardI , tl)
   62 parseInstructionStackManipulation          tl  = unrecognisedTokensIn "parseInstructionStackManipulation" tl
   63 
   64 parseInstructionArithmetic ∷ MonadSafe m ⇒ InstructionParser m
   65 parseInstructionArithmetic (S : S : tl) = pure (addI , tl)
   66 parseInstructionArithmetic (S : T : tl) = pure (subI , tl)
   67 parseInstructionArithmetic (S : N : tl) = pure (mulI , tl)
   68 parseInstructionArithmetic (T : S : tl) = pure (divI , tl)
   69 parseInstructionArithmetic (T : T : tl) = pure (modI , tl)
   70 parseInstructionArithmetic          tl  = unrecognisedTokensIn "parseInstructionArithmetic" tl
   71 
   72 parseInstructionHeadAccess ∷ MonadSafe m ⇒ InstructionParser m
   73 parseInstructionHeadAccess (S : tl) = pure (storeI , tl)
   74 parseInstructionHeadAccess (T : tl) = pure (loadI  , tl)
   75 parseInstructionHeadAccess      tl  = unrecognisedTokensIn "parseInstructionHeadAccess" tl
   76 
   77 parseInstructionFlowControl ∷ MonadSafe m ⇒ LabelType → InstructionParser m
   78 parseInstructionFlowControl ascii (S : S : tl) = build <$> parseLabel ascii tl where build (label , tl') = (markSI  label , tl')
   79 parseInstructionFlowControl ascii (S : T : tl) = build <$> parseLabel ascii tl where build (label , tl') = (callSI label  , tl')
   80 parseInstructionFlowControl ascii (S : N : tl) = build <$> parseLabel ascii tl where build (label , tl') = (jumpSI label  , tl')
   81 parseInstructionFlowControl ascii (T : S : tl) = build <$> parseLabel ascii tl where build (label , tl') = (bEzSI   label  , tl')
   82 parseInstructionFlowControl ascii (T : T : tl) = build <$> parseLabel ascii tl where build (label , tl') = (bLtzSI  label  , tl')
   83 parseInstructionFlowControl     _ (T : N : tl) = pure (returnI , tl)
   84 parseInstructionFlowControl     _ (N : N : tl) = pure (End     , tl)
   85 parseInstructionFlowControl     _          tl  = unrecognisedTokensIn "parseInstructionFlowControl" tl
   86 
   87 parseInstructionIO ∷ MonadSafe m ⇒ InstructionParser m
   88 parseInstructionIO (S : S : tl) = pure (sOutputI    , tl)
   89 parseInstructionIO (S : T : tl) = pure (sOutputDecI , tl)
   90 parseInstructionIO (T : S : tl) = pure (mInputI     , tl)
   91 parseInstructionIO (T : T : tl) = pure (mInputDecI  , tl)
   92 parseInstructionIO          tl  = unrecognisedTokensIn "parseInstructionIO" tl
   93 
   94 unrecognisedTokensIn ∷ MonadSafe m ⇒ Text → TokenList → m a
   95 unrecognisedTokensIn name tl = liftErrorTupleList [("Unrecognised tokens in" , name) , ("Rest tokens" , show tl)]
   96 
   97 type InstructionParser m = ParserFromTokenList m Instruction