HeliumLang.core

{- The (type) constructors and functions in this module are
   used in the translation of language constructs.
-} 

module HeliumLang
    ( Bool(True, False), '':[]''('':[]'', (:)), '':()''('':()''), '':->''
    , String, Int, Float, IO, Char
    
    , showFunction, showIO, showPolymorphic
    , showChar, showString, showInt, showList, showBool, showUnit, showFloat  
    , showTuple2, showTuple3, showTuple4, showTuple5, showTuple6, showTuple7
    , showTuple8, showTuple9, showTuple10   
	
    , ''$primPutChar'', ''$primPutStr'', ''$primPutStrLn''
    , ''$primBindIO'', ''$primUnsafePerformIO''
    , ''$primErrorPacked'', ''$primPatternFailPacked''
    , ''$primNegInt'', ''$primNegFloat'', ''$primStringToFloat'', ''$primEqFloat''
    , ''$primConcat'', ''$primConcatMap''
    , ''$primPackedToString''

    , ''$negate'', ''$floatUnaryMinus''
    , ''$enumFrom'', ''$enumFromThen'', ''$enumFromTo'', ''$enumFromThenTo''
    , ''$show'' , ''$showList''
    ) where

import LvmLang 
    ( Int(), Float(), IO()
    , custom "typedecl" String
    , Bool(True, False)
    , '':[]''('':[]'', (:))
    , '':()''('':()'')
    , ''$primBindIO'' = bindIO, ''$primReturnIO'' = returnIO
    , negInt 
    , negFloat, ''$primEqFloat'' = (==.)
    , (+), (-), (>), (<), (>=), quot, rem, (==)
    , stringFromPacked
    , unsafePerformIO
    )
import LvmIO
    ( stdin, stdout, stderr, flush, outputChar, outputPacked
    )
import LvmException
    (   errorPacked
    ,   patternFailPacked
    )

{----------------------------------------------------------
  Fixities
----------------------------------------------------------}
custom infix (:) : public [5,"right"]

{--------------------------------------------------------------------------
  built into the language
--------------------------------------------------------------------------}
''$negate'' :: Int -> Int
''$negate'' i = negInt i

''$floatUnaryMinus'' :: Float -> Float
''$floatUnaryMinus'' f = ''$primNegFloat'' f

''$show'' :: "showDict -> a -> String"
''$show'' dShow
   = errorPacked "internal error: show called in the simple prelude!"

''$showList'' :: "(a -> String) -> [a] -> String"
''$showList'' = showList

-- the enumeration functions are used in the translation of the .. notation
-- [1..10]   === enumFromTo 1 10
-- [1..]     === enumFrom 1 
-- [1,3..10] === enumFromThenTo 1 3 10
-- [1,3..]   === enumFromThen 1 3

''$enumFrom'' :: Int -> [Int]
''$enumFrom'' n = (:) n (''$enumFrom'' ((+) n 1))

''$enumFromTo'' :: Int -> Int -> [Int]
''$enumFromTo'' n m =
    case (>) n m of
    {   True -> []
    ;   _    -> (:) n (''$enumFromTo'' ((+) n 1) m)
    }

''$enumFromThen'' :: Int -> Int -> [Int]
''$enumFromThen'' n a = (:) n (''$enumFromThen'' a ((+) a ((-) a n)))

''$enumFromThenTo'' :: Int -> Int -> Int -> [Int]
''$enumFromThenTo'' n a m =
    case (>) a n of
    {   True -> ''$primAscendToWithStep'' n m ((-) a n) 
    ;   _    -> ''$primDescendToWithStep'' n m ((-) a n) 
    }

{----------------------------------------------------------
  Basic data types
----------------------------------------------------------}
data '':->'' x y
-- Daan has type Char = Int
data Char

''$primPackedToString'' :: PackedString -> String
''$primPackedToString'' p
  = stringFromPacked p

''$primUnsafePerformIO'' :: IO a -> a
''$primUnsafePerformIO'' io
  = unsafePerformIO io

''$primPatternFailPacked'' :: PackedString -> a
''$primPatternFailPacked'' p
  = patternFailPacked p

''$primErrorPacked'' :: PackedString -> a
''$primErrorPacked'' p
  = errorPacked p

    
''$primPutChar'' :: Char -> IO ()
''$primPutChar'' c = 
    ''$primBindIO'' 
        (outputChar stdout c) 
        (flush stdout)
        
''$primPutChars'' :: String -> IO ()
''$primPutChars'' xs = 
    case xs of {
        '':[]''  -> ''$primReturnIO'' '':()'' ;
        (:) y ys -> ''$primBindIO'' 
                        (''$primPutChar'' y) -- if you don't want to flush each character: (outputChar stdout y) 
                        (''$primPutChars'' ys) }

''$primPutStr'' :: String -> IO ()
''$primPutStr'' xs = 
    ''$primBindIO'' 
        (''$primPutChars'' xs) 
        (flush stdout)

