-- {-# LANGUAGE DeriveFunctor #-} -- {-# LANGUAGE DeriveFoldable #-} -- {-# LANGUAGE DeriveTraversable #-} -- {-# LANGUAGE DeriveGeneric #-} -- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} -- {-# OPTIONS_GHC -cpp -DPiForallInstalled #-} -- {-# LANGUAGE TemplateHaskell #-} -- {-# LANGUAGE RecordWildCards #-} {-| Copyright : (c) Andreas Reuleaux 2015 - 2018 License : BSD2 Maintainer: Andreas Reuleaux <rx@a-rx.info> Stability : experimental Portability: non-portable decorate the syntax tree with exact position information, used subsequently to calculate token ranges, and allow for navigation in the white space aware syntax tree (in the token tree @'TT'@) by line column information -} module Decorate ( module Decorate -- , module Control.Exception -- , module Pire.Parser.Parser ) where import Control.Applicative import Control.Monad.State.Strict import Text.Trifecta hiding ((:@)) import qualified Data.Text as T import Data.Bitraversable -- import Data.Traversable import Text.Trifecta.Delta -- import Pire.Syntax.ConstructorNames (poorMansTraverse) import Syntax import Parser import Control.Lens import TT -- import Data.String.Utils -- import Data.Traversable -- import TT #ifdef DOCTEST -- for the doctests import NoPos import Parser import Parser_ import Wrap -- -- import ParseUtils import Text2String import Syntax import PrettyCommon (ppr) #endif -- addition of positions as Trifecta Deltas works, if we keep the -- last two (byte) components of Lines at 0 (ie. always use Lines _ _ 0 0) -- ie. given an initial position, as stored in the state, -- the new position is calculated as a result of (initial pos + shift by parsing) -- (in particular we don't have to split the String/T.Text by hand into lines, -- taking different line ending conventions into account etc.) {-- snippet Deco --} class Deco t where deco :: MonadState Delta m => t -> m (t, Delta) {-- /snippet Deco --} {-- snippet DecoString --} instance Deco String where deco s = do delta' <- get let (Lines l c _ _)= fromSuccess $ parseString ((many $ anyChar) >> position) delta' $ s put $ Lines l c 0 0 return (s, delta') {-- /snippet DecoString --} {-- snippet DecoText --} instance Deco T.Text where deco s = do delta' <- get let (Lines l c _ _) = fromSuccess $ parseString ((many $ anyChar) >> position) delta' $ T.unpack s put $ Lines l c 0 0 return (s, delta') {-- /snippet DecoText --} -- decorate exprs (decls, etc) with exact position info -- (relying on bitraversal, and on the fact the every token is recorded now -- with its textual repr) -- @decorate@ is just a shortcut for @evalState (bitraverse deco deco...)@, -- creates a tree of pairs -- (more fine grained than @(Pos ...)@ wrapped around only some of the exprs by the parser), -- and works after parsing as well -- >>> prettyPrint $ runState (bitraverse deco deco $ snd $ parse expr_ "f arg") $ beginning -- (Pair (Pair (Id ("f",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0))) (Pair (Id ("arg",Lines 0 2 0 0)) (Ws ("",Lines 0 5 0 0))),Lines 0 5 0 0) {-| decorate token trees with exact position info (relying on bitraversal, and on the fact the every token is recorded now with its textual repr), @'decorate' e delta@ is just a shortcut for @'evalState' ('bitraverse' 'deco' 'deco' e) delta@, creates a tree of pairs (more fine grained than @(Pos ...)@, wrapped around only some of the exprs by the parser), and works after parsing as well >>> ppr $ evalState (bitraverse deco deco $ snd $ parse expr_ "f arg") $ beginning Pair (Pair (Id ("f",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0))) (Pair (Id ("arg",Lines 0 2 0 0)) (Ws ("",Lines 0 5 0 0))) and works with String exprs as well >>> ppr $ evalState (bitraverse deco deco $ t2s $ snd $ parse expr_ "f arg") $ beginning Pair (Pair (Id ("f",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0))) (Pair (Id ("arg",Lines 0 2 0 0)) (Ws ("",Lines 0 5 0 0))) >>> ppr $ decorate (snd $ parse expr_ "\\ x . f a") $ beginning Node [Pair (Token ("\",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0)) ,Node [Pair (Binder ("x",Lines 0 3 0 0)) (Ws (" ",Lines 0 4 0 0))] ,Pair (Token (".",Lines 0 5 0 0)) (Ws (" ",Lines 0 6 0 0)) ,Abstract [("x",Lines 0 7 0 0)] (Scope (Pair (Pair (Id (F (Id ("f",Lines 0 8 0 0)))) (Ws (" ",Lines 0 9 0 0))) (Pair (Id (F (Id ("a",Lines 0 11 0 0)))) (Ws ("",Lines 0 12 0 0)))))] watch out however for /bound/ vars (they have no textual repr in the scope, and thus shift the result) >>> ppr $ decorate (snd $ parse expr_ "\\ x . x a") $ beginning Node [Pair (Token ("\",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0)) ,Node [Pair (Binder ("x",Lines 0 3 0 0)) (Ws (" ",Lines 0 4 0 0))] ,Pair (Token (".",Lines 0 5 0 0)) (Ws (" ",Lines 0 6 0 0)) ,Abstract [("x",Lines 0 7 0 0)] (Scope (Pair (Pair (Id (B 0)) (Ws (" ",Lines 0 8 0 0))) (Pair (Id (F (Id ("a",Lines 0 10 0 0)))) (Ws ("",Lines 0 11 0 0)))))] but get exact positions, even in the case of bound vars, w\/ the help of @'Wrap.wrap'@: >>> ppr $ decorate (wrap $ snd $ parse expr_ "\\ x . x a") $ beginning Node [Pair (Token ("\",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0)) ,Node [Pair (Binder ("x",Lines 0 3 0 0)) (Ws (" ",Lines 0 4 0 0))] ,Pair (Token (".",Lines 0 5 0 0)) (Ws (" ",Lines 0 6 0 0)) ,Abstract_ (Scope (Pair (Pair (Bnd ("x",Lines 0 7 0 0) (Id (B 0))) (Ws (" ",Lines 0 8 0 0))) (Pair (Id (F (Id ("a",Lines 0 10 0 0)))) (Ws ("",Lines 0 11 0 0)))))] -} -- works on exprs, decls, annots etc {-- snippet decorate --} decorate :: (Deco b, Deco a, Bitraversable t) => t a b -> Delta -> t (a, Delta) (b, Delta) decorate ex = evalState (bitraverse deco deco ex) {-- /snippet decorate --} -- can't bitraverse over modules (and thus make them Bitraversable), -- as ConstructorNames uses Sets, which are not Traversable: traversal requires an ordering -- workaround for modules thus: just use a triple (n-tuple) -- could maybe use the setTraversal as outlined in src/Pire/Syntax/ConstructorNames.hs -- (but don't need constructor names decorated with position info anyway) -- exampl (not a doctests: result too long) -- (silence $ runExceptT $ getModules ["samples"] "M") >>= return . decorateMsilly . nopos . last . fromRight' -- works (and interesting maybe for the record), but of no use, since position info makes sense -- only in syntax tree w/ white space -- decorateMsilly (Module nm imports decls constrs) = -- evalState ((,,,) <$> traverse deco nm -- <*> traverse (traverse deco) imports -- <*> traverse (bitraverse deco deco) decls -- <*> pure constrs) beginning1 -- exampl -- (silence $ runExceptT $ getModules_ ["samples"] "M") >>= return . decorateM . wrap . nopos . last . fromRight' -- fixed (emacs like) file pos convention, beginning1: the upper left corner is line 1, column 0 -- used initially, but unwieldy, as now we have to work with a huge tuple instead of a module -- just pair constructors w/ a dummy Delta's -- ie. don't care about that Delta -- (what should it mean, anyway: -- a constructor "Succ" eg, paired w/ a Delta, like so: ("Succ",Lines 0 0 0 0) ) -- but this makes it possible to apply the Module_ constructor in decorateM -- and not just the tupling (,,,,,,) as in decorateM' above decoWithDummy :: (Deco t, MonadState Delta m) => t -> m (t, Delta) decoWithDummy x = return (x, Lines 0 0 0 0) -- -------------------------------------------------- -- a variation of the above decorateM function: -- simpler in that everything is decorated just with dummy positions -- -- decoWithDummy' :: Monad m => t -> m (t, Delta) -- -- decoWithDummy' x = -- -- return (x, Lines 0 0 0 0) -- -- runIdentity (Module_ <$> traverse decoWithDummy' leadingWs -- -- <*> traverse decoWithDummy' mTok -- -- <*> traverse decoWithDummy' modnm -- -- <*> traverse decoWithDummy' whereTok -- -- <*> traverse (traverse decoWithDummy') mimports -- -- <*> traverse (bitraverse decoWithDummy' decoWithDummy') dcls -- -- <*> poorMansTraverse decoWithDummy' cs) -- -------------------------------------------------- -- get rid of these Delta's again -- maybe unDecorateM should go to its use site: Pretty/Modules.hs ie. ? -- it seems strange to import Refactor.Decorate there at least -- w/ Identity eg. -- undecorateM $ decorateM mm -- undecorateM (Module_ leadingWs mTok modnm whereTok mimports dcls cs) = -- (Module_ <$> traverse fst' leadingWs -- <*> traverse fst' mTok -- <*> traverse fst' modnm -- <*> traverse fst' whereTok -- <*> traverse (traverse fst') mimports -- <*> traverse (bitraverse fst' fst') dcls -- <*> poorMansTraverse fst' cs) -- where fst' = Identity . fst -- maybe use Delta (beginning, beginning1) as a variable (point free style) -- to take different line column number conventions into account -- something along the lines of -- (silence $ runExceptT $ getModules_ ["samples"] "M") >>= return . (\m -> decorateM' m beginning) . nopos . last . fromRight' -- (silence $ runExceptT $ getModules_ ["samples"] "M") >>= return . (\m -> decorateM' m beginning1) . nopos . last . fromRight'