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)