Parser.hs

{-# LANGUAGE FlexibleInstances #-}

module Language.Elsa.Parser
  ( parse
  , parseFile
  ) where

import qualified Control.Exception          as Ex
import           Control.Monad          (void)
import           Text.Megaparsec hiding (parse)
import qualified Text.Megaparsec.Char.Lexer as L
import           Text.Megaparsec.Char
import           Text.Megaparsec.Stream ()
import qualified Data.List as L
import           Language.Elsa.Types
import           Language.Elsa.UX
import           Data.List.NonEmpty         as NE

type Parser = Parsec SourcePos Text

--------------------------------------------------------------------------------
parse :: FilePath -> Text -> SElsa
--------------------------------------------------------------------------------
parse = parseWith elsa

parseWith  :: Parser a -> FilePath -> Text -> a
parseWith p f s = case runParser (whole p) f s of
                    Left pErrs -> Ex.throw (mkErrors pErrs f s) -- panic (show err) (posSpan . NE.head . errorPos $ err)
                    Right e  -> e

mkErrors :: ParseErrorBundle Text SourcePos -> FilePath -> Text -> [UserError]
mkErrors b f s = [ mkError (parseErrorPretty e) (span e) | e <- NE.toList (bundleErrors b)]
  where
    span e = let (l, c) = lineCol s (errorOffset e) in posSpan (SourcePos f (mkPos l) (mkPos c))

-- PosState looks relevant for finding line/column, but I (Justin) don't know how to use it

lineCol :: String -> Int -> (Int, Int)
lineCol s i = foldl f (1, 1) (Prelude.take i s)
  where
    f (l, c) char = if char == '\n' then (l + 1, 1) else (l, c + 1)

instance ShowErrorComponent SourcePos where
  showErrorComponent = show
 

-- panic msg sp = throw [Error msg sp]
-- instance Located (ParseError SourcePos Text) where
--  sourceSpan = posSpan . errorPos

-- instance PPrint (ParseError SourcePos Text) where
--   pprint = show

--------------------------------------------------------------------------------
parseFile :: FilePath -> IO SElsa
--------------------------------------------------------------------------------
parseFile f = parse f <$> readFile f

-- https://mrkkrp.github.io/megaparsec/tutorials/parsing-simple-imperative-language.html

-- | Top-level parsers (should consume all input)
whole :: Parser a -> Parser a
whole p = sc *> p <* eof

-- RJ: rename me "space consumer"
sc :: Parser ()
sc = L.space (void spaceChar) lineCmnt blockCmnt
  where
    lineCmnt  = L.skipLineComment  "--"
    blockCmnt = L.skipBlockComment "{-" "-}"

-- | `symbol s` parses just the string s (and trailing whitespace)
symbol :: String -> Parser String
symbol = L.symbol sc

arrow :: Parser String
arrow = symbol "->"

colon :: Parser String
colon = symbol ":"

equal :: Parser String
equal = symbol "="

lam :: Parser String
lam = symbol "\\"


-- | 'parens' parses something between parenthesis.
parens :: Parser a -> Parser a
parens = betweenS "(" ")"

betweenS :: String -> String -> Parser a -> Parser a
betweenS l r = between (symbol l) (symbol r)

-- | `lexeme p` consume whitespace after running p
lexeme :: Parser a -> Parser (a, SourceSpan)
lexeme p = L.lexeme sc (withSpan p)

-- | `rWord`
rWord   :: String -> Parser SourceSpan
rWord w = snd <$> (withSpan (string w) <* notFollowedBy alphaNumChar <* sc)

-- | list of reserved words
keywords :: [Text]
keywords = [ "let"  , "eval"  , "conf" ]

-- | `identifier` parses identifiers: lower-case alphabets followed by alphas or digits
identifier :: Parser (String, SourceSpan)
identifier = lexeme (p >>= check)
  where
    p       = (:) <$> letterChar <*> many identChar -- alphaNumChar
    check x = if x `elem` keywords
                then fail $ "keyword " ++ show x ++ " cannot be an identifier"
                else return x

identChar :: Parser Char
identChar =  alphaNumChar
         <|> oneOf ['_', '#', '\'']

-- | `binder` parses BareBind, used for let-binds and function parameters.
binder :: Parser SBind
binder = uncurry Bind <$> identifier

withSpan' :: Parser (SourceSpan -> a) -> Parser a
withSpan' p = do
  p1 <- getSourcePos
  f  <- p
  p2 <- getSourcePos
  return (f (SS p1 p2))

withSpan :: Parser a -> Parser (a, SourceSpan)
withSpan p = do
  p1 <- getSourcePos
  x  <- p
  p2 <- getSourcePos
  return (x, SS p1 p2)

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
elsa :: Parser SElsa
elsa = do
  items <- many elsaItem
  pure $
    Elsa
      { defns = [d | DefnItem d <- items],
        evals = [e | EvalItem e <- items]
      }

elsaItem :: Parser SElsaItem
elsaItem = 
  (DefnItem <$> defn) <|> (EvalItem <$> eval)

defn :: Parser SDefn
defn = do
  rWord "let"
  b <- binder <* equal
  e <- expr
  return (Defn b e)

eval :: Parser SEval
eval = do
  kind <- (rWord "eval" >> return Regular) <|> (rWord "conf" >> return Conf)
  name  <- binder
  colon
  root  <- expr
  steps <- many step
  return $ Eval kind name root steps

step :: Parser SStep
step = Step <$> eqn <*> expr

eqn :: Parser SEqn
eqn = withSpan' parseEqn

parseEqn :: Parser (SourceSpan -> Eqn SourceSpan)
parseEqn = try parseUnEqn <|> parseRegEqn

parseUnEqn :: Parser (SourceSpan -> Eqn SourceSpan)
parseUnEqn = do
  void $ char '<'
  op <- choice
    [ try (symbol "n*=") >> return EqUnNormOrdTrans
    , try (symbol "p*=") >> return EqUnAppOrdTrans
    , try (symbol "b=")  >> return EqUnBeta
    , try (symbol "n=") >> return EqUnNormOrd
    , try (symbol "p=") >> return EqUnAppOrd
    , try (symbol "e=")  >> return EqUnEta
    , try (symbol "*=")  >> return EqUnTrans
    ]
  return $ \sp -> Eqn op Nothing sp

parseRegEqn :: Parser (SourceSpan -> Eqn SourceSpan)
parseRegEqn = do
  void $ char '='
  op <- choice
    [ try (string "n*") >> return EqNormOrdTrans
    , try (string "p*") >> return EqAppOrdTrans
    , try (string "n") >> return EqNormOrd
    , try (string "p") >> return EqAppOrd
    , try (string "a")  >> return EqAlpha
    , try (string "b")  >> return EqBeta
    , try (string "e")  >> return EqEta
    , try (string "d")  >> return EqDefn
    , try (string "*")  >> return EqTrans
    , try (string "~")  >> return EqNormTrans
    ]
  mChk <- optional parseNormCheck
  void $ symbol ">"
  return $ \sp -> Eqn op mChk sp

parseNormCheck :: Parser NormCheck
parseNormCheck = do
  void $ char ':'
  choice
    [ char 's' >> return Strong
    , char 'w' >> return Weak
    , char 'h' >> return Head
    ]

expr :: Parser SExpr
expr =  try lamExpr
    <|> try appExpr
    <|> try idExpr
    <|> parenExpr

parenExpr :: Parser SExpr
parenExpr = parens expr

idExpr :: Parser SExpr
idExpr = uncurry EVar <$> identifier

appExpr :: Parser SExpr
appExpr  = apps <$> funExpr <*> sepBy1 funExpr sc
  where
    apps = L.foldl' (\e1 e2 -> EApp e1 e2 (tag e1 `mappend` tag e2))

funExpr :: Parser SExpr
funExpr = try idExpr <|> parenExpr

lamExpr :: Parser SExpr
lamExpr = do
  lam
  xs    <- sepBy binder sc <* arrow
  e     <- expr
  return (mkLam xs e)