{-# LANGUAGE ViewPatterns #-}
module Frontend.Parser.Foreign where

import Control.Monad

import qualified Data.Text as T
import Data.List


import Frontend.Lexer.Wrapper
import Frontend.Lexer.Tokens
import Frontend.Syntax

import Text.Show.Pretty
import Frontend.Parser.Posn
import Data.Char (isAlpha)

parseForeignItem :: Token -> Alex FfiImpEnt
parseForeignItem token@(Token (TokString impent) line col) = go 0 impent emptyItem
  where
    pn = Posn line (col + 1)

    go off xs item
      | T.pack " " `T.isPrefixOf` xs =
        let (run, rest) = T.span (== ' ') xs
        in go (off + T.length run) rest item

    go off (T.span (/= ' ') -> (x, xs)) item
      | x == xs, T.null xs = pure item
      | x == T.pack "static" =
        if fiStatic item
          then tooManyStatics pn off
          else go (off + T.length x) xs item{fiStatic = True}
      | T.pack ".h" `T.isSuffixOf` x =
        case fiHeader item of
          Nothing -> go (off + T.length x) xs item{fiHeader = Just x}
          Just _ -> tooManyHeaders pn off (T.length x)
      | T.singleton '&' `T.isPrefixOf` x, T.length x == 1 =
        if fiIsRef item
          then tooManyReferences pn off
          else go (off + 1) xs item{fiIsRef = True}
      | T.singleton '&' `T.isPrefixOf` x, T.length x >= 2 =
        if fiIsRef item
          then tooManyReferences pn off
          else go (off + 1) (T.tail x <> xs) item{fiIsRef = True}
      | otherwise =
        case fiItemName item of
          Nothing -> do
            id <- parseCid pn off x
            go (off + T.length x) xs item{fiItemName = id}
          _ -> tooManyItemNames pn off (T.length x)
parseForeignItem _ = undefined

tooManyHeaders :: Posn -> Int -> Int -> Alex a
tooManyHeaders (Posn l c) off len =
  alexThrow $ \fname ->
    ParseError 
    { parseErrorMessage    = "this foreign entity has too many header names; only one is allowed."
    , parseErrorFilename   = fname
    , parseErrorInlineDesc = Just "repeated header name"
    , parseErrorBegin      = Posn l (c + off)
    , parseErrorEnd        = Posn l (c + off + len)
    }

tooManyItemNames :: Posn -> Int -> Int -> Alex a
tooManyItemNames (Posn l c) off len =
  alexThrow $ \fname ->
    ParseError 
    { parseErrorMessage    = "this foreign entity has too many names; only one is allowed."
    , parseErrorFilename   = fname
    , parseErrorInlineDesc = Just "repeated name"
    , parseErrorBegin      = Posn l (c + off)
    , parseErrorEnd        = Posn l (c + off + len)
    }

tooManyReferences :: Posn -> Int -> Alex a
tooManyReferences (Posn l c) off =
  alexThrow $ \fname ->
    ParseError 
    { parseErrorMessage    = "this foreign entity has too many '&'s; only one is allowed."
    , parseErrorFilename   = fname
    , parseErrorInlineDesc = Just "repeated '&'"
    , parseErrorBegin      = Posn l (c + off)
    , parseErrorEnd        = Posn l (c + off + 1)
    }

tooManyStatics :: Posn -> Int -> Alex a
tooManyStatics (Posn l c) off =
  alexThrow $ \fname ->
    ParseError 
    { parseErrorMessage    = "this foreign entity has too many 'static's; only one is allowed."
    , parseErrorFilename   = fname
    , parseErrorInlineDesc = Just "repeated 'static'"
    , parseErrorBegin      = Posn l (c + off)
    , parseErrorEnd        = Posn l (c + off + length "static")
    }

parseCid :: Posn -> Int -> T.Text -> Alex (Maybe T.Text)
parseCid (Posn l c) off id
  | T.null id = pure $ Nothing
  | isValidCIdent id = pure $ Just id
  | otherwise =
    alexThrow $ \fname ->
      ParseError 
      { parseErrorMessage    = "names for foreign entities must be valid C identifiers."
      , parseErrorFilename   = fname
      , parseErrorInlineDesc = Just "this is not a C identifier"
      , parseErrorBegin      = Posn l (c + off)
      , parseErrorEnd        = Posn l (c + off + T.length id)
      }

isValidCIdent :: T.Text -> Bool
isValidCIdent = go . T.unpack where
  go :: String -> Bool
  go [] = False
  go (x:xs)
    | isAlpha x = go' xs
    | otherwise = False

  go' :: String -> Bool
  go' [] = True
  go' (x:xs)
    | 'a' <= x && x <= 'z' = go' xs
    | 'A' <= x && x <= 'Z' = go' xs
    | '0' <= x && x <= '9' = go' xs
    | x == '_'  = go' xs
    | otherwise = False

emptyItem :: FfiImpEnt
emptyItem  =
  ForeignItem { fiItemName = Nothing
              , fiHeader   = Nothing
              , fiStatic   = False
              , fiIsRef    = False
              }