content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE DataKinds #-}
  
  -- | Taken from
  -- https://github.com/nazrhom/vcs-clojure/blob/master/src/Language/Clojure/Parser.hs
  module Languages.Clojure.Parser
      ( parseTop
      , parse
      , parseTest
      , parseAsExprList
  
      -- AST
      , Expr(..)
      , FormTy(..)
      , CollTy(..)
      , Term(..)
      , Tag(..)
      , SepExprList(..)
      , Sep(..)
      ) where
  
  import Text.Parsec hiding (Empty)
  import Text.Parsec.Token hiding (braces, parens, brackets, identifier, operator)
  import Text.Parsec.Language
  import Data.Char hiding (Space)
  import qualified Data.Text as T
  import Data.Proxy
  
  import Languages.Clojure.Syntax
  
  lexer = makeTokenParser javaStyle
    { identStart = alphaNum <|> oneOf "_':*-&."
    , identLetter = alphaNum <|> oneOf ":_.'-/^?!><*#\"\\" <|> satisfy isSymbol
    }
  
  parseSeq :: Parsec String () Expr
  parseSeq = do
    p1 <- parseExpr
    whiteSpace lexer
    p2 <- (try parseSeq <|> parseEmptyProgram)
    return $ Seq p1 p2
  
  parseTop = whiteSpace lexer *> (try parseSeq <|> parseEmptyProgram) <* eof
  
  parseAsExprList = do
    top <- parseTop
    return $ walkSeq top
    -- whiteSpace lexer *> (many parseSingleExpr) <* whiteSpace lexer <* eof
  
  walkSeq (Seq a Empty) = a : []
  walkSeq (Seq a b) = a : walkSeq b
  walkSeq (Empty) = [Empty]
  walkSeq e = error $ "nowalk" ++ show e
  
  parseExpr = choice
    [ try parseSpecial
    , try parseDispatch
    , parseCollection
    , parseComment
    , parseTerm
    ]
  
  parseEmptyProgram = do
    return $ Empty
  
  parseTerm = do
      term <- parseTaggedString
      return $ Term term
  
  parseCollection = choice [ parseParens, parseVec, parseSet ]
  
  parseSpecial = do
    ident <- parseSpecialIdent
    expr <- parseExpr
    return $ Special ident expr
  
  parseSpecialIdent = choice
    [ Quote <$ char '\''
    , SQuote <$ char '`'
    , UnQuote <$ char '~'
    , DeRef <$ char '@'
    , Meta <$ char '^'
    ]
  
  parseTaggedString = choice [parseString, parseVar]
  
  parseDispatch = do
    char '#'
    disp <- parseDispatchable
    return $ Dispatch disp
    where
      parseDispatchable = choice
        [ parseExpr
        , parseRegExp
        , parseTaggedLit
        ]
      --- ref: https://yobriefca.se/blog/2014/05/19/the-weird-and-wonderful-characters-of-clojure/
      -- parseParens covers the function marco
      -- parseTaggedLit covers the var macro (as identifiers can start with a quote ('))
      parseRegExp = do
        regExp <- parseString
        return $ Term regExp
  
      parseTaggedLit = do
        tLit <- parseVar
        return $ Term tLit
  
      -- parseMeta = do
      --   start <- getPosition
      --   meta <- parseMetadata
      --   end <- getPosition
      --   return $ Term meta (mkRange start end)
  
  parseComment = do
    char ';'
    comment <- manyTill anyChar (newline <|> eofS)
    -- single line comment, if we parse end here we have parsed newline as well
    return $ Comment (T.pack comment)
  
  eofS = do
    eof
    return '\n'
  
  parens p = between (symbol lexer "(") (string ")") p
  braces p = between (symbol lexer "{") (string "}") p
  brackets p = between (symbol lexer "[") (string "]") p
  
  
  parseSet = do
    contents <- braces parseSepExprList
    return $ Collection Set contents
  
  parseVec = do
    contents <- brackets parseSepExprList
    return $ Collection Vec contents
  
  parseParens = do
    contents <- parens parseSepExprList
    return $ Collection Parens contents
  
  parseSepExprList = parseSepExprList1 <|> parseEmptyList
  
  parseEmptyList = do
    return $ Nil
  
  parseSepExprList1 = do
    x <- parseExpr
    sep <- parseSep
    xs <- parseSepExprList
    return $ Cons x sep xs
  
  parseSep = choice
    [ Comma <$ lexeme lexer (char ',')
    , NewLine <$ lexeme lexer (many1 endOfLine)
    , Space <$ lexeme lexer (many1 (space <|> tab))
    , EmptySep <$ (lookAhead (anyChar) <|> eofS)
    ]
  parseString = do
    qstring <- quotedString
    return $ TaggedString String (T.pack qstring)
    where
      quotedString :: Parsec String () String
      quotedString = do
        char '"'
        x <- many (try (try (string "\\\\") <|> string "\\\"") <|> fmap pure (noneOf "\""))
        char '"'
        return $ concat x
  
  parseVar = do
    vstring <- (identifier)
    return $ TaggedString Var (T.pack vstring)
  
  identifier = do
    c <- alphaNum <|> oneOf ":!#$%&*+./<=>?@\\^|-~_',"
    cs <- many (alphaNum <|> oneOf ":!?#$%&*+-/.<=>'?@^|~_'^\"\\" <|> satisfy isSymbol)
    return (c:cs)
  
  -- parseMetadata = do
  --   start <- getPosition
  --   char '^'
  --   meta <- identifier
  --   end <- getPosition
  --   return $ TaggedString Metadata (T.pack meta) (mkRange start end)
  