helium-1.8: lib/HeliumLang.core

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

module HeliumLang
    ( Bool(True, False)
    , '':[]''('':[]'', (:)) -- lists
    , '':()''('':()'') -- unit tuple
    , '':->'' -- function arrow
    , String, Int, Float, IO, Char
    
    , showFunction, showIO, showPolymorphic -- all show functions are used in inserted main
    , showChar, showString, showInt, showList, showBool, showUnit, showFloat  
    , showTuple2, showTuple3, showTuple4, showTuple5, showTuple6, showTuple7
    , showTuple8, showTuple9, showTuple10
    
    , ''$primPutStrLn'' -- inserted main
    , ''$primPutChar'', ''$primPutStr'' -- necessary for ''$primPutStrLn''
    , ''$primBindIO'' -- do-notation
    , ''$primUnsafePerformIO'' -- inserted main
    , ''$primPatternFailPacked'' -- pattern-match failed runtime error
    , ''$primEnumFrom'', ''$primEnumFromThen'', ''$primEnumFromTo'', ''$primEnumFromThenTo'' -- [1..] etc
    , ''$primNegFloat'' -- unary minus for Expression_NegateFloat. Unnecessary in overloaded Helium?
    , ''$primStringToFloat'' -- float literals
    , ''$primEqFloat'' -- pattern-matching on floats
    , ''$primConcat'' -- derived show functions 
    , ''$primConcatMap'' -- list comprehensions
    , ''$primPackedToString'' -- string literals and the built-in string  "No main defined..." and derived shows

    , ''$negate''
    , ''$enumFrom'', ''$enumFromThen'', ''$enumFromTo'', ''$enumFromThenTo''
    , ''$floatUnaryMinus''
    , ''$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'' :: "Num a => a -> a"
''$negate'' dNum = 
    case dNum of
     (@0, 7) x1 x2 x3 x4 x5 x6 x7 -> x6


''$enumFrom'' :: "Enum a => a -> [a]"
''$enumFrom'' dEnum = 
    case dEnum of
        (@0, 8) x1 x2 x3 x4 x5 x6 x7 x8 -> x3
		
''$enumFromThen'' :: "Enum a => a -> a -> [a]"
''$enumFromThen'' dEnum = 
    case dEnum of
        (@0, 8) x1 x2 x3 x4 x5 x6 x7 x8 -> x4

''$enumFromTo'' :: "Enum a => a -> a -> [a]"
''$enumFromTo'' dEnum = 
    case dEnum of
        (@0, 8) x1 x2 x3 x4 x5 x6 x7 x8 -> x7
		
''$enumFromThenTo'' :: "Enum a => a -> a -> a -> [a]"
''$enumFromThenTo'' dEnum = 
    case dEnum of
        (@0, 8) x1 x2 x3 x4 x5 x6 x7 x8 -> x8

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

''$show'' :: "Show a => a -> String"
''$show'' dShow = 
    case dShow of
        (@0, 2) x1 x2 -> x1

''$showList'' :: "(a -> String) -> [a] -> String"
''$showList'' = showList
        
{----------------------------------------------------------
  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)
    }

-- the ''$primEnum'' functions are used in the translation of the .. notation
-- [1..10]   === ''$primEnumFromTo'' 1 10
-- [1..]     === ''$primEnumFrom'' 1 
-- [1,3..10] === ''$primEnumFromThenTo'' 1 3 10
-- [1,3..]   === ''$primEnumFromThen'' 1 3

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

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

''$primEnumFromThenTo'' :: Int -> Int -> Int -> [Int]
''$primEnumFromThenTo'' n a m =
    case (>) a n of
    {   True -> ''$primAscendToWithStep'' n m ((-) a n) 
    ;   _    -> ''$primDescendToWithStep'' n m ((-) a n) 
    }
    
''$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)
    }

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

-- 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"

-- in overloaded version, a negative float is shown as usual (not with "-.")
showFloat : public [custom "type"  ["Float -> String"]]
  = \f -> 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
        }
    }