--------------------------------------------------------------------------------
-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file 
-- is distributed under the terms of the BSD3 License. For more information, 
-- see the file "LICENSE.txt", which is included in the distribution.
--------------------------------------------------------------------------------
--  $Id: Read.hs 291 2012-11-08 11:27:33Z heere112 $

module Lvm.Read (lvmReadFile, lvmRead) where

import Control.Monad
import Data.Array
import Lvm.Common.Byte hiding (readByteList)
import Lvm.Common.Id
import Lvm.Data
import Lvm.Instr.Data
import Prelude hiding (Read)
import qualified Lvm.Common.Byte as Byte

{--------------------------------------------------------------
  Magic numbers
--------------------------------------------------------------}
lvmMajor, lvmMinor :: Int
lvmMajor  = 15
lvmMinor  = 0

data Record v   = RecDecl       (Decl v)
                
                | RecName       Id
                | RecKind       Id
                | RecBytes      !Bytes
                | RecCode       ![Int]
                | RecModule     Id !Int !Int [Custom]
                | RecExternType !String
                | RecAnon       !DeclKind [Custom]
                
{--------------------------------------------------------------
  read an LVM file
--------------------------------------------------------------}

{-
test src
  = do{ path    <- getLvmPath
      ; source  <- searchPath path ".lvm" src
      ; mod     <- lvmReadFile source
      ; putDoc (modulePretty instrPretty mod)
      }  -}

lvmReadFile :: FilePath -> IO (Module v)
lvmReadFile fname
  = do{ bs <- Byte.readByteList fname
      ; ns <- newNameSupply
      ; return (lvmRead ns fname bs)
      }

lvmRead :: NameSupply -> FilePath -> [Byte] -> Module v
lvmRead = runRead readModule 

readModule :: Read v (Module v,[Record v])
readModule
  = do{ tag    <- readRaw
      ; readGuard (tag == recHeader) "readHeader" "magic number is incorrect"
      ; _len     <- readint
      ; total    <- readint
      ; lvmmajor <- readint
      ; lvmminor <- readint
      ; readGuard (lvmmajor == lvmMajor && lvmminor >= lvmMinor) "readHeader" ("incompatible lvm version " ++ show lvmmajor ++ "." ++ show lvmminor)
      ; count    <- readint
      ; _bcount  <- readint
      ; ~(x,major,minor)  <- readModuleIdx 
      ; recs   <- readRecords total [] 
      ; readGuard (count == length recs) "readModule" "incorrect record count"
      ; return (Module x major minor [d | RecDecl d <- filter isRecDecl recs],recs)
      }
  where
    isRecDecl (RecDecl _) = True
    isRecDecl _           = False