''$primPutStrLn'' :: String -> IO ()
''$primPutStrLn'' xs = 
    ''$primBindIO''  
        (''$primPutChars'' xs) 
        (''$primPutChar'' '\n') -- does the flush
        
''$primNegInt''   :: Int -> Int!
''$primNegInt''   = negInt

''$primConcat'' :: [[a]] -> [a]
''$primConcat'' xss =
    case xss of 
    {   '':[]'' -> []
    ;   (:) ys yss -> ''$primAppend'' ys (''$primConcat'' yss)
    }

''$primConcatMap'' :: (a -> [b]) -> [a] -> [b]
''$primConcatMap'' f xs =
    case xs of 
    {   '':[]''  -> []
    ;   (:) y ys -> ''$primAppend'' (f y) (''$primConcatMap'' f ys)
    }
    
''$primAppend'' :: [a] -> [a] -> [a] -- is '++'
''$primAppend'' xs ys =
    case xs of 
    {   '':[]'' -> ys
    ;   (:) z zs -> (:) z (''$primAppend'' zs ys)
    }

    
''$primAscendToWithStep'' :: Int -> Int -> Int -> [Int]
''$primAscendToWithStep'' n m step = 
    case (>) n m of 
    {   True -> []
    ;   _    -> (:) n (''$primAscendToWithStep'' ((+) n step) m step)
    }
    

''$primDescendToWithStep'' :: Int -> Int -> Int -> [Int]
''$primDescendToWithStep'' n m step = 
    case (<) n m of 
    {   True -> []
    ;   _    -> (:) n (''$primDescendToWithStep'' ((+) n step) m step)
    }


-- Show

showBool :: Bool -> String
showBool b = 
    case b of
    {   True -> stringFromPacked "True"
    ;   _    -> stringFromPacked "False"
    }

showUnit :: () -> String
showUnit u = 
    case u of
    {   '':()'' -> stringFromPacked "()"
    }

showFunction :: (a -> String) -> (b -> String) -> (a->b) -> String
showFunction a b x = let! x = x in stringFromPacked "<<function>>"

showIO :: (a -> String) -> IO a -> String
showIO a x = let! x = x in stringFromPacked "<<IO action>>"

showChar :: Char -> String
showChar c = 
    (:) '\'' (''$primAppend'' (safeShowChar True c) 
                         [ '\'' ])

safeShowChar :: Bool -> Char -> String
safeShowChar inChar c = 
    case c of
    { '\a' -> stringFromPacked "\\a"
    ; '\b' -> stringFromPacked "\\b"
    ; '\f' -> stringFromPacked "\\f"
    ; '\n' -> stringFromPacked "\\n"
    ; '\r' -> stringFromPacked "\\r"
    ; '\t' -> stringFromPacked "\\t"
    ; '\\' -> stringFromPacked "\\\\"
    ; '\'' -> case inChar of { True -> stringFromPacked "\\'"
                             ; _    -> [c]
                             }
    ; '\"' -> case inChar of { True -> [c]
                             ; _    -> stringFromPacked "\\\""
                             }
    ; _    -> 
        case logicalAnd ((>=) c 32) ((<) c 127) of
        {   True -> [c]
        ;   _    -> (:) '\\' (showInt c)
        }
    }
            
logicalAnd :: Bool -> Bool -> Bool
logicalAnd b1 b2 =
    case b1 of
    {   True -> b2
    ;   _    -> False
    }

showString :: String -> String
showString s = 
    (:) '\"' (''$primAppend'' (''$primConcatMap'' (safeShowChar False) s) 
                         (stringFromPacked "\""))

showInt :: Int -> String
showInt n = 
    case (<) n 0 of
    {   True -> (:) '(' ((:) '-' 
                    (''$primAppend'' 
                        (showPositiveInt (''$primNegInt'' n)) 
                        (stringFromPacked ")")
                    ))
    ;   _ -> showPositiveInt n
    } 

showPositiveInt :: Int -> String
showPositiveInt i =
    let 
        rest = quot i 10
        digit = [ (+) '0' (rem i 10) ]
    in 
        case (==) rest 0 of
        {   True -> digit 
        ;   _    -> ''$primAppend'' (showPositiveInt rest) digit
        }

showList :: (a -> String) -> [a] -> String
showList showElem list =
    ''$primConcat'' [ ['['], commaList (''$primMap'' showElem list), [']'] ] 
    
''$primMap'' f xs =
    case xs of
    {   '':[]'' -> []
    ;   (:) y ys -> (:) (f y) (''$primMap'' f ys)
    }
    
showPolymorphic :: a -> String
showPolymorphic x = 
    let! x = x in stringFromPacked "<<polymorphic value>>"

showTuple2 s1 s2 t : public [custom "type" ["(a -> String) -> (b -> String) -> (a, b) -> String" ]] =
    case t of
        (@0, 2) x1 x2 -> 
            showTupleList [ s1 x1, s2 x2 ]

