----------------------------------------------------------------
-- Daan Leijen (c) 2001
--
-- $Revision$
-- $Author$
-- $Date$
----------------------------------------------------------------
module LvmLang( Bytes, Int, Float
              , Bool(..), '':[]''(..)
              , IO, Char, Double, PackedString, String

              , packedFromString, stringFromPacked, packedLength
              , bindIO, returnIO
              , primIO, unsafePerformIO, unsafePerformStrictIO
              ) where

{----------------------------------------------------------
  Instructions
----------------------------------------------------------}
instruction primAddInt  "addint" :: Int! -> Int! -> Int!
instruction primSubInt  "subint" :: Int! -> Int! -> Int!
instruction primMulInt  "mulint" :: Int! -> Int! -> Int!
instruction primDivInt  "divint" :: Int! -> Int! -> Int!
instruction primModInt  "modint" :: Int! -> Int! -> Int!
instruction primQuotInt "quotint":: Int! -> Int! -> Int!
instruction primRemInt  "remint" :: Int! -> Int! -> Int!
instruction primAndInt  "andint" :: Int! -> Int! -> Int!
instruction primXorInt  "xorint" :: Int! -> Int! -> Int!
instruction primOrInt   "orint"  :: Int! -> Int! -> Int!
instruction primShrInt  "shrint" :: Int! -> Int! -> Int!
instruction primShlInt  "shlint" :: Int! -> Int! -> Int!
instruction primShrNat  "shrnat" :: Int! -> Int! -> Int!
instruction primNegInt  "negint" :: Int! -> Int!

instruction primEqInt   "eqint"  :: Int! -> Int! -> Bool!
instruction primNeInt   "neint"  :: Int! -> Int! -> Bool!
instruction primLtInt   "ltint"  :: Int! -> Int! -> Bool!
instruction primGtInt   "gtint"  :: Int! -> Int! -> Bool!
instruction primLeInt   "leint"  :: Int! -> Int! -> Bool!
instruction primGeInt   "geint"  :: Int! -> Int! -> Bool!