readRecords :: Int -> [Record v] -> Read v [Record v]
readRecords total acc
  = do{ x     <- readRaw
      ; len   <- readint
      ; if x == recFooter
         then do{ total' <- readint
                ; readGuard (total==total') "readRecords" "footer doesn't match with header"
                ; return (reverse acc)
                }
        else if isInt x
         then do{ let tag = decodeInt x 
                ; rec_ <- case tag of
                          0     -> readName len
                          1     -> readKind len
                          2     -> readBytes len
                          3     -> readCode len
                          4     -> readValue len
                          5     -> readCon len
                          6     -> readImport len
                          7     -> readModuleRec len
                          8     -> readExtern len
                          9     -> readExternType len
                          _ -> readError "readRecords" ("unknown standard record kind (" ++ show tag ++ ")")
                ; readRecords total (rec_:acc)
                }
         else do{ let idx = decodeIdx x
                ; rec_ <- readDeclCustom idx len 
                ; readRecords total (rec_:acc)
                }
      }


{--------------------------------------------------------------
  declarations
--------------------------------------------------------------}
readValue :: Int -> Read v (Record v)
readValue len
  = do{ x      <- readNameIdx "value"
      ; acc    <- readAccess
      ; arity  <- readint
      ; _      <- readEnclosing
      ; _      <- readIdx "code"
      ; customs<- readCustoms (len - 20)
      ; return (RecDecl (DeclAbstract x acc arity customs))
      }

readCon :: Int -> Read v (Record a)
readCon len
  = do{ x     <- readNameIdx "constructor"
      ; acc   <- readAccess
      ; arity <- readint
      ; tag   <- readint
      ; customs <- readCustoms (len - 16)
      ; return (RecDecl (DeclCon x acc arity tag customs))
      }

readImport :: Int -> Read v (Record v1)
readImport len
  = do{ x     <- readNameIdx "import"
      ; flags <- readint
      ; ~(modid,major,minor) <- readModuleIdx
      ; impid <- readNameIdx "imported"
      ; kind  <- readKindIdx
      ; customs <- readCustoms (len - 20)
      ; return (RecDecl (DeclImport x (Imported (odd flags) modid impid kind major minor) customs))
      }

readKindIdx :: Read v DeclKind
readKindIdx
  = do{ xkind <- readRaw
      ; if isInt xkind
         then return (toEnum (decodeInt xkind))
         else do{ kindid <- resolveKindIdx (decodeIdx xkind)
                ; return (DeclKindCustom kindid)
                }
      }
readModuleRec :: Int -> Read v (Record a)
readModuleRec len
  = do{ x     <- readNameIdx "module"
      ; major <- readint
      ; minor <- readint
      ; customs <- readCustoms (len - 12)
      ; return (RecModule x major minor customs)
      }

readDeclCustom :: Index -> Int -> Read v (Record v)
readDeclCustom kindIdx len
  = do{ kindid  <- resolveKindIdx kindIdx
      ; mbId    <- readCustomNameIdx
      ; case mbId of
          Just x   -> do{ acc     <- readAccess
                        ; customs <- readCustoms (len-8)
                        ; return (RecDecl (DeclCustom x acc (DeclKindCustom kindid) customs))
                        }
          Nothing  -> do{ customs <- readCustoms (len-4)
                        ; return (RecAnon (DeclKindCustom kindid) customs)
                        }
      }

readExtern :: Int -> Read v (Record v)
readExtern len
  = do{ x     <- readNameIdx "extern"
      ; acc   <- readAccess
      ; arity <- readint
      ; tp    <- readExternTypeIdx
      ; libname <- readNameStringIdx
      ; xname <- readRaw 
      ; mode  <- readint
      ; link  <- readint
      ; call  <- readint
      ; customs <- readCustoms (len - 9*4)
      ; name  <- case mode of
                   1  -> fmap Decorate  (readNameString (decodeIdx xname))
                   2  -> return (Ordinal (decodeInt xname))
                   _  -> fmap Plain     (readNameString (decodeIdx xname))
      ; let linkMode = case link of
                         1 -> LinkDynamic
                         2 -> LinkRuntime
                         _ -> LinkStatic
            callMode = case call of
                         1 -> CallStd
                         2 -> CallInstr
                         _ -> CallC
      ; return (RecDecl (DeclExtern x acc arity tp linkMode callMode libname name customs))
      }
                   
{--------------------------------------------------------------
  constants
--------------------------------------------------------------}
readCode :: Int -> Read v (Record v)
readCode len
  = do{ ints   <- mapM (const readRaw) [1..div len 4]
      ; return (RecCode ints)
      }

readName :: Int -> Read v (Record v)
readName len
  = do{ bs <- readByteSeq len
      ; return (RecName (idFromString (stringFromByteList bs)))
      }

readKind :: Int -> Read v (Record v)
readKind len
  = do{ bs <- readByteSeq len
      ; return (RecKind (idFromString (stringFromByteList bs)))
      }

readBytes :: Int -> Read v (Record v)
readBytes len
  = do{ bs <- readByteSeq len
      ; return (RecBytes (bytesFromByteList bs))
      }

readExternType :: Int -> Read v (Record a)
readExternType len
  = do{ bs <- readByteSeq len
      ; return (RecExternType (stringFromByteList bs))
      }

readByteSeq :: Int -> Read v [Byte]
readByteSeq len
  = do{ blen <- readint
      ; bs   <- readByteList blen
      ; skip (len - 4 - blen)      
      ; return bs
      }

readCustoms :: Int -> Read v [Custom]
readCustoms len
  = mapM (const readCustom) [1..div len 4]
    
readAccess :: Read v Access
readAccess
  = do{ flags <- readint
      ; return (Defined (odd flags))
      }

readCustom :: Read v Custom
readCustom
  = do{ x <- readRaw
      ; if isInt x
         then return (CustomInt (decodeInt x))
        else if decodeIdx x == 0
         then return CustomNothing
         else resolve (decodeIdx x) recToCustom
      }
  where
    recToCustom rec_
      = case rec_ of
          RecName x         -> CustomName x
          RecBytes bs       -> CustomBytes bs
          RecDecl d         -> CustomLink (declName d) (declKindFromDecl d)
          RecAnon kind cs   -> CustomDecl kind cs
          _                 -> error "LvmRead.readCustom: invalid link"


{--------------------------------------------------------------
  indices
--------------------------------------------------------------}
readNameIdx :: String -> Read v Id
readNameIdx parent
  = do{ idx <- readIdx (parent ++ ".name")
      ; if idx == 0
         then readFreshId
         else resolve idx (\rec_ -> case rec_ of 
                              RecName x  -> x
                              _          -> error "LvmRead.readName: invalid name index")
      }

readCustomNameIdx :: Read v (Maybe Id)
readCustomNameIdx
  = do{ idx <- readIdx "custom name"
      ; if idx==0
         then return Nothing
         else do{ x1 <- resolve idx (\rec_ -> case rec_ of 
                                               RecName x2  -> x2
                                               _       -> error "LvmRead.readCustomNameIdx: invalid name index")
                ; return (Just x1)
                }
      }

resolveKindIdx :: Index -> Read v Id
resolveKindIdx idx
  = resolve idx (\rec_ -> case rec_ of 
                          RecKind x  -> x
                          _       -> error "LvmRead.resolveKindIdx: invalid kind index")

readModuleIdx :: Read v (Id, Int, Int)
readModuleIdx 
  = do{ idx <- readIdx "module descriptor"
      ; resolve idx (\rec_ -> case rec_ of
                               RecModule modid major minor _ -> (modid,major,minor)
                               _ -> error "LvmRead.readModule: invalid module index")
      }

readExternTypeIdx :: Read v String
readExternTypeIdx
  = do{ idx <- readIdx "extern type"
      ; resolve idx (\rec_ -> case rec_ of
                               RecExternType tp -> tp
                               _  -> error "LvmRead.readExternType: invalid extern type index")
      }

readNameStringIdx :: Read v String
readNameStringIdx
  = do{ idx <- readIdx "name string"
      ; readNameString idx
      }

readNameString :: Int -> Read v String
readNameString idx 
  = resolve idx (\rec_ -> case rec_ of
                           RecName x    -> stringFromId x
                           RecBytes bs  -> stringFromBytes bs
                           _  -> error "LvmRead.readNameString: invalid name index")

readEnclosing :: Read a (Maybe Id)
readEnclosing
  = do{ idx  <- readIdx "enclosing"
      ; if idx == 0
          then return Nothing
          else resolve idx (\rec_ -> case rec_ of
                                     RecDecl d  | isDeclValue d || isDeclAbstract d -> Just (declName d)
                                     _            -> error "readEnclosing" "invalid enclosing index"
                          )
      }



readint :: Read v Int
readint 
  = do{ i <- readRaw
      ; readGuard (isInt i) "readint" "expecting integer but found index"
      ; return (decodeInt i)
      }
readIdx :: String -> Read v Int
readIdx name
  = do{ i <- readRaw
      ; readGuard (isIdx i) "readIdx" ("expecting index but found integer (" ++ name ++ ")")
      ; return (decodeIdx i)
      }

isInt, isIdx :: Int -> Bool
isInt = odd
isIdx = even

decodeInt, decodeIdx :: Int -> Int
decodeInt i = (i-1) `div` 2
decodeIdx i = i `div` 2

{--------------------------------------------------------------
  Reader monad.
  Note the lazy recursive definition, where resolving
  and reading is done in a single pass (using delayed 
  computations).
--------------------------------------------------------------}
newtype Read v a  = Read (Env v -> State -> Result a)
type    Records v = Array Int (Record v)
data    Result a  = Result a !State
data    Env v     = Env   !FilePath (Records v)
data    State     = State ![Byte] !NameSupply

unRead :: Read a b -> Env a -> State -> Result b
unRead (Read r)   = r

runRead :: Read v (a,[Record v]) -> NameSupply -> FilePath -> [Byte]-> a
runRead (Read r) ns fname bs
  = let (Result (x,rs) _) = r (Env fname (listArray (1,length rs) rs)) (State bs ns)
    in x

instance Functor (Read v) where
  fmap f (Read r) = Read (\env st1 -> case r env st1 of
                                        Result x st2 -> Result (f x) st2)
instance Monad (Read v) where
  return x        = Read (\_  bs -> Result x bs)
  (Read r) >>= f  = Read (\rs bs -> case r rs bs of
                                      Result x bsx -> unRead (f x) rs bsx) 


readRaw :: Read v Int
readRaw 
  = Read (\_ (State bs ns) -> case int32FromByteList bs of (i,cs) -> Result i (State cs ns))

readByteList :: Int -> Read v [Byte]
readByteList n
  = Read (\_ (State bs ns) -> case splitAt n bs of (xs,cs) -> Result xs (State cs ns))

skip :: Int -> Read v ()
skip n
  = Read (\_ (State bs ns) -> Result () (State (drop n bs) ns))

readFreshId :: Read v Id
readFreshId
  = Read (\_ (State bs ns) -> let (x,ns') = freshId ns in Result x (State bs ns'))
  
readGuard :: Bool -> String -> String -> Read v ()
readGuard test fun = unless test . readError fun

readError :: String -> String -> Read v a
readError fun msg
  = Read (\(Env fname _) _ -> error ("LvmRead." ++ fun ++ ": \"" ++ fname ++ "\"\n  " ++ msg))

resolve :: Int -> (Record v -> a) -> Read v a
resolve idx f
  = Read (\(Env _ rs) st -> Result (f (rs ! idx)) st)