diff options
| -rw-r--r-- | utils/ext-core/Check.hs | 2 | ||||
| -rw-r--r-- | utils/ext-core/Driver.hs | 15 | ||||
| -rw-r--r-- | utils/ext-core/Encoding.hs | 204 | ||||
| -rw-r--r-- | utils/ext-core/Interp.hs | 2 | ||||
| -rw-r--r-- | utils/ext-core/Lex.hs | 1 | ||||
| -rw-r--r-- | utils/ext-core/ParseGlue.hs | 16 | ||||
| -rw-r--r-- | utils/ext-core/Parser.y | 18 | ||||
| -rw-r--r-- | utils/ext-core/Prep.hs | 2 | ||||
| -rw-r--r-- | utils/ext-core/Printer.hs | 29 |
9 files changed, 272 insertions, 17 deletions
diff --git a/utils/ext-core/Check.hs b/utils/ext-core/Check.hs index 8b928b0f5a..75470d5a56 100644 --- a/utils/ext-core/Check.hs +++ b/utils/ext-core/Check.hs @@ -398,7 +398,7 @@ mlookupM selector external_env _ (Just m) = do globalEnv <- getGlobalEnv case elookup globalEnv m of Just env' -> return (selector env') - Nothing -> fail ("undefined module name: " ++ show m) + Nothing -> fail ("Check: undefined module name: " ++ show m) qlookupM :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> Env a b -> Qual a -> CheckResult b diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs index da15dce75b..fd42f9eab0 100644 --- a/utils/ext-core/Driver.hs +++ b/utils/ext-core/Driver.hs @@ -5,6 +5,8 @@ -} import Monad +import System.Environment + import Core import Printer import Parser @@ -40,12 +42,20 @@ process (senv,modules) f = FailP s -> do putStrLn ("Parse failed: " ++ s) error "quit" -main = do (_,modules) <- foldM process (initialEnv,[]) flist +main = do fname <- getSingleArg + (_,modules) <- foldM process (initialEnv,[]) [fname] -- flist let result = evalProgram modules putStrLn ("Result = " ++ show result) putStrLn "All done" -- TODO - where flist = ["PrelBase.hcr", +-- see what breaks + where flist = ["Main.hcr"] + getSingleArg = getArgs >>= (\ a -> + case a of + (f:_) -> return f + _ -> error $ "usage: ./Driver [filename]") +{- + ["PrelBase.hcr", "PrelMaybe.hcr", "PrelTup.hcr", "PrelList.hcr", @@ -85,3 +95,4 @@ main = do (_,modules) <- foldM process (initialEnv,[]) flist "Prelude.hcr", "Main.hcr" ] +-}
\ No newline at end of file diff --git a/utils/ext-core/Encoding.hs b/utils/ext-core/Encoding.hs new file mode 100644 index 0000000000..c276932013 --- /dev/null +++ b/utils/ext-core/Encoding.hs @@ -0,0 +1,204 @@ +module Encoding where + +import Data.Char +import Numeric + +-- tjc: TODO: Copied straight out of Encoding.hs. +-- Ugh, maybe we can avoid this copy-pasta... + +-- ----------------------------------------------------------------------------- +-- The Z-encoding + +{- +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is done +right before we emit a symbol name into the compiled C or asm code. +Z-encoding of strings is cached in the FastString interface, so we +never encode the same string more than once. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower) and digits + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'zx' or 'Zx' for some + alphabetic character x + +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character + + Before After + -------------------------- + Trak Trak + foo_wib foozuwib + > zg + >1 zg1 + foo# foozh + foo## foozhzh + foo##1 foozhzh1 + fooZ fooZZ + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (# #) Z1H unboxed 1-tuple (note the space) + (#,,,,#) Z5H unboxed 5-tuple + (NB: There is no Z1T nor Z0H.) +-} + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +zEncodeString :: UserString -> EncodedString +zEncodeString cs = case maybe_tuple cs of + Just n -> n -- Tuples go to Z2T etc + Nothing -> go cs + where + go [] = [] + go (c:cs) = encode_ch c ++ go cs + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = 'z' : if isDigit (head hex_str) then hex_str + else '0':hex_str + where hex_str = showHex (ord c) "U" + -- ToDo: we could improve the encoding here in various ways. + -- eg. strings of unicode characters come out as 'z1234Uz5678U', we + -- could remove the 'U' in the middle (the 'z' works as a separator). + + showHex = showIntAtBase 16 intToDigit + -- needed because prior to GHC 6.2, Numeric.showHex added a "0x" prefix + +zDecodeString :: EncodedString -> UserString +zDecodeString [] = [] +zDecodeString ('Z' : d : rest) + | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : zDecodeString rest +zDecodeString ('z' : d : rest) + | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : zDecodeString rest +zDecodeString (c : rest) = c : zDecodeString rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch + +-- Characters not having a specific code are coded as z224U (in hex) +decode_num_esc :: Char -> EncodedString -> UserString +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest + go n ('U' : rest) = chr n : zDecodeString rest + go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to zDecodeString after decoding the tuple, because + -- the tuple might be embedded in a longer name. + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ('T':rest) = "()" ++ zDecodeString rest + go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest + go 1 ('H':rest) = "(# #)" ++ zDecodeString rest + go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest + go n other = error ("decode_tuple: " ++ show n ++ ' ':other) + +{- +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z<digit> + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. +-} + +maybe_tuple :: UserString -> Maybe EncodedString + +maybe_tuple "(# #)" = Just("Z1H") +maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing +maybe_tuple "()" = Just("Z0T") +maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing +maybe_tuple _ = Nothing + +count_commas :: Int -> String -> (Int, String) +count_commas n (',' : cs) = count_commas (n+1) cs +count_commas n cs = (n,cs) + diff --git a/utils/ext-core/Interp.hs b/utils/ext-core/Interp.hs index b2f68bfdf4..882ec8eab5 100644 --- a/utils/ext-core/Interp.hs +++ b/utils/ext-core/Interp.hs @@ -378,7 +378,7 @@ mlookup _ env Nothing = env mlookup globalEnv _ (Just m) = case elookup globalEnv m of Just env' -> env' - Nothing -> error ("undefined module name: " ++ show m) + Nothing -> error ("Interp: undefined module name: " ++ show m) qlookup :: Menv -> Venv -> (Mname,Var) -> Value qlookup globalEnv env (m,k) = diff --git a/utils/ext-core/Lex.hs b/utils/ext-core/Lex.hs index 8150b16fb8..991ee0ac37 100644 --- a/utils/ext-core/Lex.hs +++ b/utils/ext-core/Lex.hs @@ -33,6 +33,7 @@ lexer cont ('/':'\\':cs) = cont TKbiglambda cs lexer cont ('@':cs) = cont TKat cs lexer cont ('?':cs) = cont TKquestion cs lexer cont (';':cs) = cont TKsemicolon cs +lexer cont (':':cs) = cont TKcolon cs lexer cont (c:cs) = failP "invalid character" [c] lexChar cont ('\\':'x':h1:h0:'\'':cs) diff --git a/utils/ext-core/ParseGlue.hs b/utils/ext-core/ParseGlue.hs index 9bd3c4f7eb..7335656b17 100644 --- a/utils/ext-core/ParseGlue.hs +++ b/utils/ext-core/ParseGlue.hs @@ -1,8 +1,16 @@ module ParseGlue where +import Encoding + +import Data.List + data ParseResult a = OkP a | FailP String type P a = String -> Int -> ParseResult a +instance Show a => Show (ParseResult a) + where show (OkP r) = show r + show (FailP s) = s + thenP :: P a -> (a -> P b) -> P b m `thenP` k = \ s l -> case m s l of @@ -53,7 +61,13 @@ data Token = | TKchar Char | TKEOF - +-- ugh +splitModuleName mn = + let decoded = zDecodeString mn + parts = filter (notElem '.') $ groupBy + (\ c1 c2 -> c1 /= '.' && c2 /= '.') + decoded in + (take (length parts - 1) parts, last parts) diff --git a/utils/ext-core/Parser.y b/utils/ext-core/Parser.y index ac186e399a..4ff3d1d6c4 100644 --- a/utils/ext-core/Parser.y +++ b/utils/ext-core/Parser.y @@ -173,8 +173,8 @@ exp :: { Exp } { foldr Lam $4 $2 } | '%let' vdefg '%in' exp { Let $2 $4 } - | '%case' ty aexp '%of' vbind '{' alts1 '}' - { Case $3 $5 $2 $7 } + | '%case' '(' ty ')' aexp '%of' vbind '{' alts1 '}' + { Case $5 $7 $3 $9 } | '%cast' exp aty { Cast $2 $3 } | '%note' STRING exp @@ -211,15 +211,23 @@ cname :: { Id } : CNAME { $1 } mname :: { AnMname } - : pkgName ':' mnames '.' name - { ($1, $3, $5) } + : pkgName ':' cname + { let (parentNames, childName) = splitModuleName $3 in + ($1, parentNames, childName) } pkgName :: { Id } : NAME { $1 } +-- TODO: Clean this up. Now hierarchical names are z-encoded. + +-- note that a sequence of mnames is either: +-- empty, or a series of cnames separated by +-- dots, with a leading dot +-- See the definition of mnames: the "name" part +-- is required. mnames :: { [Id] } : {- empty -} {[]} - | name '.' mnames {$1:$3} + | '.' cname mnames {$2:$3} -- it sucks to have to repeat the Maybe-checking twice, -- but otherwise we get reduce/reduce conflicts diff --git a/utils/ext-core/Prep.hs b/utils/ext-core/Prep.hs index 352108e198..0a105c1b52 100644 --- a/utils/ext-core/Prep.hs +++ b/utils/ext-core/Prep.hs @@ -127,7 +127,7 @@ prepModule globalEnv (Module mn tdefs vdefgs) = mlookup selector _ (Just m) = case elookup globalEnv m of Just env -> selector env - Nothing -> error ("undefined module name: " ++ show m) + Nothing -> error ("Prep: undefined module name: " ++ show m) qlookup :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b qlookup selector local_env (m,k) = diff --git a/utils/ext-core/Printer.hs b/utils/ext-core/Printer.hs index 8ff4ba5ad2..404fda9bc8 100644 --- a/utils/ext-core/Printer.hs +++ b/utils/ext-core/Printer.hs @@ -5,6 +5,7 @@ import Numeric (fromRat) import Char import Core +import Encoding instance Show Module where showsPrec d m = shows (pmodule m) @@ -61,14 +62,30 @@ pcdef (Constr qdcon tbinds tys) = pname id = text id -pqname (m,id) = pmname m <> char '.' <> pname id +pqname (m,id) = pmname m <> pname id +-- be sure to print the '.' here so we don't print out +-- ".foo" for unqualified foo... pmname Nothing = empty -pmname (Just m) = panmname m - -panmname (pkgName, parents, name) = pname pkgName <> char ':' - <> (sep (punctuate (char '.') (map pname parents))) - <> char '.' <> pname name +pmname (Just m) = panmname m <> char '.' + +panmname p@(pkgName, parents, name) = + let parentStrs = map pname parents in + pname pkgName <> char ':' <> + -- This is to be sure to not print out: + -- main:.Main for when there's a single module name + -- with no parents. + (case parentStrs of + [] -> empty + _ -> hcat (punctuate hierModuleSeparator + (map pname parents)) + <> hierModuleSeparator) + <> pname name + +-- note that this is not a '.' but a Z-encoded '.': +-- GHCziIOBase.IO, not GHC.IOBase.IO. +-- What a pain. +hierModuleSeparator = text (zEncodeString ".") ptbind (t,Klifted) = pname t ptbind (t,k) = parens (pname t <> text "::" <> pkind k) |