module Language.Haskell.TokenUtils.HSE.Layout
(
loadFile
, loadFileWithMode
, templateHaskellMode
, TuToken(..)
, s2ss
, ss2s
) where
import Control.Exception
import Data.Generics hiding (GT)
import Data.List
import Data.Monoid
import Data.Tree
import Language.Haskell.Exts.Annotated
import Language.Haskell.TokenUtils.Types
import Language.Haskell.TokenUtils.Utils
import Debug.Trace
data TuToken = T Token | C Comment
deriving (Show,Eq)
loadFile :: FilePath -> IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))
loadFile file = loadFileWithMode defaultParseMode file
loadFileWithMode :: ParseMode -> FilePath -> IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))
loadFileWithMode parseMode file = do
src <- readFile file
let mtoks = lexTokenStream src
let res = case parseFileContentsWithComments parseMode src of
ParseOk (modu,comments) -> case mtoks of
ParseOk toks -> ParseOk (modu,comments,toks)
ParseFailed l s -> ParseFailed l s
ParseFailed l s -> ParseFailed l s
case res of
ParseOk (m, comments,toks) -> return $ ParseOk (m, (mergeToksAndComments toks comments))
ParseFailed l s -> return (ParseFailed l s)
templateHaskellMode :: ParseMode
templateHaskellMode
= defaultParseMode { extensions = (EnableExtension TemplateHaskell):(extensions defaultParseMode)}
mergeToksAndComments :: [Loc Token] -> [Comment] -> [Loc TuToken]
mergeToksAndComments toks comments = go toks comments
where
tokToTu (Loc l t) = Loc l (T t)
commentToTu c@(Comment _ l _) = Loc l (C c)
go :: [Loc Token] -> [Comment] -> [Loc TuToken]
go ts [] = map tokToTu ts
go [] cs = map commentToTu cs
go (ht:ts) (hc@(Comment _ l _):cs)
= if loc ht < l
then tokToTu ht : go ts (hc:cs)
else commentToTu hc : go (ht:ts) cs
instance IsToken (Loc TuToken) where
tokenLen (Loc l (T t)) = hseTokenLen (Loc l t)
tokenLen (Loc _l (C (Comment _ _ s))) = length s
isComment (Loc _ (C _)) = True
isComment _ = False
isEmpty _ = False
mkZeroToken = (Loc (s2ss ((0,0),(0,0))) (T (VarId "")))
isDo (Loc _ (T KW_Do)) = True
isDo (Loc _ (T KW_MDo)) = True
isDo _ = False
isElse (Loc _ (T KW_Else)) = True
isElse _ = False
isIn (Loc _ (T KW_In)) = True
isIn _ = False
isLet (Loc _ (T KW_Let)) = True
isLet _ = False
isOf (Loc _ (T KW_Of)) = True
isOf _ = False
isThen (Loc _ (T KW_Then)) = True
isThen _ = False
isWhere (Loc _ (T KW_Where)) = True
isWhere _ = False
tokenToString = hseTokenToString
showTokenStream = hseShowTokenStream
lexStringToTokens = hseLexStringToTokens
markToken = assert False undefined
isMarked = assert False undefined
instance HasLoc (Loc a) where
getLoc = getLoc . loc
getLocEnd = getLocEnd . loc
putSpan (Loc l v) ns = (Loc (putSpan l ns) v)
instance HasLoc SrcSpan where
getLoc (SrcSpan _ sl sc _el _ec) = (sl,sc)
getLocEnd (SrcSpan _ _sl _sc el ec) = (el,ec)
putSpan _ ss = s2ss ss
ss2s :: SrcSpan -> SimpSpan
ss2s (SrcSpan _fn sr sc er ec) = ((sr,sc),(er,ec))
s2ss :: SimpSpan -> SrcSpan
s2ss ((sr,sc),(er,ec)) = (SrcSpan "<unknown>" sr sc er ec)
s2f :: SrcSpan -> ForestSpan
s2f = ss2f . ss2s
f2s :: ForestSpan -> SrcSpan
f2s = s2ss .f2ss
hseTokenLen :: Loc Token -> Int
hseTokenLen (Loc _ t) = length (showToken' t)
hseTokenToString :: Loc TuToken -> String
hseTokenToString (Loc _ (C (Comment True _ s))) = "{-" ++ s ++ "-}"
hseTokenToString (Loc _ (C (Comment False _ s))) = "--" ++ s
hseTokenToString (Loc _ (T tok)) = showToken' tok
hseShowTokenStream :: [Loc TuToken] -> String
hseShowTokenStream ts2 = (go startLoc ts2 "") ++ "\n"
where startLoc = (1,1)
go _ [] = id
go (locLine,locCol) (tok@(Loc ss _):ts1)
= case ss of
SrcSpan _ tokLine tokCol er ec
| locLine == tokLine -> ((replicate (tokCol locCol) ' ') ++)
. (str ++)
. go tokEnd ts1
| otherwise -> ((replicate (tokLine locLine) '\n') ++)
. ((replicate (tokCol 1) ' ') ++)
. (str ++)
. go tokEnd ts1
where tokEnd = (er,ec)
str = tokenToString tok
hseLexStringToTokens :: SimpSpan -> String -> [Loc TuToken]
hseLexStringToTokens startLoc str = r
where
mtoks = lexTokenStream str
r = case mtoks of
ParseOk toks -> addOffsetToToks offset $ mergeToksAndComments toks []
where
((sr,sc),_) = startLoc
offset = (sr 1, sc 1)
ParseFailed _l _s -> []
showToken' :: Token -> String
showToken' t = case t of
VarId s -> s
QVarId (q,s) -> q ++ '.':s
IDupVarId s -> '?':s
ILinVarId s -> '%':s
ConId s -> s
QConId (q,s) -> q ++ '.':s
DVarId ss -> concat $ intersperse "-" ss
VarSym s -> s
ConSym s -> s
QVarSym (q,s) -> q ++ '.':s
QConSym (q,s) -> q ++ '.':s
IntTok (_, s) -> s
FloatTok (_, s) -> s
Character (_, s) -> '\'':s ++ "'"
StringTok (_, s) -> '"':s ++ "\""
IntTokHash (_, s) -> s ++ "#"
WordTokHash (_, s) -> s ++ "##"
FloatTokHash (_, s) -> s ++ "#"
DoubleTokHash (_, s) -> s ++ "##"
CharacterHash (_, s) -> '\'':s ++ "'#"
StringHash (_, s) -> '"':s ++ "\"#"
LeftParen -> "("
RightParen -> ")"
LeftHashParen -> "(#"
RightHashParen -> "#)"
SemiColon -> ";"
LeftCurly -> "{"
RightCurly -> "}"
VRightCurly -> "virtual }"
LeftSquare -> "["
RightSquare -> "]"
Comma -> ","
Underscore -> "_"
BackQuote -> "`"
Dot -> "."
DotDot -> ".."
Colon -> ":"
DoubleColon -> "::"
Equals -> "="
Backslash -> "\\"
Bar -> "|"
LeftArrow -> "<-"
RightArrow -> "->"
At -> "@"
Tilde -> "~"
DoubleArrow -> "=>"
Minus -> "-"
Exclamation -> "!"
Star -> "*"
LeftArrowTail -> ">-"
RightArrowTail -> "-<"
LeftDblArrowTail -> ">>-"
RightDblArrowTail -> "-<<"
THExpQuote -> "[|"
THPatQuote -> "[p|"
THDecQuote -> "[d|"
THTypQuote -> "[t|"
THCloseQuote -> "|]"
THIdEscape s -> '$':s
THParenEscape -> "$("
THVarQuote -> "'"
THTyQuote -> "''"
THQuasiQuote (n,q) -> "[$" ++ n ++ "|" ++ q ++ "]"
RPGuardOpen -> "(|"
RPGuardClose -> "|)"
RPCAt -> "@:"
XCodeTagOpen -> "<%"
XCodeTagClose -> "%>"
XStdTagOpen -> "<"
XStdTagClose -> ">"
XCloseTagOpen -> "</"
XEmptyTagClose -> "/>"
XPCDATA s -> "PCDATA " ++ s
XRPatOpen -> "<["
XRPatClose -> "]>"
PragmaEnd -> "#-}"
RULES -> "{-# RULES"
INLINE b -> "{-# " ++ if b then "INLINE" else "NOINLINE"
INLINE_CONLIKE -> "{-# " ++ "INLINE_CONLIKE"
SPECIALISE -> "{-# SPECIALISE"
SPECIALISE_INLINE b -> "{-# SPECIALISE " ++ if b then "INLINE" else "NOINLINE"
SOURCE -> "{-# SOURCE"
DEPRECATED -> "{-# DEPRECATED"
WARNING -> "{-# WARNING"
SCC -> "{-# SCC"
GENERATED -> "{-# GENERATED"
CORE -> "{-# CORE"
UNPACK -> "{-# UNPACK"
OPTIONS (mt,_s) -> "{-# OPTIONS" ++ maybe "" (':':) mt ++ " ..."
LANGUAGE -> "{-# LANGUAGE"
ANN -> "{-# ANN"
KW_As -> "as"
KW_By -> "by"
KW_Case -> "case"
KW_Class -> "class"
KW_Data -> "data"
KW_Default -> "default"
KW_Deriving -> "deriving"
KW_Do -> "do"
KW_MDo -> "mdo"
KW_Else -> "else"
KW_Family -> "family"
KW_Forall -> "forall"
KW_Group -> "group"
KW_Hiding -> "hiding"
KW_If -> "if"
KW_Import -> "import"
KW_In -> "in"
KW_Infix -> "infix"
KW_InfixL -> "infixl"
KW_InfixR -> "infixr"
KW_Instance -> "instance"
KW_Let -> "let"
KW_Module -> "module"
KW_NewType -> "newtype"
KW_Of -> "of"
KW_Proc -> "proc"
KW_Rec -> "rec"
KW_Then -> "then"
KW_Type -> "type"
KW_Using -> "using"
KW_Where -> "where"
KW_Qualified -> "qualified"
KW_Foreign -> "foreign"
KW_Export -> "export"
KW_Safe -> "safe"
KW_Unsafe -> "unsafe"
KW_Threadsafe -> "threadsafe"
KW_Interruptible -> "interruptible"
KW_StdCall -> "stdcall"
KW_CCall -> "ccall"
XChildTagOpen -> "<%>"
KW_CPlusPlus -> "cplusplus"
KW_DotNet -> "dotnet"
KW_Jvm -> "jvm"
KW_Js -> "js"
KW_CApi -> "capi"
EOF -> "EOF"
instance Allocatable (Module SrcSpanInfo) (Loc TuToken) where
allocTokens = hseAllocTokens
hseAllocTokens :: Module SrcSpanInfo -> [Loc TuToken] -> LayoutTree (Loc TuToken)
hseAllocTokens modu toks = r
where
ss = allocTokens' modu
ss1 = (ghead "hseAllocTokens" ss)
ss2 = addEndOffsets ss1 toks
ss3 = decorate ss2 toks
r = ss3
allocTokens' :: Data a => a -> [LayoutTree (Loc TuToken)]
allocTokens' modu = r
where
start :: [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
start old = old
r = synthesizel [] redf (start `mkQ` bb
`extQ` letExp
`extQ` expr
`extQ` match
`extQ` bind
`extQ` decl
`extQ` stmt
) modu
bb :: SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
bb (SrcSpanInfo ss _sss) vv = [Node (Entry (s2f ss) NoChange []) vv]
letExp :: Exp SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
letExp (Let l@(SrcSpanInfo ss _) _bs _e) vv =
case srcInfoPoints l of
[letPos,inPos] ->
let
(letStart, _letEnd) = ss2s letPos
(_inStart, inEnd) = ss2s inPos
io = FromAlignCol letStart
(lstart, lend) = ss2s ss
eo = FromAlignCol inEnd
in
[Node (Entry (s2f ss) (Above io lstart lend eo) []) [(makeGroup vv)]]
_ -> vv
letExp _ vv = vv
expr :: Exp SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
expr (Do l@(SrcSpanInfo _ss _) stmts) vv =
case srcInfoPoints l of
(doPos:_) ->
let
(doStart, _doEnd) = ss2s doPos
io = FromAlignCol doStart
s = makeSpanFromTrees subs
(lstart, lend) = f2ss s
eo = None
subs = concatMap allocTokens' stmts
in
[makeGroup [Node (Entry (s2f doPos) NoChange []) [],
Node (Entry s (Above io lstart lend eo) []) subs]]
_ -> vv
expr _ vv = vv
match :: Match SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
match (InfixMatch l@(SrcSpanInfo ss _) pat name pats rhs mWhere) vv = vv
match (Match l@(SrcSpanInfo _ss _) fname pats rhs mWhere) _vv =
let
treeName = allocTokens' fname
treePats = allocTokens' pats
treeRhs = subTreeOnly (allocTokens' rhs)
treeWhereClause = case mWhere of
(Just bd@(BDecls (SrcSpanInfo _bs _) _)) -> [makeGroup (treeWhere ++ treeDecls)]
where
wherePos = ghead "redf.match" (srcInfoPoints l)
treeWhere = [Node (Entry (s2f wherePos) NoChange []) [] ]
treeSubDecls = subTreeOnly (allocTokens' bd)
treeDecls = [makeGroupLayout (Above io lstart lend eo) treeSubDecls]
s = makeSpanFromTrees treeSubDecls
(lstart, lend) = f2ss s
(whereStart, _whereEnd) = ss2s wherePos
io = FromAlignCol whereStart
Just (IPBinds l binds) -> []
Nothing -> []
eo = None
subs = treeName ++ treePats ++ treeRhs ++ treeWhereClause
in
[makeGroup subs]
bind :: Binds SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
bind (BDecls (SrcSpanInfo _ss _) bs) _vv =
let
subs = concatMap allocTokens' bs
in
[makeGroup subs]
bind (IPBinds l@(SrcSpanInfo ss _) bs) vv = vv
decl :: Decl SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
decl (FunBind (SrcSpanInfo _ss _) matches) _vv =
let
subs = concatMap allocTokens' matches
in
[makeGroup subs]
decl (PatBind (SrcSpanInfo _ _) _ _ _ Nothing) vv = vv
decl (PatBind l@(SrcSpanInfo _ss _) pat mtyp rhs (Just bd@(BDecls (SrcSpanInfo _bs _) _))) vv =
case srcInfoPoints l of
(wherePos:_) ->
let
treePat = allocTokens' pat
treeType = allocTokens' mtyp
treeRhs = allocTokens' rhs
treeWhereClause = [makeGroup (treeWhere ++ treeDecls)]
where
treeWhere = [Node (Entry (s2f wherePos) NoChange []) [] ]
treeSubDecls = subTreeOnly (allocTokens' bd)
treeDecls = [makeGroupLayout (Above io lstart lend eo) treeSubDecls]
s = makeSpanFromTrees treeSubDecls
(lstart,lend) = f2ss s
(whereStart,_whereEnd) = ss2s wherePos
io = FromAlignCol whereStart
eo = None
subs = treePat ++ treeType ++ treeRhs ++ treeWhereClause
in
[makeGroup subs]
_ -> vv
decl _ vv = vv
stmt :: Stmt SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
stmt (LetStmt l@(SrcSpanInfo _ss _) _binds) vv =
case srcInfoPoints l of
(letPos:_) ->
let
(letStart, _letEnd) = ss2s letPos
io = FromAlignCol letStart
(lstart, lend) = f2ss $ makeSpanFromTrees (subTreeOnly vv)
eo = None
in
[makeGroup [Node (Entry (s2f letPos) NoChange []) [],
makeGroupLayout (Above io lstart lend eo) (subTreeOnly vv)]]
_ -> error $ "allocTokens'.stmt:LetStmt:missing statements:" ++ show (l,_binds)
stmt _ vv = vv
mergeSubs as bs = as ++ bs
redf :: [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
redf [] b = b
redf a [] = a
redf [a@(Node e1@(Entry s1 l1 []) sub1)] [b@(Node _e2@(Entry s2 l2 []) sub2)]
=
let
(as,ae) = treeStartEnd a
(bs,be) = treeStartEnd b
ss = combineSpans s1 s2
ret =
case (compare as bs,compare ae be) of
(EQ,EQ) -> [Node (Entry s1 (l1 <> l2) []) (sub1 ++ sub2)]
(LT,EQ) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs sub1 [b])]
(GT,EQ) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs sub2 [a])]
(EQ,GT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [b] sub1)]
(EQ,LT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [a] sub2)]
(_,_) -> if ae <= bs
then [Node e [a,b]]
else if be <= as
then [Node e [b,a]]
else
[Node e1 (sub1++[b])]
where
e = Entry ss NoChange []
(Node (Entry _ _lr []) _) = head ret
in
ret
redf new old = error $ "bar2.redf:" ++ show (new,old)
synthesizel :: s -> (s -> t -> s) -> GenericQ (s -> t) -> GenericQ t
synthesizel z o f x = f x (foldl o z (gmapQ (synthesizel z o f) x))
instance Monoid Layout where
mempty = NoChange
mappend NoChange NoChange = NoChange
mappend NoChange x = x
mappend x NoChange = x
mappend (Above bo1 ps1 pe1 eo1) (Above bo2 ps2 pe2 eo2)
= (Above bo ps pe eo)
where
(bo,ps) = if ps1 <= ps2 then (bo1,ps1)
else (bo2,ps2)
(eo,pe) = if pe1 >= pe2 then (eo1,pe1)
else (eo2,pe2)