module Term where

import qualified ModuleBase as Module
import qualified TermParser as Parser
import TermParser
            ( lexer, symbol, operators,
              operatorSymbols, operatorStart, operatorLetter )
import SourceText
            ( ModuleRange(ModuleRange), emptyRange,
              ParserRange, consRange, ranged )
import InOut ( Input, Output, input, output )

import qualified Text.ParserCombinators.Parsec.Token as T
import qualified Text.ParserCombinators.Parsec.Expr as Expr
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec.Expr ( Assoc )
import Text.ParserCombinators.Parsec ( Parser, getPosition, (<|>), (<?>), )
import Text.PrettyPrint.HughesPJ ( Doc, (<+>), fsep, parens, render, text )

import qualified Control.Monad.Exception.Synchronous as ME
import Control.Monad.Exception.Synchronous ( Exceptional(Exception) )
import Control.Monad ( liftM2, mzero )
import Control.Applicative ( (<$>) )
import Data.Char (isUpper, isLower)


data Identifier range = Identifier { range :: range, name :: String }

instance Functor Identifier where
    fmap f (Identifier rng idname) = Identifier (f rng) idname

identifier :: Module.Name -> String -> Identifier ModuleRange
identifier moduName =
    Identifier (ModuleRange moduName Module.noVersion emptyRange)


isConstructor :: Identifier range -> Bool
isConstructor i =
    case name i of
        c:_ -> c == '[' || c == ':' || isUpper c
        _ -> error "isConstructor: identifier must be non-empty"

isVariable :: Identifier range -> Bool
isVariable i =
    case name i of
        c:_ -> isLower c || elem c ('_':operatorSymbols)
        _ -> error "isVariable: identifier must be non-empty"


parenOperator :: (ParserRange range) => Parser (Identifier range)
parenOperator =
    T.parens lexer $ T.lexeme lexer $
    fmap (uncurry Identifier) $ ranged $
    liftM2 (:) operatorStart (Parsec.many operatorLetter)

infixOperator :: (ParserRange range) => Parser (Identifier range)
infixOperator =
    T.lexeme lexer $
    fmap (uncurry Identifier) $ ranged $
       Parsec.between (Parsec.char '`') (Parsec.char '`') Parser.identifier
       <|>
       liftM2 (:) operatorStart (Parsec.many operatorLetter)


instance (ParserRange range) => Input (Identifier range) where
  input =
      T.lexeme lexer $
      fmap (uncurry Identifier) $ ranged Parser.identifier

instance Output (Identifier range) where
  output i = text $ name i

instance Show (Identifier range) where show = render . output


data Term range =
      Node (Identifier range) [ Term range ]
    | Number range Integer
    | StringLiteral range String

instance Show (Term range) where show = render . output

match :: Term range -> Term range -> Bool
match (Node x xs) (Node y ys)  =  name x == name y && equatingList match xs ys
match (Number _rngx x) (Number _rngy y)  =  x==y
match (StringLiteral _rngx x) (StringLiteral _rngy y)  =  x==y
match _ _ = False

equatingList :: (a -> a -> Bool) -> [a] -> [a] -> Bool
equatingList eq =
    let go (x:xs) (y:ys) = eq x y && go xs ys
        go [] [] = True
        go _ _ = False
    in  go


variable :: Module.Name -> String -> Term ModuleRange
variable moduName n = Node (identifier moduName n) []

main :: Term ModuleRange
main = variable Module.mainName "main"


{- |
simplifies case analysis
-}
viewNode :: Term range -> Maybe (String, [Term range])
viewNode (Node f xs) = Just (Term.name f, xs)
viewNode _ = Nothing


liftMonadFail :: (Monad m) => Exceptional String a -> m a
liftMonadFail = ME.switch fail return

{- |
This function allows us to handle @((f) a) b@ equivalently to @f a b@
in any circumstance, i.e. parsing and rewriting.
-}
appendArguments :: Term range -> [Term range] -> Exceptional String (Term range)
appendArguments g ys =
    case (g, ys) of
        (Node f xs, _) -> return $ Node f $ xs ++ ys
        (t, []) -> return t
        (t, _) ->
            Exception $
            unwords [ "cannot apply ", show t,
                      "to arguments like a function" ]

{- |
I would like to use 'T.stringLiteral'
but this skips trailing spaces
and we need the precise range of the literal.
However this implementation is very simplistic,
since T.stringChar is not exported.
-}
parseStringLiteral :: Parsec.Parser String
parseStringLiteral =
    flip (<?>) "literal string" $
