content: {-# 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.Pattern where
  
  import Text.InterpolatedString.Perl6
  import Data.Maybe
  import Language.Javascript.JMacro
  
  import Control.Applicative
  import Control.Monad
  
  import Text.Parsec         hiding ((<|>), State, many, spaces, parse, label)
  import qualified Text.Parsec as P
  import qualified Data.List as L
  import Text.Parsec.Indent  hiding (same)
  
  import qualified Data.Map as M
  
  import Forml.Parser.Utils
  import Forml.Javascript.Utils
  
  import Forml.Types.Literal
  import Forml.Types.Type
  import Forml.Types.Symbol
  import Forml.TypeCheck.Types
  
  import Prelude hiding (curry, (++))
  import System.IO.Unsafe (unsafePerformIO)
  import Data.Monoid (mappend)
  import qualified Data.Serialize as S
  
  import GHC.Generics
  
  
  
  
  
  -- Pattern
  -- --------------------------------------------------------------------------------
  
  data Match a = Match [Pattern a] (Maybe a) deriving (Eq, Generic)
  data Pattern a = VarPattern String
                 | AnyPattern
                 | LiteralPattern Literal
                 | RecordPattern (M.Map Symbol (Pattern a)) Partial
                 | ListPattern [Pattern a]
                 | ViewPattern a (Pattern a)
                 | AliasPattern [Pattern a]
                 deriving (Eq, Generic)
  
  instance (S.Serialize a) => S.Serialize (Match a)
  instance (S.Serialize a) => S.Serialize (Pattern a)
  
  instance (Show a) => Show (Match a) where
      show (Match p Nothing)  = sep_with " " p
      show (Match p (Just x)) = [qq|{sep_with " " p} when $x|]
  
  instance (Syntax a, Show a) => Syntax (Match a) where
  
      syntax = try conditional <|> ((\x -> Match x Nothing) <$> (try jStyle <|> hStyle))
  
          where 
  
            jStyle = do x <- indentPairs "(" (syntax `sepBy1` comma) ")"
                        spaces
                        if length x > 1 then return x else fail "Java-style arguments"
  
            hStyle = syntax `sepEndBy` whitespace1
  
            conditional = do x <- try jStyle <|> try hStyle
                             string "when"
                             whitespace1
                             spaces
                             ex <- syntax
                             spaces
                             return $ Match x (Just ex)
  
  newtype Condition = Condition JExpr
  
  instance ToJExpr [Condition] where
      toJExpr [] = toJExpr True
      toJExpr (Condition x : []) = [jmacroE| `(x)` |]
      toJExpr (Condition x : xs) = [jmacroE| `(x)` && `(xs)` |]
  
  data PatternMatch a = PM String (Pattern a)
  
  instance (Show a) => ToJExpr [PatternMatch a] where
      toJExpr []     = toJExpr True
      toJExpr (x:[]) = [jmacroE| `(x)` |]
      toJExpr (x:xs) = [jmacroE| `(x)` && `(xs)` |]
  
  instance (Show a) => ToJExpr (PatternMatch a) where
  
      toJExpr (PM n (AliasPattern xs)) = toJExpr $ filter fil $ map (PM n) xs
  
      toJExpr (PM n (LiteralPattern x)) =
  
          [jmacroE| `(ref n)` === `(x)` |]
  
      toJExpr (PM n (RecordPattern (M.toList -> xs) _)) =
  
          [jmacroE| `(map g xs)` && `(filter fil $ map f xs)` |]
              where f (key, val) = PM (n ++ "[\"" ++ to_name key ++ "\"]") val
                    g (key, _) = Condition [jmacroE| __check(`(ref n)`, `(to_name key)`) |]
  
      toJExpr (PM n (ListPattern [])) =
          [jmacroE| equals(`(n)`)([]) |]
      toJExpr (PM n (ListPattern xs)) = 
          let x = toJExpr (map f (zip [(0 :: Int) ..] xs))
              f (index, val) = toJExpr (PM (n ++ "[" ++ show index ++ "]") val)
          in   [jmacroE| `(x)` && `(ref n)`.length == `(length xs)` |]
      toJExpr (PM _ x) = error $ "Unimplemented " ++ show x
  
  data Partial = Partial | Complete deriving (Eq, Show, Generic)
  
  instance S.Serialize Partial
  
  instance (Show a) => Show (Pattern a) where
      show (VarPattern x)     = x
      show AnyPattern         = "_"
      show (LiteralPattern x) = show x
      show (ListPattern x)    = [qq|[ {sep_with ", " x} ]|]
      show (ViewPattern x y)  = [qq|($x -> $y)|]
      show (RecordPattern m Complete)  = [qq|\{ {unsep_with " = " m} \}|] 
      show (RecordPattern m Partial)   = [qq|\{ {unsep_with " = " m}, _ \}|]
      show (AliasPattern a) = sep_with " & " a
  
  instance (Show a, ToJExpr a) => ToJExpr [Pattern a] where
  
      toJExpr ps = toJExpr$ filter fil $ zipWith PM (reverse . take (length ps) . map local_pool $ [0 .. 26]) ps
      
  fil (PM _ (VarPattern _)) = False
  fil (PM _ AnyPattern) = False
  fil (PM _ (RecordPattern (M.toList -> []) Complete)) = False
  fil _ = True
  
  instance (Syntax a, Show a) => Syntax (Pattern a) where
      
      syntax = try literal
               <|> try var
               <|> any'
               <|> try record
               <|> naked_apply
               <|> array
               <|> list
               <|> indentPairs "(" (try alias <|> syntax) ")"
                       
          where alias = let sep = P.spaces <* string "&" <* P.spaces
                        in  AliasPattern <$> ((:) <$> syntax <* sep <*> sepBy1 syntax sep) 
  
                var = 
                
                    do (Symbol x) <- syntax
                       return (VarPattern x)
                
                literal     = LiteralPattern <$> syntax
                any'        = many1 (string "_") *> return AnyPattern
                naked_apply =
  
                    do x <- indentPairs "{" (many1 letter) "}"
                       return $ RecordPattern (M.fromList [(Symbol x, AnyPattern )]) Complete
  
                record  = indentPairs "{" any_record "}"
                                                     
  
                    where pairs = (try key_eq_val <|> (many1 (char '_') >> return Nothing)) `sepEndBy` optional_sep
  
                          any_record =
                          
                                do ps <- pairs
                                   let ps' = catMaybes ps
                                   return $
                                     case (length ps, (not . isJust) `filter` ps) of
                                       (0, _)           -> RecordPattern M.empty Complete
                                       (_, (Nothing:_)) -> RecordPattern (M.fromList ps') Partial
                                       _                -> RecordPattern (M.fromList ps') Complete
  
                          key_eq_val = do key <- syntax
                                          spaces
                                          string "=" <|> string ":"
                                          spaces
                                          value <- syntax
                                          return$ Just (key, value)
  
                list = ListPattern <$> indentPairs "[" (syntax `sepBy` optional_sep) "]"
  
                array = f <$> indentAsymmetricPairs "[:" v (try (string ":]") <|> string "]")
  
                    where v = do whitespace
                                 withPosTemp (syntax `sepBy` optional_sep)
  
                          f []     = RecordPattern (M.fromList [(Symbol "nil", AnyPattern)]) Complete
                          f (x:xs) = RecordPattern (M.fromList [(Symbol "head", x), (Symbol "tail", f xs)]) Complete
  
  
  
  instance (Show b) => Infer (Pattern b) Type where
  
      infer (AliasPattern (x:[])) = infer x
             
      infer (AliasPattern (x:xs)) = 
          do z <- infer x
             z' <- infer (AliasPattern xs)
             unify z z'
             return z'
  
      infer (VarPattern i) = do v <- newTVar Star
                                assume (i :>: toScheme v)
                                return v
  
      infer AnyPattern = newTVar Star
  
      infer (LiteralPattern x) = infer x
  
      infer (ListPattern xs) = do ts <- mapM infer xs
                                  t' <- newTVar Star
                                  t <- freshInst list_scheme
                                  mapM_ (unify t') ts
                                  return t
  
      infer (RecordPattern (unzip . M.toList -> (names, patterns)) p) =
          
          do ts <- mapM infer patterns
             p' <- case p of
                     Complete -> return TComplete
                     Partial  -> do t <-  newTVar Star
                                    return$ TPartial t
  
             let r = TypeRecord (TRecord (M.fromList (zip (map f names) ts)) p' Star)
             t' <- newTVar Star
             sc <- find $ quantify (tv r) r
             case sc of
               Nothing ->
                   do unify t' r
                      return t'
               Just (Forall _ scr, sct) ->
                   do t''  <- freshInst sct
                      t''' <- return$ inst (map TypeVar$ tv t'') scr
                      t    <- freshInst (quantify (tv t''' L.\\ tv t'') t''')
                      unify t r
                      unify t' t''
                      s <- get_substitution
                      let t''' = apply s t
                          r''' = apply s r
                          qt = quantify (tv t''') t'''
                          rt = quantify (tv r''') r'''
                      if qt /= rt
                          then do add_error$ "Object constructor does not match signature\n" 
                                               ++ "  Expected: " ++ show qt ++ "\n" 
                                               ++ "  Actual:   " ++ show rt
                                  return t'
                          else return t'
  
          where f (Symbol x) = x
                f (Operator x) = x
  