module Parse.Declaration where

import Control.Applicative ((<$>), (<*>))
import qualified Data.List as List
import Text.Parsec hiding (newline,spaces)
import Text.Parsec.Indent
import qualified Text.Pandoc as Pan

import Parse.Helpers
import qualified Parse.Expression as Expr
import qualified SourceSyntax.Type as T
import qualified Parse.Type as Type
import SourceSyntax.Declaration (Declaration(..), Assoc(..))

import Unique

declaration :: IParser (Declaration t v)
declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition

definition :: IParser (Declaration t v)
definition = Definition <$> Expr.def

alias :: IParser (Declaration t v)
alias = do
  reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
  forcedWS
  alias <- capVar
  args  <- spacePrefix lowVar
  whitespace ; string "=" ; whitespace
  tipe <- Type.expr
  return (TypeAlias alias args tipe)

datatype :: IParser (Declaration t v)
datatype = do
  reserved "data" <?> "datatype definition (data T = A | B | ...)"
  forcedWS
  name <- capVar <?> "name of data-type"
  args <- spacePrefix lowVar
  whitespace ; string "=" ; whitespace
  tcs <- pipeSep1 Type.constructor
  return $ Datatype name args tcs


infixDecl :: IParser (Declaration t v)
infixDecl = do
  assoc <- choice [ reserved "infixl" >> return L
                  , reserved "infix"  >> return N
                  , reserved "infixr" >> return R ]
  whitespace
  n <- digit
  forcedWS
  Fixity assoc (read [n]) <$> anyOp


foreignDef :: IParser (Declaration t v)
foreignDef = do
  try (reserved "foreign")
  whitespace
  importEvent <|> exportEvent

exportEvent :: IParser (Declaration t v)
exportEvent = do
  try (reserved "export") >> whitespace >> reserved "jsevent" >> whitespace
  eventName <- jsVar
  whitespace
  elmVar <- lowVar
  whitespace ; hasType ; whitespace
  tipe <- Type.expr
  case tipe of
    T.Data "Signal" [t] ->
        case isExportable t of
          Nothing -> return (ExportEvent eventName elmVar tipe)
          Just err -> error err
    _ -> error "When importing foreign events, the imported value must have type Signal."

importEvent :: IParser (Declaration t v)
importEvent = do
  try (reserved "import") >> whitespace >> reserved "jsevent" >> whitespace
  eventName <- jsVar
  whitespace
  baseValue <- Expr.term <?> "Base case for imported signal (signals cannot be undefined)"
  whitespace
  elmVar  <- lowVar <?> "Name of imported signal"
  whitespace ; hasType ; whitespace
  tipe <- Type.expr
  case tipe of
    T.Data "Signal" [t] ->
        case isExportable t of
          Nothing -> return (ImportEvent eventName baseValue elmVar tipe)
          Just err -> error err
    _ -> error "When importing foreign events, the imported value must have type Signal."

jsVar :: IParser String
jsVar = betwixt '"' '"' $ do
  v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')
  if v `notElem` jsReserveds then return v else
      error $ "'" ++ v ++
          "' is not a good name for a importing or exporting JS values."

jsReserveds :: [String]
jsReserveds =
    [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
    , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
    , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
    , "transient", "synchronized", "function", "break", "case", "catch"
    , "continue", "debugger", "default", "delete", "do", "else", "finally"
    , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
    , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
    , "const", "enum", "export", "extends", "import", "super", "implements"
    , "interface", "let", "package", "private", "protected", "public"
    , "static", "yield"
    ]

isExportable tipe =
  case tipe of
    T.Lambda _ _ ->
        Just $ "Elm's JavaScript event interface does not yet handle functions. " ++
               "Only simple values can be imported and exported in this release."

    T.Data "JSArray" [t] -> isExportable t

    T.Data name []
        | any (`List.isSuffixOf` name) jsTypes -> Nothing
        | otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg

    T.Data name _ ->
        Just $ "'" ++ name ++ "' is not an exportable type " ++
               "constructor. Only 'JSArray' is an exportable container."

    T.Var _ -> Just $ "Cannot export type variables." ++ msg
  where
    msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes
    jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]