Loc.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}

module Descript.Misc.Build.Read.Parse.Loc
  ( RangeStream
  , runParserFR
  , ranged
  , expRanged
  , expRanged_
  , exactlyR
  , mapSatisfyR
  , rangeToPosStack
  , getLoc
  , posToLoc
  , locToPos
  ) where

import Descript.Misc.Loc
import Descript.Misc.Ann
import Text.Megaparsec hiding (parse)
import Core.Text.Megaparsec
import Core.Text.Megaparsec.Error
import Data.List
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import qualified Data.Text as Text

type RangeStream a = [a Range]

instance (Ann a, Ord (a Range)) => Stream (RangeStream a) where
  type Token (RangeStream a) = a Range
  type Tokens (RangeStream a) = [a Range]

  tokenToChunk _pxy x = [x]
  tokensToChunk _pxy = id
  chunkToTokens _pxy = id
  chunkLength _pxy = length
  chunkEmpty _pxy = null
  positionAt1 _pxy pos = rePos pos . start . getRange
  positionAtN _pxy pos [] = pos
  positionAtN _pxy pos (x : _) = rePos pos $ start $ getRange x
  advance1 _pxy _ pos = rePos pos . end . getRange
  advanceN _pxy _ pos [] = pos
  advanceN _pxy _ pos xs = rePos pos $ start $ getRange $ last xs
  take1_ = uncons
  takeN_ 0 [] = Just ([], [])
  takeN_ _ [] = Nothing
  takeN_ n xs = Just $ splitAt n xs
  takeWhile_ = span

-- | If the parser fails, converts the failure information back into
-- text using the given source so it can be displayed to the user.
runParserFR :: (Ord e, Ann i, Ord (i Range))
            => Parsec e (RangeStream i) o
            -> String
            -> Text
            -> RangeStream i
            -> Either (ParseError Char e) o
runParserFR parser filename source input
  = case runParserF parser filename input of
         Left err -> Left $ traverseErrorSource fixErrorSource err
         Right output -> Right output
  where fixErrorSource = Text.unpack . (`inText` source) . getRange

-- | All text consumed by the parser will be in the range.
ranged :: (MonadParsec e s m) => m (Range -> a) -> m a
ranged parse = do
  start' <- getLoc
  f <- parse
  end' <- getLoc
  let range
        = Range
          { start = start'
          , end = end'
          }
  pure $ f range

-- | The range will start where the parser starts, and have the given
-- length in columns and no length in lines.
expRanged :: (MonadParsec e s m)
          => Int -> m (Range -> a) -> m a
expRanged len parse = do
  start' <- getLoc
  f <- parse
  let range
        = Range
        { start = start'
        , end = start' `addCols` len
        }
  pure $ f range

-- | The range will start where the parser starts, and have the given
-- length in columns and no length in lines.
expRanged_ :: (MonadParsec e s m)
           => Int -> m () -> m Range
expRanged_ len = expRanged len . (id <$)

-- | Expects the input without the range to be the given value.
exactlyR :: (MonadParsec e s m, Functor a, Token s ~ a Range, Eq (a ()))
         => a () -> m ()
exactlyR = mapExactly remAnns . (singletonRange loc1 <$)

-- | Applies the function to the input without the range. If it
-- succeeds, returns the output. If it fails, returns an error
-- indicating that the input was unexpected.
mapSatisfyR :: (MonadParsec e s m, Functor a, Token s ~ a Range)
            => (a () -> Maybe b) -> m b
mapSatisfyR f = mapSatisfy $ f . remAnns

getLoc :: MonadParsec e s m => m Loc
getLoc = posToLoc <$> getPosition

-- | Converts a range to a stack of positions for a 'ParseError'.
-- The stack will have one item - the start of the range.
-- Uses the string for the filename.
rangeToPosStack :: String -> Range -> NonEmpty SourcePos
rangeToPosStack filename range = locToPos filename (start range) :| []

posToLoc :: SourcePos -> Loc
posToLoc pos
  = Loc
  { line = sourceLine pos
  , column = sourceColumn pos
  }

rePos :: SourcePos -> Loc -> SourcePos
rePos = locToPos . sourceName

locToPos :: String -> Loc -> SourcePos
locToPos filename loc
  = SourcePos
  { sourceName = filename
  , sourceLine = line loc
  , sourceColumn = column loc
  }

-- | Alias for 'getAnn' when dealing with a ranged value.
getRange :: (Ann a) => a Range -> Range
getRange = getAnn