{-# LANGUAGE OverloadedStrings #-}
module Grin.ExtendedSyntax.Parse.Basic where

import Data.Set (Set)
import Data.Vector (Vector)
import qualified Data.Set    as Set

import qualified Data.Vector as Vec

import Data.String (fromString)
import Data.Text (Text)
import Data.Void

import Control.Monad (void)
import Text.Megaparsec
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Char

import Grin.ExtendedSyntax.Grin
import Grin.ExtendedSyntax.TypeEnvDefs

type Parser = Parsec Void Text

keywords = Set.fromList
  [ "case", "of"
  , "fetch", "store", "update"
  , "if", "then", "else"
  , "do", "pure"
  , "#True", "#False"
  , "#undefined"
  , "primop", "effectful"
  ] `Set.union` simpleTypes

simpleTypes = Set.fromList
  [ "T_Int64", "T_Word64", "T_Float"
  , "T_Bool",  "T_Unit"
  , "T_Location", "T_Dead"
  , "T_String", "T_Char"
  ]

lineComment :: Parser ()
lineComment = L.skipLineComment "--"

blockComment :: Parser ()
blockComment = L.skipBlockComment "{-" "-}"

sc :: Parser ()
sc = L.space (void spaceChar) lineComment blockComment

sc' :: Parser ()
sc' = L.space (void $ oneOf (" \t" :: String)) lineComment blockComment

lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc'

symbol = L.symbol sc'

parens = between (symbol "(") (symbol ")")

brackets = between (symbol "[") (symbol "]")

braces = between (symbol "{") (symbol "}")

kw w = lexeme $ string w

op w = L.symbol sc' w

int :: Parser Int
int = lexeme L.decimal

integer = lexeme L.decimal
signedInteger = L.signed sc' integer

float = lexeme L.float
signedFloat = L.signed sc' float

list :: Parser a -> Parser [a]
list p = brackets (sepBy p (op ","))

list1 :: Parser a -> Parser [a]
list1 p = brackets (sepBy1 p (op ","))

vec :: Parser a -> Parser (Vector a)
vec p = Vec.fromList <$> list p

vec1 :: Parser a -> Parser (Vector a)
vec1 p = Vec.fromList <$> list1 p

bracedList :: Parser a -> Parser [a]
bracedList p = braces (sepBy p (op ","))

bracedList1 :: Parser a -> Parser [a]
bracedList1 p = braces (sepBy1 p (op ","))

set :: Ord a => Parser a -> Parser (Set a)
set p = Set.fromList <$> bracedList p

set1 :: Ord a => Parser a -> Parser (Set a)
set1 p = Set.fromList <$> bracedList1 p

anySingleBut :: MonadParsec e s m => Token s -> m (Token s)
anySingleBut t = satisfy (/= t)


-- grin syntax

escaped :: Parser Char
escaped = string "\\\"" >> pure '"'

quotedVar :: Parser Name
quotedVar = packName <$ char '"' <*> someTill (escaped <|> anySingle) (char '"')

escapedStringChar :: Parser Char
escapedStringChar =
  (string "\\\"" >> pure '"') <|>
  (string "\\\\" >> pure '\\') <|>
  (string "\\a" >> pure '\a') <|>
  (string "\\b" >> pure '\b') <|>
  (string "\\f" >> pure '\f') <|>
  (string "\\n" >> pure '\n') <|>
  (string "\\r" >> pure '\r') <|>
  (string "\\t" >> pure '\t') <|>
  (string "\\v" >> pure '\v')

quotedString :: Parser Text
quotedString = fromString <$> (char '"' *> manyTill (escapedStringChar <|> anySingle) (char '"'))

simpleVar :: Parser Name
simpleVar = (\c s -> packName $ c : s) <$> oneOf allowedInitial <*> many (alphaNumChar <|> oneOf allowedSpecial)

-- TODO: allow keywords in quotes
var :: Parser Name
var = try $ lexeme (quotedVar <|> simpleVar) >>= \x@(NM x') -> case Set.member x' keywords of
  True -> fail $ "keyword: " ++ unpackName x
  False -> return x

tag :: Parser Tag
tag = Tag C <$ char 'C' <*> var <|>
      Tag F <$ char 'F' <*> var <|>
      Tag <$> (P <$ char 'P' <*> L.decimal) <*> var

-- type syntax

simpleType :: Parser SimpleType
simpleType =
  T_Int64 <$ kw "T_Int64" <|>
  T_Word64 <$ kw "T_Word64" <|>
  T_Float <$ kw "T_Float" <|>
  T_Bool <$ kw "T_Bool" <|>
  T_Unit <$ kw "T_Unit" <|>
  T_UnspecifiedLocation <$ kw "#ptr" <|>
  T_Location <$> bracedList int <|>
  T_String <$ kw "T_String" <|>
  T_Char <$ kw "T_Char" <|>
  T_Dead <$ kw "T_Dead"

# LANGUAGE OverloadedStrings #
 grin syntax
 TODO: allow keywords in quotes
 type syntax
module Grin.ExtendedSyntax.Parse.Basic where

import Data.Set (Set)
import Data.Vector (Vector)
import qualified Data.Set    as Set

import qualified Data.Vector as Vec

import Data.String (fromString)
import Data.Text (Text)
import Data.Void

import Control.Monad (void)
import Text.Megaparsec
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Char

import Grin.ExtendedSyntax.Grin
import Grin.ExtendedSyntax.TypeEnvDefs

type Parser = Parsec Void Text

keywords = Set.fromList
  [ "case", "of"
  , "fetch", "store", "update"
  , "if", "then", "else"
  , "do", "pure"
  , "#True", "#False"
  , "#undefined"
  , "primop", "effectful"
  ] `Set.union` simpleTypes

simpleTypes = Set.fromList
  [ "T_Int64", "T_Word64", "T_Float"
  , "T_Bool",  "T_Unit"
  , "T_Location", "T_Dead"
  , "T_String", "T_Char"
  ]

lineComment :: Parser ()
lineComment = L.skipLineComment "--"

blockComment :: Parser ()
blockComment = L.skipBlockComment "{-" "-}"

sc :: Parser ()
sc = L.space (void spaceChar) lineComment blockComment

sc' :: Parser ()
sc' = L.space (void $ oneOf (" \t" :: String)) lineComment blockComment

lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc'

symbol = L.symbol sc'

parens = between (symbol "(") (symbol ")")

brackets = between (symbol "[") (symbol "]")

braces = between (symbol "{") (symbol "}")

kw w = lexeme $ string w

op w = L.symbol sc' w

int :: Parser Int
int = lexeme L.decimal

integer = lexeme L.decimal
signedInteger = L.signed sc' integer

float = lexeme L.float
signedFloat = L.signed sc' float

list :: Parser a -> Parser [a]
list p = brackets (sepBy p (op ","))

list1 :: Parser a -> Parser [a]
list1 p = brackets (sepBy1 p (op ","))

vec :: Parser a -> Parser (Vector a)
vec p = Vec.fromList <$> list p

vec1 :: Parser a -> Parser (Vector a)
vec1 p = Vec.fromList <$> list1 p

bracedList :: Parser a -> Parser [a]
bracedList p = braces (sepBy p (op ","))

bracedList1 :: Parser a -> Parser [a]
bracedList1 p = braces (sepBy1 p (op ","))

set :: Ord a => Parser a -> Parser (Set a)
set p = Set.fromList <$> bracedList p

set1 :: Ord a => Parser a -> Parser (Set a)
set1 p = Set.fromList <$> bracedList1 p

anySingleBut :: MonadParsec e s m => Token s -> m (Token s)
anySingleBut t = satisfy (/= t)



escaped :: Parser Char
escaped = string "\\\"" >> pure '"'

quotedVar :: Parser Name
quotedVar = packName <$ char '"' <*> someTill (escaped <|> anySingle) (char '"')

escapedStringChar :: Parser Char
escapedStringChar =
  (string "\\\"" >> pure '"') <|>
  (string "\\\\" >> pure '\\') <|>
  (string "\\a" >> pure '\a') <|>
  (string "\\b" >> pure '\b') <|>
  (string "\\f" >> pure '\f') <|>
  (string "\\n" >> pure '\n') <|>
  (string "\\r" >> pure '\r') <|>
  (string "\\t" >> pure '\t') <|>
  (string "\\v" >> pure '\v')

quotedString :: Parser Text
quotedString = fromString <$> (char '"' *> manyTill (escapedStringChar <|> anySingle) (char '"'))

simpleVar :: Parser Name
simpleVar = (\c s -> packName $ c : s) <$> oneOf allowedInitial <*> many (alphaNumChar <|> oneOf allowedSpecial)

var :: Parser Name
var = try $ lexeme (quotedVar <|> simpleVar) >>= \x@(NM x') -> case Set.member x' keywords of
  True -> fail $ "keyword: " ++ unpackName x
  False -> return x

tag :: Parser Tag
tag = Tag C <$ char 'C' <*> var <|>
      Tag F <$ char 'F' <*> var <|>
      Tag <$> (P <$ char 'P' <*> L.decimal) <*> var


simpleType :: Parser SimpleType
simpleType =
  T_Int64 <$ kw "T_Int64" <|>
  T_Word64 <$ kw "T_Word64" <|>
  T_Float <$ kw "T_Float" <|>
  T_Bool <$ kw "T_Bool" <|>
  T_Unit <$ kw "T_Unit" <|>
  T_UnspecifiedLocation <$ kw "#ptr" <|>
  T_Location <$> bracedList int <|>
  T_String <$ kw "T_String" <|>
  T_Char <$ kw "T_Char" <|>
  T_Dead <$ kw "T_Dead"
