Parser.hs

-- A simple parser for the Frank language
{-# LANGUAGE PackageImports #-}
module Parser (runTokenProgParse, runTokenParse, tm) where

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class

import Data.Char
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.HashSet as HashSet

import Text.Trifecta
import Text.Trifecta.Delta
import "indentation-trifecta" Text.Trifecta.Indentation

import Text.Parser.Token as Tok
import Text.Parser.Token.Style
import qualified Text.Parser.Token.Highlight as Hi

import qualified Data.ByteString.Char8 as Char8

import BwdFwd
import Syntax
import ParserCommon
import Debug

---------------------------
-- Top-level definitions --
---------------------------

prog :: (MonadicParsing m) => m (Prog Raw, [FilePath])
prog = do whiteSpace
          (tts,fs) <- liftM eplist (many defOrInc)
          eof -- disallows gibberish at the end of the file
          return $ (MkProg tts,fs)

defOrInc :: (MonadicParsing m) => m (Either (TopTm Raw) FilePath)
defOrInc = choice [Left <$> def,
                   Right <$> (reserved "include" >> identifier)]


def :: MonadicParsing m => m (TopTm Raw)
def = attachLoc (DataTm <$> dataDef <|>
                 SigTm <$> handlerTopSig <|>
                 ClsTm <$> handlerTopCls <|>
                 ItfAliasTm <$> itfAliasDef <|>
                 ItfTm <$> itfDef)

dataDef :: MonadicParsing m => m (DataT Raw)
dataDef = attachLoc $ do reserved "data"
                         name <- identifier
                         ps <- many tyVar
                         symbol "="
                         cs <- localIndentation Gt ctrList
                         return $ DT name ps cs

tyVar :: MonadicParsing m => m (Id, Kind)
tyVar = (\x -> (x, ET)) <$> brackets evar <|>
        (\x -> (x, VT)) <$> identifier

evar :: MonadicParsing m => m Id
evar = do mx <- optional identifier
          case mx of
            Nothing -> return "£"
            Just x -> return x

ctrList :: MonadicParsing m => m [Ctr Raw]
ctrList = sepBy ctr (symbol "|")

ctr :: MonadicParsing m => m (Ctr Raw)
ctr = attachLoc $ Ctr <$> identifier <*> many vtype'

handlerTopSig :: MonadicParsing m => m (MHSig Raw)
handlerTopSig = attachLoc $ Sig <$> (try $ identifier <* symbol ":")        -- try: commit after colon
                                <*> sigType

-- As the outer braces are optional in top-level signatures we require
-- that plain pegs must have explicit ability brackets.
--
-- The following collections of signatures are equivalent:
--
--   f : {A -> B -> C}  and  f : A -> B -> C
--   x : {Int}  and  x : {[]Int}  and x : []Int
--
-- A signature of the form
--
--   x : Int
--
-- is not currently valid. Once we add support for top level values it
-- will become valid, but will not mean the same thing as:
--
--   x : []Int
sigType :: MonadicParsing m => m (CType Raw)
sigType = (do a <- getLoc
              ct <- ctypeOld
              rest <- optional (symbol "->" *> ctypeOldNoBrac)
              return $
                case rest of
                  Nothing -> modifyAnn a ct
                  Just (CType ports peg a') ->
                        CType (Port [] (SCTy ct a') a' : ports) peg a) <|>
          -- TODO: LC: Integrate the new syntax properly...
          -- Part of new syntax [...]{... -> A} instead of {... -> [...]A}
          try ctypeNew <|>
          attachLoc (do ports <- some (try (port <* symbol "->"))
                        peg <- peg
                        return $ CType ports peg) <|>
          attachLoc (do peg <- pegExplicit
                        return $ CType [] peg)

handlerTopCls :: MonadicParsing m => m (MHCls Raw)
handlerTopCls = provideLoc $ \a -> do
  (name, ps) <- try $ do name <- identifier
                         ps <- choice [some pattern, symbol "!" >> return []]
                         symbol "="
                         return (name, ps)
  seq <- localIndentation Gt tm
  return $ MHCls name (Cls ps seq a) a

itfDef :: MonadicParsing m => m (Itf Raw)
itfDef = attachLoc $ do
             reserved "interface"
             name <- identifier
             ps <- many tyVar
             symbol "="
             xs <- localIndentation Gt $ sepBy1 cmdDef (symbol "|")
             return (Itf name ps xs)

cmdDef :: MonadicParsing m => m (Cmd Raw)
cmdDef = attachLoc $ do cmd <- identifier
                        ps <- many tyVar  -- polymorphic commands
                        symbol ":"
                        (xs,y) <- cmdDefType
                        return (Cmd cmd ps xs y)

-- input types, output type
cmdDefType :: MonadicParsing m => m ([VType Raw], VType Raw)
cmdDefType = do vs <- sepBy1 vtype (symbol "->")
                if length vs == 1 then return ([],head vs)
                else return (init vs, last vs)

itfAliasDef :: MonadicParsing m => m (ItfAlias Raw)
itfAliasDef = attachLoc $ do
  (name, ps) <- try $ do reserved "interface"
                         name <- identifier
                         ps <- many tyVar
                         symbol "="
                         symbol "["
                         return (name, ps)
  m <- itfInstances
  symbol "]"
  return $ ItfAlias name ps m

-----------
-- Types --
-----------

-- Supports both syntaxes [...]{... -> A} and {... -> [...]A}
ctype :: MonadicParsing m => m (CType Raw)
ctype = ctypeNew <|> ctypeOld

-- New syntax [...]{... -> A}, must have explicit [...]
ctypeNew :: MonadicParsing m => m (CType Raw)
ctypeNew = do ab <- abExplicit
              sndPart ab
  where
  sndPart :: MonadicParsing m => Ab Raw -> m (CType Raw)
  sndPart ab = braces (attachLoc $ do ports <- many (try (port <* symbol "->"))
                                      peg <- pegSndPart ab
                                      return $ CType ports peg)
  pegSndPart :: MonadicParsing m => Ab Raw -> m (Peg Raw)
  pegSndPart ab = attachLoc $ Peg ab <$> vtype

-- Old syntax {... -> [...]A}, does not need to have explicit [...]
ctypeOld :: MonadicParsing m => m (CType Raw)
ctypeOld = braces (ctypeOldNoBrac)

ctypeOldNoBrac :: MonadicParsing m => m (CType Raw)
ctypeOldNoBrac = attachLoc $ do ports <- many (try (port <* symbol "->"))
                                peg <- peg
                                return $ CType ports peg

port :: MonadicParsing m => m (Port Raw)
port = attachLoc $ Port <$> portAdjs <*> vtype

portAdjs :: MonadicParsing m => m [Adjustment Raw]
portAdjs = do mAdjs <- optional $ angles (do adps <- portAdps
                                             extensions <- portExtensions
                                             return $ adps ++ extensions)
              case mAdjs of
                Nothing   -> return []
                Just adjs -> return adjs

portAdps :: MonadicParsing m => m [Adjustment Raw]
portAdps = try (do adps <- sepBy (attachLoc $ AdaptorAdj <$> adaptor) (symbol ",")
                   symbol "|"
                   return adps) <|>
           return []

portExtensions :: MonadicParsing m => m [Adjustment Raw]
portExtensions = sepBy consAdj (symbol ",")

peg :: MonadicParsing m => m (Peg Raw)
peg = attachLoc $ Peg <$> ab <*> vtype

-- peg with explicit ability
pegExplicit :: MonadicParsing m => m (Peg Raw)
pegExplicit = attachLoc $ Peg <$> abExplicit <*> vtype

adjs :: MonadicParsing m => m [Adjustment Raw]
adjs = do mAdjs <- optional $ angles (sepBy adj (symbol ","))
          case mAdjs of
            Nothing   -> return []
            Just adjs -> return adjs

adj :: MonadicParsing m => m (Adjustment Raw)
adj = (attachLoc $ AdaptorAdj <$> adaptor) <|>
      consAdj




consAdj :: MonadicParsing m => m (Adjustment Raw)
consAdj = attachLoc $ do x <- identifier
                         ts <- many tyArg
                         return $ ConsAdj x ts

-- TODO: LC: Name consistently `instances` or `instantiations`
itfInstances :: MonadicParsing m => m (ItfMap Raw)
itfInstances = do
  a <- getLoc
  insts <- sepBy itfInstance (symbol ",")
  return $ foldl addInstanceToItfMap (ItfMap M.empty a) insts

itfInstance :: MonadicParsing m => m (Id, [TyArg Raw])
itfInstance = do x <- identifier
                 ts <- many tyArg
                 return (x, ts)

ab :: MonadicParsing m => m (Ab Raw)
ab = do mxs <- optional $ abExplicit
        case mxs of
          Nothing -> provideLoc $ \a ->
            return $ Ab (AbVar "£" a) (ItfMap M.empty a) a
          Just ab -> return ab

abExplicit :: MonadicParsing m => m (Ab Raw)
abExplicit = brackets abBody

-- 0 | 0|Interfaces | E|Interfaces | Interfaces
abBody :: MonadicParsing m => m (Ab Raw)
abBody = provideLoc $ \a ->
           -- closed ability: [0] or [0 | i_1, ... i_n]
           (do symbol "0"
               m <- option (ItfMap M.empty a) (symbol "|" *> itfInstances)
               return $ Ab (EmpAb a) m a) <|>
           -- open ability:   [i_1, ..., i_n] (implicitly e := £) or
           -- [e | i_1, ..., i_n]
           (do e <- option (AbVar "£" a)
                      (try $ AbVar <$> identifier <* symbol "|" <*> pure a)
               m <- itfInstances
               return $ Ab e m a)

-- This parser gives higher precedence to MkDTTy when coming across "X"
-- E.g., the type "X" becomes   MkDTTy "X" []   (instead of MkTVar "X")
vtype :: MonadicParsing m => m (VType Raw)
vtype = try dataInstance <|> -- could possibly also be a MKTvar (determined
                                 -- during refinement)
             vtype'

-- This parser gives higher precedence to MkTVar when coming across "X"
-- E.g., the type "X" becomes   MkTVar "X"   (instead of MkDTTy "X" [])
-- By writing "(X)" one can escape back to vtype
vtype' :: MonadicParsing m => m (VType Raw)
vtype' = parens vtype <|>
              (attachLoc $ SCTy <$> try ctype) <|>
              (attachLoc $ StringTy <$ reserved "String") <|>
              (attachLoc $ FloatTy <$ reserved "Float") <|>
              (attachLoc $ IntTy <$ reserved "Int") <|>
              (attachLoc $ CharTy <$ reserved "Char") <|>
              -- could possibly also be a MkDTTy (determined during refinement)
              (attachLoc $ TVar <$> identifier)

tyArg :: MonadicParsing m => m (TyArg Raw)
tyArg = attachLoc $ VArg <$> vtype' <|>
                    EArg <$> abExplicit

-- Parse a potential datatype. Note it may actually be a type variable.
dataInstance :: MonadicParsing m => m (VType Raw)
dataInstance = attachLoc $ do x <- identifier
                              args <- localIndentation Gt $ many tyArg
                              return $ DTTy x args

-----------
-- Terms --
-----------

-- The following are high-level syntactic categories that make use of concrete
-- parser combinators. This means that e.g. `ltm` may not necessarily parse
-- a let expression, but instead an object of a lower category (in this case
-- `btm`).

-- term
tm :: MonadicParsing m => m (Tm Raw)
tm = letTm tm tm <|>                                  -- let x = stm in stm
     stm                                              -- stm

-- sequence term
stm :: MonadicParsing m => m (Tm Raw)
stm = provideLoc $ \a -> do
        t <- btm
        m <- optional $ symbol ";"
        case m of
          Just _ -> do t' <- tm                       -- btm ; tm
                       return $ TmSeq t t' a
          Nothing -> return t                         -- btm

-- binary operation term (takes care of associativity)
btm :: MonadicParsing m => m (Tm Raw)
btm = do t <- untm
         binOperation t
  where
    binOperation :: (MonadicParsing m) => Tm Raw -> m (Tm Raw)
    binOperation t =
      (provideLoc $ \a -> do
         operator <- binOpLeft                        -- untm +  ...  + untm
         t' <- untm
         binOperation (Use (RawComb operator [t, t'] a) a)) <|>
      (provideLoc $ \a -> do
         operator <- binOpRight                       -- untm :: ... :: untm
         t' <- btm
         binOperation (Use (RawComb operator [t, t'] a) a)) <|>
      (return t)

-- unary operation term
untm :: MonadicParsing m => m (Tm Raw)
untm = unOperation <|>                                -- - untm
       usetm                                          -- usetm

-- use term
usetm :: MonadicParsing m => m (Tm Raw)
usetm = (attachLoc $ Use <$> (try $ use nctm)) <|>    -- use
        atm                                           -- atm
  where
    -- nullary comb term
    nctm :: MonadicParsing m => m (Tm Raw)
    nctm = (attachLoc $ Use <$> (try $ ncuse nctm)) <|> -- ncuse
           atm                                        -- atm

-- atomic term
atm :: MonadicParsing m => m (Tm Raw)
atm = (attachLoc $ SC <$> suspComp) <|>                       -- { p_1 -> t_1 | ... }
      (attachLoc $ StrTm <$> stringLiteral) <|>               -- "string"
      (attachLoc $ FloatTm <$> try double) <|>                    -- 3.14
      (attachLoc $ (IntTm . fromIntegral) <$> natural) <|>    -- 42
      (attachLoc $ CharTm <$> charLiteral) <|>                -- 'c'
      (attachLoc $ ListTm <$> listTm) <|>                     -- [t_1, ..., t_n]
      parens tm                                               -- (ltm ; ... ; ltm)

letTm :: MonadicParsing m => m (Tm Raw) -> m (Tm Raw) -> m (Tm Raw)
letTm p p' = attachLoc $ do reserved "let"
                            x <- identifier
                            symbol "="
                            t <- p
                            reserved "in"
                            t' <- p'
                            return $ Let x t t'

binOpLeft :: MonadicParsing m => m (Use Raw)
binOpLeft = attachLoc $ do op <- choice $ map symbol ((map (\x -> x ++ "~")) arithOps ++ arithOps)
                           return $ RawId op
  where
    arithOps = ["+","-","*","/",">","<", "=="]

binOpRight :: MonadicParsing m => m (Use Raw)
binOpRight = attachLoc $ do op <- choice $ map symbol ["::"]
                            let op' = if op == "::" then "cons" else op
                            return $ RawId op'

-- unary operation
unOperation :: (MonadicParsing m) => m (Tm Raw)
unOperation = try negInt <|>
              negFloat

negInt :: (MonadicParsing m) => m (Tm Raw)
negInt = provideLoc $ \a -> do
                symbol "-"
                t <- untm
                return $ Use (RawComb (RawId "-" a) [IntTm 0 a, t] a) a

negFloat :: (MonadicParsing m) => m (Tm Raw)
negFloat = provideLoc $ \a -> do
                symbol "-~"
                t <- untm
                return $ Use (RawComb (RawId "-~" a) [FloatTm 0.0 a, t] a) a

-- use
use :: MonadicParsing m => m (Tm Raw) -> m (Use Raw)
use p = adapted (ncuse p) <|>                      -- <adp_1,...adp_n> ncuse
        cuse p                                        -- cuse

-- comb use
cuse :: MonadicParsing m => m (Tm Raw) -> m (Use Raw)
cuse p = provideLoc $ \a -> do
           op <- ncuse p
           args <- many p
           if null args
              then return op                          -- ncuse
              else return $ RawComb op args a         -- ncuse p ... p

-- nullary comb use
ncuse :: MonadicParsing m => m (Tm Raw) -> m (Use Raw)
ncuse p = provideLoc $ \a -> do
           op <- ause p
           bang <- optional (symbol "!")
           case bang of
             Nothing -> return op                     -- ause
             Just _  -> return $ RawComb op [] a      -- ause!

-- atomic use
ause :: MonadicParsing m => m (Tm Raw) -> m (Use Raw)
ause p = parens (use p) <|>                           -- (use)
         idUse                                        -- x

adapted :: MonadicParsing m => m (Use Raw) -> m (Use Raw)
adapted p = attachLoc $ do -- <adp_1,adp_2,...,adp_n> stm
              xs <- angles (sepBy adaptor (symbol ","))
              t <- p
              return $ Adapted xs t

adaptor :: MonadicParsing m => m (Adaptor Raw)
adaptor = attachLoc $ do
            x <- identifier
            (do symbol "("
                liat <- identifier -- (reverse tail)
                left <- many identifier
                symbol "->"
                right <- many identifier
                symbol ")"
                return $ RawAdp x liat left right)
             <|> (return $ RawAdp x "s" ["x"] ["s"])

adaptor' :: MonadicParsing m => m (Adaptor Raw)
adaptor' = (provideLoc $ \a -> do (x, liat, left, right) <- try $ do x <- identifier
                                                                     symbol "("
                                                                     liat <- identifier -- (reverse tail)
                                                                     left <- many identifier
                                                                     symbol "->"
                                                                     right <- many identifier
                                                                     symbol ")"
                                                                     return (x, liat, left, right)
                                  return $ RawAdp x liat left right a)
                                 -- TODO: LC: make "try" block more minimal...

idUse :: MonadicParsing m => m (Use Raw)
idUse = attachLoc $ do x <- identifier
                       return $ RawId x

listTm :: MonadicParsing m => m [Tm Raw]              -- [t_1, ..., t_n]
listTm = brackets (sepBy tm (symbol ","))

suspComp :: MonadicParsing m => m (SComp Raw)
suspComp = attachLoc $ localIndentation Gt $ absoluteIndentation $
             do cs <- braces $ sepBy anonymousCls (symbol "|")
                return $ SComp cs

anonymousCls :: MonadicParsing m => m (Clause Raw)
anonymousCls = attachLoc $ do ps <- choice [try patterns, pure []]
                              seq <- tm
                              return $ Cls ps seq
  where patterns = do
          ps <- choice [some pattern, symbol "!" >> return []]
          symbol "->"
          return ps

--------------
-- Patterns --
--------------

pattern :: MonadicParsing m => m (Pattern Raw)
pattern = try compPat <|> (attachLoc $ VPat <$> valPat)

compPat :: MonadicParsing m => m (Pattern Raw)
compPat = angles $ try cmdPat <|> thunkPat

thunkPat :: MonadicParsing m => m (Pattern Raw)
thunkPat = attachLoc $ do x <- identifier
                          return (ThkPat x)

cmdPat :: MonadicParsing m => m (Pattern Raw)
cmdPat = attachLoc $ do cmd <- identifier
                        mn <- optional (
                          do symbol "."
                             parseInt)
                        n <- (case mn of
                          Nothing -> return 0
                          Just n | n >= 0 -> return n)
                        -- TODO LC: handle case of negative n
                        ps <- many valPat
                        symbol "->"
                        g <- identifier
                        return (CmdPat cmd n ps g)

valPat :: MonadicParsing m => m (ValuePat Raw)
valPat = dataPat <|>
         (attachLoc $ do x <- identifier
                         return $ VarPat x) <|>
         (attachLoc $ FloatPat <$> try double) <|>
         (attachLoc $ IntPat <$> try parseInt) <|> -- try block for unary minus
         (attachLoc $ CharPat <$> charLiteral) <|>
         (attachLoc $ StrPat <$> stringLiteral) <|>
         (attachLoc $ ListPat <$> brackets (sepBy valPat (symbol ",")))

dataPat :: MonadicParsing m => m (ValuePat Raw)
dataPat = attachLoc $ parens $ ((try (do p <- valPat
                                         symbol "::"
                                         q <- valPat
                                         return $ ConsPat p q)) <|>
                                   (do k <- identifier
                                       ps <- many valPat
                                       return $ DataPat k ps))

----------------------
-- Helper functions --
----------------------

evalCharIndentationParserT :: Monad m => FrankParser Char m a ->
                              IndentationState -> m a
evalCharIndentationParserT = evalIndentationParserT . runFrankParser

evalTokenIndentationParserT :: Monad m => FrankParser Token m a ->
                               IndentationState -> m a
evalTokenIndentationParserT = evalIndentationParserT . runFrankParser

--TODO: LC: Give types, make parsing-interface clearer
runParse ev p input =
   let indA = ev p $ mkIndentationState 0 infIndentation True Ge
   in case parseString indA (Directed Char8.empty 0 0 0 0) input of
    Failure err -> Left (show err)
    Success t -> Right t

runProgParse ev input = runParse ev prog input

-- runParseFromFileEx ev p fname =
--   let indA = ev p $ mkIndentationState 0 infIndentation True Ge in
--   do res <- parseFromFileEx indA fname
--      case res of
--        Failure err -> return $ Left (show err)
--        Success t -> return $ Right t

-- runProgParseFromFileEx ev fname = runParseFromFileEx ev prog fname

-- runTokenParseFromFile :: (MonadIO m, Applicative m, MonadicParsing m) =>
--                          String -> m (Either String (Prog Raw))
-- runTokenParseFromFile = runProgParseFromFileEx evalTokenIndentationParserT

runTokenParse p = runParse evalTokenIndentationParserT p
runTokenProgParse = runProgParse evalTokenIndentationParserT

getLoc :: (MonadicParsing m) => m Raw
getLoc = do r <- rend
            line <- line
            pos <- position
            case delta r of
              (Directed _ l c _ _) ->
                return $ Raw $ InCode (fromIntegral l + 1, fromIntegral c + 1)
              _ -> error "precondition not fulfilled"

attachLoc :: (MonadicParsing m) => m (Raw -> AnnotTFix Raw f) ->
             m (AnnotTFix Raw f)
attachLoc parser = do a <- getLoc
                      parser <*> pure a

provideLoc :: (MonadicParsing m) => (Raw -> m (AnnotTFix Raw f)) ->
              m (AnnotTFix Raw f)
provideLoc parser = do a <- getLoc
                       parser a

-- Turn a list of eithers into a pair of lists
eplist :: [Either a b] -> ([a],[b])
eplist xs = g xs [] []
  where g :: [Either a b] -> [a] -> [b] -> ([a],[b])
        g [] as bs = (reverse as, reverse bs)
        g (Left a : xs) as bs = g xs (a:as) bs
        g (Right b : xs) as bs = g xs as (b:bs)

parseInt :: (MonadicParsing m) => m Int
parseInt = integer >>= (return . fromIntegral)