module Yi.Mode.Haskell
(
haskellAbstract,
cleverMode,
preciseMode,
literateMode,
fastMode,
ghciGet,
ghciSend,
ghciLoadBuffer,
ghciInferType,
ghciSetProcessName,
ghciSetProcessArgs
) where
import Control.Applicative
import Control.Lens
import Control.Monad hiding (forM_)
import Data.Binary
import Data.Default
import Data.Foldable
import Data.Maybe (listToMaybe, isJust)
import Data.Monoid
import qualified Data.Text as T
import Data.Typeable
import Prelude hiding (and,error,elem,notElem,all,concatMap,exp)
import Text.Read (readMaybe)
import Yi.Buffer
import Yi.Core (sendToProcess)
import Yi.Debug
import Yi.Types (YiVariable)
import Yi.Editor
import Yi.File
import qualified Yi.IncrementalParse as IncrParser
import Yi.Keymap
import Yi.Lexer.Alex (Tok(..), Posn(..), tokBegin, tokEnd,
commonLexer, AlexState, lexScanner, CharScanner)
import Yi.Lexer.Haskell as Haskell
import qualified Yi.Lexer.LiterateHaskell as LiterateHaskell
import Yi.MiniBuffer
import qualified Yi.Mode.GHCi as GHCi
import qualified Yi.Mode.Interactive as Interactive
import Yi.Modes (anyExtension, extensionOrContentsMatch)
import Yi.Monad
import qualified Yi.Rope as R
import Yi.String
import Yi.Syntax
import qualified Yi.Syntax.Driver as Driver
import Yi.Syntax.Haskell as Hask
import Yi.Syntax.Layout (State)
import Yi.Syntax.OnlineTree as OnlineTree
import Yi.Syntax.Paren as Paren
import Yi.Syntax.Strokes.Haskell as HS
import Yi.Syntax.Tree
import Yi.Utils
haskellAbstract :: Mode (tree TT)
haskellAbstract = emptyMode
& modeAppliesA .~ extensionOrContentsMatch extensions shebangPattern
& modeNameA .~ "haskell"
& modeToggleCommentSelectionA .~ Just (toggleCommentB "--")
where extensions = ["hs", "x", "hsc", "hsinc"]
shebangPattern = "^#![[:space:]]*/usr/bin/env[[:space:]]+runhaskell"
cleverMode :: Mode (Paren.Tree (Tok Haskell.Token))
cleverMode = haskellAbstract
& modeIndentA .~ cleverAutoIndentHaskellB
& modeGetStrokesA .~ strokesOfParenTree
& modeHLA .~ mkParenModeHL (skipScanner 50) haskellLexer
& modeAdjustBlockA .~ adjustBlock
& modePrettifyA .~ cleverPrettify . allToks
fastMode :: Mode (OnlineTree.Tree TT)
fastMode = haskellAbstract
& modeNameA .~ "fast haskell"
& modeHLA .~ mkOnlineModeHL haskellLexer
& modeGetStrokesA .~ tokenBasedStrokes Paren.tokenToStroke
literateMode :: Mode (Paren.Tree TT)
literateMode = haskellAbstract
& modeNameA .~ "literate haskell"
& modeAppliesA .~ anyExtension ["lhs"]
& modeHLA .~ mkParenModeHL id literateHaskellLexer
& modeGetStrokesA .~ strokesOfParenTree
& modeAdjustBlockA .~ adjustBlock
& modeIndentA .~ cleverAutoIndentHaskellB
& modePrettifyA .~ cleverPrettify . allToks
preciseMode :: Mode (Hask.Tree TT)
preciseMode = haskellAbstract
& modeNameA .~ "precise haskell"
& modeIndentA .~ cleverAutoIndentHaskellC
& modeGetStrokesA .~ (\ast point begin end -> HS.getStrokes point begin end ast)
& modeHLA .~ mkHaskModeHL haskellLexer
& modePrettifyA .~ cleverPrettify . allToks
strokesOfParenTree :: Paren.Tree TT -> Point -> Point -> Point -> [Stroke]
strokesOfParenTree t p b e = Paren.getStrokes p b e t
type CharToTTScanner s = CharScanner -> Scanner (AlexState s) TT
mkParenModeHL :: (IsTree tree, Show state)
=> (Scanner
(IncrParser.State (State Token lexState) TT (Paren.Tree TT))
(Paren.Tree TT)
-> Scanner state (tree (Tok tt)))
-> CharToTTScanner lexState
-> ExtHL (tree (Tok tt))
mkParenModeHL f l = ExtHL $ Driver.mkHighlighter scnr
where
scnr = f . IncrParser.scanner Paren.parse . Paren.indentScanner . l
mkHaskModeHL :: Show st => CharToTTScanner st -> ExtHL (Exp (Tok Token))
mkHaskModeHL l = ExtHL $ Driver.mkHighlighter scnr
where
scnr = IncrParser.scanner Hask.parse . Hask.indentScanner . l
mkOnlineModeHL :: Show st => (CharScanner -> Scanner st (Tok tt))
-> ExtHL (OnlineTree.Tree (Tok tt))
mkOnlineModeHL l = ExtHL $ Driver.mkHighlighter scnr
where
scnr = IncrParser.scanner OnlineTree.manyToks . l
haskellLexer :: CharScanner -> Scanner (AlexState Haskell.HlState) TT
haskellLexer = lexScanner (commonLexer Haskell.alexScanToken Haskell.initState)
literateHaskellLexer :: CharScanner -> Scanner (AlexState LiterateHaskell.HlState) TT
literateHaskellLexer = lexScanner (commonLexer LiterateHaskell.alexScanToken LiterateHaskell.initState)
adjustBlock :: Paren.Tree (Tok Token) -> Int -> BufferM ()
adjustBlock e len = do
p <- pointB
l <- curLn
let t = Paren.getIndentingSubtree e p l
case t of
Nothing -> return ()
Just it -> savingExcursionB $ do
let (_startOfs, height) = Paren.getSubtreeSpan it
col <- curCol
forM_ [1..height] $ const $ do
lineDown
indent <- indentOfB =<< readLnB
when (indent > col) $
if len >= 0
then do
insertN $ R.replicateChar len ' '
leftN len
else deleteN (negate len)
insideGroup :: Token -> Bool
insideGroup (Special c) = T.any (== c) "',;})]"
insideGroup _ = True
indentInfoB :: BufferM (Int, Int, Int, Point, Point)
indentInfoB = do
indentLevel <- shiftWidth <$> indentSettingsB
previousIndent <- indentOfB =<< getNextNonBlankLineB Backward
nextIndent <- indentOfB =<< getNextNonBlankLineB Forward
solPnt <- pointAt moveToSol
eolPnt <- pointAt moveToEol
return (indentLevel, previousIndent, nextIndent, solPnt, eolPnt)
cleverAutoIndentHaskellB :: Paren.Tree TT -> IndentBehaviour -> BufferM ()
cleverAutoIndentHaskellB e behaviour = do
(indentLevel, previousIndent, nextIndent, solPnt, eolPnt) <- indentInfoB
let onThisLine ofs = ofs >= solPnt && ofs <= eolPnt
firstTokNotOnLine = listToMaybe .
filter (not . onThisLine . posnOfs . tokPosn) .
filter (not . isErrorTok . tokT) . concatMap allToks
let stopsOf :: [Paren.Tree TT] -> [Int]
stopsOf (g@(Paren.Paren open ctnt close):ts')
| isErrorTok (tokT close) || getLastOffset g >= solPnt
= [groupIndent open ctnt]
| otherwise = stopsOf ts'
stopsOf (Paren.Atom (Tok {tokT = t}):_) | startsLayout t = [nextIndent, previousIndent + indentLevel]
stopsOf (Paren.Atom _:ts) = stopsOf ts
stopsOf (t@(Paren.Block _):ts) = shiftBlock + maybe 0 (posnCol . tokPosn) (getFirstElement t) : stopsOf ts
stopsOf (_:ts) = stopsOf ts
stopsOf [] = []
firstTokOnLine = fmap tokT $ listToMaybe $
dropWhile ((solPnt >) . tokBegin) $
takeWhile ((eolPnt >) . tokBegin) $
filter (not . isErrorTok . tokT) $ allToks e
shiftBlock = case firstTokOnLine of
Just (Reserved t) | t `elem` [Where, Deriving] -> indentLevel
Just (ReservedOp Haskell.Pipe) -> indentLevel
Just (ReservedOp Haskell.Equal) -> indentLevel
_ -> 0
deepInGroup = maybe True insideGroup firstTokOnLine
groupIndent (Tok {tokT = Special openChar, tokPosn = Posn _ _ openCol}) ctnt
| deepInGroup = case firstTokNotOnLine ctnt of
Nothing -> openCol + nominalIndent openChar
Just t -> posnCol . tokPosn $ t
| otherwise = openCol
groupIndent (Tok {}) _ = error "unable to indent code"
case getLastPath [e] solPnt of
Nothing -> return ()
Just path -> let stops = stopsOf path
in trace ("Stops = " <> showT stops) $
trace ("firstTokOnLine = " <> showT firstTokOnLine) $
cycleIndentsB behaviour stops
cleverAutoIndentHaskellC :: Exp TT -> IndentBehaviour -> BufferM ()
cleverAutoIndentHaskellC e behaviour = do
(indentLevel, previousIndent, nextIndent, solPnt, eolPnt) <- indentInfoB
let onThisLine ofs = ofs >= solPnt && ofs <= eolPnt
firstTokNotOnLine = listToMaybe .
filter (not . onThisLine . posnOfs . tokPosn) .
filter (not . isErrorTok . tokT) . concatMap allToks
let stopsOf :: [Hask.Exp TT] -> [Int]
stopsOf (g@(Hask.Paren (Hask.PAtom open _) ctnt (Hask.PAtom close _)):ts)
| isErrorTok (tokT close) || getLastOffset g >= solPnt
= [groupIndent open ctnt]
| otherwise = stopsOf ts
stopsOf (Hask.PAtom (Tok {tokT = t}) _:_) | startsLayout t || (t == ReservedOp Equal)
= [nextIndent, previousIndent + indentLevel]
stopsOf (l@(Hask.PLet _ (Hask.Block _) _):ts') = [colOf' l | lineStartsWith (Reserved Haskell.In)] <> stopsOf ts'
stopsOf (t@(Hask.Block _):ts') = (shiftBlock + colOf' t) : stopsOf ts'
stopsOf (Hask.PGuard' (PAtom pipe _) _ _:ts') = [tokCol pipe | lineStartsWith (ReservedOp Haskell.Pipe)] <> stopsOf ts'
stopsOf (d@(Hask.PData {}):ts') = colOf' d + indentLevel
: stopsOf ts' --FIXME!
stopsOf (Hask.RHS (Hask.PAtom{}) exp:ts')
= [case firstTokOnLine of
Just (Operator op') -> opLength op' (colOf' exp)
_ -> colOf' exp | lineIsExpression ] <> stopsOf ts'
stopsOf [] = [0]
stopsOf (_:ts) = stopsOf ts
opLength ts' r = let l = r (length ts' + 1)
in if l > 0 then l else 1
lineStartsWith tok = firstTokOnLine == Just tok
lineIsExpression = all (`notElem` [ReservedOp Haskell.Pipe, ReservedOp Haskell.Equal, ReservedOp RightArrow]) toksOnLine
&& not (lineStartsWith (Reserved Haskell.In))
firstTokOnLine = listToMaybe toksOnLine
toksOnLine = fmap tokT $
dropWhile ((solPnt >) . tokBegin) $
takeWhile ((eolPnt >) . tokBegin) $
filter (not . isErrorTok . tokT) $ allToks e
shiftBlock = case firstTokOnLine of
Just (Reserved t) | t `elem` [Where, Deriving] -> indentLevel
Just (ReservedOp Haskell.Pipe) -> indentLevel
Just (ReservedOp Haskell.Equal) -> indentLevel
_ -> 0
deepInGroup = maybe True insideGroup firstTokOnLine
groupIndent (Tok {tokT = Special openChar, tokPosn = Posn _ _ openCol}) ctnt
| deepInGroup = case firstTokNotOnLine ctnt of
Nothing -> openCol + nominalIndent openChar
Just t -> posnCol . tokPosn $ t
| otherwise = openCol
groupIndent (Tok{}) _ = error "unable to indent code"
case getLastPath [e] solPnt of
Nothing -> return ()
Just path ->let stops = stopsOf path
in trace ("Path = " <> showT path) $
trace ("Stops = " <> showT stops) $
trace ("Previous indent = " <> showT previousIndent) $
trace ("Next indent = " <> showT nextIndent) $
trace ("firstTokOnLine = " <> showT firstTokOnLine) $
cycleIndentsB behaviour stops
colOf' :: Foldable t => t TT -> Int
colOf' = maybe 0 tokCol . getFirstElement
tokCol :: Tok t -> Int
tokCol = posnCol . tokPosn
nominalIndent :: Char -> Int
nominalIndent '{' = 2
nominalIndent _ = 1
tokText :: Tok t -> BufferM R.YiString
tokText = readRegionB . tokRegion
tokRegion :: Tok t -> Region
tokRegion t = mkRegion (tokBegin t) (tokEnd t)
isLineComment :: TT -> Bool
isLineComment = (Just Haskell.Line ==) . tokTyp . tokT
contiguous :: Tok t -> Tok t -> Bool
contiguous a b = lb la <= 1
where [la,lb] = fmap (posnLine . tokPosn) [a,b]
coalesce :: Tok Token -> Tok Token -> Bool
coalesce a b = isLineComment a && isLineComment b && contiguous a b
cleverPrettify :: [TT] -> BufferM ()
cleverPrettify toks = do
pnt <- pointB
let groups = groupBy' coalesce toks
isCommentGroup g = tokTyp (tokT $ head g) `elem` fmap Just [Haskell.Line]
thisCommentGroup = listToMaybe $ dropWhile ((pnt >) . tokEnd . last) $ filter isCommentGroup groups
case thisCommentGroup of
Nothing -> return ()
Just g -> do
text <- T.unwords . fmap (T.drop 2 . R.toText) <$> mapM tokText g
let region = mkRegion (tokBegin . head $ g) (tokEnd . last $ g)
mkGrp = const . R.unlines $ R.append "-- " <$> fillText 80 (R.fromText text)
modifyRegionB mkGrp region
tokTyp :: Token -> Maybe Haskell.CommentType
tokTyp (Comment t) = Just t
tokTyp _ = Nothing
newtype GhciBuffer = GhciBuffer {_ghciBuffer :: Maybe BufferRef}
deriving (Default, Typeable, Binary)
instance YiVariable GhciBuffer
ghci :: YiM BufferRef
ghci = do
g <- getEditorDyn
b <- GHCi.spawnProcess (g ^. GHCi.ghciProcessName) (g ^. GHCi.ghciProcessArgs)
withEditor . putEditorDyn . GhciBuffer $ Just b
return b
ghciGet :: YiM BufferRef
ghciGet = withOtherWindow $ do
GhciBuffer mb <- withEditor getEditorDyn
case mb of
Nothing -> ghci
Just b -> do
stillExists <- isJust <$> findBuffer b
if stillExists
then do withEditor $ switchToBufferE b
return b
else ghci
ghciSend :: String -> YiM ()
ghciSend cmd = do
b <- ghciGet
withGivenBuffer b botB
sendToProcess b (cmd <> "\n")
ghciLoadBuffer :: YiM ()
ghciLoadBuffer = do
void fwriteE
f <- withCurrentBuffer (gets file)
case f of
Nothing -> error "Couldn't get buffer filename in ghciLoadBuffer"
Just filename -> ghciSend $ ":load " <> show filename
ghciInferType :: YiM ()
ghciInferType = do
nm <- withCurrentBuffer (readUnitB unitWord)
unless (R.null nm) $
withMinibufferGen (R.toText nm) noHint "Insert type of which identifier?"
return (const $ return ()) (ghciInferTypeOf . R.fromText)
ghciInferTypeOf :: R.YiString -> YiM ()
ghciInferTypeOf nm = do
buf <- ghciGet
result <- Interactive.queryReply buf (":t " <> R.toString nm)
let successful = (not . R.null) nm && nm == result
when successful . withCurrentBuffer $
moveToSol *> insertB '\n' *> leftB
*> insertN result *> rightB
ghciSetProcessName :: YiM ()
ghciSetProcessName = do
g <- getEditorDyn
let nm = g ^. GHCi.ghciProcessName
prompt = T.concat [ "Command to call for GHCi, currently ‘"
, T.pack nm, "’: " ]
withMinibufferFree prompt $ \s ->
putEditorDyn $ g & GHCi.ghciProcessName .~ T.unpack s
ghciSetProcessArgs :: YiM ()
ghciSetProcessArgs = do
g <- getEditorDyn
let nm = g ^. GHCi.ghciProcessName
args = g ^. GHCi.ghciProcessArgs
prompt = T.unwords [ "List of args to call "
, T.pack nm
, "with, currently"
, T.pack $ show args
, ":"
]
withMinibufferFree prompt $ \arg ->
case readMaybe $ T.unpack arg of
Nothing -> printMsg "Could not parse as [String], keep old args."
Just arg' -> putEditorDyn $ g & GHCi.ghciProcessArgs .~ arg'