{-# LANGUAGE RecordWildCards, UnboxedTuples, PatternSynonyms #-}
{-|
Module      : Parsley.Internal.Backend.Machine.Types.Input.Pos
Description : Packaging of offsets and positions.
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

This module contains the machinery for manipulating position information, both in static and dynamic
forms.

@since 2.1.0.0
-}
module Parsley.Internal.Backend.Machine.Types.Input.Pos (
    StaPos, DynPos,
    fromDynPos, toDynPos, fromStaPos,
    force, update
  ) where

import Data.Bits                               ((.|.))
import Data.List                               (foldl')
import Parsley.Internal.Common.Utils           (Code)
import Parsley.Internal.Core.CharPred          (CharPred, pattern Specific, apply)
import Parsley.Internal.Core.CombinatorAST     (PosSelector(..))
import Parsley.Internal.Backend.Machine.PosOps (liftPos)

import qualified Parsley.Internal.Backend.Machine.PosOps as Ops
import qualified Parsley.Internal.Backend.Machine.Types.Base as Base (Pos)

{-|
The type-alias for dynamic positions.

@since 2.1.0.0
-}
type DynPos = Code Base.Pos

{-|
Type that represents static positions and their associated data.

@since 2.1.0.0
-}
data StaPos = StaPos {
    StaPos -> Pos
dynPos :: !Pos,
    StaPos -> Alignment
alignment :: !Alignment,
    StaPos -> [StaChar]
contributing :: ![StaChar]
  }

{-|
Converts a dynamic position into an unannotated static one.

@since 2.1.0.0
-}
fromDynPos :: DynPos -> StaPos
fromDynPos :: DynPos -> StaPos
fromDynPos = Pos -> StaPos
mkStaPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynPos -> Pos
Dynamic

{-|
Forgets the static information found in a position and converts it into a dynamic one.

@since 2.1.0.0
-}
toDynPos :: StaPos -> DynPos
toDynPos :: StaPos -> DynPos
toDynPos = Pos -> DynPos
fromPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaPos -> Pos
collapse

{-|
Produce a static position from a given line and column pair.

@since 2.1.0.0
-}
fromStaPos :: (Word, Word) -> StaPos
fromStaPos :: (Word, Word) -> StaPos
fromStaPos = Pos -> StaPos
mkStaPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word -> Word -> Pos
Static

{-|
Given a static position, and a component to select, collapse the position down to its smallest form
(binding this to a let if necessary) and extract the desired component. The new, potentially rebound,
position is provided to the continuation too.

@since 2.1.0.0
-}
force :: StaPos -> PosSelector -> (Code Int -> StaPos -> Code r) -> Code r
force :: forall r.
StaPos -> PosSelector -> (Code Int -> StaPos -> Code r) -> Code r
force StaPos
p PosSelector
sel Code Int -> StaPos -> Code r
k
  | forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null (StaPos -> [StaChar]
contributing StaPos
p) = Code Int -> StaPos -> Code r
k (PosSelector -> Pos -> Code Int
extract PosSelector
sel (StaPos -> Pos
dynPos StaPos
p)) StaPos
p
  | Bool
otherwise = case StaPos -> Pos
collapse StaPos
p of
    p' :: Pos
p'@Static{} -> Code Int -> StaPos -> Code r
k (PosSelector -> Pos -> Code Int
extract PosSelector
sel Pos
p') (Pos -> StaPos
newPos Pos
p')
    Dynamic DynPos
qpos -> [||
        let pos = $$qpos
        in $$(k (extract sel (Dynamic [||pos||])) (newPos (Dynamic [||pos||])))
      ||]
  where
    newPos :: Pos -> StaPos
newPos Pos
pos = StaPos {
      dynPos :: Pos
dynPos = Pos
pos,
      alignment :: Alignment
alignment = [StaChar] -> Alignment -> Alignment
updateAlignment (StaPos -> [StaChar]
contributing StaPos
p) (StaPos -> Alignment
alignment StaPos
p),
      contributing :: [StaChar]
contributing = []
    }
    extract :: PosSelector -> Pos -> Code Int
extract PosSelector
Line (Dynamic DynPos
pos) = DynPos -> Code Int
Ops.extractLine DynPos
pos
    extract PosSelector
Line (Static Word
line Word
_) = let line' :: Int
line' = forall a. Enum a => a -> Int
fromEnum Word
line in [||line'||]
    extract PosSelector
Col (Dynamic DynPos
pos) = DynPos -> Code Int
Ops.extractCol DynPos
pos
    extract PosSelector
Col (Static Word
_ Word
col) = let col' :: Int
col' = forall a. Enum a => a -> Int
fromEnum Word
col in [||col'||]

{-|
Advance a static position accounting for the dynamic character that was last read and the
static predicate that guarded that read.

@since 2.1.0.0
-}
update :: StaPos -> Code Char -> CharPred -> StaPos
update :: StaPos -> Code Char -> CharPred -> StaPos
update StaPos
pos Code Char
c CharPred
p = StaPos
pos { contributing :: [StaChar]
contributing = Code Char -> CharPred -> StaChar
StaChar Code Char
c CharPred
p forall a. a -> [a] -> [a]
: StaPos -> [StaChar]
contributing StaPos
pos }

{-----------------}
{-   INTERNALS   -}
{-----------------}

-- Data

-- TODO: This could be more fine-grained, for instance a partially static position.
data Pos = Static {-# UNPACK #-} !Word {-# UNPACK #-} !Word | Dynamic !DynPos

data Alignment = Unknown | Unaligned {-# UNPACK #-} !Word

pattern Aligned :: Alignment
pattern $bAligned :: Alignment
$mAligned :: forall {r}. Alignment -> ((# #) -> r) -> ((# #) -> r) -> r
Aligned = Unaligned 0

data StaChar = StaChar {
    StaChar -> Code Char
char :: !(Code Char),
    StaChar -> CharPred
predicate :: !CharPred
  }

data CharClass = Tab | Newline | Regular | NonNewline

data Updater = DynUpdater !DynUpdater !(Code Char)
             | StaUpdater !StaUpdater

data StaUpdater = OffsetLineAndSetCol {-# UNPACK #-} !Word {-# UNPACK #-} !Word
                | OffsetCol {-# UNPACK #-} !Word
                | OffsetAlignOffsetCol {-# UNPACK #-} !Word {-# UNPACK #-} !Word

data DynUpdater = FullUpdate
                | NoNewlineUpdate
                | NoColUpdate

-- Functions

mkStaPos :: Pos -> StaPos
mkStaPos :: Pos -> StaPos
mkStaPos Pos
pos = StaPos { dynPos :: Pos
dynPos = Pos
pos, alignment :: Alignment
alignment = Pos -> Alignment
alignment Pos
pos, contributing :: [StaChar]
contributing = [] }
  where
    alignment :: Pos -> Alignment
alignment Dynamic{} = Alignment
Unknown
    alignment (Static Word
_ Word
col) = Word -> Alignment
Unaligned (Word
col forall a. Num a => a -> a -> a
- Word
1 forall a. Integral a => a -> a -> a
`mod` forall a. Num a => a
Ops.tabWidth)

fromPos :: Pos -> DynPos
fromPos :: Pos -> DynPos
fromPos (Static Word
l Word
c) = Word -> Word -> DynPos
liftPos Word
l Word
c
fromPos (Dynamic DynPos
p) = DynPos
p

updateAlignment :: [StaChar] -> Alignment -> Alignment
updateAlignment :: [StaChar] -> Alignment -> Alignment
updateAlignment [StaChar]
cs Alignment
a = forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe CharClass -> Alignment -> Alignment
updateAlignment' forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPred -> Maybe CharClass
knownChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaChar -> CharPred
predicate) Alignment
a [StaChar]
cs
  where
    updateAlignment' :: Maybe CharClass -> Alignment -> Alignment
updateAlignment' Maybe CharClass
Nothing           Alignment
_             = Alignment
Unknown
    updateAlignment' (Just CharClass
Regular)    (Unaligned Word
n) = Word -> Alignment
Unaligned (Word
n forall a. Num a => a -> a -> a
+ Word
1 forall a. Integral a => a -> a -> a
`mod` forall a. Num a => a
Ops.tabWidth)
    updateAlignment' (Just CharClass
Regular)    Alignment
Unknown       = Alignment
Unknown
    updateAlignment' (Just CharClass
NonNewline) Alignment
_             = Alignment
Unknown
    updateAlignment' Maybe CharClass
_                 Alignment
_             = Alignment
Aligned

collapse :: StaPos -> Pos
collapse :: StaPos -> Pos
collapse StaPos{[StaChar]
Alignment
Pos
contributing :: [StaChar]
alignment :: Alignment
dynPos :: Pos
contributing :: StaPos -> [StaChar]
alignment :: StaPos -> Alignment
dynPos :: StaPos -> Pos
..} = Pos -> [Updater] -> Pos
applyUpdaters Pos
dynPos (Alignment -> [StaChar] -> [Updater]
buildUpdaters Alignment
alignment [StaChar]
contributing)

updateTab :: Maybe StaUpdater -> StaUpdater
updateTab :: Maybe StaUpdater -> StaUpdater
updateTab Maybe StaUpdater
Nothing = Word -> Word -> StaUpdater
OffsetAlignOffsetCol Word
0 Word
0
updateTab (Just (OffsetLineAndSetCol Word
n Word
m)) = Word -> Word -> StaUpdater
OffsetLineAndSetCol Word
n (Word -> Word
Ops.toNextTab Word
m)
updateTab (Just (OffsetCol Word
n)) = Word -> Word -> StaUpdater
OffsetAlignOffsetCol Word
n Word
0
updateTab (Just (OffsetAlignOffsetCol Word
firstBy Word
thenBy)) = Word -> Word -> StaUpdater
OffsetAlignOffsetCol Word
firstBy (Word -> Word
toNextTabFromKnownAlignment Word
thenBy)

updateRegular :: Maybe StaUpdater -> StaUpdater
updateRegular :: Maybe StaUpdater -> StaUpdater
updateRegular Maybe StaUpdater
Nothing = Word -> StaUpdater
OffsetCol Word
1
updateRegular (Just (OffsetLineAndSetCol Word
n Word
m)) = Word -> Word -> StaUpdater
OffsetLineAndSetCol Word
n (Word
m forall a. Num a => a -> a -> a
+ Word
1)
updateRegular (Just (OffsetCol Word
n)) = Word -> StaUpdater
OffsetCol (Word
n forall a. Num a => a -> a -> a
+ Word
1)
updateRegular (Just (OffsetAlignOffsetCol Word
firstBy Word
thenBy)) = Word -> Word -> StaUpdater
OffsetAlignOffsetCol Word
firstBy (Word
thenBy forall a. Num a => a -> a -> a
+ Word
1)

updateNewline :: Maybe StaUpdater -> StaUpdater
updateNewline :: Maybe StaUpdater -> StaUpdater
updateNewline (Just (OffsetLineAndSetCol Word
n Word
_)) = Word -> Word -> StaUpdater
OffsetLineAndSetCol (Word
n forall a. Num a => a -> a -> a
+ Word
1) Word
1
updateNewline Maybe StaUpdater
_ = Word -> Word -> StaUpdater
OffsetLineAndSetCol Word
1 Word
1

toNextTabFromKnownAlignment :: Word -> Word
toNextTabFromKnownAlignment :: Word -> Word
toNextTabFromKnownAlignment Word
x = (Word
x forall a. Bits a => a -> a -> a
.|. forall a. Num a => a
Ops.tabWidth forall a. Num a => a -> a -> a
- Word
1) forall a. Num a => a -> a -> a
+ Word
1

{-| Takes the initial alignment and contributing characters and
    return the list of updaters (in order from left-to-right)
    that must be applied to update the position properly -}
buildUpdaters :: Alignment -> [StaChar] -> [Updater]
buildUpdaters :: Alignment -> [StaChar] -> [Updater]
buildUpdaters Alignment
alignment = Alignment -> [Updater] -> [Updater]
applyAlignment Alignment
alignment forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Updater] -> [Updater]
removeDeadUpdates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe StaUpdater -> [Updater] -> [Updater]
combine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StaChar
-> (Maybe StaUpdater, [Updater]) -> (Maybe StaUpdater, [Updater])
f (forall a. Maybe a
Nothing, [])
  where
    -- The known initial alignment can affect the /first/ updater
    applyAlignment :: Alignment -> [Updater] -> [Updater]
    applyAlignment :: Alignment -> [Updater] -> [Updater]
applyAlignment (Unaligned Word
n) (StaUpdater (OffsetAlignOffsetCol Word
firstBy Word
thenBy) : [Updater]
updaters) =
      -- We know what the current alignment boundary is, so can eliminate the Align
      let pre :: Word
pre = Word
n forall a. Num a => a -> a -> a
+ Word
firstBy
          nextTabIn :: Word
nextTabIn = Word -> Word
toNextTabFromKnownAlignment Word
pre
      in StaUpdater -> Updater
StaUpdater (Word -> StaUpdater
OffsetCol (Word
nextTabIn forall a. Num a => a -> a -> a
+ Word
thenBy)) forall a. a -> [a] -> [a]
: [Updater]
updaters
    applyAlignment Alignment
_ [Updater]
updaters = [Updater]
updaters

    combine :: Maybe StaUpdater -> [Updater] -> [Updater]
    combine :: Maybe StaUpdater -> [Updater] -> [Updater]
combine Maybe StaUpdater
Nothing [Updater]
updaters = [Updater]
updaters
    combine (Just StaUpdater
updater) [Updater]
updaters = StaUpdater -> Updater
StaUpdater StaUpdater
updater forall a. a -> [a] -> [a]
: [Updater]
updaters

    f :: StaChar -> (Maybe StaUpdater, [Updater]) -> (Maybe StaUpdater, [Updater])
    f :: StaChar
-> (Maybe StaUpdater, [Updater]) -> (Maybe StaUpdater, [Updater])
f StaChar{Code Char
CharPred
predicate :: CharPred
char :: Code Char
predicate :: StaChar -> CharPred
char :: StaChar -> Code Char
..} (Maybe StaUpdater
updater, [Updater]
updaters) =
      let charClass :: Maybe CharClass
charClass = CharPred -> Maybe CharClass
knownChar CharPred
predicate
      in case Maybe CharClass
charClass of
        Just CharClass
Tab        -> (forall a. a -> Maybe a
Just (Maybe StaUpdater -> StaUpdater
updateTab Maybe StaUpdater
updater), [Updater]
updaters)
        Just CharClass
Newline    -> (forall a. a -> Maybe a
Just (Maybe StaUpdater -> StaUpdater
updateNewline Maybe StaUpdater
updater), [Updater]
updaters)
        Just CharClass
Regular    -> (forall a. a -> Maybe a
Just (Maybe StaUpdater -> StaUpdater
updateRegular Maybe StaUpdater
updater), [Updater]
updaters)
        Just CharClass
NonNewline -> (forall a. Maybe a
Nothing, DynUpdater -> Code Char -> Updater
DynUpdater DynUpdater
NoNewlineUpdate Code Char
char forall a. a -> [a] -> [a]
: Maybe StaUpdater -> [Updater] -> [Updater]
combine Maybe StaUpdater
updater [Updater]
updaters)
        Maybe CharClass
_               -> (forall a. Maybe a
Nothing, DynUpdater -> Code Char -> Updater
DynUpdater DynUpdater
FullUpdate Code Char
char forall a. a -> [a] -> [a]
: Maybe StaUpdater -> [Updater] -> [Updater]
combine Maybe StaUpdater
updater [Updater]
updaters)

    -- This function should reverse the list, and also remove any redundant updaters:
    -- when a newline is known, any updater before it is only useful for the newlines.
    removeDeadUpdates :: [Updater] -> [Updater]
    removeDeadUpdates :: [Updater] -> [Updater]
removeDeadUpdates = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Updater], Bool) -> Updater -> ([Updater], Bool)
g ([], Bool
True)
      where
        g :: ([Updater], Bool) -> Updater -> ([Updater], Bool)
        g :: ([Updater], Bool) -> Updater -> ([Updater], Bool)
g res :: ([Updater], Bool)
res@([Updater]
updaters, Bool
keep) updater :: Updater
updater@(DynUpdater DynUpdater
kind Code Char
c)
          | Bool
keep                              = (Updater
updater forall a. a -> [a] -> [a]
: [Updater]
updaters, Bool
True)
          -- If we're dropping because of lines, then a dynamic update known not to affect lines isn't needed
          | Bool -> Bool
not Bool
keep, DynUpdater
NoNewlineUpdate <- DynUpdater
kind = ([Updater], Bool)
res
          -- If we're dropping because of lines, then we don't need column updates
          | Bool
otherwise                         = (DynUpdater -> Code Char -> Updater
DynUpdater DynUpdater
NoColUpdate Code Char
c forall a. a -> [a] -> [a]
: [Updater]
updaters, Bool
False)
        -- This is a line updater, no tab or regular updaters matter anymore
        g ([Updater]
updaters, Bool
_) updater :: Updater
updater@(StaUpdater OffsetLineAndSetCol{}) = (Updater
updater forall a. a -> [a] -> [a]
: [Updater]
updaters, Bool
False)
        -- This a static non-line related update, we can drop it if needed
        g res :: ([Updater], Bool)
res@([Updater]
updaters, Bool
keep) updater :: Updater
updater@StaUpdater{}
          | Bool
keep      = (Updater
updater forall a. a -> [a] -> [a]
: [Updater]
updaters, Bool
True)
          | Bool
otherwise = ([Updater], Bool)
res

applyUpdaters :: Pos -> [Updater] -> Pos
applyUpdaters :: Pos -> [Updater] -> Pos
applyUpdaters = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Pos -> Updater -> Pos
applyUpdater
  where
    applyUpdater :: Pos -> Updater -> Pos
applyUpdater (Static Word
line Word
_) (DynUpdater DynUpdater
NoColUpdate Code Char
c) = DynPos -> Pos
Dynamic (Code Char -> Word -> DynPos
Ops.updatePosNewlineOnly Code Char
c Word
line)
    applyUpdater (Dynamic DynPos
pos) (DynUpdater DynUpdater
NoColUpdate Code Char
c)   = DynPos -> Pos
Dynamic (Code Char -> DynPos -> DynPos
Ops.updatePosNewlineOnlyQ Code Char
c DynPos
pos)
    applyUpdater (Static Word
line Word
col) (DynUpdater DynUpdater
_ Code Char
c)         = DynPos -> Pos
Dynamic (Code Char -> Word -> Word -> DynPos
Ops.updatePos Code Char
c Word
line Word
col)
    applyUpdater (Dynamic DynPos
pos) (DynUpdater DynUpdater
_ Code Char
c)             = DynPos -> Pos
Dynamic (Code Char -> DynPos -> DynPos
Ops.updatePosQ Code Char
c DynPos
pos)
    applyUpdater Pos
pos (StaUpdater StaUpdater
updater)                   = Pos -> StaUpdater -> Pos
applyStaUpdater Pos
pos StaUpdater
updater

    applyStaUpdater :: Pos -> StaUpdater -> Pos
applyStaUpdater (Static Word
line Word
_)   (OffsetLineAndSetCol Word
n Word
m)             = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word -> Word -> Pos
Static forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word -> (Word, Word)
Ops.shiftLineAndSetCol Word
n Word
m Word
line
    applyStaUpdater (Static Word
line Word
col) (OffsetCol Word
n)                         = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word -> Word -> Pos
Static forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word -> (Word, Word)
Ops.shiftCol Word
n Word
line Word
col
    applyStaUpdater (Static Word
line Word
col) (OffsetAlignOffsetCol Word
firstBy Word
thenBy) = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word -> Word -> Pos
Static forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word -> Word -> (Word, Word)
Ops.shiftAlignAndShiftCol Word
firstBy Word
thenBy Word
line Word
col
    applyStaUpdater (Dynamic DynPos
pos)     (OffsetLineAndSetCol Word
n Word
m)             = DynPos -> Pos
Dynamic forall a b. (a -> b) -> a -> b
$ Word -> Word -> DynPos -> DynPos
Ops.shiftLineAndSetColQ Word
n Word
m DynPos
pos
    applyStaUpdater (Dynamic DynPos
pos)     (OffsetCol Word
n)                         = DynPos -> Pos
Dynamic forall a b. (a -> b) -> a -> b
$ Word -> DynPos -> DynPos
Ops.shiftColQ Word
n DynPos
pos
    applyStaUpdater (Dynamic DynPos
pos)     (OffsetAlignOffsetCol Word
firstBy Word
thenBy) = DynPos -> Pos
Dynamic forall a b. (a -> b) -> a -> b
$ Word -> Word -> DynPos -> DynPos
Ops.shiftAlignAndShiftColQ Word
firstBy Word
thenBy DynPos
pos

knownChar :: CharPred -> Maybe CharClass
knownChar :: CharPred -> Maybe CharClass
knownChar (Specific Char
'\t')         = forall a. a -> Maybe a
Just CharClass
Tab
knownChar (Specific Char
'\n')         = forall a. a -> Maybe a
Just CharClass
Newline
knownChar CharPred
p | Bool -> Bool
not (CharPred -> Char -> Bool
apply CharPred
p Char
'\n')  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not (CharPred -> Char -> Bool
apply CharPred
p Char
'\t') then CharClass
Regular else CharClass
NonNewline
knownChar CharPred
_                       = forall a. Maybe a
Nothing