module Lexers.Haskell.Layout where import Parsers.Haskell.Common (anyComment) import Utils.Foldable (hasNone, hasSome) import Utils.List (safeHead, safeTail) import Utils.String (joinWords, wrapCurly', wrapDoubleQuotes', wrapParens', wrapQuotes') import Bookhound.Parser (ParseError, Parser, check, runParser, withError) import Bookhound.ParserCombinators (IsMatch (is, isNot, noneOf, oneOf), (->>-), (<|>), (|*), (|+), (|?)) import Bookhound.Parsers.Char (char, space) import Bookhound.Parsers.String (spacing, withinDoubleQuotes, withinParens, withinQuotes, word) import Control.Monad (foldM) import Data.Foldable (Foldable (fold)) import Data.List (isPrefixOf) import Data.Monoid.HT (when) import Data.Text (Text, pack) adaptLayout :: Text -> Either [ParseError] Text adaptLayout :: Text -> Either [ParseError] Text adaptLayout Text str = String -> Text pack forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. [a] -> [a] -> [a] ++ String " }") forall b c a. (b -> c) -> (a -> b) -> a -> c . [String] -> String unlines forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {a} {b} {c} {d}. (a, b, c, d) -> a fst4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Either [ParseError] ([String], [Int], Bool, Bool) layoutLines where layoutLines :: Either [ParseError] ([String], [Int], Bool, Bool) layoutLines = forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM ([String], [Int], Bool, Bool) -> String -> Either [ParseError] ([String], [Int], Bool, Bool) layout forall {a} {a}. ([a], [a], Bool, Bool) args forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. [a] -> [a] -> [a] ++ forall (f :: * -> *) a. Applicative f => a -> f a pure String "") forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter forall (t :: * -> *) a. Foldable t => t a -> Bool hasSome forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Either [ParseError] [String] input input :: Either [ParseError] [String] input = String -> [String] lines forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Parser a -> Text -> Either [ParseError] a runParser Parser [String] parensLayout Text str args :: ([a], [a], Bool, Bool) args = ([], [], Bool False, Bool False) fst4 :: (a, b, c, d) -> a fst4 (a x, b _, c _, d _) = a x layout :: ([String], [Int], Bool, Bool) -> String -> Either [ParseError] ([String], [Int], Bool, Bool) layout :: ([String], [Int], Bool, Bool) -> String -> Either [ParseError] ([String], [Int], Bool, Bool) layout ([String] x, [Int] y, Bool z, Bool t) String str = forall a. Parser a -> Text -> Either [ParseError] a runParser Parser ([String], [Int], Bool, Bool) layoutParser forall a b. (a -> b) -> a -> b $ String -> Text pack String str where layoutParser :: Parser ([String], [Int], Bool, Bool) layoutParser = forall a. String -> Parser a -> Parser a withError String "Layout lexer" forall a b. (a -> b) -> a -> b $ do String spaces' <- (Parser Char space |*) String beginning <- Parser String otherText Maybe String layoutText <- (Parser String layoutBegin |?) String spaces'' <- (Parser Char space |*) String rest <- Parser String otherText let hasIn :: Bool hasIn = forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool False (String "in" ==) (forall a. [a] -> Maybe a safeHead forall a b. (a -> b) -> a -> b $ String -> [String] words String beginning) hasCurly :: Bool hasCurly = forall a. Eq a => [a] -> [a] -> Bool isPrefixOf String "{" String rest indents :: [Int] indents = forall m. Monoid m => Bool -> m -> m when Bool z [forall (t :: * -> *) a. Foldable t => t a -> Int length String spaces'] forall a. [a] -> [a] -> [a] ++ if Bool -> Bool not Bool hasIn then [Int] y else (forall (t :: * -> *) a. Foldable t => t a -> Int length String spaces' forall a. Num a => a -> a -> a + Int 1) forall a. a -> [a] -> [a] : (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold forall a b. (a -> b) -> a -> b $ forall a. [a] -> Maybe [a] safeTail [Int] y) layoutNextLine :: Bool layoutNextLine = forall (t :: * -> *) a. Foldable t => t a -> Bool hasSome Maybe String layoutText Bool -> Bool -> Bool && forall (t :: * -> *) a. Foldable t => t a -> Bool hasNone String rest contextIndent :: Int contextIndent = forall (t :: * -> *) a. Foldable t => t a -> Int length forall a b. (a -> b) -> a -> b $ String spaces' forall a. [a] -> [a] -> [a] ++ String beginning forall a. [a] -> [a] -> [a] ++ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold Maybe String layoutText forall a. [a] -> [a] -> [a] ++ String spaces'' ([Int] newIndents, String beginSep, Bool stop) = [Int] -> Int -> Bool -> String -> ([Int], String, Bool) calcIndent [Int] indents (forall (t :: * -> *) a. Foldable t => t a -> Int length String spaces') (Bool t Bool -> Bool -> Bool || Bool hasCurly) String beginning endSep :: String endSep = forall m. Monoid m => Bool -> m -> m when (forall (t :: * -> *) a. Foldable t => t a -> Bool hasSome Maybe String layoutText Bool -> Bool -> Bool && Bool -> Bool not Bool hasCurly) String " {" indents' :: [Int] indents' = forall m. Monoid m => Bool -> m -> m when (forall (t :: * -> *) a. Foldable t => t a -> Bool hasSome Maybe String layoutText Bool -> Bool -> Bool && forall (t :: * -> *) a. Foldable t => t a -> Bool hasSome String rest) [Int contextIndent] forall a. [a] -> [a] -> [a] ++ [Int] newIndents text :: [String] text = [String] x forall a. [a] -> [a] -> [a] ++ [String spaces' forall a. [a] -> [a] -> [a] ++ String beginSep forall a. [a] -> [a] -> [a] ++ String beginning forall a. [a] -> [a] -> [a] ++ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold Maybe String layoutText forall a. [a] -> [a] -> [a] ++ String endSep forall a. [a] -> [a] -> [a] ++ String spaces'' forall a. [a] -> [a] -> [a] ++ String rest] forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ ([String] text, [Int] indents', Bool layoutNextLine, Bool stop Bool -> Bool -> Bool || Bool hasCurly) parensLayout :: Parser [String] parensLayout :: Parser [String] parensLayout = (((Parser String spacing |?) forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- Parser String elem' forall a. Parser a -> Parser a -> Parser a <|> Parser String parensParser forall a. Parser a -> Parser a -> Parser a <|> (String -> String wrapParens' forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall b. Parser b -> Parser b withinParens Parser [String] parensLayout) forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- (Parser String spacing |?)) |*) where elem' :: Parser String elem' = (Parser String -> Parser String) -> Parser String lexeme' forall a. a -> a id parensParser :: Parser String parensParser = String -> String wrapParens' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall b. Parser b -> Parser b withinParens ((Parser String spacing |?) forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- Parser String layoutBegin forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- Parser String spacing forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- (String -> String wrapCurly' forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser [String] parensLayout)) calcIndent :: [Int] -> Int -> Bool -> String -> ([Int], String, Bool) calcIndent :: [Int] -> Int -> Bool -> String -> ([Int], String, Bool) calcIndent [Int] indentLvls Int curr Bool stop String beginning = ([Int] newIndentLvls, [String] -> String joinWords [String closeContexts, String sep], Bool shouldStop) where extraElems :: [Int] extraElems = if Bool -> Bool not Bool stop then [Int] extra else forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold forall a b. (a -> b) -> a -> b $ forall a. [a] -> Maybe [a] safeTail [Int] extra closeContexts :: String closeContexts = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold (String "} " forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ [Int] extraElems) shouldStop :: Bool shouldStop = Bool stop Bool -> Bool -> Bool && forall (t :: * -> *) a. Foldable t => t a -> Bool hasNone [Int] extra sep :: String sep = forall m. Monoid m => Bool -> m -> m when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (forall a. Eq a => a -> a -> Bool == Int curr) (forall a. [a] -> Maybe a safeHead [Int] newIndentLvls) Bool -> Bool -> Bool && forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool notElem String beginning [String] nestTokens) String "; " ([Int] extra, [Int] newIndentLvls) = forall a. (a -> Bool) -> [a] -> ([a], [a]) span (Int curr <) [Int] indentLvls nestTokens :: [String] nestTokens :: [String] nestTokens = [String "then", String "else"] layoutTokens :: [String] layoutTokens :: [String] layoutTokens = [(String "(" ++), forall a. a -> a id] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> [String "where", String "let", String "do", String "of", String "\\case"] layoutBegin :: Parser String layoutBegin :: Parser String layoutBegin = forall a. IsMatch a => [a] -> Parser a oneOf [String] layoutTokens lexeme :: Parser String lexeme :: Parser String lexeme = String -> String wrapDoubleQuotes' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall b. Parser b -> Parser b withinDoubleQuotes (forall a. IsMatch a => a -> Parser a isNot Char '"' |+) forall a. Parser a -> Parser a -> Parser a <|> String -> String wrapQuotes' forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a. Applicative f => a -> f a pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall b. Parser b -> Parser b withinQuotes (Parser Char char forall a. Parser a -> Parser a -> Parser a <|> (forall a. IsMatch a => a -> Parser a is Char '\\' |?) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> Parser Char char) forall a. Parser a -> Parser a -> Parser a <|> Parser String anyComment forall a. Parser a -> Parser a -> Parser a <|> Parser String word otherText :: Parser String otherText :: Parser String otherText = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser [String] elems where elems :: Parser [String] elems = (((forall a. String -> (a -> Bool) -> Parser a -> Parser a check String "" (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `notElem` [String] layoutTokens) Parser String lexeme) forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- (Parser Char space |*)) |*) lexeme' :: (Parser String -> Parser String) -> Parser String lexeme' :: (Parser String -> Parser String) -> Parser String lexeme' Parser String -> Parser String f = (Parser String spacing |?) forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- Parser String -> Parser String f Parser String lexeme forall a b. (ToString a, ToString b) => Parser a -> Parser b -> Parser String ->>- (Parser String spacing |?) otherText' :: Parser String otherText' :: Parser String otherText' = (Parser String -> Parser String) -> Parser String lexeme' (forall a. String -> (a -> Bool) -> Parser a -> Parser a check String "" (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `notElem` [String] layoutTokens)) word' :: Parser String word' :: Parser String word' = ((forall a. IsMatch a => [a] -> Parser a noneOf [Char ' ', Char '\n', Char '\t', Char '(', Char ')']) |+)