showTuple3 s1 s2 s3 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (a, b, c) -> String" ]] =
    case t of
        (@0, 3) x1 x2 x3 ->
            showTupleList [ s1 x1, s2 x2, s3 x3 ]

showTuple4 s1 s2 s3 s4 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (d -> String) -> (a, b, c, d) -> String" ]] =
    case t of
        (@0, 4) x1 x2 x3 x4 ->
            showTupleList [ s1 x1, s2 x2, s3 x3, s4 x4 ]

showTuple5 s1 s2 s3 s4 s5 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (d -> String) -> (e -> String) -> (a, b, c, d, e) -> String" ]] =
    case t of
        (@0, 5) x1 x2 x3 x4 x5 ->
            showTupleList [ s1 x1, s2 x2, s3 x3, s4 x4, s5 x5 ]

showTuple6 s1 s2 s3 s4 s5 s6 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (d -> String) -> (e -> String) -> (f -> String) -> (a, b, c, d, e, f) -> String" ]] =
    case t of
        (@0, 6) x1 x2 x3 x4 x5 x6 ->
            showTupleList [ s1 x1, s2 x2, s3 x3, s4 x4, s5 x5, s6 x6 ]

showTuple7 s1 s2 s3 s4 s5 s6 s7 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (d -> String) -> (e -> String) -> (f -> String) -> (g -> String) -> (a, b, c, d, e, f, g) -> String" ]] =
    case t of
        (@0, 7) x1 x2 x3 x4 x5 x6 x7 ->
            showTupleList [ s1 x1, s2 x2, s3 x3, s4 x4, s5 x5, s6 x6, s7 x7 ]

showTuple8 s1 s2 s3 s4 s5 s6 s7 s8 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (d -> String) -> (e -> String) -> (f -> String) -> (g -> String) -> (h -> String) -> (a, b, c, d, e, f, g, h) -> String" ]] =
    case t of
        (@0, 8) x1 x2 x3 x4 x5 x6 x7 x8 ->
            showTupleList [ s1 x1, s2 x2, s3 x3, s4 x4, s5 x5, s6 x6, s7 x7, s8 x8 ]

showTuple9 s1 s2 s3 s4 s5 s6 s7 s8 s9 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (d -> String) -> (e -> String) -> (f -> String) -> (g -> String) -> (h -> String) -> (i -> String) -> (a, b, c, d, e, f, g, h, i) -> String" ]] =
    case t of
        (@0, 9) x1 x2 x3 x4 x5 x6 x7 x8 x9 ->
            showTupleList [ s1 x1, s2 x2, s3 x3, s4 x4, s5 x5, s6 x6, s7 x7, s8 x8, s9 x9 ]

showTuple10 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 t : public [custom "type" ["(a -> String) -> (b -> String) -> (c -> String) -> (d -> String) -> (e -> String) -> (f -> String) -> (g -> String) -> (h -> String) -> (i -> String) -> (j -> String) -> (a, b, c, d, e, f, g, h, i, j) -> String" ]]=
    case t of
        (@0, 10) x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 ->
            showTupleList [ s1 x1, s2 x2, s3 x3, s4 x4, s5 x5, s6 x6, s7 x7, s8 x8, s9 x9, s10 x10 ]

showTupleList :: [String] -> String
showTupleList xs = 
    ''$primConcat'' [ ['('], commaList xs, [')'] ] 

commaList :: [String] -> String
commaList list =
    case list of
    {   '':[]''  -> []
    ;   (:) x xs ->
        case xs of
        { '':[]'' -> x 
        ; _ -> ''$primAppend'' x (''$primConcatMap'' (''$primAppend'' [ ',' ]) xs)
        }
    }

-- Float

''$primNegFloat''   :: Float -> Float!
''$primNegFloat''   = negFloat

''$primStringToFloat'' :: String -> Float
''$primStringToFloat'' = float_of_string_extern

extern float_of_string_extern "float_of_string" :: "Fz"

''$primShowFloat'' :: Float -> String
''$primShowFloat'' x = let! x = x in stringFromPacked (stringFromFloat x 6 'g')

extern stringFromFloat "string_of_float" :: "aFII"

showFloat : public [custom "type"  ["Float -> String"]]
  = \f -> safeMinus (addPointZero (''$primShowFloat'' f))

safeMinus : private [custom "type"  ["String -> String"]]
  = \s  -> 
    case s of
    { (:) x xs -> 
        case x of 
        { '-' -> ''$primAppend'' (stringFromPacked "(-.") (''$primAppend'' xs (stringFromPacked ")"))
        ; _   -> s
        }
    ; _ -> s
    }

addPointZero : private [custom "type"  ["String -> String"]]
    = \s ->
        case hasPointOrE s of
        { True -> s
        ; _ -> ''$primAppend'' s (stringFromPacked ".0")
        }
        
hasPointOrE : private []
    = \xs ->
    case xs of
    { [] -> False
    ; (:) y ys ->
        case y of 
        { '.' -> True
        ; 'e' -> True
        ; _   -> hasPointOrE ys
        }
    }