never executed always true always false

    1 module HelVM.HelMA.Automata.WhiteSpace.Parser (
    2   parseForTest,
    3   flipParseVisible,
    4   flipParseWhite,
    5   parseVisible,
    6   parseWhite,
    7   parse,
    8   parseFromTL
    9 ) where
   10 
   11 import           HelVM.HelMA.Automata.WhiteSpace.Lexer
   12 import           HelVM.HelMA.Automata.WhiteSpace.OperandParsers
   13 import           HelVM.HelMA.Automata.WhiteSpace.Token
   14 
   15 import           HelVM.HelMA.Automaton.API.IOTypes
   16 
   17 import           HelVM.HelMA.Automaton.Instruction
   18 import           HelVM.HelMA.Automaton.Instruction.Extras.Constructors
   19 
   20 import           HelVM.HelMA.Automaton.Types.FormatType
   21 import           HelVM.HelMA.Automaton.Types.TokenType
   22 
   23 import           HelVM.HelIO.Control.Safe
   24 import           HelVM.HelIO.Extra
   25 
   26 parseForTest :: FormatType -> TokenType -> Source -> Safe InstructionList
   27 parseForTest formatType tokenType s = parse tokenType s formatType
   28 
   29 flipParseVisible :: FormatType -> Source -> Safe InstructionList
   30 flipParseVisible = flip parseVisible
   31 
   32 flipParseWhite :: FormatType -> Source -> Safe InstructionList
   33 flipParseWhite = flip parseWhite
   34 
   35 parseVisible :: Source -> FormatType -> Safe InstructionList
   36 parseVisible = parse VisibleTokenType
   37 
   38 parseWhite :: Source -> FormatType -> Safe InstructionList
   39 parseWhite = parse WhiteTokenType
   40 
   41 parse :: MonadSafe m => TokenType -> Source -> FormatType -> m InstructionList
   42 parse tokenType = flip parseFromTL . tokenize tokenType
   43 
   44 parseFromTL :: MonadSafe m => FormatType -> TokenList -> m InstructionList
   45 parseFromTL ascii = repeatedlyM (parseInstruction ascii)
   46 
   47 parseInstruction :: MonadSafe m => FormatType -> 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 => FormatType -> 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