Parser.hs

module Parser where

import Debug
import Expr
import Builtins
import PrattParser
import DecompressString
import Codepage
import Text.Parsec
import Text.Parsec.Char
import Control.Monad (forM, foldM)
import qualified Data.Map as Map
import Data.List (elemIndex)
import Data.Maybe (catMaybes)

-- Parser state
data PState = PState {varStack :: [(Maybe ELabel, Maybe ELabel)],
                      varSupply :: Int,
                      numLines :: Int,
                      unmarked :: [Int]}

-- Parser type
type Parser = Parsec String PState

-- Unwrapped parser, giving strings for errors
parseExpr :: String -> Either String [Exp [Lit Scheme]]
parseExpr str = case runParser multiline initState "" str of
  Left err -> Left $ show err
  Right val -> Right val
  where initState = PState [] 0 0 []

-- Generate a new expression variable
genVar :: String -> Parser ELabel
genVar s = do
  stat <- getState
  let var = s ++ show (varSupply stat)
  putState stat{varSupply = varSupply stat + 1}
  return $ trace' 2 ("created " ++ var) var

-- Push a block, possibly with generated expression variables
pushBlock :: (Bool, Bool) -> Parser ()
pushBlock (gen1, gen2) = do
  var1 <- if gen1
          then Just <$> genVar "x"
          else return Nothing
  var2 <- if gen2
          then Just <$> genVar "x"
          else return Nothing
  stat <- getState
  putState stat{varStack = trace' 2 ("pushed " ++ show var1 ++ ", " ++ show var2) $ (var1, var2) : varStack stat}

-- Append a block, possibly with generated expression variables
appendBlock :: (Bool, Bool) -> Parser (Maybe ELabel, Maybe ELabel)
appendBlock (gen1, gen2) = do
  var1 <- if gen1
          then Just <$> genVar "y"
          else return Nothing
  var2 <- if gen2
          then Just <$> genVar "y"
          else return Nothing
  stat <- getState
  putState stat{varStack = varStack stat ++ [(var1, var2)]}
  return $ trace' 2 ("appended " ++ show var1 ++ ", " ++ show var2) (var1, var2)

-- Create a variable at a specific stack index
putVarAt :: Int -> Parser ELabel
putVarAt ix = do
  newVar <- genVar "z"
  stat <- getState
  let (before, (var1, var2) : after) = splitAt (div ix 2) $ varStack stat
  putState $ if even ix
             then stat{varStack = before ++ (Just newVar, var2) : after}
             else stat{varStack = before ++ (var1, Just newVar) : after}
  return newVar

-- Peek at a variable from the stack; extend stack if necessary
peekVar :: Int -> Parser ELabel
peekVar ix = do
  stack <- varStack <$> getState
  let len = length stack
  if ix >= 2 * len
    then do
      vars <- forM [0 .. div ix 2 - len - 1] $ const $ appendBlock (False, False)
      newVar <-
        if even ix
        then do
          (Just var, Nothing) <- appendBlock (True, False)
          return var
        else do
          (Nothing, Just var) <- appendBlock (False, True)
          return var
      return $ message stack newVar
    else
      let (var1, var2) = stack !! div ix 2
          maybeVar = if even ix then var1 else var2
      in case maybeVar of
           Just var -> return $ message stack var
           Nothing -> do
             var <- putVarAt ix
             return $ message stack var
  where message stack var = trace' 2 ("peeked " ++ show ix ++ " from " ++ show stack ++ ", got " ++ show var) var

-- Pop a 2-variable block off the stack
popBlock :: Parser (Maybe ELabel, Maybe ELabel)
popBlock = do
  stat <- getState
  let stack = varStack stat
  putState stat{varStack = trace' 2 ("popping from " ++ show stack) $ tail stack}
  return $ head stack

-- Parse a right paren or be at end of line
rParen :: Parser ()
rParen = (char ')' >> return ()) <|> (lookAhead endOfLine >> return ()) <|> lookAhead eof

-- Eat a lone space character (not followed by sub- or superscipt)
soleSpace :: Parser ()
soleSpace = try $ char ' ' >> notFollowedBy (oneOf "⁰¹²³⁴⁵⁶⁷⁸⁹₀₁₂₃₄₅₆₇₈₉")

-- List of builtins applied to overflowing line numbers
lineFuncs :: [Exp [Lit Scheme]]
lineFuncs = [bins "argdup",
             bins "flip",
             bins "map",
             bins "zip",
             bins "hook"]

-- Parse a multiline expression, where some lines are marked with a leading space
multiline :: Parser [Exp [Lit Scheme]]
multiline = do
  lineExprs <- sepBy1 (try markedLine <|> unmarkedLine) endOfLine
  numLn <- numLines <$> getState
  unmarkeds <- unmarked <$> getState
  return $ map (updateLineNums numLn unmarkeds) lineExprs
  where markedLine = do
          soleSpace
          expr <- lineExpr
          stat <- getState
          putState stat{numLines = numLines stat + 1}
          return (True, expr)
        unmarkedLine = do
          expr <- lineExpr
          stat <- getState
          putState stat{unmarked = unmarked stat ++ [numLines stat],
                        numLines = numLines stat + 1}
          return (False, expr)
        updateLineNums numLn unmark (marked, expr) = go expr
          where numUnmark = length unmark
                go (ELine n)
                  | marked, lNum <- mod n numLn, rounds <- div n numLn =
                      case rounds of 0 -> ELine lNum
                                     k -> EApp (lineFuncs !! (k-1)) $ ELine lNum
                  | lNum <- mod n numUnmark, rounds <- div n numUnmark =
                      case rounds of 0 -> ELine (unmark !! lNum)
                                     k -> EApp (lineFuncs !! (k-1)) $ ELine (unmark !! lNum)
                go (EApp e1 e2) = EApp (go e1) (go e2)
                go (EOp e1 e2 e3) = EOp (go e1) (go e2) (go e3)
                go (EAbs name exp) = EAbs name (go exp)
                go (ELet name exp body) = ELet name (go exp) (go body)
                go e = e
                
-- Parse a line of Husk code
lineExpr :: Parser (Exp [Lit Scheme])
lineExpr = do
  state <- getState
  putState state{varStack = []}
  expr <- expression
  overflowVars <- varStack <$> getState
  lambdified <- lambdify expr $ trace' 2 ("lambdifying " ++ show expr ++ " with " ++ show overflowVars) overflowVars
  return $ trace' 2 (show lambdified) lambdified

-- Add blocks of lambdas to an expression
lambdify :: Exp [Lit Scheme] -> [(Maybe String, Maybe String)] -> Parser (Exp [Lit Scheme])
lambdify expr pairs = go expr (reverse pairs) []
  where go expr ((Just var1, Just var2) : rest) vars = do
          innerExpr <- go expr rest (vars ++ [EVar var2])
          return $ EAbs var2 $ ELet var1 (EApp (bins "flipap") $ EVar var2) innerExpr
        go expr ((Just var1, Nothing)   : rest) vars = do
          innerExpr <- go expr rest vars
          return $ EAbs var1 innerExpr
        go expr ((Nothing,   Just var2) : rest) vars = do
          innerExpr <- go expr rest (vars ++ [EVar var2])
          return $ EAbs var2 innerExpr
        go expr ((Nothing,   Nothing)   : rest) vars = do
          var <- genVar "c"
          innerExpr <- go expr rest vars
          return $ EAbs (var ++ "_") innerExpr
        go expr [] vars = return $ foldl EApp expr vars

-- Parse an expression
expression :: Parser (Exp [Lit Scheme])
expression = mkPrattParser opTable term
  where term = between (char '(') rParen expression <|> builtin <|> try float <|> integer <|> character <|> str <|> comprstr <|> intseq <|> lambda <|> try lambdaArg <|> subscript
        opTable = [[InfixL $ optional soleSpace >> return (EOp invisibleOp)]]
        invisibleOp = bins "com4 com3 com2 com app"

-- Parse a builtin
builtin :: Parser (Exp [Lit Scheme])
builtin = do
  label <- oneOf commands
  return $ cmd label

-- Parse an integer
integer :: Parser (Exp [Lit Scheme])
integer = do
  digits <- many1 digit
  return $ ELit [Value digits numType]
  where numType = Scheme [] $ CType [] $ TConc TNum

-- Parse a float
float :: Parser (Exp [Lit Scheme])
float = do
  prefix <- many digit
  char '.'
  suffix <- many digit
  case (prefix,suffix) of
    ("","") -> return $ ELit [Value "0.5" numType]
    (_ ,"") -> return $ ELit [Value (prefix ++ ".5") numType]
    ("", _) -> return $ ELit [Value ("0." ++ suffix) numType]
    (_ , _) -> return $ ELit [Value (prefix ++ "." ++ suffix) numType]
  where numType = Scheme [] $ CType [] $ TConc TNum
 
-- Parse a character
character :: Parser (Exp [Lit Scheme])
character = do
  quote <- char '\''
  coded <- anyChar
  let c :: Char
      c = toEnum $ findByte coded
  return $ ELit [Value (show c) $ Scheme [] $ CType [] $ TConc TChar]

-- Parse a string
str :: Parser (Exp [Lit Scheme])
str = do
  quote <- char '"'
  s <- content
  quote2 <- (char '"' >> return ()) <|> (lookAhead endOfLine >> return ()) <|> lookAhead eof
  return $ ELit [Value (show s) $ Scheme [] $ CType [] $ TList (TConc TChar)]
  where
    content = do
      codedText <- many $ noneOf "\"\n\\"
      plainText <- return $ map decode codedText
      maybeEscape <- optionMaybe $ char '\\' >> anyChar
      case maybeEscape of
        Nothing -> return plainText
        Just c -> do plainText2 <- content; return $ plainText ++ toEnum (findByte c) : plainText2
    decode '¶' = '\n'
    decode '¨' = '"'
    decode '¦' = '\\'
    decode  c  = toEnum $ findByte c

-- Parse a compressed string
comprstr :: Parser (Exp [Lit Scheme])
comprstr = do
  quote <- char '¨'
  s <- content
  quote2 <- (char '¨' >> return ()) <|> (lookAhead endOfLine >> return ()) <|> lookAhead eof
  return $ ELit [Value (show $ s) $ Scheme [] $CType [] $ TList (TConc TChar)]
  where
    content = do
      comprText <- many $ noneOf "¨\n"
      decomprText <- return $ decompressString comprText
      return $ map decode decomprText
    decode '¶' = '\n'
    decode  c  =  c

-- Parse an integer sequence
intseq :: Parser (Exp [Lit Scheme])
intseq = do
  iseqCommand <- char 'İ'
  seqId <- anyChar
  return $ EApp (bins "intseq") $ ELit [Value (show seqId) $ Scheme [] $ CType [] $ TConc TChar]

-- Parse a generalized lambda
lambda :: Parser (Exp [Lit Scheme])
lambda = do
  lam <- oneOf "λμξφψχ"
  let blocks = case lam of
        'λ' -> 1
        'μ' -> 2
        'ξ' -> 3
        'φ' -> 1
        'ψ' -> 2
        'χ' -> 3
  expr <- wrap expression blocks
  rParen
  return $ if lam `elem` "φψχ" then EApp (bins "fix") expr else expr
  where
    wrap parser blocks = do
      sequence $ replicate blocks $ pushBlock (False, False)
      expr <- parser
      vars <- sequence $ replicate blocks popBlock
      lambdify expr vars

-- Parse a lambda argument
lambdaArg :: Parser (Exp [Lit Scheme])
lambdaArg = do
  supStr <- try (pure <$> oneOf sups) <|> (char ' ' >> many1 (oneOf sups))
  let digits = catMaybes $ (`elemIndex` sups) <$> supStr
      supNum = foldl1 (\n d -> 10*n + d) digits
  var <- peekVar supNum
  return $ EVar var
  where sups = "⁰¹²³⁴⁵⁶⁷⁸⁹"

-- Parse a subscript; used as line numbers
subscript :: Parser (Exp [Lit Scheme])
subscript = do
  subStr <- try (pure <$> oneOf subs) <|> (char ' ' >> many1 (oneOf subs))
  let digits = catMaybes $ (`elemIndex` subs) <$> subStr
      subNum = foldl1 (\n d -> 10*n + d) digits
  return $ ELine subNum
  where subs  = "₀₁₂₃₄₅₆₇₈₉"