Paren.hs

{-# LANGUAGE FlexibleInstances, TypeFamilies, TemplateHaskell #-}
-- Copyright (c) JP Bernardy 2008
-- | Parser for haskell that takes in account only parenthesis and layout
module Yi.Syntax.Paren where

import Yi.IncrementalParse
import Yi.Lexer.Alex
import Yi.Lexer.Haskell
import Yi.Style (hintStyle, errorStyle, StyleName)
import Yi.Syntax.Layout
import Yi.Syntax.Tree
import Yi.Syntax.BList
import Yi.Syntax
import Yi.Prelude 
import Prelude ()
import Data.Monoid
import Data.DeriveTH
import Data.Derive.Foldable
import Data.Maybe
import Data.List (filter, takeWhile)

indentScanner :: Scanner (AlexState lexState) (TT)
              -> Scanner (Yi.Syntax.Layout.State Token lexState) (TT)
indentScanner = layoutHandler startsLayout [(Special '(', Special ')'),
                                            (Special '[', Special ']'),
                                            (Special '{', Special '}')] ignoredToken
                         (fmap Special ['<', '>', '.'])

-- HACK: We insert the Special '<', '>', '.', that don't occur in normal haskell
-- parsing.

ignoredToken :: TT -> Bool
ignoredToken (Tok t _ (Posn _ _ col)) = col == 0 && isComment t || t == CppDirective
    
isNoise :: Token -> Bool
isNoise (Special c) = c `elem` ";,`"
isNoise _ = True

type Expr t = [Tree t]

data Tree t
    = Paren t (Expr t) t -- A parenthesized expression (maybe with [ ] ...)
    | Block (BList (Expr t))      -- A list of things separated by layout (as in do; etc.)
    | Atom t
    | Error t
      deriving Show

$(derive makeFoldable ''Tree)
instance IsTree Tree where
    subtrees (Paren _ g _) = g
    subtrees (Block s) = concat s
    subtrees _ = []

-- | Search the given list, and return the 1st tree after the given
-- point on the given line.  This is the tree that will be moved if
-- something is inserted at the point.  Precondition: point is in the
-- given line.  

-- TODO: this should be optimized by just giving the point of the end
-- of the line
getIndentingSubtree :: [Tree TT] -> Point -> Int -> Maybe (Tree TT)
getIndentingSubtree roots offset line =
    listToMaybe $ [t | (t,posn) <- takeWhile ((<= line) . posnLine . snd) $ allSubTreesPosn,
                   -- it's very important that we do a linear search
                   -- here (takeWhile), so that the tree is evaluated
                   -- lazily and therefore parsing it can be lazy.
                   posnOfs posn > offset, posnLine posn == line]
    where allSubTreesPosn = [(t',posn) | root <- roots, t'@(Block _) <-filter (not . null . toList) (getAllSubTrees root), 
                             let (tok:_) = toList t',
                             let posn = tokPosn tok]


-- | given a tree, return (first offset, number of lines).
getSubtreeSpan :: Tree TT -> (Point, Int)
getSubtreeSpan tree = (posnOfs $ first, lastLine - firstLine)
    where bounds@[first, _last] = fmap (tokPosn . assertJust) [getFirstElement tree, getLastElement tree]
          [firstLine, lastLine] = fmap posnLine bounds
          assertJust (Just x) = x
          assertJust _ = error "assertJust: Just expected"
    

-- $(derive makeFunctor ''Tree)

-- dropWhile' f = foldMap (\x -> if f x then mempty else Endo (x :))
-- 
-- isBefore l (Atom t) = isBefore' l t
-- isBefore l (Error t) = isBefore l t
-- isBefore l (Paren l g r) = isBefore l r
-- isBefore l (Block s) = False
-- 
-- isBefore' l (Tok {tokPosn = Posn {posnLn = l'}}) = 


parse :: P TT [Tree TT]
parse = parse' tokT tokFromT

parse' :: (TT -> Token) -> (Token -> TT) -> P TT [Tree TT]
parse' toTok fromT = pExpr <* eof
    where 
      -- | parse a special symbol
      sym c = symbol (isSpecial [c] . toTok)

      -- | Create a special character symbol
      newT c = fromT (Special c)

      pleaseSym c = (recoverWith (pure $ newT '!')) <|> sym c

      pExpr :: P TT (Expr TT)
      pExpr = Yi.Prelude.many pTree

      pBlocks = pExpr `Yi.Syntax.BList.sepBy` sym '.' -- see HACK above
      -- also, we discard the empty statements

      pTree :: P TT (Tree TT)
      pTree = (Paren  <$>  sym '(' <*> pExpr  <*> pleaseSym ')')
          <|> (Paren  <$>  sym '[' <*> pExpr  <*> pleaseSym ']')
          <|> (Paren  <$>  sym '{' <*> pExpr  <*> pleaseSym '}')

          <|> (Block <$> (sym '<' *> pBlocks <* sym '>')) -- see HACK above

          <|> (Atom <$> symbol (isNoise . toTok))
          <|> (Error <$> recoverWith (symbol (isSpecial "})]" . toTok)))

      -- note that, by construction, '<' and '>' will always be matched, so
      -- we don't try to recover errors with them.

instance SubTree (Tree TT) where
    type Element (Tree TT) = TT
    foldMapToksAfter begin f t0 = work t0
        where work (Atom t) = f t
              work (Error t) = f t
              work (Block s) = foldMapAfter begin (foldMapToksAfter begin f) s
              work (Paren l g r) = f l <> foldMap work g <> f r
    foldMapToks f = foldMap (foldMapToks f)


-- TODO: (optimization) make sure we take in account the begin, so we don't return useless strokes
getStrokes :: Point -> Point -> Point -> [Tree TT] -> [Stroke]
getStrokes point begin _end t0 = trace (show t0) result 
    where getStrokes' (Atom t) = one (ts t)
          getStrokes' (Error t) = one (modStroke errorStyle (ts t)) -- paint in red
          getStrokes' (Block s) = foldMapAfter begin getStrokesL s
          getStrokes' (Paren l g r)
              | isErrorTok $ tokT r = one (modStroke errorStyle (ts l)) <> getStrokesL g
              -- left paren wasn't matched: paint it in red.
              -- note that testing this on the "Paren" node actually forces the parsing of the
              -- right paren, undermining online behaviour.
              | (posnOfs $ tokPosn $ l) == point || (posnOfs $ tokPosn $ r) == point - 1

               = one (modStroke hintStyle (ts l)) <> getStrokesL g <> one (modStroke hintStyle (ts r))
              | otherwise  = one (ts l) <> getStrokesL g <> one (ts r)
          getStrokesL = foldMap getStrokes'
          ts = tokenToStroke
          result = appEndo (getStrokesL t0) []
          one x = Endo (x :)
          

tokenToStroke :: TT -> Stroke
tokenToStroke = fmap tokenToStyle . tokToSpan

modStroke :: StyleName -> Stroke -> Stroke
modStroke f = fmap (f `mappend`)

tokenToAnnot :: TT -> Maybe (Span String)
tokenToAnnot (Tok t len posn) = case tokenToText t of
    Nothing -> Nothing
    Just x -> Just (Span (posnOfs posn) x (posnOfs posn +~ len))