never executed always true always false

    1 module HelVM.HelMA.Automata.FALSE.Parser (
    2   parseSafe,
    3   parse,
    4   charToSimpleInstruction,
    5 ) where
    6 
    7 import           HelVM.HelMA.Automata.FALSE.Expression
    8 
    9 import           HelVM.HelMA.Automaton.API.IOTypes
   10 import           HelVM.HelMA.Automaton.Instruction
   11 import           HelVM.HelMA.Automaton.Instruction.Groups.IOInstruction
   12 import           HelVM.HelMA.Automaton.Instruction.Groups.SMInstruction
   13 import           HelVM.HelMA.Automaton.ReadPExtra
   14 
   15 import           HelVM.HelMA.Automaton.Instruction.Extras.Constructors
   16 
   17 import           HelVM.HelIO.Control.Safe
   18 import           HelVM.HelIO.Extra                                      hiding (runParser)
   19 import           HelVM.HelIO.ReadText
   20 
   21 import           Data.Char
   22 
   23 import           Text.ParserCombinators.ReadP                           hiding (many)
   24 
   25 parseSafe :: Source -> Safe ExpressionList
   26 parseSafe = parse
   27 
   28 parse :: MonadSafe m => Source -> m ExpressionList
   29 parse = runParser vlParser
   30 
   31 vlParser :: ReadP ExpressionList
   32 vlParser = many (skipSpaces *> valueParser) <* skipSpaces
   33 
   34 valueParser :: ReadP Expression
   35 valueParser = lambdaParser <|> commentParser <|> writeStringParser <|> constParser <|> refParser <|> simpleParser
   36 
   37 lambdaParser :: ReadP Expression
   38 lambdaParser = Lambda <$> (char '[' *> vlParser <* char ']')
   39 
   40 commentParser :: ReadP Expression
   41 commentParser = Comment <$> (char '{' *> many (notChar '}') <* char '}')
   42 
   43 writeStringParser :: ReadP Expression
   44 writeStringParser = Str <$> stringParser
   45 
   46 constParser :: ReadP Expression
   47 constParser = Inst . consI . fromIntegral <$> naturalParser
   48 
   49 refParser :: ReadP Expression
   50 refParser = refFromChar <$> letterAscii
   51 
   52 simpleParser :: ReadP Expression
   53 simpleParser = fromJustWithText "imposible" . charToSimpleInstruction <$> oneOf simpleInstructionChars
   54 
   55 simpleInstructionChars :: String
   56 simpleInstructionChars = "$%\\@`+-*/_&|~<=!?#:;^,.ß"
   57 
   58 charToSimpleInstruction :: Char -> Maybe Expression
   59 charToSimpleInstruction '$'  = inst dupI
   60 charToSimpleInstruction '%'  = inst discardI
   61 charToSimpleInstruction '\\' = inst swapI
   62 charToSimpleInstruction '@'  = inst rotI
   63 charToSimpleInstruction '`'  = inst copyTI
   64 
   65 charToSimpleInstruction '+'  = inst addI
   66 charToSimpleInstruction '-'  = inst subI
   67 charToSimpleInstruction '*'  = inst mulI
   68 charToSimpleInstruction '/'  = inst divI
   69 charToSimpleInstruction '_'  = inst negI
   70 
   71 charToSimpleInstruction '&'  = inst $ binary BAnd
   72 charToSimpleInstruction '|'  = inst $ binary BOr
   73 charToSimpleInstruction '~'  = inst $ unary BNot
   74 
   75 charToSimpleInstruction '<'  = inst $ binary LGT
   76 charToSimpleInstruction '='  = inst $ binary LEQ
   77 
   78 charToSimpleInstruction '!'  = pure Exec
   79 charToSimpleInstruction '?'  = pure Cond
   80 charToSimpleInstruction '#'  = pure While
   81 
   82 charToSimpleInstruction ':'  = pure Store
   83 charToSimpleInstruction ';'  = pure Fetch
   84 
   85 charToSimpleInstruction '^'  = inst $ sio InputChar
   86 charToSimpleInstruction ','  = inst $ sio OutputChar
   87 charToSimpleInstruction '.'  = inst $ sio OutputDec
   88 charToSimpleInstruction 'ß'  = pure Flush
   89 
   90 charToSimpleInstruction  _   = Nothing
   91 
   92 inst :: Instruction -> Maybe Expression
   93 inst = pure . Inst
   94 
   95 -- | Extra
   96 
   97 refFromChar :: Char -> Expression
   98 refFromChar c = Ref $ fromIntegral $ ord (toLower c) - ord 'a'
   99 
  100 naturalParser :: ReadP Natural
  101 naturalParser = naturalLiteralParser <|> ordCharLiteralParser
  102 
  103 naturalLiteralParser :: ReadP Natural
  104 naturalLiteralParser = readUnsafe <$> many1 digit
  105 
  106 ordCharLiteralParser :: Integral a => ReadP a
  107 ordCharLiteralParser = fromIntegral . ord <$> (skipSpacesAndChar '\'' *> anyChar)
  108 
  109 stringParser :: ReadP String
  110 stringParser = skipSpacesAndChar '"' *> many (notChar '"') <* char '"'
  111 
  112 skipSpacesAndChar :: Char -> ReadP Char
  113 skipSpacesAndChar c = skipSpaces *> char c