--    fmap catMaybes $
    Parsec.between
        (Parsec.char '"')
        (Parsec.char '"' <?> "end of string")
        (Parsec.many (Parsec.noneOf $ '"':"\n\r\\"))
--        (Parsec.many (T.stringChar lexer))


parseAtom :: (ParserRange range) => Parser (Term range)
parseAtom =
        (T.lexeme lexer $ fmap (uncurry Number) $
         ranged (fmap read $ Parsec.many1 Parsec.digit))
    <|> fmap (uncurry StringLiteral)
             (T.lexeme lexer (ranged parseStringLiteral))
--    <|> fmap (uncurry StringLiteral) (ranged (T.stringLiteral lexer))
    <|> T.parens lexer input
    <|> bracketedList
    <|> fmap (flip Node []) input

parse :: (ParserRange range) => Parser (Term range)
parse =
    liftMonadFail =<<
        liftM2 appendArguments parseAtom (Parsec.many parseAtom)

instance (ParserRange range) => Input (Term range) where
  input = Expr.buildExpressionParser table parse


table :: (ParserRange range) => Expr.OperatorTable Char st (Term range)
table = map ( map binary ) operators

binary ::
    (ParserRange range) => (String, Assoc) -> Expr.Operator Char st (Term range)
binary (s, assoc) = flip Expr.Infix assoc $ do
    rng <- Parsec.try $ T.lexeme lexer $ do
        (rng,_) <- ranged $ Parsec.string s
        Parsec.notFollowedBy operatorLetter <?> ("end of " ++ show s)
        return rng
    return $ \ l r -> Node ( Identifier { name = s, range = rng } ) [ l, r ]


bracketedList :: (ParserRange range) => Parser (Term range)
bracketedList = do
    (r,_) <- ranged $ symbol "["
    insideBracketedList r

insideBracketedList :: (ParserRange range) => range -> Parser (Term range)
insideBracketedList rng =
        do (r,_) <- ranged $ symbol "]"
           return $ Node ( Identifier { name = "[]", range = r } ) []
    <|> do x <- input
           q <- getPosition
           xs <-   do symbol "]" ; r <- getPosition
                      return $ Node
                        ( Identifier { name = "[]", range = consRange q r } ) []
               <|> do symbol "," ; r <- getPosition
                      insideBracketedList $ consRange q r
           return $ Node ( Identifier { name = ":", range = rng } ) [ x, xs ]

instance Output (Term range) where
  output t = case t of
     Number _ n -> text $ show n
     StringLiteral _ s -> text $ show s
     Node f args -> output f <+> fsep ( map protected args )

protected :: Term range -> Doc
protected t = case t of
  Node _f (_:_) -> parens $ output t
  _ -> output t


termRange :: Term range -> range
termRange (Node i _) = range i
termRange (Number rng _) = rng
termRange (StringLiteral rng _) = rng

instance Functor Term where
    fmap f t =
        case t of
            Node i ts -> Node (f <$> i) (map (fmap f) ts)
            Number rng n -> Number (f rng) n
            StringLiteral rng str -> StringLiteral (f rng) str

{- |
compute the number of nodes in the same depth
-}
breadths :: Term range -> [ Int ]
breadths t = 1 : case t of
    Node _f xs -> foldl addList [] $ map breadths xs
    _ -> []

addList :: [ Int ] -> [ Int ] -> [ Int ]
addList (x:xs) (y:ys) = (x+y) : addList xs ys
addList [] ys = ys
addList xs [] = xs


type Position = [ Int ]

subterms :: Term range -> [ (Position, Term range) ]
subterms t = ( [], t ) : case t of
    Node _f xs -> do
        (k, x) <- zip [ 0.. ] xs
        (p, s) <- subterms x
        return (k : p, s)
    _ -> []

peek :: Term range -> Position -> Maybe (Term range)
peek t [] = return t
peek (Node _f xs) (k : ks) =
    case drop k xs of
        x:_ -> peek x ks
        [] -> mzero
peek _ _  = mzero

poke :: Term range -> Position -> Term range -> Maybe (Term range)
poke _t [] s = return s
poke (Node f xs) (k : ks) s =
    case splitAt k xs of
        (pre, x : post) -> do
            y <- poke x ks s
            return $ Node f $ pre ++ y : post
        (_, []) -> error "Term.poke: index too large"
poke _ (_:_) _ =
    error "Term.poke: cannot access a leaf with an index"