diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2014-07-20: v0.0.0.4 + * Bring in tokenise and basicTokenise 2014-07-09: v0.0.0.3 * Simplifying location information * Moving across more machinery from HaRe diff --git a/haskell-token-utils.cabal b/haskell-token-utils.cabal --- a/haskell-token-utils.cabal +++ b/haskell-token-utils.cabal @@ -1,5 +1,5 @@ name: haskell-token-utils -version: 0.0.0.3 +version: 0.0.0.4 synopsis: Utilities to tie up tokens to an AST description: This library is currently experimental. . @@ -43,7 +43,7 @@ , Language.Haskell.TokenUtils.HSE.Layout -- other-modules: -- other-extensions: - build-depends: base >=4.5 && <4.7 + build-depends: base >=4.5 && <= 4.7 , containers , dual-tree , semigroups @@ -56,6 +56,7 @@ , ghc , ghc-syb-utils , syb + , ghc-paths -- for HSE, until split out , haskell-src-exts @@ -75,7 +76,7 @@ src, test, src-ghc, src-hse default-language: Haskell2010 build-depends: - base >= 4.0 && < 4.7 + base >= 4.5 && <= 4.7 , Diff >= 0.3.0 , HUnit , QuickCheck >= 2.5 @@ -102,6 +103,7 @@ -- For testing the haskell-src-exts one , haskell-src-exts >= 1.15 + , uniplate source-repository head type: git diff --git a/src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs b/src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs --- a/src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs +++ b/src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# Language MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- @@ -28,8 +29,9 @@ , newNameTok + , GhcPosToken + -- * For testing - , addEndOffsets ) where import qualified Bag as GHC @@ -37,32 +39,40 @@ import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC +import qualified GHC.Paths as GHC import qualified Lexer as GHC import qualified Name as GHC import qualified NameSet as GHC import qualified Outputable as GHC import qualified RdrName as GHC import qualified SrcLoc as GHC +import qualified StringBuffer as GHC import qualified UniqSet as GHC import qualified Unique as GHC import qualified Var as GHC -import Outputable +-- import Outputable import qualified GHC.SYB.Utils as SYB +import qualified Data.Generics as SYB import Control.Exception +import Data.Generics hiding (GT) import Data.List +import Data.Monoid import Data.Tree +import System.IO.Unsafe + import Language.Haskell.TokenUtils.DualTree import Language.Haskell.TokenUtils.Layout import Language.Haskell.TokenUtils.TokenUtils import Language.Haskell.TokenUtils.Types import Language.Haskell.TokenUtils.Utils --- import qualified Data.Tree.Zipper as Z +import qualified Data.Tree.Zipper as Z +import Debug.Trace -- --------------------------------------------------------------------- @@ -590,48 +600,6 @@ ++ (makeLeafFromToks toks7) ++ (makeLeafFromToks toks') )] -{- -tcdND :: NewOrData -tcdCtxt :: LHsContext name - - Context... - - Context -tcdLName :: Located name - - Name of the class - - type constructor - - Type constructor -tcdTyVars :: [LHsTyVarBndr name] - - Class type variables - - type variables - - Type variables -tcdTyPats :: Maybe [LHsType name] - - Type patterns See Note [tcdTyVars and tcdTyPats] - - Type patterns. See Note [tcdTyVars and tcdTyPats] -tcdKindSig :: Maybe (LHsKind name) - - Optional kind signature. - - (Just k) for a GADT-style data, or data instance decl with explicit kind sig -tcdCons :: [LConDecl name] - - Data constructors - - For data T a = T1 | T2 a the LConDecls all have ResTyH98. For data T a where { T1 :: T a } the LConDecls all have ResTyGADT. -tcdDerivs :: Maybe [LHsType name] - - Derivings; Nothing => not specified, Just [] => derive exactly what is asked - - These types must be of form forall ab. C ty1 ty2 Typically the foralls and ty args are empty, but they are non-empty for the newtype-deriving case --} #endif #if __GLASGOW_HASKELL__ > 704 allocLTyClDecl (GHC.L l (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs _fvs)) toks = r @@ -2102,6 +2070,7 @@ instance Allocatable GHC.ParsedSource GhcPosToken where allocTokens = ghcAllocTokens + -- allocTokens = ghcAllocTokens' instance (IsToken (GHC.Located GHC.Token, String)) where -- getSpan = ghcGetSpan @@ -2123,6 +2092,8 @@ tokenToString (_,s) = s showTokenStream = GHC.showRichTokenStream + lexStringToTokens = ghcLexStringToTokens + markToken = ghcMarkToken isMarked = ghcIsMarked @@ -2347,5 +2318,314 @@ GHC.mkSrcSpan locStart locEnd _ -> l +-- ===================================================================== +-- Trying approach used in HSE version + +-- --------------------------------------------------------------------- + +ghcAllocTokens' :: GHC.ParsedSource-> [GhcPosToken] -> LayoutTree GhcPosToken +ghcAllocTokens' parsed toks = r + where + parsed' = sanitize parsed + ss = allocTokensSrcSpans parsed' + ss1 = (ghead "ghcAllocTokens" ss) + ss2 = addEndOffsets ss1 toks + ss3 = decorate ss2 toks + + ss4 = addLayout parsed ss3 + + -- r = error $ "foo=" ++ show ss + -- r = error $ "foo=" ++ drawTreeCompact (head ss) + r = error $ "foo=" ++ drawTreeWithToks ss4 + -- r = undefined + -- r = ss4 + +-- --------------------------------------------------------------------- + +allocTokensSrcSpans :: Data a => a -> [LayoutTree GhcPosToken] +allocTokensSrcSpans modu = r + where + start :: [LayoutTree (GhcPosToken)] -> [LayoutTree (GhcPosToken)] + start old = old + + -- r = synthesize [] redf (start `mkQ` bb + -- NOTE: the token re-alignement needs a left-biased tree, not a right-biased one, hence synthesizel + -- r = synthesizel [] redf (start `mkQ` bb + r = synthesizelStaged SYB.Parser [] [] redf (start `mkQ` bb + -- `extQ` localBinds + ) modu + + -- ends up as GenericQ (SrcSpanInfo -> LayoutTree TuToken) + bb :: GHC.SrcSpan -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] + bb ss@(GHC.RealSrcSpan _) vv = [Node (Entry (gs2f ss) NoChange []) vv] + bb ss vv = vv -- error $ "allocTokensSrcSpans:got weird ss:" ++ show ss + + -- -------------- +{- + localBinds :: GHC.HsLocalBinds GHC.RdrName -> [LayoutTree a] -> [LayoutTree a] + localBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) vv = r + where + bindList = GHC.bagToList binds + + startBind = startPosForList bindList + startSig = startPosForList sigs + start = if startSig < startBind then startSig else startBind + + endBind = endPosForList bindList + endSig = endPosForList sigs + end = if endSig > endBind then endSig else endBind + + -- s1 will contain the 'where' token, split into prior comments, + -- the token, and post comments so that if the 'where' token must + -- be removed the comments will stay + (s1p,s1r) = break isWhereOrLet s1 + (w,s1a) = break (not.isWhereOrLet) s1r + whereLayout = makeLeafFromToks s1p ++ makeLeafFromToks w ++ makeLeafFromToks s1a + + firstBindTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored toksBinds + p1 = (ghcTokenRow firstBindTok,ghcTokenCol firstBindTok) + (ro,co) = case (filter isWhereOrLet s1) of + [] -> (0,0) + (x:_) -> (ghcTokenRow firstBindTok - ghcTokenRow x, + ghcTokenCol firstBindTok - (ghcTokenCol x + tokenLen x)) + + (rt,ct) = calcLastTokenPos toksBinds + + r = undefined + localBinds _ vv = vv +-} + -- -------------- + + mergeSubs as bs = as ++ bs + + + -- TODO: redf exists identically in the HSE version, harvest commonality + redf :: [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] + 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])] -- b is sub of a + (GT,EQ) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs sub2 [a])] -- a is sub of b + + (EQ,GT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [b] sub1)] -- b is sub of a + (EQ,LT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [a] sub2)] -- a is sub of b + + (_,_) -> if ae <= bs + then [Node e [a,b]] + else if be <= as + then [Node e [b,a]] + else -- fully nested case + [Node e1 (sub1++[b])] -- should merge subs + where + e = Entry ss NoChange [] + (Node (Entry _ _lr []) _) = head ret + + in + {- + trace (show ((compare as bs,compare ae be),(f2ss $ treeStartEnd a,l1,length sub1) + ,(f2ss $ treeStartEnd b,l2,length sub2) + -- , (as,ae,bs,be,ss) + )) + + -} + ret + + redf new old = error $ "bar2.redf:" ++ show (new,old) + +-- --------------------------------------------------------------------- +-- | Bottom-up synthesis of a data structure; +-- 1st argument z is the initial element for the synthesis; +-- 2nd argument o is for reduction of results from subterms; +-- 3rd argument f updates the synthesised data according to the given term +-- +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)) + +-- Staged version of synthesizel +synthesizelStaged :: SYB.Stage -> t -> s -> (s -> t -> s) -> GenericQ (s -> t) -> GenericQ t +synthesizelStaged stage zt z o f x + | checkItemStage stage x = zt + | otherwise = f x (foldl' o z (gmapQ ((synthesizelStaged stage zt) z o f) x)) + +-- --------------------------------------------------------------------- + +-- | Checks whether the current item is undesirable for analysis in the current +-- AST Stage. +checkItemStage :: (Typeable a, Data a) => SYB.Stage -> a -> Bool +checkItemStage stage x = (checkItemStage1 stage x) +#if __GLASGOW_HASKELL__ > 704 + || (checkItemStage2 stage x) +#endif + +-- Check the Typeable items +checkItemStage1 :: (Typeable a) => SYB.Stage -> a -> Bool +checkItemStage1 stage x = (const False `SYB.extQ` postTcType `SYB.extQ` fixity `SYB.extQ` nameSet) x + where nameSet = const (stage `elem` [SYB.Parser,SYB.TypeChecker]) :: GHC.NameSet -> Bool + postTcType = const (stage < SYB.TypeChecker ) :: GHC.PostTcType -> Bool + fixity = const (stage < SYB.Renamer ) :: GHC.Fixity -> Bool + +#if __GLASGOW_HASKELL__ > 704 +-- | Check the Typeable1 items +checkItemStage2 :: Data a => SYB.Stage -> a -> Bool +checkItemStage2 stage x = (const False `SYB.ext1Q` hsWithBndrs) x + where + hsWithBndrs = const (stage < SYB.Renamer) :: GHC.HsWithBndrs a -> Bool +#endif + +-- --------------------------------------------------------------------- + +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) + + +-- --------------------------------------------------------------------- +-- |sanitize the GHC ParsedSource by purging it of undefineds +-- These can occur in (at least one place) +-- HsCmdTop - last field +sanitize :: (Typeable a,Data a) => a -> a +sanitize t = r + where + r = everywhereStaged SYB.Parser (SYB.mkT cmdTopR `SYB.extT` cmdTopN +#if __GLASGOW_HASKELL__ > 704 + `SYB.extT` parStmt +#endif + ) t + + cmdTopN :: GHC.HsCmdTop GHC.Name -> GHC.HsCmdTop GHC.Name + cmdTopN (GHC.HsCmdTop cmd ts typ _) = (GHC.HsCmdTop cmd ts typ []) + + cmdTopR :: GHC.HsCmdTop GHC.RdrName -> GHC.HsCmdTop GHC.RdrName + cmdTopR (GHC.HsCmdTop cmd ts typ _) = (GHC.HsCmdTop cmd ts typ []) + +#if __GLASGOW_HASKELL__ > 704 + parStmt :: GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> GHC.ParStmtBlock GHC.RdrName GHC.RdrName + parStmt (GHC.ParStmtBlock stmts _ typ) = (GHC.ParStmtBlock stmts [] typ) +#endif + +-- --------------------------------------------------------------------- + +-- TODO: These are duplicates of those in HaRe, we need one only, +-- hopefully can move to ghc-syb-utils + +-- | Bottom-up transformation +everywhereStaged :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a +everywhereStaged stage f x + | checkItemStage stage x = x + | otherwise = (f . gmapT (everywhereStaged stage f)) x + +-- | Top-down version of everywhereStaged +everywhereStaged' :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a +everywhereStaged' stage f x + | checkItemStage stage x = x + | otherwise = (gmapT (everywhereStaged stage f) . f) x + +-- | Staged variation of SYB.everything +-- The stage must be provided to avoid trying to modify elements which +-- may not be present at all stages of AST processing. +-- Note: Top-down order +everythingStaged :: SYB.Stage -> (r -> r -> r) -> r -> SYB.GenericQ r -> SYB.GenericQ r +everythingStaged stage k z f x + | checkItemStage stage x = z + | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) + +-- --------------------------------------------------------------------- + +-- |Traverse the parsed source looking for points requiring layout, +-- and insert them into the LayoutTree at the appropriate point +addLayout :: GHC.ParsedSource -> LayoutTree GhcPosToken -> LayoutTree GhcPosToken +addLayout parsed tree = r + where + ztree = Z.fromTree tree + + [r] = everythingStaged SYB.Parser combine [tree] ([] `SYB.mkQ` lgrhs + `SYB.extQ` lmatch + ) parsed + + combine :: [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] + combine [] rs = rs + combine ls [] = ls + combine [l] [rt] = trace ("addLayout.combine1:" ++ show (rootLabel l,rootLabel rt)) [rt] + combine ls rs = trace ("addLayout.combine2:" ++ show (ls,rs)) [] + + lgrhs :: GHC.Located (GHC.GRHSs GHC.RdrName) -> [LayoutTree GhcPosToken] + -- lgrhs (GHC.L l (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))) = tt + lgrhs (GHC.L l (GHC.GRHSs rhs (GHC.HsValBinds binds))) = tt + where + z = openZipperToSpan (gs2f l) ztree + + tt = trace ("lgrhs:z=" ++ show (Z.label z)) undefined + lgrhs _ = [] + + lmatch :: GHC.LMatch GHC.RdrName -> [LayoutTree GhcPosToken] + -- lgrhs (GHC.L l (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))) = tt + lmatch (GHC.L l (GHC.Match pats mtyp (GHC.GRHSs rhs (GHC.HsValBinds binds)) )) = tt + where + z = openZipperToSpan (gs2f l) ztree + + -- Need to get tokens, look for the where, and identify how it + -- fits in + + -- tt = trace ("lmatch:z=" ++ show (Z.label z)) undefined + -- tt = trace ("lmatch:z=" ++ show (Z.tree z)) undefined + tt = trace ("lmatch:z=" ++ drawTreeWithToks (Z.tree z)) undefined + lmatch _ = [] + +-- --------------------------------------------------------------------- + +ghcLexStringToTokens :: SimpSpan -> String -> [GhcPosToken] +ghcLexStringToTokens startLoc str = r + where + rsl = case ss2gs startLoc of + GHC.RealSrcSpan x -> GHC.realSrcSpanStart x + _ -> undefined + r = unsafePerformIO $ lexStringToRichTokens rsl str + +-- --------------------------------------------------------------------- + + +lexStringToRichTokens :: GHC.RealSrcLoc -> String -> IO [GhcPosToken] +lexStringToRichTokens startLoc str = do +#if __GLASGOW_HASKELL__ > 704 + GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do +#else + GHC.defaultErrorHandler GHC.defaultLogAction $ do +#endif + GHC.runGhc (Just GHC.libdir) $ do + dflags <- GHC.getSessionDynFlags + let dflags' = foldl GHC.xopt_set dflags + [GHC.Opt_Cpp, GHC.Opt_ImplicitPrelude, GHC.Opt_MagicHash] + _ <- GHC.setSessionDynFlags dflags' + + let res = GHC.lexTokenStream (GHC.stringToStringBuffer str) startLoc dflags' + case res of + GHC.POk _ toks -> return $ GHC.addSourceToTokens startLoc (GHC.stringToStringBuffer str) toks + GHC.PFailed _srcSpan _msg -> error $ "lexStringToRichTokens:" -- ++ (show $ GHC.ppr msg) + + + + +-- --------------------------------------------------------------------- -- EOF diff --git a/src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs b/src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs --- a/src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs +++ b/src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs @@ -124,6 +124,7 @@ tokenToString = hseTokenToString showTokenStream = hseShowTokenStream + lexStringToTokens = hseLexStringToTokens markToken = assert False undefined isMarked = assert False undefined @@ -189,7 +190,20 @@ where tokEnd = (er,ec) str = tokenToString tok +-- --------------------------------------------------------------------- +hseLexStringToTokens :: SimpSpan -> String -> [Loc TuToken] +hseLexStringToTokens startLoc str = r + where + -- lexTokenStream :: String -> ParseResult [Loc Token] + 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 -> [] + -- --------------------------------------------------------------------- -- This function is copied here from haskell-src-exts @@ -368,7 +382,7 @@ -- --------------------------------------------------------------------- - +{- moved to TokenUtils.Utils -- Allocate all the tokens to the given tree decorate :: LayoutTree (Loc TuToken) -> [Loc TuToken] -> LayoutTree (Loc TuToken) decorate tree toks = go toks tree @@ -394,7 +408,7 @@ subs'' = subs' ++ makeLeafFromToks end -- go ts tr = error $ "decorate:not processing :" ++ show (ts,tr) - +-} -- --------------------------------------------------------------------- {- diff --git a/src/Language/Haskell/TokenUtils/TokenUtils.hs b/src/Language/Haskell/TokenUtils/TokenUtils.hs --- a/src/Language/Haskell/TokenUtils/TokenUtils.hs +++ b/src/Language/Haskell/TokenUtils/TokenUtils.hs @@ -24,6 +24,7 @@ -- * Operations at 'LayoutTree' level + , updateTokensForSrcSpan , replaceTokenForSrcSpan , getSrcSpanFor , indentDeclToks @@ -32,6 +33,11 @@ , addOffsetToSpan , reIndentToks + + -- * Working with tokens + , basicTokenise + , tokenise + -- * , invariant , reverseToks @@ -72,7 +78,6 @@ , insertSrcSpan , insertLenChangedInSrcSpan , insertVersionsInSrcSpan - , updateTokensForSrcSpan , removeSrcSpan , containsStart , containsMiddle @@ -411,7 +416,7 @@ showToks :: (IsToken a) => [a] -> String showToks toks = show $ map doOne toks where - doOne tok = (s,e,tok) + doOne tok = (s,e,tokenToString tok) where (s,e) = getSpan tok -- --------------------------------------------------------------------- @@ -819,16 +824,12 @@ | otherwise = [toks] where toks = concat $ reverse $ map retrieveTokensInterim $ Z.before zz - -- toks = concat $ map retrieveTokensInterim $ Z.before zz -- --------------------------------------------------------------------- -{- -posToSpan :: (SimpPos,SimpPos) -> Span -posToSpan (s,e) = Span s e --} --- --------------------------------------------------------------------- +-- |Place the new tokens so that they are positioned correctly +-- relative to the previous tokens reIndentToks :: (IsToken a) => Positioning -> [a] -> [a] -> [a] reIndentToks _ _ [] = [] reIndentToks pos prevToks toks = toks'' @@ -1689,6 +1690,41 @@ ((sl,_),_) = getSpan tok nl = sl + jump tok' = putSpan mkZeroToken ((nl,1),(nl,1)) + +-- --------------------------------------------------------------------- + +-- | Convert a string into a set of Haskell tokens, following the +-- given position, with each line indented by a given column offset if +-- required +-- TODO: replace 'colOffset withFirstLineIndent' with a Maybe Int ++AZ++ +tokenise :: (IsToken a) => SimpSpan -> Int -> Bool -> String -> [a] +tokenise _ _ _ [] = [] +tokenise startPos colOffset withFirstLineIndent str + = let str' = case lines str of + (ln:[]) -> addIndent ln ++ if glast "tokenise" str=='\n' then "\n" else "" + (ln:lns)-> addIndent ln ++ "\n" ++ concatMap (\n->replicate colOffset ' '++n++"\n") lns + [] -> [] + str'' = if glast "tokenise" str' == '\n' && glast "tokenise" str /= '\n' + then genericTake (length str' -1) str' + else str' + toks = lexStringToTokens startPos str'' + + in toks + -- in error $ "tokenise:" ++ (showToks $ head toks) + where + addIndent ln = if withFirstLineIndent + then replicate colOffset ' '++ ln + else ln + +-- --------------------------------------------------------------------- + +-- |Convert a string into a set of Haskell tokens. It has default +-- position and offset, since it will be stitched into place in TokenUtils +basicTokenise :: (IsToken a) => String -> [a] +basicTokenise str = tokenise startPos 0 False str + where + -- startPos = (GHC.mkRealSrcLoc tokenFileMark 0 1) + startPos = ((0,1),(0,1)) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/TokenUtils/Types.hs b/src/Language/Haskell/TokenUtils/Types.hs --- a/src/Language/Haskell/TokenUtils/Types.hs +++ b/src/Language/Haskell/TokenUtils/Types.hs @@ -185,6 +185,10 @@ -- TODO: may be able to get rid of next due to former showTokenStream :: [a] -> String + -- |Create a stream of tokens from source, with first token start at + -- given location + lexStringToTokens :: SimpSpan -> String -> [a] + -- |Mark a token so that it can be use to trigger layout checking -- later when the toks are retrieved markToken :: a -> a diff --git a/src/Language/Haskell/TokenUtils/Utils.hs b/src/Language/Haskell/TokenUtils/Utils.hs --- a/src/Language/Haskell/TokenUtils/Utils.hs +++ b/src/Language/Haskell/TokenUtils/Utils.hs @@ -69,6 +69,7 @@ , srcPosToSimpPos , addOffsetToToks + , decorate -- * Spans -- , spanStartEnd @@ -746,6 +747,41 @@ -- |Add a constant line and column offset to a span of tokens addOffsetToToks :: (IsToken a) => SimpPos -> [a] -> [a] addOffsetToToks (r,c) toks = map (\t -> increaseSrcSpan (r,c) t) toks + +-- --------------------------------------------------------------------- + +-- Allocate all the tokens to the given tree +decorate :: (IsToken a) => LayoutTree a -> [a] -> LayoutTree a +decorate tree toks = go toks tree + where + go :: (IsToken a) => [a] -> LayoutTree a -> LayoutTree a + go ts (Node e subs) = r + where + -- b = map (\t -> let f = treeStartEnd t in (getLoc f, getLocEnd f)) subs + + doOne :: (IsToken a) => ([a],[LayoutTree a]) -> LayoutTree a -> ([a],[LayoutTree a]) + doOne (ts1,acc) tree1 = (ts1',acc') + where + ss = treeStartEnd tree1 + (before,middle,after) = splitToksIncComments (getLoc ss,getLocEnd ss) ts1 + ts1' = after + tree' = case tree1 of + Node (Entry ss1 lo []) [] -> [Node (Entry ss1 lo middle) []] + _ -> [go middle tree1] + acc' = acc ++ makeLeafFromToks before ++ tree' + + (end,subs') = foldl' doOne (ts,[]) subs + -- (end,subs') = doOne (ts,[]) (head subs) + subs'' = subs' ++ makeLeafFromToks end + r = case makeLeafFromToks end of + [] -> Node e subs' + trs -> Node (Entry (ss,se) NoChange []) (subs'++trs) + where + (ss,_) = treeStartEnd (ghead "decorate" subs') + (_,se) = treeStartEnd (glast "decorate" trs) + + -- go ts tr = error $ "decorate:not processing :" ++ show (ts,tr) + -- ---------------------------------------------------------------------