module Data.ParserCombinators.Kangaroo.Region
(
RegionCoda(..)
, RegionStart
, RegionEnd
, RegionName
, Pos
, RegionInfo
, ParseStack
, RegionError(..)
, newStack
, newRegion
, regionStart
, regionEnd
, push
, pop
, move1
, move
, location
, printParseStack
) where
import Text.PrettyPrint.JoinPrint hiding ( length )
data RegionCoda = Dalpunto | Alfermata | Alfine
deriving (Enum,Eq,Show)
type RegionStart = Int
type RegionEnd = Int
type RegionName = String
type Pos = Int
data RegionInfo = RegionInfo
{ region_start_incl :: !RegionStart
, region_end_incl :: !RegionEnd
, region_coda :: !RegionCoda
, region_name :: !String
}
deriving (Eq,Show)
data ParseStack = P0 Pos RegionInfo | Pn Pos RegionInfo ParseStack
deriving (Eq,Show)
newtype RegionError = RegionError { getRegionError :: String }
deriving (Eq,Show)
mapTop :: (RegionInfo -> a) -> ParseStack -> a
mapTop f (P0 _ info) = f info
mapTop f (Pn _ info _) = f info
modifyPos :: (Pos -> Pos) -> ParseStack -> ParseStack
modifyPos f (P0 p info) = P0 (f p) info
modifyPos f (Pn p info stk) = Pn (f p) info stk
validBounds :: RegionStart -> RegionEnd -> ParseStack -> Bool
validBounds s e stk = s >= regionStart stk && e <= regionEnd stk
infos :: ParseStack -> [RegionInfo]
infos (P0 _ info) = [info]
infos (Pn _ info stk) = info : infos stk
regionError :: RegionName -> RegionStart -> RegionEnd -> ParseStack
-> RegionError
regionError nm s e stk = step (regionStart stk) (regionEnd stk)
where
step rs re | s < rs && e > re = mkMsg nm "past the bounds" (s,e) (rs,re)
| s < rs = mkMsg nm "past the left" (s,e) (rs,re)
| e > re = mkMsg nm "past the right" (s,e) (rs,re)
| otherwise = RegionError $
"regionError called on invalid data."
mkMsg :: RegionName -> String -> (Int,Int) -> (Int,Int) -> RegionError
mkMsg name descr new old = RegionError $
unwords [ "The new region"
, ('\'' : name ++ "'")
, show new
, "extends"
, descr
, "of the old region"
, show old
]
regionStart :: ParseStack -> Int
regionStart = mapTop region_start_incl
regionEnd :: ParseStack -> Int
regionEnd = mapTop region_end_incl
newStack :: RegionStart -> RegionEnd -> RegionCoda -> RegionName -> ParseStack
newStack s e coda name = P0 0 (RegionInfo s e coda name)
newRegion :: RegionStart -> Int -> RegionCoda -> RegionName -> RegionInfo
newRegion s len coda name = RegionInfo s (s+len1) coda name
push :: RegionInfo -> ParseStack -> Either RegionError ParseStack
push info@(RegionInfo s e _ name) stk
| validBounds s e stk = Right $ Pn s info stk
| otherwise = Left $ regionError name s e stk
pop :: ParseStack -> ParseStack
pop (P0 p info) = P0 p info
pop (Pn p info stk) = case region_coda info of
Dalpunto -> stk
Alfermata -> modifyPos (const p) stk
Alfine -> modifyPos (const $ region_end_incl info) stk
move1 :: ParseStack -> ParseStack
move1 = modifyPos (+1)
move :: (Pos -> Pos) -> ParseStack -> ParseStack
move = modifyPos
location :: ParseStack -> Int
location (P0 p _) = p
location (Pn p _ _) = p
printParseStack :: ParseStack -> String
printParseStack pstack = unlines $ map (render . fn) stk
where
stk = infos pstack
(w1,w4) = onSnd (length . show) $ foldr phi (0,0) stk
phi info (a,b) = (max a (length $ region_name info), max b $ region_end_incl info)
onSnd f (a,b) = (a, f b)
fn :: RegionInfo -> Doc
fn rgn = padl w1 ' ' (text $ region_name rgn)
<+> padl w4 ' ' (int $ region_start_incl rgn)
<+> padl w4 ' ' (int $ region_end_incl rgn)