{-# LANGUAGE RecordWildCards, UnboxedTuples, PatternSynonyms #-}
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)
type DynPos = Code Base.Pos
data StaPos = StaPos {
StaPos -> Pos
dynPos :: !Pos,
StaPos -> Alignment
alignment :: !Alignment,
StaPos -> [StaChar]
contributing :: ![StaChar]
}
fromDynPos :: DynPos -> StaPos
fromDynPos :: DynPos -> StaPos
fromDynPos = Pos -> StaPos
mkStaPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynPos -> Pos
Dynamic
toDynPos :: StaPos -> DynPos
toDynPos :: StaPos -> DynPos
toDynPos = Pos -> DynPos
fromPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaPos -> Pos
collapse
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
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'||]
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 }
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
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
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
applyAlignment :: Alignment -> [Updater] -> [Updater]
applyAlignment :: Alignment -> [Updater] -> [Updater]
applyAlignment (Unaligned Word
n) (StaUpdater (OffsetAlignOffsetCol Word
firstBy Word
thenBy) : [Updater]
updaters) =
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)
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)
| Bool -> Bool
not Bool
keep, DynUpdater
NoNewlineUpdate <- DynUpdater
kind = ([Updater], Bool)
res
| Bool
otherwise = (DynUpdater -> Code Char -> Updater
DynUpdater DynUpdater
NoColUpdate Code Char
c forall a. a -> [a] -> [a]
: [Updater]
updaters, Bool
False)
g ([Updater]
updaters, Bool
_) updater :: Updater
updater@(StaUpdater OffsetLineAndSetCol{}) = (Updater
updater forall a. a -> [a] -> [a]
: [Updater]
updaters, Bool
False)
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