yi-language-0.18.0/src/0000755000000000000000000000000013226661437012771 5ustar0000000000000000yi-language-0.18.0/src/Yi/0000755000000000000000000000000013246272742013351 5ustar0000000000000000yi-language-0.18.0/src/Yi/Buffer/0000755000000000000000000000000013226661437014563 5ustar0000000000000000yi-language-0.18.0/src/Yi/Lexer/0000755000000000000000000000000013246272742014430 5ustar0000000000000000yi-language-0.18.0/src/Yi/Style/0000755000000000000000000000000013246272742014451 5ustar0000000000000000yi-language-0.18.0/test/0000755000000000000000000000000013246272742013160 5ustar0000000000000000yi-language-0.18.0/src/Yi/Buffer/Basic.hs0000644000000000000000000000436013226661437016143 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP #-} -- Copyright 2008 JP Bernardy -- | Basic types useful everywhere we play with buffers. module Yi.Buffer.Basic where import Data.Binary import Data.Typeable import GHC.Generics (Generic) import Data.Ix import Data.Default import Yi.Utils -- | Direction of movement inside a buffer data Direction = Backward | Forward deriving (Eq, Ord, Typeable, Show, Bounded, Enum, Generic) instance Binary Direction reverseDir :: Direction -> Direction reverseDir Forward = Backward reverseDir Backward = Forward -- | reverse if Backward mayReverse :: Direction -> [a] -> [a] mayReverse Forward = id mayReverse Backward = reverse -- | 'direction' is in the same style of 'maybe' or 'either' functions, -- It takes one argument per direction (backward, then forward) and a -- direction to select the output. directionElim :: Direction -> a -> a -> a directionElim Backward b _ = b directionElim Forward _ f = f -- | A mark in a buffer newtype Mark = Mark {markId::Int} deriving (Eq, Ord, Show, Typeable, Binary) -- | Reference to a buffer. newtype BufferRef = BufferRef Int deriving (Eq, Ord, Typeable, Binary, Num) instance Show BufferRef where show (BufferRef r) = "B#" ++ show r -- | A point in a buffer newtype Point = Point {fromPoint :: Int} -- offset in the buffer (#codepoints, NOT bytes) deriving (Eq, Ord, Enum, Bounded, Typeable, Binary, Ix, Num, Real, Integral) instance Show Point where show (Point p) = show p -- | Size of a buffer region newtype Size = Size {fromSize :: Int} -- size in bytes (#bytes, NOT codepoints) deriving (Show, Eq, Ord, Num, Enum, Real, Integral, Binary) instance SemiNum Point Size where Point p +~ Size s = Point (p + s) Point p -~ Size s = Point (p - s) Point p ~- Point q = Size (abs (p - q)) -- | Window references newtype WindowRef = WindowRef { unWindowRef :: Int } deriving(Eq, Ord, Enum, Show, Typeable, Binary) instance Default WindowRef where def = WindowRef (-1) yi-language-0.18.0/src/Yi/Lexer/Alex.hs0000644000000000000000000001652213246272742015663 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Lexer.Alex -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Utilities to turn a lexer generated by Alex into a 'Scanner' that -- can be used by Yi. Most lexers will use the types defined here. -- Some things are exported for use by lexers themselves through the -- use of @Yi/Lexers/common.hsinc@. module Yi.Lexer.Alex ( module Yi.Lexer.Alex , (+~), (~-), Size(..), Stroke ) where import Lens.Micro.Platform (_1, view, makeLenses) import qualified Data.Bits import Data.Char (ord) import Data.Function (on) import Data.Ix import Data.List (foldl') import Data.Ord (comparing) import Data.Word (Word8) import Yi.Style (StyleName) import Yi.Syntax hiding (mkHighlighter) import Yi.Utils -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. utf8Encode :: Char -> [Word8] utf8Encode = map fromIntegral . go . ord where go oc | oc <= 0x7f = [oc] | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) , 0x80 + oc Data.Bits..&. 0x3f ] | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) , 0x80 + oc Data.Bits..&. 0x3f ] | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) , 0x80 + oc Data.Bits..&. 0x3f ] type Byte = Word8 type IndexedStr = [(Point, Char)] type AlexInput = (Char, [Byte], IndexedStr) type Action hlState token = IndexedStr -> hlState -> (hlState, token) -- | Lexer state data AlexState lexerState = AlexState { stLexer :: lexerState, -- (user defined) lexer state lookedOffset :: !Point, -- Last offset looked at stPosn :: !Posn } deriving Show data Tok t = Tok { tokT :: t , tokLen :: Size , tokPosn :: Posn } deriving Functor instance Eq (Tok a) where (==) = (==) `on` tokPosn tokToSpan :: Tok t -> Span t tokToSpan (Tok t len posn) = Span (posnOfs posn) t (posnOfs posn +~ len) tokFromT :: t -> Tok t tokFromT t = Tok t 0 startPosn tokBegin :: Tok t -> Point tokBegin = posnOfs . tokPosn tokEnd :: Tok t -> Point tokEnd t = tokBegin t +~ tokLen t instance Show t => Show (Tok t) where show tok = show (tokPosn tok) ++ ": " ++ show (tokT tok) data Posn = Posn { posnOfs :: !Point , posnLine :: !Int , posnCol :: !Int } deriving (Eq, Ix) -- TODO: Verify that this is right. /Deniz instance Ord Posn where compare = comparing posnOfs instance Show Posn where show (Posn o l c) = "L" ++ show l ++ " " ++ "C" ++ show c ++ "@" ++ show o startPosn :: Posn startPosn = Posn 0 1 0 moveStr :: Posn -> IndexedStr -> Posn moveStr posn str = foldl' moveCh posn (fmap snd str) moveCh :: Posn -> Char -> Posn moveCh (Posn o l c) '\t' = Posn (o+1) l (((c+8) `div` 8)*8) moveCh (Posn o l _) '\n' = Posn (o+1) (l+1) 0 moveCh (Posn o l c) _ = Posn (o+1) l (c+1) alexGetChar :: AlexInput -> Maybe (Char, AlexInput) alexGetChar (_,_,[]) = Nothing alexGetChar (_,b,(_,c):rest) = Just (c, (c,b,rest)) alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) alexGetByte (c, b:bs, s) = Just (b,(c,bs,s)) alexGetByte (_, [], []) = Nothing alexGetByte (_, [], c:s) = case utf8Encode (snd c) of (b:bs) -> Just (b, ((snd c), bs, s)) [] -> Nothing {-# ANN alexCollectChar "HLint: ignore Use String" #-} alexCollectChar :: AlexInput -> [Char] alexCollectChar (_, _, []) = [] alexCollectChar (_, b, (_, c):rest) = c : alexCollectChar (c, b, rest) alexInputPrevChar :: AlexInput -> Char alexInputPrevChar = view _1 -- | Return a constant token actionConst :: token -> Action lexState token actionConst token = \_str state -> (state, token) -- | Return a constant token, and modify the lexer state actionAndModify :: (lexState -> lexState) -> token -> Action lexState token actionAndModify modifierFct token = \_str state -> (modifierFct state, token) -- | Convert the parsed string into a token, -- and also modify the lexer state actionStringAndModify :: (s -> s) -> (String -> token) -> Action s token actionStringAndModify modF f = \istr s -> (modF s, f $ fmap snd istr) -- | Convert the parsed string into a token actionStringConst :: (String -> token) -> Action lexState token actionStringConst f = \indexedStr state -> (state, f $ fmap snd indexedStr) type ASI s = (AlexState s, AlexInput) -- | Function to (possibly) lex a single token and give us the -- remaining input. type TokenLexer l s t i = (l s, i) -> Maybe (t, (l s, i)) -- | Handy alias type CharScanner = Scanner Point Char -- | Generalises lexers. This allows us to easily use lexers which -- don't want to be cornered into the types we have predefined here -- and use in @common.hsinc@. data Lexer l s t i = Lexer { _step :: TokenLexer l s t i , _starting :: s -> Point -> Posn -> l s , _withChars :: Char -> [(Point, Char)] -> i , _looked :: l s -> Point , _statePosn :: l s -> Posn , _lexEmpty :: t , _startingState :: s } -- | Just like 'Lexer' but also knows how to turn its tokens into -- 'StyleName's. data StyleLexer l s t i = StyleLexer { _tokenToStyle :: t -> StyleName , _styleLexer :: Lexer l s (Tok t) i } -- | 'StyleLexer' over 'ASI'. type StyleLexerASI s t = StyleLexer AlexState s t AlexInput -- | Defines a 'Lexer' for 'ASI'. This exists to make using the new -- 'lexScanner' easier if you're using 'ASI' as all our lexers do -- today, 23-08-2014. commonLexer :: (ASI s -> Maybe (Tok t, ASI s)) -> s -> Lexer AlexState s (Tok t) AlexInput commonLexer l st0 = Lexer { _step = l , _starting = AlexState , _withChars = \c p -> (c, [], p) , _looked = lookedOffset , _statePosn = stPosn , _lexEmpty = error "Yi.Lexer.Alex.commonLexer: lexEmpty" , _startingState = st0 } -- | Combine a character scanner with a lexer to produce a token -- scanner. May be used together with 'mkHighlighter' to produce a -- 'Highlighter', or with 'linearSyntaxMode' to produce a 'Mode'. lexScanner :: Lexer l s t i -> CharScanner -> Scanner (l s) t lexScanner Lexer {..} src = Scanner { scanLooked = _looked , scanInit = _starting _startingState 0 startPosn , scanRun = \st -> case posnOfs $ _statePosn st of 0 -> unfoldLexer _step (st, _withChars '\n' $ scanRun src 0) ofs -> case scanRun src (ofs -1) of [] -> [] (_, ch) : rest -> unfoldLexer _step (st, _withChars ch rest) , scanEmpty = _lexEmpty } -- | unfold lexer into a function that returns a stream of (state, token) unfoldLexer :: ((state, input) -> Maybe (token, (state, input))) -> (state, input) -> [(state, token)] unfoldLexer f b = fst b `seq` case f b of Nothing -> [] Just (t, b') -> (fst b, t) : unfoldLexer f b' -- * Lenses makeLensesWithSuffix "A" ''Posn makeLensesWithSuffix "A" ''Tok makeLenses ''Lexer makeLenses ''StyleLexer yi-language-0.18.0/src/Yi/Lexer/Compilation.x0000644000000000000000000000256213246272742017104 0ustar0000000000000000-- -*- haskell -*- -- -- Lexical syntax for compilation messages -- { #define NO_ALEX_CONTEXTS {-# OPTIONS -w #-} module Yi.Lexer.Compilation (lexer, Token(..)) where import Yi.Lexer.Alex hiding (tokenToStyle) import Yi.Regex (matchOnceText, Regex, makeRegex) import Yi.Style (commentStyle) } $digit = 0-9 $white = [\ \n] $filechar = ~[\: $white] @file = $filechar+ @number = $digit+ tokens :- @file":" @number ":" @number ":" .*\n { \str st -> let Just (_before, arr, _after) = matchOnceText re $ map snd str re :: Regex re = makeRegex "^(.+):([0-9]+):([0-9]+):(.*)$" in (st, Report (fst $ arr!1) (read $ fst $ arr!2) (read $ fst $ arr!3) (fst $ arr!4)) } -- without a column number @file":" @number ":" .*\n { \str st -> let Just (_before, arr, _after) = matchOnceText re $ map snd str re :: Regex re = makeRegex "^(.+):([0-9]+):(.*)$" in (st, Report (fst $ arr!1) (read $ fst $ arr!2) 0 (fst $ arr!3)) } $white+ ; -- unparseable stuff [^$white]+ ; { type HlState = () data Token = Report String Int Int String | Text String deriving Show stateToInit () = 0 initState = () lexer :: StyleLexerASI HlState Token lexer = StyleLexer { _tokenToStyle = const commentStyle , _styleLexer = commonLexer alexScanToken initState } #include "common.hsinc" } yi-language-0.18.0/src/Yi/Regex.hs0000644000000000000000000001277113246272742014767 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} -- Copyright (c) Jean-Philippe Bernardy 2008 module Yi.Regex ( SearchOption(..), makeSearchOptsM , SearchExp(..), searchString, searchRegex, emptySearch , emptyRegex , regexEscapeString , reversePattern , module Text.Regex.TDFA ) where import Data.Bifunctor (first) import Data.Binary import GHC.Generics (Generic) import Yi.Buffer.Basic (Direction(..)) import Text.Regex.TDFA ( Regex, CompOption(..), caseSensitive, multiline , defaultCompOpt, defaultExecOpt, makeRegexOptsM , matchOnceText, makeRegex, RegexLike(matchAll) , AllTextSubmatches(..), (=~)) import Text.Regex.TDFA.Pattern (Pattern(..), DoPa(..), showPattern) import Text.Regex.TDFA.ReadRegex(parseRegex) import Text.Regex.TDFA.TDFA(patternToRegex) -- input string, regexexp, backward regex. data SearchExp = SearchExp { seInput :: String , seCompiled :: Regex , seBackCompiled :: Regex , seOptions :: [SearchOption] } searchString :: SearchExp -> String searchString = seInput searchRegex :: Direction -> SearchExp -> Regex searchRegex Forward = seCompiled searchRegex Backward = seBackCompiled -- -- What would be interesting would be to implement our own general -- mechanism to allow users to supply a regex function of any kind, and -- search with that. This removes the restriction on strings be valid -- under regex(3). -- data SearchOption = IgnoreCase -- ^ Compile for matching that ignores char case | NoNewLine -- ^ Compile for newline-insensitive matching | QuoteRegex -- ^ Treat the input not as a regex but as a literal string to search for. deriving (Eq, Generic) instance Binary SearchOption searchOpt :: SearchOption -> CompOption -> CompOption searchOpt IgnoreCase = \o->o{caseSensitive = False} searchOpt NoNewLine = \o->o{multiline = False} searchOpt QuoteRegex = id makeSearchOptsM :: [SearchOption] -> String -> Either String SearchExp makeSearchOptsM opts re = (\p->SearchExp { seInput = re , seCompiled = compile p , seBackCompiled = compile $ reversePattern p , seOptions = opts }) <$> pattern where searchOpts = foldr ((.) . searchOpt) id compile source = patternToRegex source (searchOpts opts defaultCompOpt) defaultExecOpt pattern = if QuoteRegex `elem` opts then Right (literalPattern re) else first show (parseRegex re) instance Binary SearchExp where get = do re <- get opts <- get return $ case makeSearchOptsM opts re of Left err -> error err Right se -> se put (SearchExp { seInput = re, seOptions = opts, .. }) = do put re put opts -- | Return an escaped (for parseRegex use) version of the string. regexEscapeString :: String -> String regexEscapeString source = showPattern . literalPattern' $ source -- | Return a pattern that matches its argument. literalPattern :: (Num t) => String -> (Pattern, (t, DoPa)) literalPattern source = (literalPattern' source, (0,DoPa 0)) literalPattern' :: String -> Pattern literalPattern' = PConcat . map (PChar (DoPa 0)) -- | Reverse a pattern. Note that the submatches will be reversed as well. reversePattern :: (Pattern, (t, DoPa)) -> (Pattern, (t, DoPa)) reversePattern (pattern,rest) = (rev pattern, rest) where rev (PConcat l) = PConcat (reverse (map rev l)) rev (PCarat dp) = PDollar dp rev (PDollar dp) = PCarat dp rev (PEscape dp '<') = PEscape dp '>' rev (PEscape dp '>') = PEscape dp '<' rev (PGroup a x) = PGroup a (rev x) rev (POr l) = POr (map rev l) rev (PQuest x) = PQuest (rev x) rev (PPlus x) = PPlus (rev x) rev (PStar b x) = PStar b (rev x) rev (PBound i m x) = PBound i m (rev x) rev (PNonCapture x) = PNonCapture (rev x) rev (PNonEmpty x) = PNonEmpty (rev x) rev x = x {- Chris K Commentary: I have one DIRE WARNING and one suggestion. The DIRE WARNING is against using the reversed Pattern to find captured subexpressions. It will work perfectly to find the longest match but give nonsense for captures. In particular matching text "abc" with "(.)*" forward returns the 1st capture as "c". Searching "cba" with the reverse of "(.)*", which is identical, returns the 1st capture as "a". Enough changes to the matching engine could allow for the reversed search on the reversed text to return the same captures as the the forward search on the forward text. Rather than that tricky complexity, if you need the substring captures you can use the reversed pattern to find a whole match and then run the forward pattern on that substring. The one suggestion is that the DoPa are irrelevant to the matching — they are there to allow a person to understand how the output of each stage of the regex-tdfa code relates to the input pattern. -} emptySearch :: SearchExp emptySearch = SearchExp "" emptyRegex emptyRegex [] -- | The regular expression that matches nothing. emptyRegex :: Regex Just emptyRegex = makeRegexOptsM defaultCompOpt defaultExecOpt "[[:empty:]]" yi-language-0.18.0/src/Yi/Region.hs0000644000000000000000000000673213246272742015140 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} -- Copyright (C) 2008 JP Bernardy -- | This module defines the Region ADT module Yi.Region ( Region , emptyRegion , regionIsEmpty , mkRegion, mkRegion', mkSizeRegion , regionStart , regionEnd , regionSize , regionDirection , inRegion, nearRegion , includedRegion , fmapRegion , intersectRegion , unionRegion , regionFirst, regionLast, regionsOverlap ) where import Yi.Buffer.Basic import Yi.Utils import Data.Typeable import Data.Binary import GHC.Generics (Generic) -- | The region data type. -- The region is semi open: it includes the start but not the end bound. -- This allows simpler region-manipulation algorithms. -- Invariant : regionStart r <= regionEnd r data Region = Region { regionDirection :: !Direction , regionStart, regionEnd :: !Point } deriving (Typeable, Generic) instance Binary Region instance Show Region where show r = show (regionStart r) ++ (case regionDirection r of Forward -> " -> " Backward -> " <- " ) ++ show (regionEnd r) regionFirst :: Region -> Point regionFirst (Region Forward p _) = p regionFirst (Region Backward _ p) = p regionLast :: Region -> Point regionLast (Region Forward _ p) = p regionLast (Region Backward p _) = p fmapRegion :: (Point -> Point) -> Region -> Region fmapRegion f (Region d x y) = Region d (f x) (f y) regionSize :: Region -> Size regionSize r = regionEnd r ~- regionStart r -- | Take the intersection of two regions intersectRegion :: Region -> Region -> Region intersectRegion (Region _ x1 y1) (Region _ x2 y2) = ordRegion (max x1 x2) (min y1 y2) -- | Take the union of two regions (including what is between them) unionRegion :: Region -> Region -> Region unionRegion (Region _ x1 y1) (Region _ x2 y2) = mkRegion (min x1 x2) (max y1 y2) -- | Create a region from ordered bounds. If 2nd argument is greater than -- 1st, then the region will be empty. ordRegion :: Point -> Point -> Region ordRegion x y = if x < y then Region Forward x y else emptyRegion -- | Construct a region from its bounds, emacs style: -- the right bound is excluded mkRegion :: Point -> Point -> Region mkRegion x y = if x <= y then Region Forward x y else Region Backward y x mkRegion' :: Direction -> Point -> Point -> Region mkRegion' d x y = if x <= y then Region d x y else Region d y x mkSizeRegion :: Point -> Size -> Region mkSizeRegion x s = mkRegion x (x +~ s) -- | The empty region emptyRegion :: Region emptyRegion = Region Forward 0 0 -- | True if the given point is inside the given region. inRegion :: Point -> Region -> Bool p `inRegion` (Region _ start stop) = start <= p && p < stop -- | True if the given point is inside the given region or at the end of it. nearRegion :: Point -> Region -> Bool p `nearRegion` (Region _ start stop) = start <= p && p <= stop -- | Returns if a region (1st arg) is included in another (2nd arg) includedRegion :: Region -> Region -> Bool r0 `includedRegion` r = regionStart r <= regionStart r0 && regionEnd r0 <= regionEnd r regionIsEmpty :: Region -> Bool regionIsEmpty (Region _ start stop) = start >= stop regionsOverlap :: Bool -> Region -> Region -> Bool regionsOverlap border (Region _ x1 y1) (Region _ x2 y2) = cmp x2 y1 y2 || cmp x2 x1 y2 || cmp x1 y2 y1 || cmp x1 x2 y1 where cmp a b c = a <= b && if border then b <=c else b < c yi-language-0.18.0/src/Yi/Style.hs0000644000000000000000000001260713226661437015014 0ustar0000000000000000-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons -- | Colors and friends. module Yi.Style where import Data.Word (Word8) import Data.Char (chr, ord) import Data.Monoid -- | Visual text attributes to be applied during layout. data Attributes = Attributes { foreground :: !Color , background :: !Color , reverseAttr :: !Bool -- ^ The text should be show as "active" or "selected". -- This can be implemented by reverse video on the terminal. , bold :: !Bool , italic :: !Bool , underline :: !Bool } deriving (Eq, Ord, Show) emptyAttributes :: Attributes emptyAttributes = Attributes { foreground = Default, background = Default, reverseAttr = False, bold = False, italic = False, underline = False } -- | The style is used to transform attributes by modifying -- one or more of the visual text attributes. type Style = Endo Attributes -- | The UI type data UIStyle = UIStyle { modelineAttributes :: Attributes -- ^ ground attributes for the modeline , modelineFocusStyle :: Style -- ^ transformation of modeline in focus , tabBarAttributes :: Attributes -- ^ ground attributes for the tabbar , tabInFocusStyle :: Style -- ^ a tab that currently holds the focus , tabNotFocusedStyle :: Style -- ^ a tab that does not have the current focus , baseAttributes :: Attributes -- ^ ground attributes for the main text views -- General styles applied to the ground attributes above , selectedStyle :: Style -- ^ the selected portion , eofStyle :: Style -- ^ empty file marker colours , errorStyle :: Style -- ^ indicates errors in text , hintStyle :: Style -- ^ search matches/paren matches/other hints , strongHintStyle :: Style -- ^ current search match -- Syntax highlighting styles , commentStyle :: Style -- ^ all comments , blockCommentStyle :: Style -- ^ additional only for block comments , keywordStyle :: Style -- ^ applied to language keywords , numberStyle :: Style -- ^ numbers , preprocessorStyle :: Style -- ^ preprocessor directive (often in Haskell or C) , stringStyle :: Style -- ^ constant strings , longStringStyle :: Style -- ^ additional style for long strings , typeStyle :: Style -- ^ type name (such as class in an OO language) , dataConstructorStyle :: Style -- ^ data constructor , importStyle :: Style -- ^ style of import names , builtinStyle :: Style -- ^ builtin things, e.g. Array in JavaScript , regexStyle :: Style -- ^ regular expressions , variableStyle :: Style -- ^ any standard variable (identifier) , operatorStyle :: Style -- ^ infix operators , quoteStyle :: Style -- ^ Style of a quotation (e.g. in template haskell) , makeFileAction :: Style -- ^ stuff that's passed to the shell in a Makefile , makeFileRuleHead :: Style -- ^ makefile rule headers } -- | A StyleName determines what style to use, taking into account the -- set of rendering preferences given by a 'UIStyle'. Typically, style -- names will be 'Style'-valued field names of 'UIStyle'. type StyleName = UIStyle -> Style withFg, withBg :: Color -> Style -- | A style that sets the foreground. withFg c = Endo $ \s -> s { foreground = c } -- | A style that sets the background. withBg c = Endo $ \s -> s { background = c } withBd, withItlc, withUnderline, withReverse :: Bool -> Style -- | A style that sets the font to bold withBd c = Endo $ \s -> s { bold = c } -- | A style that sets the style to italics withItlc c = Endo $ \s -> s { italic = c } -- | A style that sets the style to underlined withUnderline c = Endo $ \s -> s { underline = c } -- | A style that sets the style to underlined withReverse c = Endo $ \s -> s { reverseAttr = c } -- | The identity transform. defaultStyle :: StyleName defaultStyle = mempty data Color = RGB {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 | Default -- ^ The system-default color of the engine used. -- e.g. in Gtk this should pick whatever the user has chosen as default color -- (background or forground depending on usage) for the text. deriving (Eq,Ord,Show) -- | Convert a color to its text specification, as to be accepted by XParseColor colorToText :: Color -> String colorToText Default = "default" colorToText (RGB r g b) = ('#':) . showsHex r . showsHex g . showsHex b $ [] where showsHex x s = showHex1 (x `div` 16) : showHex1 (x `mod` 16) : s showHex1 x | x < 10 = chr (ord '0' + fromIntegral x) | otherwise = chr (ord 'A' + fromIntegral x - 10) ------------------------------------------------------------------------ -- Some simple colours black, grey, lightGrey, darkred, red, darkgreen, green, brown, yellow :: Color darkblue, blue, purple, magenta, darkcyan, cyan, white, brightwhite :: Color black = RGB 0 0 0 grey = RGB 128 128 128 lightGrey = RGB 100 100 100 darkred = RGB 139 0 0 red = RGB 255 0 0 darkgreen = RGB 0 100 0 green = RGB 0 128 0 brown = RGB 165 42 42 yellow = RGB 255 255 0 darkblue = RGB 0 0 139 blue = RGB 0 0 255 purple = RGB 128 0 128 magenta = RGB 255 0 255 darkcyan = RGB 0 139 139 cyan = RGB 0 255 255 white = RGB 165 165 165 brightwhite = RGB 255 255 255 yi-language-0.18.0/src/Yi/Style/Library.hs0000644000000000000000000000461313246272742016415 0ustar0000000000000000-- A collection of Themes. module Yi.Style.Library where import Yi.Style import Data.Prototype type Theme = Proto UIStyle -- | Abstract theme that provides useful defaults. defaultTheme :: Theme defaultTheme = Proto $ const UIStyle { modelineAttributes = emptyAttributes { foreground = white, background = grey } , modelineFocusStyle = withFg brightwhite , tabBarAttributes = emptyAttributes , tabInFocusStyle = withFg black `mappend` withBg white , tabNotFocusedStyle = mempty , baseAttributes = emptyAttributes , selectedStyle = withFg white `mappend` withBg purple , eofStyle = withFg blue , errorStyle = withBg red , hintStyle = withFg black `mappend` withBg cyan , strongHintStyle = withFg black `mappend` withBg magenta , commentStyle = withFg purple , blockCommentStyle = withFg purple , keywordStyle = withFg darkblue , numberStyle = withFg darkred , preprocessorStyle = withFg red , stringStyle = withFg darkcyan , longStringStyle = mempty , typeStyle = withFg darkgreen , dataConstructorStyle = withBd True `mappend` withFg darkgreen , importStyle = withFg blue , builtinStyle = withFg blue , regexStyle = withFg red , variableStyle = mempty , operatorStyle = withFg brown , makeFileRuleHead = withFg blue , makeFileAction = withFg grey , quoteStyle = withFg grey } -- | A Theme inspired by the darkblue colorscheme of Vim. darkBlueTheme :: Theme darkBlueTheme = defaultTheme `override` \super _ -> super { modelineAttributes = emptyAttributes { foreground = darkblue, background = white } , modelineFocusStyle = withBg brightwhite , tabBarAttributes = emptyAttributes { foreground = darkblue, background = brightwhite } , tabInFocusStyle = withFg grey `mappend` withBg white , tabNotFocusedStyle = withFg lightGrey `mappend` withBg white , baseAttributes = emptyAttributes { foreground = white, background = black } , selectedStyle = withFg white `mappend` withBg blue , eofStyle = withFg red , hintStyle = withBg darkblue , strongHintStyle = withBg blue , commentStyle = withFg darkred , keywordStyle = withFg brown , stringStyle = withFg purple , variableStyle = withFg cyan , operatorStyle = withFg brown } yi-language-0.18.0/src/Yi/Syntax.hs0000644000000000000000000001146213246272742015177 0ustar0000000000000000{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Syntax -- Copyright : (c) Don Stewart 2007 -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- This module defines a common interface for syntax-awareness. -- -- There have been many tens of wasted hours in this and lexer -- modules. This note is to commemorate those who have fallen in -- battle. module Yi.Syntax ( Highlighter ( .. ) , Cache , Scanner (..) , ExtHL ( .. ) , noHighlighter, mkHighlighter, skipScanner, emptyFileScan , Point(..), Size(..), Length, Stroke , Span(..) ) where import qualified Data.Map as M import Control.Arrow import Yi.Style import Yi.Buffer.Basic import Yi.Region type Length = Int -- size in #codepoints type Stroke = Span StyleName data Span a = Span {spanBegin :: !Point, spanContents :: !a, spanEnd :: !Point} deriving (Show, Functor, Foldable, Traversable) -- | The main type of syntax highlighters. This record type combines all -- the required functions, and is parametrized on the type of the internal -- state. -- FIXME: this is actually completetly abstrcted from sytnax HL, so -- the names are silly. data Highlighter cache syntax = SynHL { hlStartState :: cache -- ^ The start state for the highlighter. , hlRun :: Scanner Point Char -> Point -> cache -> cache , hlGetTree :: cache -> WindowRef -> syntax , hlFocus :: M.Map WindowRef Region -> cache -> cache -- ^ focus at a given point, and return the coresponding node. -- (hint -- the root can always be returned, at the cost of -- performance.) } data ExtHL syntax = forall cache. ExtHL (Highlighter cache syntax) data Scanner st a = Scanner { scanInit :: st -- ^ Initial state , scanLooked :: st -> Point -- ^ How far did the scanner look to produce this intermediate state? -- The state can be reused as long as nothing changes before that point. , scanEmpty :: a -- hack :/ , scanRun :: st -> [(st ,a)] -- ^ Running function returns a list of results and intermediate -- states. Note: the state is the state /before/ producing the -- result in the second component. } skipScanner :: Int -> Scanner st a -> Scanner st a skipScanner n (Scanner i l e r) = Scanner i l e (other 0 . r) where other _ [] = [] other _ [x] = [x] -- we must return the final result (because if -- the list is empty mkHighlighter thinks it -- can reuse the previous result) other 0 (x:xs) = x : other n xs other m (_:xs) = other (m-1) xs instance Functor (Scanner st) where fmap f (Scanner i l e r) = Scanner i l (f e) (fmap (second f) . r) data Cache state result = Cache [state] result emptyFileScan :: Scanner Point Char emptyFileScan = Scanner { scanInit = 0 , scanRun = const [] , scanLooked = id , scanEmpty = error "emptyFileScan: no scanEmpty" } -- | This takes as input a scanner that returns the "full" result at -- each element in the list; perhaps in a different form for the -- purpose of incremental-lazy eval. mkHighlighter :: forall state result. Show state => (Scanner Point Char -> Scanner state result) -> Highlighter (Cache state result) result mkHighlighter scanner = Yi.Syntax.SynHL { hlStartState = Cache [] emptyResult , hlRun = updateCache , hlGetTree = \(Cache _ result) _windowRef -> result , hlFocus = \_ c -> c } where startState :: state startState = scanInit (scanner emptyFileScan) emptyResult = scanEmpty (scanner emptyFileScan) updateCache :: Scanner Point Char -> Point -> Cache state result -> Cache state result updateCache newFileScan dirtyOffset (Cache cachedStates oldResult) = Cache newCachedStates newResult where newScan = scanner newFileScan reused :: [state] reused = takeWhile ((< dirtyOffset) . scanLooked (scanner newFileScan)) cachedStates resumeState :: state resumeState = if null reused then startState else last reused newCachedStates = reused ++ fmap fst recomputed recomputed = scanRun newScan resumeState newResult :: result newResult = if null recomputed then oldResult else snd $ head recomputed noHighlighter :: Highlighter () syntax noHighlighter = SynHL { hlStartState = () , hlRun = \_ _ a -> a , hlFocus = \_ c -> c , hlGetTree = \ _ -> error "noHighlighter: tried to use syntax" } yi-language-0.18.0/src/Yi/Utils.hs0000644000000000000000000001162613246272742015013 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for Binary instance of Hashmap -- | -- Module : Yi.Utils -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Various utility functions and instances used throughout Yi. Some of -- the functions from the now-removed Yi.Prelude found a new home -- here. module Yi.Utils where import Lens.Micro.Platform import Control.Monad.Base import Data.Binary import Data.Char (toLower) import qualified Data.HashMap.Strict as HashMap import Data.Hashable(Hashable) import qualified Data.List.PointedList as PL import qualified Data.Map as Map import qualified Data.Set as Set import qualified Language.Haskell.TH.Syntax as THS io :: MonadBase IO m => IO a -> m a io = liftBase fst3 :: (a,b,c) -> a fst3 (x,_,_) = x snd3 :: (a,b,c) -> b snd3 (_,x,_) = x trd3 :: (a,b,c) -> c trd3 (_,_,x) = x class SemiNum absolute relative | absolute -> relative where (+~) :: absolute -> relative -> absolute (-~) :: absolute -> relative -> absolute (~-) :: absolute -> absolute -> relative {-# ANN nubSet "HLint: ignore Eta reduce" #-} -- TODO: move somewhere else. -- | As 'Prelude.nub', but with O(n*log(n)) behaviour. nubSet :: (Ord a) => [a] -> [a] nubSet xss = f Set.empty xss where f _ [] = [] f s (x:xs) = if x `Set.member` s then f s xs else x : f (Set.insert x s) xs -- | As Map.adjust, but the combining function is applied strictly. mapAdjust' :: (Ord k) => (a -> a) -> k -> Map.Map k a -> Map.Map k a mapAdjust' f = Map.alter f' where f' Nothing = Nothing f' (Just x) = let x' = f x in x' `seq` Just x' -- This works because Map is structure-strict, and alter needs to force f' to compute -- the structure. -- | Generalisation of 'Map.fromList' to arbitrary foldables. mapFromFoldable :: (Foldable t, Ord k) => t (k, a) -> Map.Map k a mapFromFoldable = foldMap (uncurry Map.singleton) -- | Alternative to groupBy. -- -- > groupBy' (\a b -> abs (a - b) <= 1) [1,2,3] = [[1,2,3]] -- -- whereas -- -- > groupBy (\a b -> abs (a - b) <= 1) [1,2,3] = [[1,2],[3]] -- -- TODO: Check in ghc 6.12 release if groupBy == groupBy'. groupBy' :: (a -> a -> Bool) -> [a] -> [[a]] groupBy' _ [] = [] groupBy' p l = s1 : groupBy' p s2 where (s1, s2) = chain p l chain :: (a -> a -> Bool) -> [a] -> ([a],[a]) chain _ [] = ([], []) chain _ [e] = ([e], []) chain q (e1 : es@(e2 : _)) | q e1 e2 = let (s1, s2) = chain q es in (e1 : s1, s2) | otherwise = ([e1], es) -- | Return the longest common prefix of a set of lists. -- -- > P(xs) === all (isPrefixOf (commonPrefix xs)) xs -- > length s > length (commonPrefix xs) --> not (all (isPrefixOf s) xs) commonPrefix :: Eq a => [[a]] -> [a] commonPrefix [] = [] commonPrefix strings | any null strings = [] | all (== prefix) heads = prefix : commonPrefix tailz | otherwise = [] where (heads, tailz) = unzip [(h,t) | (h:t) <- strings] prefix = head heads -- for an alternative implementation see GHC's InteractiveUI module. {-# ANN findPL "HLint: ignore Eta reduce" #-} ---------------------- PointedList stuff -- | Finds the first element satisfying the predicate, and returns a zipper pointing at it. findPL :: (a -> Bool) -> [a] -> Maybe (PL.PointedList a) findPL p xs = go [] xs where go _ [] = Nothing go ls (f:rs) | p f = Just (PL.PointedList ls f rs) | otherwise = go (f:ls) rs {-# ANN swapFocus "HLint: ignore Redundant bracket" #-} -- | Given a function which moves the focus from index A to index B, return a function which swaps the elements at indexes A and B and then moves the focus. See Yi.Editor.swapWinWithFirstE for an example. swapFocus :: (PL.PointedList a -> PL.PointedList a) -> (PL.PointedList a -> PL.PointedList a) swapFocus moveFocus xs = let xs' = moveFocus xs f1 = view PL.focus xs f2 = view PL.focus xs' in set PL.focus f1 . moveFocus . set PL.focus f2 $ xs ----------------- Orphan 'Binary' instances instance (Eq k, Hashable k, Binary k, Binary v) => Binary (HashMap.HashMap k v) where put x = put (HashMap.toList x) get = HashMap.fromList <$> get makeClassyWithSuffix :: String -> THS.Name -> THS.Q [THS.Dec] makeClassyWithSuffix s = makeLensesWith (classyRules & lensField .~ (\_ _ n -> addSuffix n s) & lensClass .~ classy) where classy :: THS.Name -> Maybe (THS.Name, THS.Name) classy n = case THS.nameBase n of x:xs -> Just (THS.mkName ("Has" ++ x:xs), THS.mkName (toLower x : xs ++ s)) [] -> Nothing addSuffix :: THS.Name -> String -> [DefName] addSuffix n s = [TopName $ THS.mkName $ THS.nameBase n ++ s] makeLensesWithSuffix :: String -> THS.Name -> THS.Q [THS.Dec] makeLensesWithSuffix s = makeLensesWith (lensRules & lensField .~ (\_ _ n -> addSuffix n s)) yi-language-0.18.0/test/Spec.hs0000644000000000000000000000360513246272742014412 0ustar0000000000000000 import Data.Bifunctor (first) import Test.Tasty import Test.Tasty.Hspec import Test.Tasty.QuickCheck import Yi.Regex import Text.Regex.TDFA.ReadRegex (parseRegex) import Text.Regex.TDFA.Pattern ignoreDoPa :: Pattern -> Pattern ignoreDoPa (PCarat _dp ) = PCarat (DoPa 0) ignoreDoPa (PDollar _dp ) = PDollar (DoPa 0) ignoreDoPa (PDot _dp ) = PDot (DoPa 0) ignoreDoPa (PAny _dp ps) = PAny (DoPa 0) ps ignoreDoPa (PAnyNot _dp ps) = PAnyNot (DoPa 0) ps ignoreDoPa (PEscape _dp pc) = PEscape (DoPa 0) pc ignoreDoPa (PChar _dp pc) = PChar (DoPa 0) pc ignoreDoPa (PGroup m p ) = PGroup m (ignoreDoPa p) ignoreDoPa (POr l ) = POr (map ignoreDoPa l) ignoreDoPa (PConcat l ) = PConcat (map ignoreDoPa l) ignoreDoPa (PQuest p ) = PQuest (ignoreDoPa p) ignoreDoPa (PPlus p ) = PPlus (ignoreDoPa p) ignoreDoPa (PStar b p ) = PStar b (ignoreDoPa p) ignoreDoPa (PBound i m p) = PBound i m (ignoreDoPa p) ignoreDoPa (PNonCapture p) = PNonCapture (ignoreDoPa p) ignoreDoPa (PNonEmpty p) = PNonEmpty (ignoreDoPa p) ignoreDoPa p = p main :: IO () main = defaultMain =<< tests tests :: IO TestTree tests = testSpec "(Hspec tests)" $ do describe "reversePattern" $ do it "reverses normal characters" $ (first ignoreDoPa . reversePattern <$> parseRegex "ab") `shouldBe` (first ignoreDoPa <$> parseRegex "ba") it "changes carat to dollar" $ (reversePattern <$> parseRegex "^") `shouldBe` parseRegex "$" it "changes dollar to carat" $ (reversePattern <$> parseRegex "$") `shouldBe` parseRegex "^" it "forms the identity when applied twice" $ property $ \p -> (reversePattern . reversePattern <$> parseRegex p) `shouldBe` parseRegex p it "recursively reverses patterns" $ (first ignoreDoPa . reversePattern <$> parseRegex "foo|bar") `shouldBe` (first ignoreDoPa <$> parseRegex "oof|rab")yi-language-0.18.0/Setup.hs0000644000000000000000000000005613226661437013637 0ustar0000000000000000import Distribution.Simple main = defaultMain yi-language-0.18.0/yi-language.cabal0000644000000000000000000000346613326314660015373 0ustar0000000000000000name: yi-language version: 0.18.0 synopsis: Collection of language-related Yi libraries. category: Yi homepage: https://github.com/yi-editor/yi#readme bug-reports: https://github.com/yi-editor/yi/issues maintainer: Yi developers license: GPL-2 build-type: Simple cabal-version: >= 1.10 extra-source-files: src/Yi/Lexer/common.hsinc source-repository head type: git location: https://github.com/yi-editor/yi library hs-source-dirs: src ghc-options: -Wall -ferror-spans include-dirs: src/Yi/Lexer build-depends: base >= 4.8 && < 5 , array , binary , data-default , template-haskell >= 2.4 , containers , hashable >=1.1.2.5 , pointedlist >= 0.5 , regex-base ==0.93.* , regex-tdfa >= 1.1 && <1.3 , transformers-base , unordered-containers >= 0.1.3 && < 0.3 , microlens-platform , oo-prototypes build-tools: alex >= 3.0.3 && < 3.2.0 || >= 3.2.1 exposed-modules: Yi.Buffer.Basic Yi.Lexer.Alex Yi.Lexer.Compilation Yi.Regex Yi.Region Yi.Style Yi.Style.Library Yi.Syntax Yi.Utils other-modules: Paths_yi_language default-language: Haskell2010 test-suite tasty type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test ghc-options: -Wall -ferror-spans build-depends: base >= 4.8 && < 5 , array , binary , data-default , template-haskell >= 2.4 , containers , hashable >=1.1.2.5 , pointedlist >= 0.5 , regex-base ==0.93.* , regex-tdfa >= 1.1 && <1.3 , transformers-base , unordered-containers >= 0.1.3 && < 0.3 , microlens-platform , tasty , tasty-hspec , tasty-quickcheck , yi-language default-language: Haskell2010 yi-language-0.18.0/src/Yi/Lexer/common.hsinc0000644000000000000000000000705013226661437016751 0ustar0000000000000000-- -*- Haskell -*- -- The include file for alex-generated syntax highlighters. Because alex -- declares its own types, any wrapper must have the highlighter in scope... -- so it must be included. Doubleplusyuck. #define IBOX(n) (I# (n)) #define GEQ_(x, y) (tagToEnum# (x >=# y)) #define EQ_(x, y) (tagToEnum# (x ==# y)) -- | Scan one token. Return (maybe) a token and a new state. alexScanToken :: (AlexState HlState, AlexInput) -> Maybe (Tok Token, (AlexState HlState, AlexInput)) alexScanToken (AlexState state lookedOfs pos, inp@(_prevCh,_bs,str)) = let (scn,lookahead) = alexScanUser' state inp (stateToInit state) lookedOfs' = max lookedOfs (posnOfs pos +~ Size lookahead) in case scn of AlexEOF -> Nothing AlexError inp' -> Nothing AlexSkip inp' len -> let chunk = take (fromIntegral len) str in alexScanToken (AlexState state lookedOfs' (moveStr pos chunk), inp') AlexToken inp' len act -> let (state', tokValue) = act chunk state chunk = take (fromIntegral len) str newPos = moveStr pos chunk in Just (Tok tokValue (posnOfs newPos ~- posnOfs pos) pos, (AlexState state' lookedOfs' newPos, inp')) alexScan' input (I# (sc)) = alexScanUser' undefined input (I# (sc)) alexScanUser' user input (I# (sc)) = case alex_scan_tkn' user input 0# input sc AlexNone of (AlexNone, input', lookahead) -> case alexGetByte input of Nothing -> (AlexEOF, lookahead) Just _ -> (AlexError input', lookahead) (AlexLastSkip input'' len, _, lookahead) -> (AlexSkip input'' len, lookahead) #if MIN_TOOL_VERSION_alex(3,2,0) (AlexLastAcc k input'' len, _, lookahead) -> (AlexToken input'' len (alex_actions ! k), lookahead) #else (AlexLastAcc k input'' len, _, lookahead) -> (AlexToken input'' len k, lookahead) #endif -- Same as alex_scan_tkn, but also return the length of lookahead. alex_scan_tkn' user orig_input len input s last_acc = input `seq` -- strict in the input let new_acc = check_accs (alex_accept `quickIndex` IBOX(s)) in new_acc `seq` case alexGetByte input of Nothing -> (new_acc, input, IBOX(len)) Just (c, new_input) -> let base = alexIndexInt32OffAddr alex_base s ord_c = case fromIntegral c of (I# x) -> x offset = (base +# ord_c) check = alexIndexInt16OffAddr alex_check offset new_s = if GEQ_(offset, 0#) && EQ_(check, ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s new_len = if c < 0x80 || c >= 0xC0 then len +# 1# else len in case new_s of -1# -> (new_acc, input, IBOX(new_len)) -- on an error, we want to keep the input *before* the -- character that failed, not after. -- (but still, we looked after) _ -> alex_scan_tkn' user orig_input new_len new_input new_s new_acc where check_accs (AlexAccNone) = last_acc check_accs (AlexAcc a ) = AlexLastAcc a input IBOX(len) check_accs (AlexAccSkip) = AlexLastSkip input IBOX(len) #ifndef NO_ALEX_CONTEXTS check_accs (AlexAccPred a predx rest) | predx user orig_input IBOX(len) input = AlexLastAcc a input IBOX(len) | otherwise = check_accs rest check_accs (AlexAccSkipPred predx rest) | predx user orig_input IBOX(len) input = AlexLastSkip input IBOX(len) | otherwise = check_accs rest #endif c = actionConst m = actionAndModify ms = actionStringAndModify cs = actionStringConst