-- | PNM file parser
{-# LANGUAGE DeriveFunctor #-}
module PNMparser(parsePNM) where
--import Control.Applicative
import Control.Monad(ap)
import PNM
import Data.Char(isSpace)

default (Int)

-- | A monad with state and error handling used for parsing
newtype S e s a = S {unS::S' e s a} deriving Functor
type S' e s a = s -> (Either e a,s)

instance Applicative (S e s) where
  pure a = S (unit a)
    where unit a = \s -> (Right a,s)
  (<*>) = ap

instance Monad (S e s) where
  return = pure

  S m >>= f = S (m $> (unS . f))
    where
      (f $> g) s = case f s of
                     (Right a,s) -> g a s
                     (Left e,s) -> (Left e,s)

fail' =  S (\s -> (Left s,s))
    
run f = fst . unS f

--fm `ap` xm = fm >>= \ f -> xm >>= \ x -> pure (f x)

skipSpace = dropWhile isSpace

takeWord l = get [] $ skipSpace l where
  get a [] = (reverse a,[])
  get a (x:xs) = if x == '#' then get a $ drop 1 $ dropWhile (/='\n') xs
                 else if isSpace x then (reverse a,xs)
		      else get (x:a) xs

getWord = S getWord'
getWord' l = let (w,rest) = takeWord l in (if null w then Left "EOF!"
						    else Right w,rest)

getRest = S getRest'
getRest' l = (Right l,[])

getRaw :: Int -> S e String [Int]
getRaw maxval =  group.map fromEnum <$> getRest
  where
    group = if maxval<256 then id else groupBigEndian
    groupBigEndian (hi:lo:rest) = 256*hi+lo:groupBigEndian rest
    groupBigEndian _ = []

getAscii = map read.words <$> getRest  -- !! read can fail
 
parsePNM :: String -> Either String PNM
parsePNM = 
    run (getWord >>= \fmt ->
         (unpadPNM `oo` PNM) <$> getSize <*> parseBody fmt)

parseBody fmt =
  case fmt of
    "P1" -> parsePBM getBits
    "P2" -> parsePGM (const getAscii)
    "P3" -> parsePPM (const getAscii)
    "P4" -> parsePBM getRawBits
    "P5" -> parsePGM getRaw
    "P6" -> parsePPM getRaw
    _    -> fail'

parsePPM get=
     getInt >>= \ maxval -> PPM maxval <$> getRGBs maxval
  where
     getRGBs maxval = groupWith3 RGB <$> get maxval

parsePGM get = getInt >>= \ maxval -> PGM maxval <$> get maxval

parsePBM get = PBM <$> get

getBits =  (\grays -> [g/=0 | g<-grays]) <$> getAscii

getRawBits =
     (\bytes -> [bit | byte<-bytes, bit<-explode byte]) <$> getRaw 1

explode = reverse.take 8.expl
  where expl n = odd n:expl (n `quot` 2)

getSize = (,) <$> getInt <*> getInt

getInt = getWord >>= \w -> 
           case reads w of
		(i,_):_ -> pure i
		_ -> fail'

unpadPNM (PNM s@(w,_) (PBM bits)) | w>0 =
   PNM s (PBM (unpad w (((w+7) `quot` 8)*8) bits))
unpadPNM pnm = pnm

unpad t d [] = []
unpad t d xs = take t xs++unpad t d (drop d xs)

groupWith3 f (x1:x2:x3:xs) = f x1 x2 x3:groupWith3 f xs
groupWith3 _ _ = []

(f `oo` g) x y = f (g x y)