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
')']) |+)