{-# LANGUAGE BangPatterns, RankNTypes, TypeFamilies, FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Lexer.Inchworm.Source
( Source (..), Location (..)
, Sequence (..)
, makeListSourceIO)
where
import Data.IORef
import qualified Data.List as List
import Prelude hiding (length)
class Sequence is where
type Elem is
length :: is -> Int
instance Sequence [a] where
type Elem [a] = a
length = List.length
data Source m loc input
= Source
{
sourceSkip :: (Elem input -> Bool) -> m ()
, sourceTry :: forall a. m (Maybe a) -> m (Maybe a)
, sourcePull :: (Elem input -> Bool)
-> m (Maybe (loc, Elem input))
, sourcePulls :: forall s
. Maybe Int
-> (Int -> Elem input -> s -> Maybe s)
-> s
-> m (Maybe (loc, input))
, sourceBumpLoc :: Elem input -> loc -> loc
, sourceRemaining :: m (loc, input)
}
makeListSourceIO
:: forall i loc
. Eq i
=> loc
-> (i -> loc -> loc)
-> [i]
-> IO (Source IO loc [i])
makeListSourceIO loc00 bumpLoc cs0
= do refLoc <- newIORef loc00
refSrc <- newIORef cs0
return
$ Source
(skipListSourceIO refLoc refSrc)
(tryListSourceIO refLoc refSrc)
(pullListSourceIO refLoc refSrc)
(pullsListSourceIO refLoc refSrc)
(bumpLoc)
(remainingSourceIO refLoc refSrc)
where
skipListSourceIO refLoc refSrc fPred
= do
loc0 <- readIORef refLoc
cc0 <- readIORef refSrc
let eat !loc !cc
= case cc of
[]
-> do writeIORef refLoc loc
writeIORef refSrc []
return ()
c : cs
| fPred c
-> eat (bumpLoc c loc) cs
| otherwise
-> do writeIORef refLoc loc
writeIORef refSrc (c : cs)
return ()
eat loc0 cc0
tryListSourceIO refLoc refSrc comp
= do loc <- readIORef refLoc
cc <- readIORef refSrc
mx <- comp
case mx of
Just i
-> return (Just i)
Nothing
-> do writeIORef refLoc loc
writeIORef refSrc cc
return Nothing
pullListSourceIO refLoc refSrc fPred
= do loc <- readIORef refLoc
cc <- readIORef refSrc
case cc of
[]
-> return Nothing
c : cs
| fPred c
-> do writeIORef refLoc (bumpLoc c loc)
writeIORef refSrc cs
return $ Just (loc, c)
| otherwise
-> return Nothing
pullsListSourceIO
:: IORef loc -> IORef [i]
-> Maybe Int -> (Int -> i -> s -> Maybe s)
-> s -> IO (Maybe (loc, [i]))
pullsListSourceIO refLoc refSrc mLenMax work s0
= do loc0 <- readIORef refLoc
cc0 <- readIORef refSrc
let eat !ix !(l :: loc) !cc !acc !s
| Just mx <- mLenMax
, ix >= mx
= return (ix, l, cc, reverse acc)
| otherwise
= case cc of
[]
-> return (ix, l, cc, reverse acc)
c : cs
-> case work ix c s of
Nothing -> return (ix, l, cc, reverse acc)
Just s' -> eat (ix + 1) (bumpLoc c l)
cs (c : acc) s'
(len, loc', cc', acc)
<- eat 0 loc0 cc0 [] s0
case len of
0 -> return Nothing
_ -> do writeIORef refLoc loc'
writeIORef refSrc cc'
return $ Just (loc0, acc)
remainingSourceIO
:: IORef loc -> IORef [i]
-> IO (loc, [i])
remainingSourceIO refLoc refSrc
= do loc <- readIORef refLoc
src <- readIORef refSrc
return (loc, src)
data Location
= Location
!Int
!Int
deriving Show
{-# SPECIALIZE INLINE
makeListSourceIO
:: Location
-> (Char -> Location -> Location)
-> [Char]
-> IO (Source IO Location [Char])
#-}