module UU_Offside where import Prelude hiding (getLine) import UU_Parsing import StateParser import IOExts data Context s = Context Int Int s -- column, line, start symbol | NoContext newtype OffsideParser inp out s a = OP (AnaParser (Input inp (Context s)) out s a) instance (Symbol s, InputState state s, OutputState result) => Sequence (OffsideParser state result s) where OP p <*> OP q = OP (p <*> q) OP p <* OP q = OP (p <* q) OP p *> OP q = OP (p *> q) pSucceed x = OP (pSucceed x) pLow x = OP (pLow x) instance (Symbol s, InputState state s, OutputState result) => Alternative (OffsideParser state result s) where OP p <|> OP q = OP (p <|> q) pFail = OP pFail instance (Offside s ,Symbol s, InputState state s, OutputState result) => SymParser (OffsideParser state result s) s where pCostRange c a b = pOnside (pCostRange c a b) pCostSym c a b = pOnside (pCostSym c a b) getfirsts (OP p) = getfirsts p setfirsts e (OP p) = OP (setfirsts e p) instance (OutputState result,InputState state s,Symbol s) => SplitParser (OffsideParser state result s) where getzerop (OP p) = fmap OP (getzerop p) getonep (OP p) = fmap OP (getonep p) pOnside p = pOnside' False p pOnside' same p = OP (pMap' f p) where f state result = case firstSymbol state of Nothing -> (state,result) Just s -> let context = getState state; pred = if same then (<=) else (<) in if isOnside pred (getPos s) context then (state,result) else (markLine s state, offSideMessage s context result) offSideMessage s context = changeSteps (StRepair cost message ) where message = case context of NoContext -> systemerror "UU_Offside" "For some silly reason layout is inserted(this should not have happend)" Context c l r -> Msg ( "Extra indentation is inserted " ++ "\n?? because " ++ show s ++ " should be positioned right of column " ++ show c ++"." ++ "\n?? The enclosing layout context starts at " ++ show r , show s , EStr "extra indentation" ) cost = case context of NoContext -> systemerror "UU_Offside" "For some silly reason layout is inserted(this should not have happend)" Context c l r -> 2*(c - getCol s) +1 pGoOn :: (Offside s,InputState inp s,Symbol s , OutputState out) => OffsideParser inp out s () pGoOn = OP (pMap' f (pSucceed ())) where f state result = case firstSymbol state of Nothing -> (state,failStep result) Just s -> if sameColumn (getCol s) (getState state) then (markLine s state, result) else (state,failStep result) markLine s state = setLine (getLine s) state pWithContext explicit (OP p) = pOnside (pWrap' f p) where f instate result k = let oldcontext = getState instate newcontext | explicit = NoContext | otherwise = maybe NoContext makeContext (firstSymbol instate) newState = setState newcontext instate cont state = let result = k (setState oldcontext state) in if explicit then result else costStep 1 result in (newState,result,cont) makeContext s = case getPos s of (c,l) -> Context c l s costStep x = changeSteps cost where cost steps = case steps of Cost y rest -> Cost (x+y) steps NoMoreSteps _ -> Cost x steps _ -> steps failStep = changeSteps (StRepair 1000 (Msg ("","", (EOr [])))) isOnside pred (c,l) (Context col line _) = col `pred` c || line==l isOnside _ _ _ = True sameColumn c (Context col _ _ ) = c==col sameColumn _ _ = False firstSymbol inp = case splitStateE inp of Right' _ -> Nothing Left' s _ -> Just s setLine l = updateState setLine' where setLine' NoContext = NoContext setLine' (Context c _ s) = Context c l s updateState f (Input (inp,st)) = Input (inp,f st) setState x = updateState (const x) getState (Input (inp,st)) = st changeSteps f (steps) = (f steps) pWrap' :: OutputState out => (forall r . state s -> Result r s -> (state s -> Result r s) -> (state s, Result r s, state s -> Result r s) ) -> AnaParser state out s a -> AnaParser state out s a pWrap' f = pWrap f' f where f' acc state result k = let (stl, ar, str2rr) = f state result (val ((,) undefined) . k) in (stl, val (uncurry acc) ar, val snd .str2rr) pMap' :: OutputState out => (forall r . state s -> Result r s -> ( state s, Result r s)) -> AnaParser state out s a -> AnaParser state out s a pMap' f = pMap f' f where f' acc state result = let (ostate, result') = f state result in (ostate, val (uncurry acc) result') pBlock open sep close decl = open *> pWithContext True (pListSep_ng seps1 decl <* seps <* close) <|> pWithContext False (pListSep_ng (pGoOn <|> seps1) decl <* seps ) where seps1 = () <$ pList1_ng sep seps = () <$ pList_ng sep pBlock1 open sep close decl = open *> pWithContext True (pList1Sep_ng seps1 decl <* seps <* close) <|> pWithContext False (pList1Sep_ng (pGoOn <|> seps1) decl <* seps ) where seps1 = () <$ pList1_ng sep seps = () <$ pList_ng sep class Offside s where getPos :: s -> (Int,Int) getLine s = snd(getPos s) getCol s = fst(getPos s)