instruction primAlloc   "alloc"  :: Int! {- tag -} -> Int! {- size -} -> a!
instruction primGetTag  "gettag" :: a! -> Int!
instruction primGetSize "getsize":: a! -> Int!
-- instruction primNew     "new"    :: Int! {- tag -} -> Int! {- size -} -> {- x_1 ... x_n -> -} a!
-- instruction primPack    "pack"   :: a! -> Int! {- size -} -> {- x_1 ... x_size -} ()
-- instruction primUnPack  "unpack" :: a! -> (# x_1 ... x_size #)


extern prim_chars_of_string :: "aa"
extern prim_string_of_chars :: "ala"
extern prim_string_length   :: "la"

{----------------------------------------------------------
  Basic data types
----------------------------------------------------------}
data Bytes
data Int
data Float
data Bool       = False -- tag 0
                | True  -- tag 1

{-
Be aware that de definition
data Bool       = True  -- tag 0
                | False -- tag 1
is not allowed because the instructions
eqint, neint etc. assume False has tag 0
and True has tag 1.
-}

data '':[]'' a  = '':[]'' | (:) a [a]

data IORes a    = IORes a
type IO a       = () -> IORes a

{----------------------------------------------------------
  Type definitions
----------------------------------------------------------}
type Char         = Int
type Double       = Float

type PackedString = Bytes
type String       = [Char]


{----------------------------------------------------------
  Strictness
----------------------------------------------------------}
($!) :: (a -> b) -> a -> b
($!) f x   = let! x = x in f x

seq :: a -> b -> b
seq x y    = let! x = x in y

{----------------------------------------------------------
  Basic arithmetic on Int's
----------------------------------------------------------}
(+) :: Int -> Int -> Int!
(+) x y    = let! y = y in let! x = x in primAddInt x y

(-) :: Int -> Int -> Int!
(-) x y    = let! y = y in let! x = x in primSubInt x y

(*) :: Int -> Int -> Int!
(*) x y    = let! y = y in let! x = x in primMulInt x y

(/) :: Int -> Int -> Int!
(/) x y    = let! y = y in let! x = x in primDivInt x y

(%) :: Int -> Int -> Int!
(%) x y    = let! y = y in let! x = x in primModInt x y

quot :: Int -> Int -> Int!
quot x y    = let! y = y in let! x = x in primQuotInt x y

rem :: Int -> Int -> Int!
rem x y    = let! y = y in let! x = x in primRemInt x y

and :: Int -> Int -> Int!
and x y    = let! y = y in let! x = x in primAndInt x y

xor :: Int -> Int -> Int!
xor x y    = let! y = y in let! x = x in primXorInt x y

or :: Int -> Int -> Int!
or x y    = let! y = y in let! x = x in primOrInt x y

shr :: Int -> Int -> Int!
shr x y    = let! y = y in let! x = x in primShrInt x y

shl :: Int -> Int -> Int!
shl x y    = let! y = y in let! x = x in primShlInt x y

shrNat :: Int -> Int -> Int!
shrNat x y = let! y = y in let! x = x in primShrNat x y

neg :: Int -> Int!
neg x      = let! x = x in primNegInt x

{----------------------------------------------------------
  Comparisons on Int's
----------------------------------------------------------}
(==) :: Int -> Int -> Bool!
(==) x y   = let! y = y in let! x = x in primEqInt x y

(/=) :: Int -> Int -> Bool!
(/=) x y   = let! y = y in let! x = x in primNeInt x y

(<) :: Int -> Int -> Bool!
(<) x y   = let! y = y in let! x = x in primLtInt x y

(>) :: Int -> Int -> Bool!
(>) x y   = let! y = y in let! x = x in primGtInt x y

(<=) :: Int -> Int -> Bool!
(<=) x y   = let! y = y in let! x = x in primLeInt x y

(>=) :: Int -> Int -> Bool!
(>=) x y   = let! y = y in let! x = x in primGeInt x y

{----------------------------------------------------------
  Boolean expressions
----------------------------------------------------------}
(&&) :: Bool -> Bool -> Bool
(&&) x y
  = case x of
      False   -> False
      True    -> y


(||) :: Bool -> Bool -> Bool
(||) x y
  = case x of
      True  -> True
      False -> y

not :: Bool -> Bool
not x
  = case x of
      True  -> False
      False -> True

{----------------------------------------------------------
  Packed strings
----------------------------------------------------------}
stringFromPacked :: PackedString -> String
stringFromPacked packed
  = let! packed = packed in prim_chars_of_string packed

packedFromString :: String -> PackedString
packedFromString s
  = let forceLength n xs = case xs of
                             (:) x xx -> seq x (forceLength ((+) n 1) xx)
                             []       -> n 
    in let! len = forceLength 0 s 
            s   = s 
       in prim_string_of_chars len s

packedLength :: PackedString -> Int
packedLength s
  = let! s = s in prim_string_length s

{----------------------------------------------------------
  List helpers
----------------------------------------------------------}
{-
length :: [a] -> Int
length xs
  = foldlStrict (+) 0 xs

foldlStrict :: (b -> a -> b) -> b -> [a] -> b
foldlStrict f z xs
  = case xs of
      (:) x xx -> case f z x of
                    z -> foldlStrict f z xx
      []       -> z
-}


{----------------------------------------------------------
  The IO monad
----------------------------------------------------------}
bindIO :: IO a -> (a -> IO b) -> IO b
bindIO io f
  = \_ -> case io () of
            IORes x -> f x ()

returnIO :: a -> IO a
returnIO x
  = \_ -> IORes x

primIO :: (() -> a) -> IO a
primIO f
  = \_ -> let! x = f () in IORes x

unsafePerformIO :: IO a -> a
unsafePerformIO io
  = case io () of
      IORes x -> x

-- used to execute "main"
unsafePerformStrictIO :: IO a -> a
unsafePerformStrictIO io
  = let! x = unsafePerformIO io in x