{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}
module Pugs.Parser.Util where

import Pugs.Internals
import Pugs.AST
import Pugs.Types
import Pugs.Lexer
import Pugs.Rule
import Pugs.Parser.Types
import qualified Data.Map as Map
import qualified Data.Set as Set

grammaticalCategories :: [String]
grammaticalCategories = ["prefix_circumfix_meta_operator:","infix_circumfix_meta_operator:","prefix_postfix_meta_operator:","postfix_prefix_meta_operator:","infix_postfix_meta_operator:","statement_modifier:","statement_control:","scope_declarator:","trait_auxiliary:","trait_verb:","regex_mod_external:","regex_mod_internal:","regex_assertion:","regex_backslash:","regex_metachar:","postcircumfix:","circumfix:","postfix:","infix:","prefix:","quote:","term:"]

-- around a block body we save the package and the current lexical pad
-- at the start, so that they can be restored after parsing the body
localEnv :: RuleParser Exp -> RuleParser Exp
localEnv m = do
    state   <- get
    let env = s_env state
    put state
        { s_blockPads = Map.empty
        , s_closureTraits = (id : s_closureTraits state)
        , s_outerVars = Set.empty
        , s_env = env { envOuter = Just env }
        }
    rv      <- m
    state'  <- get
    put state
        { s_env = (s_env state')
            { envPackage = envPackage env
            , envLexical = envLexical env
            , envOuter   = envOuter env
            }
        , s_closureTraits = s_closureTraits state'
        }
    return $ Map.foldWithKey Pad rv (s_blockPads state')

ruleParamList :: ParensOption -> RuleParser a -> RuleParser (Maybe [[a]])
ruleParamList wantParens parse = rule "parameter list" $ do
    (formal, hasParens) <- f $
        (((try parse) `sepEndBy` lexeme (oneOf ",;")) `sepEndBy` invColon)
    case formal of
        [[]]   -> return $ if hasParens then Just [[], []] else Nothing
        [args] -> return $ Just [[], args]
        [_,_]  -> return $ Just formal
        _      -> fail "Only one invocant list allowed"
    where
    f = case wantParens of
        ParensOptional  -> maybeParensBool
        ParensMandatory -> \x -> do rv <- parens x; return (rv, True)
    invColon = do
        ch <- oneOf ":;"
        -- Compare:
        --   sub foo (: $a)   # vs.
        --   sub foo (:$a)
        lookAhead $ (many1 space <|> string ")")
        whiteSpace
        return ch
        
maybeParensBool :: RuleParser a -> RuleParser (a, Bool)
maybeParensBool p = choice
    [ do rv <- parens p; return (rv, True)
    , do rv <- p; return (rv, False)
    ]


isOperatorName :: String -> Bool
isOperatorName ('&':name) = any hasOperatorPrefix [name, tail name]
    where
    hasOperatorPrefix :: String -> Bool
    hasOperatorPrefix name = any (`isPrefixOf` name) grammaticalCategories
isOperatorName _ = False


{-| Wraps a call to @&Pugs::Internals::check_for_io_leak@ around the input
    expression. @&Pugs::Internals::check_for_io_leak@ should @die()@ if the
    expression returned an IO handle. -}
-- Please remember to edit Prelude.pm, too, if you rename the name of the
-- checker function.
checkForIOLeak :: Exp -> Exp
checkForIOLeak exp =
    App (_Var "&Pugs::Internals::check_for_io_leak") Nothing
        [ Val $ VCode mkSub { subBody = exp } ]
    
defaultParamFor :: SubType -> [Param]
defaultParamFor SubBlock    = [defaultScalarParam]
defaultParamFor SubPointy   = []
defaultParamFor _           = [defaultArrayParam]

doExtract :: SubType -> Maybe [Param] -> Exp -> (Exp, [Var], [Param])
doExtract SubBlock formal body = (fun, names', params)
    where
    (fun, names) = extractPlaceholderVars body Set.empty
    names' | isJust formal
           = sortNames (Set.delete varTopic names)
           | otherwise
           = sortNames names
    params = map nameToParam names' ++ (maybe [] id formal)
doExtract SubPointy formal body = (body, [], maybe [] id formal)
doExtract SubMethod formal body = (body, [], maybe [] id formal)
doExtract _ formal body = (body, names', params)
    where
    (_, names) = extractPlaceholderVars body Set.empty
    names' | isJust formal
           = sortNames (Set.delete varTopic names)
           | otherwise
           = sortNames (Set.filter (== varTopic) names)
    params = map nameToParam names' ++ (maybe [] id formal)

sortNames :: Set Var -> [Var]
sortNames = sortBy (\x y -> v_name x `compare` v_name y) . Set.toList

nameToParam :: Var -> Param
nameToParam name = MkOldParam
    { isInvocant    = False
    , isOptional    = False
    , isNamed       = False
    , isLValue      = True
    , isWritable    = (name == varTopic)
    , isLazy        = False
    , paramName     = name
    , paramContext  = CxtItem $ typeOfSigilVar name
    , paramDefault  = Noop
    }

_percentUnderscore :: Var
_percentUnderscore = cast "%_"

paramsFor :: SubType -> Maybe [Param] -> [Param] -> [Param]
paramsFor SubMethod formal params 
    | isNothing (find ((_percentUnderscore ==) . paramName) params)
    = paramsFor SubRoutine formal params ++ [defaultHashParam]
paramsFor styp Nothing []       = defaultParamFor styp
paramsFor _ _ params            = params

processFormals :: Monad m => [[Exp]] -> m (Maybe Exp, [Exp])
processFormals formal = case formal of
    []      -> return (Nothing, [])
    [args]  -> return (Nothing, unwind args)
    [invs,args] | [inv] <- unwind invs -> return (Just inv, unwind args)
    _                   -> fail "Only one invocant allowed"
    where
    unwind :: [Exp] -> [Exp]
    unwind [] = []
    unwind ((Syn "," list):xs) = unwind list ++ unwind xs
    unwind x  = x

-- | A Param representing the default (unnamed) invocant of a method on the given type.
selfParam :: Type -> Param
selfParam typ = MkOldParam
    { isInvocant    = True
    , isOptional    = False
    , isNamed       = False
    , isLValue      = True
    , isWritable    = True
    , isLazy        = False
    , paramName     = cast "&self"
    , paramContext  = CxtItem typ
    , paramDefault  = Noop
    }

extractHash :: Exp -> Maybe Exp
extractHash exp = extractHash' (possiblyUnwrap exp)
    where
    possiblyUnwrap (Syn "block" [exp]) = exp
    possiblyUnwrap (App (Val (VCode (MkCode { subType = SubBlock, subBody = fun }))) Nothing []) = fun
    possiblyUnwrap x = x
    
    isHashOrPair (Ann _ exp) = isHashOrPair exp
    isHashOrPair (App (Var var) _ _) =
        v_sigil var == SHash || (var == cast "&pair") || (var == cast "&infix:=>") 
    isHashOrPair (Syn "%{}" _) = True
    isHashOrPair _ = False
    
    extractHash' (Ann _ exp) = extractHash' exp
    extractHash' exp                      | isHashOrPair exp    = Just exp
    extractHash' exp@(Syn "," (subexp:_)) | isHashOrPair subexp = Just exp
    extractHash' exp@Noop = Just exp
    extractHash' _ = Nothing

tryLookAhead :: RuleParser a -> RuleParser b -> RuleParser a
tryLookAhead rule after = try $ do
    rv <- rule
    lookAhead after
    return rv

makeVar :: String -> Exp
makeVar (s:"<>") =
    makeVarWithSigil s $ _Var "$/"
makeVar (s:rest) | all (`elem` "1234567890") rest =
    makeVarWithSigil s $ Syn "[]" [_Var "$/", Val $ VInt (read rest)]
makeVar (s:'<':'<':name) =
    makeVarWithSigil s $ Syn "{}" [_Var "$/", doSplitStr shellWords (init (init name))]
makeVar (s:'\171':name) =
    makeVarWithSigil s $ Syn "{}" [_Var "$/", doSplitStr shellWords (init name)]
makeVar (s:'<':name) =
    makeVarWithSigil s $ Syn "{}" [_Var "$/", doSplitStr perl6Words (init name)]
makeVar var = _Var var

makeVarWithSigil :: Char -> Exp -> Exp
makeVarWithSigil '$' x = x
makeVarWithSigil s   x = Syn (s:"{}") [x]

-- | splits the string into expressions on whitespace.
-- Implements the <> operator at parse-time.
doSplitStr :: (String -> [String]) -> String -> Exp
doSplitStr f str = case f str of
    []  -> Syn "," []
    [x] -> Val (VStr x)
    xs  -> Syn "," $ map (Val . VStr) xs

perl6Words :: String -> [String]
perl6Words s
    | [] <- findSpace = []
    | otherwise       = w : words s''
    where
    (w, s'')  = break isBreakingSpace findSpace
    findSpace = dropWhile isBreakingSpace s

isBreakingSpace :: Char -> Bool
isBreakingSpace '\x09'  = True
isBreakingSpace '\x0a'  = True
isBreakingSpace '\x0d'  = True
isBreakingSpace '\x20'  = True
isBreakingSpace _       = False

followedBy, tryFollowedBy :: RuleParser a -> RuleParser b -> RuleParser a
followedBy rule after = do
    rv <- rule
    after
    return rv

tryFollowedBy = (try .) . followedBy

-- XXX - Naive implementation of << 1 '2' 3 >>, only used in $<< 'foo' >> so far

data ShellWordsState = MkShellWordsState
    { s_escape  :: Bool
    , s_quote   :: (Maybe Char)
    , s_cur     :: Maybe String
    , s_acc     :: [String]
    }

shellWords :: String -> [String]
shellWords = postProc . foldl doShellWords (MkShellWordsState False Nothing Nothing [])
    where
    doShellWords state ch
        | s_escape state
        = normalChar{ s_escape = False }
        | '\\' <- ch
        = state{ s_escape = True }
        | Just q <- s_quote state
        = if ch == q then closeQuote else normalChar
        | isBreakingSpace ch
        = nextWord
        | '"' <- ch     = beginQuote
        | '\'' <- ch    = beginQuote
        | otherwise     = normalChar
        where
        cur = s_cur state
        acc = s_acc state
        normalChar = state{ s_cur = Just (maybe [ch] (ch:) cur) }
        beginQuote = state{ s_quote = Just ch }
        closeQuote = state{ s_quote = Nothing, s_cur = Just (maybe "" id cur) }
        nextWord   = state{ s_acc = maybe acc (:acc) cur, s_cur = Nothing }
    postProc MkShellWordsState{ s_cur = cur, s_acc = acc } = reverse (map reverse acc')
        where
        acc' = maybe acc (:acc) cur