{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-}

module Forml.Types.Definition where

import Text.InterpolatedString.Perl6
import Language.Javascript.JMacro

import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Serialize

import Text.Parsec hiding ((<|>), State, many, spaces, parse, label)
import qualified Text.Parsec as P
import Text.Parsec.Indent  hiding (same)

import Forml.Parser.Utils
import Forml.Javascript.Utils
import Forml.Javascript.Backend

import Forml.Types.Type
import Forml.Types.Symbol
import Forml.Types.Pattern
import Forml.Types.Axiom
import Forml.Types.Expression

import Prelude hiding (curry, (++))

import GHC.Generics



-- Definition
-- --------------------------------------------------------------------------------

data Visibility = Public | Private deriving (Eq, Generic)

data Definition = Definition Visibility Bool Symbol [Axiom (Expression Definition)] deriving (Eq, Generic)

instance Serialize Definition
instance Serialize Visibility

instance Show Definition where
    show (Definition Public _ name ax) =[qq|$name {sep_with "\\n" ax}|]
    show (Definition Private _ name ax) =[qq|private $name {sep_with "\\n" ax}|]

instance Syntax Definition where

    syntax = do whitespace
                vis <- option Public (try (string "private" >> spaces >> return Private))
                inl <- option False (try (string "inline" >> spaces >> return True))
                (x, y) <- try prefix <|> try infix''
                return $ Definition vis inl x y

        where where' = do
                  string "where"
                  whitespace1
                  P.spaces
                  Just <$> withPosTemp (syntax `sepBy1` (try comma <|> try (spaces *> same)))

              where_clause ex = do
                  where'' <- option Nothing (try where')
                  return $ case where'' of
                      Just defs -> LetExpression defs ex
                      Nothing -> ex

              infix'' =

                  do whitespace
                     first_arg <- try syntax
                     whitespace
                     op <- not_reserved $ many1 operator
                     whitespace
                     Match pss cond <- syntax
                     ax <- no_args_eq_axiom $ Match (first_arg:pss) cond
                     axs <- try (prefix' $ Operator op) <|> return []
                     return (Operator op, ax:axs)

                  where no_args_eq_axiom patterns =

                          do whitespace *> string "=" *> spaces *> indented
                             (Addr a b ex') <- withPosTemp (addr syntax)
                             P.spaces
                             ex <- where_clause ex'
                             return $ EqualityAxiom patterns (Addr a b ex)

              prefix = 

                  do name <- try syntax <|> (Symbol <$> many1 (char '_'))
                     y <- prefix' name
                     return (name, y)
          
              prefix' name =

                       do sig <- first
                          eqs <- (try $ spaces *> (withPos . many . try $ try infix_axiom <|> eq_axiom)) <|> return []
                          whitespace
                          if length sig == 0 && length eqs == 0 
                              then parserFail "Definition Axioms"
                              else return (sig ++ eqs)

                where first = try type_or_first
                              <|> ((:[]) <$> try naked_eq_axiom)
                              <|> ((:[]) <$> (whitespace *> infix_axiom))
                              <|> return []

                      type_or_first = (:) <$> type_axiom <*> second

                      second = option [] ((:[]) <$> try (no_args_eq_axiom (Match [] Nothing)))

                      eq_axiom =

                          do P.spaces
                             string "|" <|> try (string name' <* notFollowedBy (digit <|> letter)) 
                             naked_eq_axiom

                          where name' = case name of
                                         (Symbol name'')   -> name''
                                         (Operator name'') -> "(" ++ name'' ++ ")"

                      naked_eq_axiom =

                          do whitespace
                             patterns <- syntax
                             no_args_eq_axiom patterns

                      no_args_eq_axiom patterns =

                          do P.spaces *> string "=" *> P.spaces
                             (Addr a b ex') <- withPosTemp (addr syntax)
                             P.spaces
                             ex <- where_clause ex'
                             return $ EqualityAxiom patterns (Addr a b ex)

                      infix_axiom =
                          
                          case name of
                             (Symbol _)   -> parserFail "Infix Definition"
                             (Operator name'') -> do first_arg <- syntax
                                                     whitespace
                                                     string name''
                                                     whitespace
                                                     Match pss cond <- syntax
                                                     no_args_eq_axiom $ Match (first_arg:pss) cond 

                      type_axiom =

                          do spaces
                             indented
                             string ":"
                             spaces
                             indented
                             TypeAxiom <$> withPos type_axiom_signature

-- TODO Visibility should be more than skin deep?

instance Javascript Definition JStat where
    toJS (Definition _ _ _ (TypeAxiom _: [])) = return mempty
    toJS (Definition _ _ name as) = return [jmacro| `(declare_this (to_name name) $ toJExpr as)`; |]

instance ToLocalStat Definition where
    toLocal (Definition _ _ _ (TypeAxiom _: [])) = mempty
    toLocal (Definition _ _ name as) = [jmacro| `(declare (to_name name) $ toJExpr as)`; |]