"
-> showsPrec _ (Token LineComment a) = shows a
-> showsPrec _ (Token NestedComment a) = shows a
-
-\end{verbatim}
-Tables for reserved operators and identifiers
-\begin{verbatim}
-
-> reserved_ops, reserved_and_special_ops :: Map.Map String Category
-> reserved_ops = Map.fromList [
-> ("@", At),
-> ("::", DoubleColon),
-> ("..", DotDot),
-> ("=", Equals),
-> ("\\", Backslash),
-> ("|", Bar),
-> ("<-", LeftArrow),
-> ("->", RightArrow),
-> ("~", Tilde),
-> (":=", Binds)
-> ]
-> reserved_and_special_ops = foldr (uncurry Map.insert) reserved_ops [
-> (":", Colon),
-> (".", Sym_Dot),
-> ("-", Sym_Minus),
-> ("-.", Sym_MinusDot)
-> ]
-
-> reserved_ids, reserved_and_special_ids :: Map.Map String Category
-> reserved_ids = Map.fromList [
-> ("case", KW_case),
-> ("choice", KW_choice),
-> ("data", KW_data),
-> ("do", KW_do),
-> ("else", KW_else),
-> ("eval", KW_eval),
-> ("external", KW_external),
-> ("free", KW_free),
-> ("if", KW_if),
-> ("import", KW_import),
-> ("in", KW_in),
-> ("infix", KW_infix),
-> ("infixl", KW_infixl),
-> ("infixr", KW_infixr),
-> ("let", KW_let),
-> ("module", KW_module),
-> ("newtype", KW_newtype),
-> ("of", KW_of),
-> ("rigid", KW_rigid),
-> ("then", KW_then),
-> ("type", KW_type),
-> ("where", KW_where)
-> ]
-> reserved_and_special_ids = foldr (uncurry Map.insert) reserved_ids [
-> ("as", Id_as),
-> ("ccall", Id_ccall),
-> ("forall", Id_forall),
-> ("hiding", Id_hiding),
-> ("interface", Id_interface),
-> ("primitive", Id_primitive),
-> ("qualified", Id_qualified)
-> ]
-
-\end{verbatim}
-Character classes
-\begin{verbatim}
-
-> isIdent, isSym, isOctit, isHexit :: Char -> Bool
-> isIdent c = isAlphaNum c || c `elem` "'_"
-> isSym c = c `elem` "~!@#$%^&*+-=<>:?./|\\" {-$-}
-> isOctit c = c >= '0' && c <= '7'
-> isHexit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
-
-inserted for full lexing (men&bbr)
-
-> isLineComment, isNestedComment :: String -> Bool
-> isLineComment ('-':'-':_) = True
-> isLineComment _ = False
-> isNestedComment ('{':'-':s) = True
-> isNestedComment _ = False
-
-
-\end{verbatim}
-Lexing functions
-\begin{verbatim}
-
-> type SuccessP a = Position -> Token -> P a
-> type FailP a = Position -> String -> P a
-
-> lexFile :: P [(Position,Token)]
-> lexFile = fullLexer tokens failP
-> where tokens p t@(Token c _)
-> | c == EOF = returnP [(p,t)]
-> | otherwise = lexFile `thenP` returnP . ((p,t):)
-
-> lexer :: SuccessP a -> FailP a -> P a
-> lexer success fail = skipBlanks
-> where -- skipBlanks moves past whitespace and comments
-> skipBlanks p [] bol = success p (tok EOF) p [] bol
-> skipBlanks p ('\t':s) bol = skipBlanks (tab p) s bol
-> skipBlanks p ('\n':s) bol = skipBlanks (nl p) s True
-> skipBlanks p ('-':'-':s) bol =
-> skipBlanks (nl p) (tail' (dropWhile (/= '\n') s)) True
-> skipBlanks p ('{':'-':s) bol =
-> nestedComment p skipBlanks fail (incr p 2) s bol
-> skipBlanks p (c:s) bol
-> | isSpace c = skipBlanks (next p) s bol
-> | otherwise =
-> (if bol then lexBOL else lexToken) success fail p (c:s) bol
-> tail' [] = []
-> tail' (_:tl) = tl
-
-> fullLexer :: SuccessP a -> FailP a -> P a
-> fullLexer success fail = skipBlanks
-> where -- skipBlanks moves past whitespace
-> skipBlanks p [] bol = success p (tok EOF) p [] bol
-> skipBlanks p ('\t':s) bol = skipBlanks (tab p) s bol
-> skipBlanks p ('\n':s) bol = skipBlanks (nl p) s True
-> skipBlanks p s@('-':'-':_) bol = lexLineComment success p s bol
-> skipBlanks p s@('{':'-':_) bol =
-> lexNestedComment 0 id p success fail p s bol
-> skipBlanks p (c:s) bol
-> | isSpace c = skipBlanks (next p) s bol
-> | otherwise =
-> (if bol then lexBOL else lexToken) success fail p (c:s) bol
-> tail' [] = []
-> tail' (_:tl) = tl
-
-> lexLineComment :: SuccessP a -> P a
-> lexLineComment success p s = case break (=='\n') s of
-> (comment,rest) -> success p (lineCommentTok comment) (incr p (length comment)) rest
-
-> lexNestedComment :: Int -> (String -> String) ->
-> Position -> SuccessP a -> FailP a -> P a
-> lexNestedComment 1 comment p0 success fail p ('-':'}':s) =
-> success p0 (nestedCommentTok (comment "-}") ) (incr p 2) s
-> lexNestedComment n comment p0 success fail p ('{':'-':s) =
-> lexNestedComment (n+1) (comment . ("{-"++)) p0 success fail (incr p 2) s
-> lexNestedComment n comment p0 success fail p ('-':'}':s) =
-> lexNestedComment (n-1) (comment . ("-}"++)) p0 success fail (incr p 2) s
-> lexNestedComment n comment p0 success fail p (c@'\t':s) =
-> lexNestedComment n (comment . (c:)) p0 success fail (tab p) s
-> lexNestedComment n comment p0 success fail p (c@'\n':s) =
-> lexNestedComment n (comment . (c:)) p0 success fail (nl p) s
-> lexNestedComment n comment p0 success fail p (c:s) =
-> lexNestedComment n (comment . (c:)) p0 success fail (next p) s
-> lexNestedComment n comment p0 success fail p "" =
-> fail p0 "Unterminated nested comment" p []
-
-> nestedComment :: Position -> P a -> FailP a -> P a
-> nestedComment p0 success fail p ('-':'}':s) = success (incr p 2) s
-> nestedComment p0 success fail p ('{':'-':s) =
-> nestedComment p (nestedComment p0 success fail) fail (incr p 2) s
-> nestedComment p0 success fail p ('\t':s) =
-> nestedComment p0 success fail (tab p) s
-> nestedComment p0 success fail p ('\n':s) =
-> nestedComment p0 success fail (nl p) s
-> nestedComment p0 success fail p (_:s) =
-> nestedComment p0 success fail (next p) s
-> nestedComment p0 success fail p [] =
-> fail p0 "Unterminated nested comment at end-of-file" p []
-
-
-> lexBOL :: SuccessP a -> FailP a -> P a
-> lexBOL success fail p s _ [] = lexToken success fail p s False []
-> lexBOL success fail p s _ ctxt@(n:rest)
-> | col < n = success p (tok VRightBrace) p s True rest
-> | col == n = success p (tok VSemicolon) p s False ctxt
-> | otherwise = lexToken success fail p s False ctxt
-> where col = column p
-
-> lexToken :: SuccessP a -> FailP a -> P a
-> lexToken success fail p [] = success p (tok EOF) p []
-> lexToken success fail p (c:s)
-> | c == '(' = token LeftParen
-> | c == ')' = token RightParen
-> | c == ',' = token Comma
-> | c == ';' = token Semicolon
-> | c == '[' = token LeftBracket
-> | c == ']' = token RightBracket
-> | c == '_' = token Underscore
-> | c == '`' = token Backquote
-> | c == '{' = lexLeftBrace (token LeftBrace) (next p) (success p) s
-> | c == '}' = \bol -> token RightBrace bol . drop 1
-> | c == '\'' = lexChar p success fail (next p) s
-> | c == '\"' = lexString p success fail (next p) s
-> | isAlpha c = lexIdent (success p) p (c:s)
-> | isSym c = lexSym (success p) p (c:s)
-> | isDigit c = lexNumber (success p) p (c:s)
-> | otherwise = fail p ("Illegal character " ++ show c) p s
-> where token t = success p (tok t) (next p) s
-
-> lexIdent :: (Token -> P a) -> P a
-> lexIdent cont p s =
-> maybe (lexOptQual cont (token Id) [ident]) (cont . token)
-> (Map.lookup ident reserved_and_special_ids)
-> (incr p (length ident)) rest
-> where (ident,rest) = span isIdent s
-> token t = idTok t [] ident
-
-> lexSym :: (Token -> P a) -> P a
-> lexSym cont p s =
-> cont (idTok (maybe Sym id (Map.lookup sym reserved_and_special_ops)) [] sym)
-> (incr p (length sym)) rest
-> where (sym,rest) = span isSym s
-
-> lexLeftBrace leftBrace _ _ [] = leftBrace
-> lexLeftBrace leftBrace p cont (c:s)
-> | c==';' = cont (tok LeftBraceSemicolon) (next p) s
-> | otherwise = leftBrace
-
-\end{verbatim}
-{\em Note:} the function \texttt{lexOptQual} has been extended to provide
-the qualified use of the Prelude list operators and tuples.
-\begin{verbatim}
-
-> lexOptQual :: (Token -> P a) -> Token -> [String] -> P a
-> lexOptQual cont token mIdent p ('.':c:s)
-> | isAlpha c = lexQualIdent cont identCont mIdent (next p) (c:s)
-> | isSym c = lexQualSym cont identCont mIdent (next p) (c:s)
-> | c=='(' || c=='['
-> = lexQualPreludeSym cont token identCont mIdent (next p) (c:s)
-> where identCont _ _ = cont token p ('.':c:s)
-> lexOptQual cont token mIdent p s = cont token p s
-
-> lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a
-> lexQualIdent cont identCont mIdent p s =
-> maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident]))
-> (const identCont)
-> (Map.lookup ident reserved_ids)
-> (incr p (length ident)) rest
-> where (ident,rest) = span isIdent s
-
-> lexQualSym :: (Token -> P a) -> P a -> [String] -> P a
-> lexQualSym cont identCont mIdent p s =
-> maybe (cont (idTok QSym mIdent sym)) (const identCont)
-> (Map.lookup sym reserved_ops)
-> (incr p (length sym)) rest
-> where (sym,rest) = span isSym s
-
-
-> lexQualPreludeSym :: (Token -> P a) -> Token -> P a -> [String] -> P a
-> lexQualPreludeSym cont _ identCont mIdent p ('[':']':rest) =
-> cont (idTok QId mIdent "[]") (incr p 2) rest
-> lexQualPreludeSym cont _ identCont mIdent p ('(':rest)
-> | not (null rest') && head rest'==')'
-> = cont (idTok QId mIdent ('(':tup++")")) (incr p (length tup+2)) (tail rest')
-> where (tup,rest') = span (==',') rest
-> lexQualPreludeSym cont token _ _ p s = cont token p s
-
-
-\end{verbatim}
-{\em Note:} since Curry allows an unlimited range of integer numbers,
-read numbers must be converted to Haskell type \texttt{Integer}.
-\begin{verbatim}
-
-> lexNumber :: (Token -> P a) -> P a
-> lexNumber cont p ('0':c:s)
-> | c `elem` "oO" = lexOctal cont nullCont (incr p 2) s
-> | c `elem` "xX" = lexHexadecimal cont nullCont (incr p 2) s
-> where nullCont _ _ = cont (intTok 10 "0") (next p) (c:s)
-> lexNumber cont p s
-> = lexOptFraction cont (integerTok 10 digits) digits
-> (incr p (length digits)) rest
-> where (digits,rest) = span isDigit s
-> num = (read digits) :: Integer
-
-> lexOctal :: (Token -> P a) -> P a -> P a
-> lexOctal cont nullCont p s
-> | null digits = nullCont undefined undefined
-> | otherwise = cont (integerTok 8 digits) (incr p (length digits)) rest
-> where (digits,rest) = span isOctit s
-
-> lexHexadecimal :: (Token -> P a) -> P a -> P a
-> lexHexadecimal cont nullCont p s
-> | null digits = nullCont undefined undefined
-> | otherwise = cont (integerTok 16 digits) (incr p (length digits)) rest
-> where (digits,rest) = span isHexit s
-
-> lexOptFraction :: (Token -> P a) -> Token -> String -> P a
-> lexOptFraction cont _ mant p ('.':c:s)
-> | isDigit c = lexOptExponent cont (floatTok mant frac 0 "") mant frac
-> (incr p (length frac+1)) rest
-> where (frac,rest) = span isDigit (c:s)
-> lexOptFraction cont token mant p (c:s)
-> | c `elem` "eE" = lexSignedExponent cont intCont mant "" [c] (next p) s
-> where intCont _ _ = cont token p (c:s)
-> lexOptFraction cont token _ p s = cont token p s
-
-> lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a
-> lexOptExponent cont token mant frac p (c:s)
-> | c `elem` "eE" = lexSignedExponent cont floatCont mant frac [c] (next p) s
-> where floatCont _ _ = cont token p (c:s)
-> lexOptExponent cont token mant frac p s = cont token p s
-
-> lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String -> P a
-> lexSignedExponent cont floatCont mant frac e p ('+':c:s)
-> | isDigit c = lexExponent cont mant frac (e++"+") id (next p) (c:s)
-> lexSignedExponent cont floatCont mant frac e p ('-':c:s)
-> | isDigit c = lexExponent cont mant frac (e++"-") negate (next p) (c:s)
-> lexSignedExponent cont floatCont mant frac e p (c:s)
-> | isDigit c = lexExponent cont mant frac e id p (c:s)
-> lexSignedExponent cont floatCont mant frac e p s = floatCont p s
-
-> lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int) -> P a
-> lexExponent cont mant frac e expSign p s =
-> cont (floatTok mant frac exp (e++digits)) (incr p (length digits)) rest
-> where (digits,rest) = span isDigit s
-> exp = expSign (convertIntegral 10 digits)
-
-> lexChar :: Position -> SuccessP a -> FailP a -> P a
-> lexChar p0 success fail p [] = fail p0 "Illegal character constant" p []
-> lexChar p0 success fail p (c:s)
-> | c == '\\' = lexEscape p (lexCharEnd p0 success fail) fail (next p) s
-> | c == '\n' = fail p0 "Illegal character constant" p (c:s)
-> | c == '\t' = lexCharEnd p0 success fail c "\t" (tab p) s
-> | otherwise = lexCharEnd p0 success fail c [c] (next p) s
-
-> lexCharEnd :: Position -> SuccessP a -> FailP a -> Char -> String -> P a
-> lexCharEnd p0 success fail c o p ('\'':s) = success p0 (charTok c o) (next p) s
-> lexCharEnd p0 success fail c o p s =
-> fail p0 "Improperly terminated character constant" p s
-
-> lexString :: Position -> SuccessP a -> FailP a -> P a
-> lexString p0 success fail = lexStringRest p0 success fail "" id
-
-> lexStringRest :: Position -> SuccessP a -> FailP a -> String -> (String -> String) -> P a
-> lexStringRest p0 success fail s0 so p [] =
-> fail p0 "Improperly terminated string constant" p []
-> lexStringRest p0 success fail s0 so p (c:s)
-> | c == '\\' =
-> lexStringEscape p (lexStringRest p0 success fail) fail s0 so (next p) s
-> | c == '\"' = success p0 (stringTok (reverse s0) (so "")) (next p) s
-> | c == '\n' = fail p0 "Improperly terminated string constant" p []
-> | c == '\t' = lexStringRest p0 success fail (c:s0) (so . (c:)) (tab p) s
-> | otherwise = lexStringRest p0 success fail (c:s0) (so . (c:)) (next p) s
-
-> lexStringEscape :: Position -> (String -> (String -> String) -> P a) -> FailP a ->
-> String -> (String -> String) -> P a
-> lexStringEscape p0 success fail s0 so p [] = lexEscape p0 undefined fail p []
-> lexStringEscape p0 success fail s0 so p (c:s)
-> | c == '&' = success s0 (so . ("\\&"++)) (next p) s
-> | isSpace c = lexStringGap (success s0) fail so p (c:s)
-> | otherwise = lexEscape p0 (\ c' s' -> success (c':s0) (so . (s'++))) fail p (c:s)
-
-> lexStringGap :: ((String -> String) -> P a) -> FailP a -> (String -> String) -> P a
-> lexStringGap success fail so p [] = fail p "End of file in string gap" p []
-> lexStringGap success fail so p (c:s)
-> | c == '\\' = success (so . (c:)) (next p) s
-> | c == '\t' = lexStringGap success fail (so . (c:)) (tab p) s
-> | c == '\n' = lexStringGap success fail (so . (c:)) (nl p) s
-> | isSpace c = lexStringGap success fail (so . (c:)) (next p) s
-> | otherwise = fail p ("Illegal character in string gap " ++ show c) p s
-
-> lexEscape :: Position -> (Char -> String -> P a) -> FailP a -> P a
-> lexEscape p0 success fail p ('a':s) = success '\a' "\\a" (next p) s
-> lexEscape p0 success fail p ('b':s) = success '\b' "\\b" (next p) s
-> lexEscape p0 success fail p ('f':s) = success '\f' "\\f" (next p) s
-> lexEscape p0 success fail p ('n':s) = success '\n' "\\n" (next p) s
-> lexEscape p0 success fail p ('r':s) = success '\r' "\\r" (next p) s
-> lexEscape p0 success fail p ('t':s) = success '\t' "\\t" (next p) s
-> lexEscape p0 success fail p ('v':s) = success '\v' "\\v" (next p) s
-> lexEscape p0 success fail p ('\\':s) = success '\\' "\\\\" (next p) s
-> lexEscape p0 success fail p ('"':s) = success '\"' "\\\"" (next p) s
-> lexEscape p0 success fail p ('\'':s) = success '\'' "\\\'" (next p) s
-> lexEscape p0 success fail p ('^':c:s)
-> | isUpper c || c `elem` "@[\\]^_" =
-> success (chr (ord c `mod` 32)) ("\\^"++[c]) (incr p 2) s
-> lexEscape p0 success fail p ('o':c:s)
-> | isOctit c = numEscape p0 success fail 8 isOctit ("\\o"++) (next p) (c:s)
-> lexEscape p0 success fail p ('x':c:s)
-> | isHexit c = numEscape p0 success fail 16 isHexit ("\\x"++) (next p) (c:s)
-> lexEscape p0 success fail p (c:s)
-> | isDigit c = numEscape p0 success fail 10 isDigit ("\\"++) p (c:s)
-> lexEscape p0 success fail p s = asciiEscape p0 success fail p s
-
-> asciiEscape :: Position -> (Char -> String -> P a) -> FailP a -> P a
-> asciiEscape p0 success fail p ('N':'U':'L':s) = success '\NUL' "\\NUL" (incr p 3) s
-> asciiEscape p0 success fail p ('S':'O':'H':s) = success '\SOH' "\\SOH" (incr p 3) s
-> asciiEscape p0 success fail p ('S':'T':'X':s) = success '\STX' "\\STX" (incr p 3) s
-> asciiEscape p0 success fail p ('E':'T':'X':s) = success '\ETX' "\\ETX" (incr p 3) s
-> asciiEscape p0 success fail p ('E':'O':'T':s) = success '\EOT' "\\EOT" (incr p 3) s
-> asciiEscape p0 success fail p ('E':'N':'Q':s) = success '\ENQ' "\\ENQ" (incr p 3) s
-> asciiEscape p0 success fail p ('A':'C':'K':s) = success '\ACK' "\\ACK" (incr p 3) s
-> asciiEscape p0 success fail p ('B':'E':'L':s) = success '\BEL' "\\BEL" (incr p 3) s
-> asciiEscape p0 success fail p ('B':'S':s) = success '\BS' "\\BS" (incr p 2) s
-> asciiEscape p0 success fail p ('H':'T':s) = success '\HT' "\\HT" (incr p 2) s
-> asciiEscape p0 success fail p ('L':'F':s) = success '\LF' "\\LF" (incr p 2) s
-> asciiEscape p0 success fail p ('V':'T':s) = success '\VT' "\\VT" (incr p 2) s
-> asciiEscape p0 success fail p ('F':'F':s) = success '\FF' "\\FF" (incr p 2) s
-> asciiEscape p0 success fail p ('C':'R':s) = success '\CR' "\\CR" (incr p 2) s
-> asciiEscape p0 success fail p ('S':'O':s) = success '\SO' "\\SO" (incr p 2) s
-> asciiEscape p0 success fail p ('S':'I':s) = success '\SI' "\\SI" (incr p 2) s
-> asciiEscape p0 success fail p ('D':'L':'E':s) = success '\DLE' "\\DLE" (incr p 3) s
-> asciiEscape p0 success fail p ('D':'C':'1':s) = success '\DC1' "\\DC1" (incr p 3) s
-> asciiEscape p0 success fail p ('D':'C':'2':s) = success '\DC2' "\\DC2" (incr p 3) s
-> asciiEscape p0 success fail p ('D':'C':'3':s) = success '\DC3' "\\DC3" (incr p 3) s
-> asciiEscape p0 success fail p ('D':'C':'4':s) = success '\DC4' "\\DC4" (incr p 3) s
-> asciiEscape p0 success fail p ('N':'A':'K':s) = success '\NAK' "\\NAK" (incr p 3) s
-> asciiEscape p0 success fail p ('S':'Y':'N':s) = success '\SYN' "\\SYN" (incr p 3) s
-> asciiEscape p0 success fail p ('E':'T':'B':s) = success '\ETB' "\\ETB" (incr p 3) s
-> asciiEscape p0 success fail p ('C':'A':'N':s) = success '\CAN' "\\CAN" (incr p 3) s
-> asciiEscape p0 success fail p ('E':'M':s) = success '\EM' "\\EM" (incr p 2) s
-> asciiEscape p0 success fail p ('S':'U':'B':s) = success '\SUB' "\\SUB" (incr p 3) s
-> asciiEscape p0 success fail p ('E':'S':'C':s) = success '\ESC' "\\ESC" (incr p 3) s
-> asciiEscape p0 success fail p ('F':'S':s) = success '\FS' "\\FS" (incr p 2) s
-> asciiEscape p0 success fail p ('G':'S':s) = success '\GS' "\\GS" (incr p 2) s
-> asciiEscape p0 success fail p ('R':'S':s) = success '\RS' "\\RS" (incr p 2) s
-> asciiEscape p0 success fail p ('U':'S':s) = success '\US' "\\US" (incr p 2) s
-> asciiEscape p0 success fail p ('S':'P':s) = success '\SP' "\\SP" (incr p 2) s
-> asciiEscape p0 success fail p ('D':'E':'L':s) = success '\DEL' "\\DEL" (incr p 3) s
-> asciiEscape p0 success fail p s = fail p0 "Illegal escape sequence" p s
-
-> numEscape :: Position -> (Char -> String -> P a) -> FailP a -> Int
-> -> (Char -> Bool) -> (String -> String) -> P a
-> numEscape p0 success fail b isDigit so p s
-> | n >= min && n <= max = success (chr n) (so digits) (incr p (length digits)) rest
-> | otherwise = fail p0 "Numeric escape out-of-range" p s
-> where (digits,rest) = span isDigit s
-> n = convertIntegral b digits
-> min = ord minBound
-> max = ord maxBound
-
-\end{verbatim}
diff --git a/src/CurryPP.lhs b/src/CurryPP.lhs
deleted file mode 100644
--- a/src/CurryPP.lhs
+++ /dev/null
@@ -1,369 +0,0 @@
-
-% $Id: CurryPP.lhs,v 1.50 2004/02/15 22:10:27 wlux Exp $
-%
-% Copyright (c) 1999-2004, Wolfgang Lux
-% See LICENSE for the full license.
-%
-% Modified by Martin Engelke (men@informatik.uni-kiel.de)
-%
-\nwfilename{CurryPP.lhs}
-\section{A Pretty Printer for Curry}\label{sec:CurryPP}
-This module implements a pretty printer for Curry expressions. It was
-derived from the Haskell pretty printer provided in Simon Marlow's
-Haskell parser.
-\begin{verbatim}
-
-> module CurryPP(module CurryPP, Doc) where
-> import Ident
-> import CurrySyntax
-> import Pretty
-
-\end{verbatim}
-Pretty print a module
-\begin{verbatim}
-
-> ppModule :: Module -> Doc
-> ppModule (Module m es ds) = ppModuleHeader m es $$ ppBlock ds
-
-\end{verbatim}
-Module header
-\begin{verbatim}
-
-> ppModuleHeader :: ModuleIdent -> Maybe ExportSpec -> Doc
-> ppModuleHeader m es =
-> text "module" <+> ppMIdent m <+> maybePP ppExportSpec es <+> text "where"
-
-> ppExportSpec :: ExportSpec -> Doc
-> ppExportSpec (Exporting _ es) = parenList (map ppExport es)
-
-> ppExport :: Export -> Doc
-> ppExport (Export x) = ppQIdent x
-> ppExport (ExportTypeWith tc cs) = ppQIdent tc <> parenList (map ppIdent cs)
-> ppExport (ExportTypeAll tc) = ppQIdent tc <> text "(..)"
-> ppExport (ExportModule m) = text "module" <+> ppMIdent m
-
-\end{verbatim}
-Declarations
-\begin{verbatim}
-
-> ppBlock :: [Decl] -> Doc
-> ppBlock = vcat . map ppDecl
-
-> ppDecl :: Decl -> Doc
-> ppDecl (ImportDecl _ m q asM is) =
-> text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM
-> <+> maybePP ppImportSpec is
-> where ppQualified q = if q then text "qualified" else empty
-> ppAs m = text "as" <+> ppMIdent m
-> ppDecl (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)
-> ppDecl (DataDecl _ tc tvs cs) =
-> sep (ppTypeDeclLhs "data" tc tvs :
-> map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs)))
-> ppDecl (NewtypeDecl _ tc tvs nc) =
-> sep [ppTypeDeclLhs "newtype" tc tvs <+> equals,indent (ppNewConstr nc)]
-> ppDecl (TypeDecl _ tc tvs ty) =
-> sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]
-> ppDecl (TypeSig _ fs ty) =
-> list (map ppIdent fs) <+> text "::" <+> ppTypeExpr 0 ty
-> ppDecl (EvalAnnot _ fs ev) =
-> list (map ppIdent fs) <+> text "eval" <+> ppEval ev
-> where ppEval EvalRigid = text "rigid"
-> ppEval EvalChoice = text "choice"
-> ppDecl (FunctionDecl _ _ eqs) = vcat (map ppEquation eqs)
-> ppDecl (ExternalDecl p cc impent f ty) =
-> sep [text "external" <+> ppCallConv cc <+> maybePP (text . show) impent,
-> indent (ppDecl (TypeSig p [f] ty))]
-> where ppCallConv CallConvPrimitive = text "primitive"
-> ppCallConv CallConvCCall = text "ccall"
-> ppDecl (FlatExternalDecl _ fs) = list (map ppIdent fs) <+> text "external"
-> ppDecl (PatternDecl _ t rhs) = ppRule (ppConstrTerm 0 t) equals rhs
-> ppDecl (ExtraVariables _ vs) = list (map ppIdent vs) <+> text "free"
-
-> ppImportSpec :: ImportSpec -> Doc
-> ppImportSpec (Importing _ is) = parenList (map ppImport is)
-> ppImportSpec (Hiding _ is) = text "hiding" <+> parenList (map ppImport is)
-
-> ppImport :: Import -> Doc
-> ppImport (Import x) = ppIdent x
-> ppImport (ImportTypeWith tc cs) = ppIdent tc <> parenList (map ppIdent cs)
-> ppImport (ImportTypeAll tc) = ppIdent tc <> text "(..)"
-
-> ppPrec :: Infix -> Integer -> Doc
-> ppPrec fix p = ppAssoc fix <+> ppPrio p
-> where ppAssoc InfixL = text "infixl"
-> ppAssoc InfixR = text "infixr"
-> ppAssoc Infix = text "infix"
-> ppPrio p = if p < 0 then empty else integer p
-
-> ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc
-> ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)
-
-> ppConstr :: ConstrDecl -> Doc
-> ppConstr (ConstrDecl _ tvs c tys) =
-> sep [ppExistVars tvs,ppIdent c <+> fsep (map (ppTypeExpr 2) tys)]
-> ppConstr (ConOpDecl _ tvs ty1 op ty2) =
-> sep [ppExistVars tvs,ppTypeExpr 1 ty1,ppInfixOp op <+> ppTypeExpr 1 ty2]
-
-> ppNewConstr :: NewConstrDecl -> Doc
-> ppNewConstr (NewConstrDecl _ tvs c ty) =
-> sep [ppExistVars tvs,ppIdent c <+> ppTypeExpr 2 ty]
-
-> ppExistVars :: [Ident] -> Doc
-> ppExistVars tvs
-> | null tvs = empty
-> | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'
-
-> ppEquation :: Equation -> Doc
-> ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs
-
-> ppLhs :: Lhs -> Doc
-> ppLhs (FunLhs f ts) = ppIdent f <+> fsep (map (ppConstrTerm 2) ts)
-> ppLhs (OpLhs t1 f t2) =
-> ppConstrTerm 1 t1 <+> ppInfixOp f <+> ppConstrTerm 1 t2
-> ppLhs (ApLhs lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppConstrTerm 2) ts)
-
-> ppRule :: Doc -> Doc -> Rhs -> Doc
-> ppRule lhs eq (SimpleRhs _ e ds) =
-> sep [lhs <+> eq,indent (ppExpr 0 e)] $$ ppLocalDefs ds
-> ppRule lhs eq (GuardedRhs es ds) =
-> sep [lhs,indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds
-
-> ppLocalDefs :: [Decl] -> Doc
-> ppLocalDefs ds
-> | null ds = empty
-> | otherwise = indent (text "where" <+> ppBlock ds)
-
-\end{verbatim}
-Interfaces
-\begin{verbatim}
-
-> ppInterface :: Interface -> Doc
-> ppInterface (Interface m ds) =
-> text "interface" <+> ppMIdent m <+> text "where" <+> lbrace
-> $$ vcat (punctuate semi (map ppIDecl ds)) $$ rbrace
-
-> ppIDecl :: IDecl -> Doc
-> ppIDecl (IImportDecl _ m) = text "import" <+> ppMIdent m
-> ppIDecl (IInfixDecl _ fix p op) = ppPrec fix p <+> ppQInfixOp op
-> ppIDecl (HidingDataDecl _ tc tvs) =
-> text "hiding" <+> ppITypeDeclLhs "data" (qualify tc) tvs
-> ppIDecl (IDataDecl _ tc tvs cs) =
-> sep (ppITypeDeclLhs "data" tc tvs :
-> map indent (zipWith (<+>) (equals : repeat vbar) (map ppIConstr cs)))
-> where ppIConstr = maybe (char '_') ppConstr
-> ppIDecl (INewtypeDecl _ tc tvs nc) =
-> sep [ppITypeDeclLhs "newtype" tc tvs <+> equals,indent (ppNewConstr nc)]
-> ppIDecl (ITypeDecl _ tc tvs ty) =
-> sep [ppITypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]
-> ppIDecl (IFunctionDecl _ f _ ty) = ppQIdent f <+> text "::" <+> ppTypeExpr 0 ty
-
-> ppITypeDeclLhs :: String -> QualIdent -> [Ident] -> Doc
-> ppITypeDeclLhs kw tc tvs = text kw <+> ppQIdent tc <+> hsep (map ppIdent tvs)
-
-\end{verbatim}
-Types
-\begin{verbatim}
-
-> ppTypeExpr :: Int -> TypeExpr -> Doc
-> ppTypeExpr p (ConstructorType tc tys) =
-> parenExp (p > 1 && not (null tys))
-> (ppQIdent tc <+> fsep (map (ppTypeExpr 2) tys))
-> ppTypeExpr _ (VariableType tv) = ppIdent tv
-> ppTypeExpr _ (TupleType tys) = parenList (map (ppTypeExpr 0) tys)
-> ppTypeExpr _ (ListType ty) = brackets (ppTypeExpr 0 ty)
-> ppTypeExpr p (ArrowType ty1 ty2) =
-> parenExp (p > 0) (fsep (ppArrowType (ArrowType ty1 ty2)))
-> where ppArrowType (ArrowType ty1 ty2) =
-> ppTypeExpr 1 ty1 <+> rarrow : ppArrowType ty2
-> ppArrowType ty = [ppTypeExpr 0 ty]
-> ppTypeExpr p (RecordType fs rty) =
-> braces (list (map ppTypedField fs)
-> <> maybe empty (\ty -> space <> char '|' <+> ppTypeExpr 0 ty) rty)
-> where
-> ppTypedField (ls,ty) =
-> list (map ppIdent ls) <> text "::" <> ppTypeExpr 0 ty
-
-\end{verbatim}
-Literals
-\begin{verbatim}
-
-> ppLiteral :: Literal -> Doc
-> ppLiteral (Char _ c) = text (show c)
-> ppLiteral (Int _ i) = integer i
-> ppLiteral (Float _ f) = double f
-> ppLiteral (String _ s) = text (show s)
-
-\end{verbatim}
-Patterns
-\begin{verbatim}
-
-> ppConstrTerm :: Int -> ConstrTerm -> Doc
-> ppConstrTerm p (LiteralPattern l) =
-> parenExp (p > 1 && isNegative l) (ppLiteral l)
-> where isNegative (Char _ _) = False
-> isNegative (Int _ i) = i < 0
-> isNegative (Float _ f) = f < 0.0
-> isNegative (String _ _) = False
-> ppConstrTerm p (NegativePattern op l) =
-> parenExp (p > 1) (ppInfixOp op <> ppLiteral l)
-> ppConstrTerm _ (VariablePattern v) = ppIdent v
-> ppConstrTerm p (ConstructorPattern c ts) =
-> parenExp (p > 1 && not (null ts))
-> (ppQIdent c <+> fsep (map (ppConstrTerm 2) ts))
-> ppConstrTerm p (InfixPattern t1 c t2) =
-> parenExp (p > 0)
-> (sep [ppConstrTerm 1 t1 <+> ppQInfixOp c,
-> indent (ppConstrTerm 0 t2)])
-> ppConstrTerm _ (ParenPattern t) = parens (ppConstrTerm 0 t)
-> ppConstrTerm _ (TuplePattern _ ts) = parenList (map (ppConstrTerm 0) ts)
-> ppConstrTerm _ (ListPattern _ ts) = bracketList (map (ppConstrTerm 0) ts)
-> ppConstrTerm _ (AsPattern v t) = ppIdent v <> char '@' <> ppConstrTerm 2 t
-> ppConstrTerm _ (LazyPattern _ t) = char '~' <> ppConstrTerm 2 t
-> ppConstrTerm p (FunctionPattern f ts) =
-> parenExp (p > 1 && not (null ts))
-> (ppQIdent f <+> fsep (map (ppConstrTerm 2) ts))
-> ppConstrTerm p (InfixFuncPattern t1 f t2) =
-> parenExp (p > 0)
-> (sep [ppConstrTerm 1 t1 <+> ppQInfixOp f,
-> indent (ppConstrTerm 0 t2)])
-> ppConstrTerm p (RecordPattern fs rt) =
-> braces (list (map ppFieldPatt fs)
-> <> (maybe empty (\t -> space <> char '|' <+> ppConstrTerm 0 t) rt))
-
-> ppFieldPatt :: Field ConstrTerm -> Doc
-> ppFieldPatt (Field _ l t) = ppIdent l <> equals <> ppConstrTerm 0 t
-
-\end{verbatim}
-Expressions
-\begin{verbatim}
-
-> ppCondExpr :: Doc -> CondExpr -> Doc
-> ppCondExpr eq (CondExpr _ g e) =
-> vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)]
-
-> ppExpr :: Int -> Expression -> Doc
-> ppExpr _ (Literal l) = ppLiteral l
-> ppExpr _ (Variable v) = ppQIdent v
-> ppExpr _ (Constructor c) = ppQIdent c
-> ppExpr _ (Paren e) = parens (ppExpr 0 e)
-> ppExpr p (Typed e ty) =
-> parenExp (p > 0) (ppExpr 0 e <+> text "::" <+> ppTypeExpr 0 ty)
-> ppExpr _ (Tuple _ es) = parenList (map (ppExpr 0) es)
-> ppExpr _ (List _ es) = bracketList (map (ppExpr 0) es)
-> ppExpr _ (ListCompr _ e qs) =
-> brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs))
-> ppExpr _ (EnumFrom e) = brackets (ppExpr 0 e <+> text "..")
-> ppExpr _ (EnumFromThen e1 e2) =
-> brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..")
-> ppExpr _ (EnumFromTo e1 e2) =
-> brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2)
-> ppExpr _ (EnumFromThenTo e1 e2 e3) =
-> brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2
-> <+> text ".." <+> ppExpr 0 e3)
-> ppExpr p (UnaryMinus op e) = parenExp (p > 1) (ppInfixOp op <> ppExpr 1 e)
-> ppExpr p (Apply e1 e2) =
-> parenExp (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])
-> ppExpr p (InfixApply e1 op e2) =
-> parenExp (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op),
-> indent (ppExpr 1 e2)])
-> ppExpr _ (LeftSection e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))
-> ppExpr _ (RightSection op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)
-> ppExpr p (Lambda _ t e) =
-> parenExp (p > 0)
-> (sep [backsl <> fsep (map (ppConstrTerm 2) t) <+> rarrow,
-> indent (ppExpr 0 e)])
-> ppExpr p (Let ds e) =
-> parenExp (p > 0)
-> (sep [text "let" <+> ppBlock ds <+> text "in",ppExpr 0 e])
-> ppExpr p (Do sts e) =
-> parenExp (p > 0) (text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e))
-> ppExpr p (IfThenElse _ e1 e2 e3) =
-> parenExp (p > 0)
-> (text "if" <+>
-> sep [ppExpr 0 e1,
-> text "then" <+> ppExpr 0 e2,
-> text "else" <+> ppExpr 0 e3])
-> ppExpr p (Case _ e alts) =
-> parenExp (p > 0)
-> (text "case" <+> ppExpr 0 e <+> text "of" $$
-> indent (vcat (map ppAlt alts)))
-> ppExpr p (RecordConstr fs) =
-> braces (list (map (ppFieldExpr equals) fs))
-> ppExpr p (RecordSelection e l) =
-> parenExp (p > 0)
-> (ppExpr 1 e <+> text "->" <+> ppIdent l)
-> ppExpr p (RecordUpdate fs e) =
-> braces (list (map (ppFieldExpr (text ":=")) fs)
-> <+> char '|' <+> ppExpr 0 e)
-
-> ppStmt :: Statement -> Doc
-> ppStmt (StmtExpr _ e) = ppExpr 0 e
-> ppStmt (StmtBind _ t e) = sep [ppConstrTerm 0 t <+> larrow,indent (ppExpr 0 e)]
-> ppStmt (StmtDecl ds) = text "let" <+> ppBlock ds
-
-> ppAlt :: Alt -> Doc
-> ppAlt (Alt _ t rhs) = ppRule (ppConstrTerm 0 t) rarrow rhs
-
-> ppFieldExpr :: Doc -> Field Expression -> Doc
-> ppFieldExpr comb (Field _ l e) = ppIdent l <> comb <> ppExpr 0 e
-
-> ppOp :: InfixOp -> Doc
-> ppOp (InfixOp op) = ppQInfixOp op
-> ppOp (InfixConstr op) = ppQInfixOp op
-
-\end{verbatim}
-Goals
-\begin{verbatim}
-
-> ppGoal :: Goal -> Doc
-> ppGoal (Goal _ e ds) = sep [ppExpr 0 e,indent (ppLocalDefs ds)]
-
-\end{verbatim}
-Names
-\begin{verbatim}
-
-> ppIdent :: Ident -> Doc
-> ppIdent x = parenExp (isInfixOp x) (text (name x))
-
-> ppQIdent :: QualIdent -> Doc
-> ppQIdent x = parenExp (isQInfixOp x) (text (qualName x))
-
-> ppInfixOp :: Ident -> Doc
-> ppInfixOp x = backQuoteExp (not (isInfixOp x)) (text (name x))
-
-> ppQInfixOp :: QualIdent -> Doc
-> ppQInfixOp x = backQuoteExp (not (isQInfixOp x)) (text (qualName x))
-
-> ppMIdent :: ModuleIdent -> Doc
-> ppMIdent m = text (moduleName m)
-
-\end{verbatim}
-Print printing utilities
-\begin{verbatim}
-
-> indent :: Doc -> Doc
-> indent = nest 2
-
-> maybePP :: (a -> Doc) -> Maybe a -> Doc
-> maybePP pp = maybe empty pp
-
-> parenExp :: Bool -> Doc -> Doc
-> parenExp b doc = if b then parens doc else doc
-
-> backQuoteExp :: Bool -> Doc -> Doc
-> backQuoteExp b doc = if b then backQuote <> doc <> backQuote else doc
-
-> list, parenList, bracketList, braceList :: [Doc] -> Doc
-> list = fsep . punctuate comma
-> parenList = parens . list
-> bracketList = brackets . list
-> braceList = braces . list
-
-> backQuote,backsl,vbar,rarrow,larrow :: Doc
-> backQuote = char '`'
-> backsl = char '\\'
-> vbar = char '|'
-> rarrow = text "->"
-> larrow = text "<-"
-
-\end{verbatim}
diff --git a/src/CurryParser.lhs b/src/CurryParser.lhs
deleted file mode 100644
--- a/src/CurryParser.lhs
+++ /dev/null
@@ -1,818 +0,0 @@
-
-% $Id: CurryParser.lhs,v 1.75 2004/02/15 23:11:28 wlux Exp $
-%
-% Copyright (c) 1999-2004, Wolfgang Lux
-% See LICENSE for the full license.
-%
-% Modified by Martin Engelke (men@informatik.uni-kiel.de)
-%
-\nwfilename{CurryParser.lhs}
-\section{A Parser for Curry}
-The Curry parser is implemented using the (mostly) LL(1) parsing
-combinators described in appendix~\ref{sec:ll-parsecomb}.
-\begin{verbatim}
-
-> module CurryParser where
-> import Ident
-> import Position
-> import Error
-> import LLParseComb
-> import CurrySyntax
-> import CurryLexer
-
-> instance Symbol Token where
-> isEOF (Token c _) = c == EOF
-
-\end{verbatim}
-\paragraph{Modules}
-\begin{verbatim}
-
-> parseSource :: Bool -> FilePath -> String -> Error Module
-> parseSource flat path mod =
-> fmap addSrcRefs (applyParser (parseModule flat) lexer path mod)
-
-> parseHeader :: FilePath -> String -> Error Module
-> parseHeader = prefixParser (moduleHeader <*->
-> (leftBrace `opt` undefined) <*>
-> many (importDecl <*-> many semicolon))
-> lexer
-
-> parseModule :: Bool -> Parser Token Module a
-> parseModule flat = moduleHeader <*> decls flat
-
-> moduleHeader :: Parser Token ([Decl] -> Module) a
-> moduleHeader = Module <$-> token KW_module
-> <*> (mIdent "module name expected")
-> <*> ((Just <$> exportSpec) `opt` Nothing)
-> <*-> (token KW_where "where expected")
-> `opt` Module mainMIdent Nothing
-
-> exportSpec :: Parser Token ExportSpec a
-> exportSpec = Exporting <$> position <*> parens (export `sepBy` comma)
-
-> export :: Parser Token Export a
-> export = qtycon <**> (parens spec `opt` Export)
-> <|> Export <$> qfun <\> qtycon
-> <|> ExportModule <$-> token KW_module <*> mIdent
-> where spec = ExportTypeAll <$-> token DotDot
-> <|> flip ExportTypeWith <$> con `sepBy` comma
-
-\end{verbatim}
-\paragraph{Interfaces}
-Since this modified version of MCC uses FlatCurry interfaces instead of
-".icurry" files, a separate parser is not required any longer.
-\begin{verbatim}
-
-> --parseInterface :: FilePath -> String -> Error Interface
-> --parseInterface fn s = applyParser parseIface lexer fn s
-
-> --parseIface :: Parser Token Interface a
-> --parseIface = Interface <$-> token Id_interface
-> -- <*> (mIdent "module name expected")
-> -- <*-> (token KW_where "where expected")
-> -- <*> braces intfDecls
-
-\end{verbatim}
-\paragraph{Goals}
-\begin{verbatim}
-
-> parseGoal :: String -> Error Goal
-> parseGoal s = applyParser goal lexer "" s
-
-> goal :: Parser Token Goal a
-> goal = Goal <$> position <*> expr False <*> localDefs False
-
-\end{verbatim}
-\paragraph{Declarations}
-\begin{verbatim}
-
-> decls :: Bool -> Parser Token [Decl] a
-> decls flat = layout (globalDecls flat)
-
-> globalDecls :: Bool -> Parser Token [Decl] a
-> globalDecls flat =
-> (:) <$> importDecl <*> (semicolon <-*> globalDecls flat `opt` [])
-> <|> topDecl flat `sepBy` semicolon
-
-> topDecl :: Bool -> Parser Token Decl a
-> topDecl flat
-> | flat = infixDecl <|> dataDecl flat <|> typeDecl <|> functionDecl flat
-> | otherwise = infixDecl
-> <|> dataDecl flat <|> newtypeDecl <|> typeDecl
-> <|> functionDecl flat <|> externalDecl
-
-> localDefs :: Bool -> Parser Token [Decl] a
-> localDefs flat = token KW_where <-*> layout (valueDecls flat)
-> `opt` []
-
-> valueDecls :: Bool -> Parser Token [Decl] a
-> valueDecls flat = localDecl flat `sepBy` semicolon
-> where localDecl flat
-> | flat = infixDecl <|> valueDecl flat
-> | otherwise = infixDecl <|> valueDecl flat <|> externalDecl
-
-> importDecl :: Parser Token Decl a
-> importDecl =
-> flip . ImportDecl <$> position <*-> token KW_import
-> <*> (True <$-> token Id_qualified `opt` False)
-> <*> mIdent
-> <*> (Just <$-> token Id_as <*> mIdent `opt` Nothing)
-> <*> (Just <$> importSpec `opt` Nothing)
-
-> importSpec :: Parser Token ImportSpec a
-> importSpec = position <**> (Hiding <$-> token Id_hiding `opt` Importing)
-> <*> parens (spec `sepBy` comma)
-> where spec = tycon <**> (parens constrs `opt` Import)
-> <|> Import <$> fun <\> tycon
-> constrs = ImportTypeAll <$-> token DotDot
-> <|> flip ImportTypeWith <$> con `sepBy` comma
-
-> infixDecl :: Parser Token Decl a
-> infixDecl = infixDeclLhs InfixDecl <*> funop `sepBy1` comma
-
-> infixDeclLhs :: (Position -> Infix -> Integer -> a) -> Parser Token a b
-> infixDeclLhs f = f <$> position <*> tokenOps infixKW <*> integer
-> where infixKW = [(KW_infix,Infix),(KW_infixl,InfixL),(KW_infixr,InfixR)]
-
-> dataDecl :: Bool -> Parser Token Decl a
-> dataDecl flat = typeDeclLhs DataDecl KW_data <*> constrs
-> where constrs = equals <-*> constrDecl flat `sepBy1` bar
-> `opt` []
-
-> newtypeDecl :: Parser Token Decl a
-> newtypeDecl =
-> typeDeclLhs NewtypeDecl KW_newtype <*-> equals <*> newConstrDecl
-
-> typeDecl :: Parser Token Decl a
-> typeDecl = typeDeclLhs TypeDecl KW_type <*-> equals <*> typeDeclRhs --type0
-
-> typeDeclLhs :: (Position -> Ident -> [Ident] -> a) -> Category
-> -> Parser Token a b
-> typeDeclLhs f kw = f <$> position <*-> token kw <*> tycon <*> many typeVar
-> where typeVar = tyvar <|> anonId <$-> token Underscore
-
-> typeDeclRhs :: Parser Token TypeExpr a
-> typeDeclRhs = type0
-> <|> (flip RecordType) Nothing
-> <$> (layoutOff <-*> braces (labelDecls `sepBy` comma))
-
-> labelDecls = (,) <$> labId `sepBy1` comma <*-> token DoubleColon <*> type0
-
-> constrDecl :: Bool -> Parser Token ConstrDecl a
-> constrDecl flat = position <**> (existVars <**> constr)
-> where constr = conId <**> identDecl
-> <|> leftParen <-*> parenDecl
-> <|> type1 <\> conId <\> leftParen <**> opDecl
-> identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl)
-> parenDecl = conOpDeclPrefix
-> <$> conSym <*-> rightParen <*> type2 <*> type2
-> <|> tupleType <*-> rightParen <**> opDecl
-> opDecl = conOpDecl <$> conop <*> type1
-> conType f tys c = f (ConstructorType (qualify c) tys)
-> conDecl tys c tvs p = ConstrDecl p tvs c tys
-> conOpDecl op ty2 ty1 tvs p = ConOpDecl p tvs ty1 op ty2
-> conOpDeclPrefix op ty1 ty2 tvs p = ConOpDecl p tvs ty1 op ty2
-
-> newConstrDecl :: Parser Token NewConstrDecl a
-> newConstrDecl =
-> NewConstrDecl <$> position <*> existVars <*> con <*> type2
-
-> existVars :: Parser Token [Ident] a
-> {-
-> existVars flat
-> | flat = succeed []
-> | otherwise = token Id_forall <-*> many1 tyvar <*-> dot `opt` []
-> -}
-> existVars = succeed []
-
-> functionDecl :: Bool -> Parser Token Decl a
-> functionDecl flat = position <**> decl
-> where decl = fun `sepBy1` comma <**> funListDecl flat
-> <|?> funDecl <$> lhs <*> declRhs flat
-> lhs = (\f -> (f,FunLhs f [])) <$> fun
-> <|?> funLhs
-
-> valueDecl :: Bool -> Parser Token Decl a
-> valueDecl flat = position <**> decl
-> where decl = var `sepBy1` comma <**> valListDecl flat
-> <|?> valDecl <$> constrTerm0 <*> declRhs flat
-> <|?> funDecl <$> curriedLhs <*> declRhs flat
-> valDecl t@(ConstructorPattern c ts)
-> | not (isConstrId c) = funDecl (f,FunLhs f ts)
-> where f = unqualify c
-> valDecl t = opDecl id t
-> opDecl f (InfixPattern t1 op t2)
-> | isConstrId op = opDecl (f . InfixPattern t1 op) t2
-> | otherwise = funDecl (op',OpLhs (f t1) op' t2)
-> where op' = unqualify op
-> opDecl f t = patDecl (f t)
-> isConstrId c = c == qConsId || isQualified c || isQTupleId c
-
-> funDecl :: (Ident,Lhs) -> Rhs -> Position -> Decl
-> funDecl (f,lhs) rhs p = FunctionDecl p f [Equation p lhs rhs]
-
-> patDecl :: ConstrTerm -> Rhs -> Position -> Decl
-> patDecl t rhs p = PatternDecl p t rhs
-
-> funListDecl :: Bool -> Parser Token ([Ident] -> Position -> Decl) a
-> funListDecl flat
-> | flat = typeSig <$-> token DoubleColon <*> type0
-> <|> evalAnnot <$-> token KW_eval <*> tokenOps evalKW
-> <|> externalDecl <$-> token KW_external
-> | otherwise = typeSig <$-> token DoubleColon <*> type0
-> <|> evalAnnot <$-> token KW_eval <*> tokenOps evalKW
-> where typeSig ty vs p = TypeSig p vs ty
-> evalAnnot ev vs p = EvalAnnot p vs ev
-> evalKW = [(KW_rigid,EvalRigid),(KW_choice,EvalChoice)]
-> externalDecl vs p = FlatExternalDecl p vs
-
-> valListDecl :: Bool -> Parser Token ([Ident] -> Position -> Decl) a
-> valListDecl flat = funListDecl flat <|> extraVars <$-> token KW_free
-> where extraVars vs p = ExtraVariables p vs
-
-> funLhs :: Parser Token (Ident,Lhs) a
-> funLhs = funLhs <$> fun <*> many1 constrTerm2
-> <|?> flip ($ id) <$> constrTerm1 <*> opLhs'
-> <|?> curriedLhs
-> where opLhs' = opLhs <$> funSym <*> constrTerm0
-> <|> infixPat <$> gConSym <\> funSym <*> constrTerm1 <*> opLhs'
-> <|> backquote <-*> opIdLhs
-> opIdLhs = opLhs <$> funId <*-> checkBackquote <*> constrTerm0
-> <|> infixPat <$> qConId <\> funId <*-> backquote <*> constrTerm1
-> <*> opLhs'
-> funLhs f ts = (f,FunLhs f ts)
-> opLhs op t2 f t1 = (op,OpLhs (f t1) op t2)
-> infixPat op t2 f g t1 = f (g . InfixPattern t1 op) t2
-
-> curriedLhs :: Parser Token (Ident,Lhs) a
-> curriedLhs = apLhs <$> parens funLhs <*> many1 constrTerm2
-> where apLhs (f,lhs) ts = (f,ApLhs lhs ts)
-
-> declRhs :: Bool -> Parser Token Rhs a
-> declRhs flat = rhs flat equals
-
-> rhs :: Bool -> Parser Token a b -> Parser Token Rhs b
-> rhs flat eq = rhsExpr <*> localDefs flat
-> where rhsExpr = SimpleRhs <$-> eq <*> position <*> expr flat
-> <|> GuardedRhs <$> many1 (condExpr flat eq)
-
-> externalDecl :: Parser Token Decl a
-> externalDecl =
-> ExternalDecl <$> position <*-> token KW_external
-> <*> callConv <*> (Just <$> string `opt` Nothing)
-> <*> fun <*-> token DoubleColon <*> type0
-> where callConv = CallConvPrimitive <$-> token Id_primitive
-> <|> CallConvCCall <$-> token Id_ccall
-> "Unsupported calling convention"
-
-\end{verbatim}
-\paragraph{Interface declarations}
-\begin{verbatim}
-
-> --intfDecls :: Parser Token [IDecl] a
-> --intfDecls = (:) <$> iImportDecl <*> (semicolon <-*> intfDecls `opt` [])
-> -- <|> intfDecl `sepBy` semicolon
-
-> --intfDecl :: Parser Token IDecl a
-> --intfDecl = iInfixDecl
-> -- <|> iHidingDecl <|> iDataDecl <|> iNewtypeDecl <|> iTypeDecl
-> -- <|> iFunctionDecl <\> token Id_hiding
-
-> --iImportDecl :: Parser Token IDecl a
-> --iImportDecl = IImportDecl <$> position <*-> token KW_import <*> mIdent
-
-> --iInfixDecl :: Parser Token IDecl a
-> --iInfixDecl = infixDeclLhs IInfixDecl <*> qfunop
-
-> --iHidingDecl :: Parser Token IDecl a
-> --iHidingDecl = position <*-> token Id_hiding <**> (dataDecl <|> funcDecl)
-> -- where dataDecl = hiddenData <$-> token KW_data <*> tycon <*> many tyvar
-> -- funcDecl = hidingFunc <$-> token DoubleColon <*> type0
-> -- hiddenData tc tvs p = HidingDataDecl p tc tvs
-> -- hidingFunc ty p = IFunctionDecl p hidingId ty
-> -- hidingId = qualify (mkIdent "hiding")
-
-> --iDataDecl :: Parser Token IDecl a
-> --iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs
-> -- where constrs = equals <-*> iConstrDecl `sepBy1` bar
-> -- `opt` []
-> -- iConstrDecl = Just <$> constrDecl False <\> token Underscore
-> -- <|> Nothing <$-> token Underscore
-
-> --iNewtypeDecl :: Parser Token IDecl a
-> --iNewtypeDecl =
-> -- iTypeDeclLhs INewtypeDecl KW_newtype <*-> equals <*> newConstrDecl
-
-> --iTypeDecl :: Parser Token IDecl a
-> --iTypeDecl = iTypeDeclLhs ITypeDecl KW_type <*-> equals <*> type0
-
-> --iTypeDeclLhs :: (Position -> QualIdent -> [Ident] -> a) -> Category
-> -- -> Parser Token a b
-> --iTypeDeclLhs f kw = f <$> position <*-> token kw <*> qtycon <*> many tyvar
-
-> --iFunctionDecl :: Parser Token IDecl a
-> --iFunctionDecl = IFunctionDecl <$> position <*> qfun <*-> token DoubleColon
-> -- <*> type0
-
-\end{verbatim}
-\paragraph{Types}
-\begin{verbatim}
-
-> type0 :: Parser Token TypeExpr a
-> type0 = type1 `chainr1` (ArrowType <$-> token RightArrow)
-
-> type1 :: Parser Token TypeExpr a
-> type1 = ConstructorType <$> qtycon <*> many type2
-> <|> type2 <\> qtycon
-
-> type2 :: Parser Token TypeExpr a
-> type2 = anonType <|> identType <|> parenType <|> listType
-
-> anonType :: Parser Token TypeExpr a
-> anonType = VariableType anonId <$-> token Underscore
-
-> identType :: Parser Token TypeExpr a
-> identType = VariableType <$> tyvar
-> <|> flip ConstructorType [] <$> qtycon <\> tyvar
-
-> parenType :: Parser Token TypeExpr a
-> parenType = parens tupleType
-
-> tupleType :: Parser Token TypeExpr a
-> tupleType = type0 (tuple <$> many1 (comma <-*> type0))
-> `opt` TupleType []
-> where tuple tys ty = TupleType (ty:tys)
-
-> listType :: Parser Token TypeExpr a
-> listType = ListType <$> brackets type0
-
-\end{verbatim}
-\paragraph{Literals}
-\begin{verbatim}
-
-> literal :: Parser Token Literal a
-> literal = mk Char <$> char
-> <|> mkInt <$> integer
-> <|> mk Float <$> float
-> <|> mk String <$> string
-
-\end{verbatim}
-\paragraph{Patterns}
-\begin{verbatim}
-
-> constrTerm0 :: Parser Token ConstrTerm a
-> constrTerm0 = constrTerm1 `chainr1` (flip InfixPattern <$> gconop)
-
-> constrTerm1 :: Parser Token ConstrTerm a
-> constrTerm1 = varId <**> identPattern
-> <|> ConstructorPattern <$> qConId <\> varId <*> many constrTerm2
-> <|> minus <**> negNum
-> <|> fminus <**> negFloat
-> <|> leftParen <-*> parenPattern
-> <|> constrTerm2 <\> qConId <\> leftParen
-> where identPattern = optAsPattern
-> <|> conPattern <$> many1 constrTerm2
-> parenPattern = minus <**> minusPattern negNum
-> <|> fminus <**> minusPattern negFloat
-> <|> gconPattern
-> <|> funSym <\> minus <\> fminus <*-> rightParen
-> <**> identPattern
-> <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen
-> minusPattern p = rightParen <-*> identPattern
-> <|> parenMinusPattern p <*-> rightParen
-> gconPattern = ConstructorPattern <$> gconId <*-> rightParen
-> <*> many constrTerm2
-> conPattern ts = flip ConstructorPattern ts . qualify
-
-> constrTerm2 :: Parser Token ConstrTerm a
-> constrTerm2 = literalPattern <|> anonPattern <|> identPattern
-> <|> parenPattern <|> listPattern <|> lazyPattern
-> <|> recordPattern
-
-> literalPattern :: Parser Token ConstrTerm a
-> literalPattern = LiteralPattern <$> literal
-
-> anonPattern :: Parser Token ConstrTerm a
-> anonPattern = VariablePattern anonId <$-> token Underscore
-
-> identPattern :: Parser Token ConstrTerm a
-> identPattern = varId <**> optAsPattern
-> <|> flip ConstructorPattern [] <$> qConId <\> varId
-
-> parenPattern :: Parser Token ConstrTerm a
-> parenPattern = leftParen <-*> parenPattern
-> where parenPattern = minus <**> minusPattern negNum
-> <|> fminus <**> minusPattern negFloat
-> <|> flip ConstructorPattern [] <$> gconId <*-> rightParen
-> <|> funSym <\> minus <\> fminus <*-> rightParen
-> <**> optAsPattern
-> <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen
-> minusPattern p = rightParen <-*> optAsPattern
-> <|> parenMinusPattern p <*-> rightParen
-
-> listPattern :: Parser Token ConstrTerm a
-> listPattern = mk' ListPattern <$> brackets (constrTerm0 `sepBy` comma)
-
-> lazyPattern :: Parser Token ConstrTerm a
-> lazyPattern = mk LazyPattern <$-> token Tilde <*> constrTerm2
-
-> recordPattern :: Parser Token ConstrTerm a
-> recordPattern = layoutOff <-*> braces content
-> where
-> content = RecordPattern <$> fields <*> record
-> fields = fieldPatt `sepBy` comma
-> fieldPatt = Field <$> position <*> labId <*-> checkEquals <*> constrTerm0
-> record = Just <$-> checkBar <*> constrTerm2 `opt` Nothing
-
-\end{verbatim}
-Partial patterns used in the combinators above, but also for parsing
-the left-hand side of a declaration.
-\begin{verbatim}
-
-> gconId :: Parser Token QualIdent a
-> gconId = colon <|> tupleCommas
-
-> negNum,negFloat :: Parser Token (Ident -> ConstrTerm) a
-> negNum = flip NegativePattern
-> <$> (mkInt <$> integer <|> mk Float <$> float)
-> negFloat = flip NegativePattern . mk Float
-> <$> (fromIntegral <$> integer <|> float)
-
-> optAsPattern :: Parser Token (Ident -> ConstrTerm) a
-> optAsPattern = flip AsPattern <$-> token At <*> constrTerm2
-> `opt` VariablePattern
-
-> optInfixPattern :: Parser Token (ConstrTerm -> ConstrTerm) a
-> optInfixPattern = infixPat <$> gconop <*> constrTerm0
-> `opt` id
-> where infixPat op t2 t1 = InfixPattern t1 op t2
-
-> optTuplePattern :: Parser Token (ConstrTerm -> ConstrTerm) a
-> optTuplePattern = tuple <$> many1 (comma <-*> constrTerm0)
-> `opt` ParenPattern
-> where tuple ts t = mk TuplePattern (t:ts)
-
-> parenMinusPattern :: Parser Token (Ident -> ConstrTerm) a
-> -> Parser Token (Ident -> ConstrTerm) a
-> parenMinusPattern p = p <.> optInfixPattern <.> optTuplePattern
-
-> parenTuplePattern :: Parser Token ConstrTerm a
-> parenTuplePattern = constrTerm0 <**> optTuplePattern
-> `opt` mk TuplePattern []
-
-\end{verbatim}
-\paragraph{Expressions}
-\begin{verbatim}
-
-> condExpr :: Bool -> Parser Token a b -> Parser Token CondExpr b
-> condExpr flat eq =
-> CondExpr <$> position <*-> bar <*> expr0 flat <*-> eq <*> expr flat
-
-> expr :: Bool -> Parser Token Expression a
-> expr flat = expr0 flat (flip Typed <$-> token DoubleColon <*> type0)
-
-> expr0 :: Bool -> Parser Token Expression a
-> expr0 flat = expr1 flat `chainr1` (flip InfixApply <$> infixOp)
-
-> expr1 :: Bool -> Parser Token Expression a
-> expr1 flat = UnaryMinus <$> (minus <|> fminus) <*> expr2 flat
-> <|> expr2 flat
-
-> expr2 :: Bool -> Parser Token Expression a
-> expr2 flat = lambdaExpr flat <|> letExpr flat <|> doExpr flat
-> <|> ifExpr flat <|> caseExpr flat
-> <|> expr3 flat <**> applicOrSelect
-> where
-> applicOrSelect = flip RecordSelection
-> <$-> (token RightArrow "-> expected")
-> <*> labId
-> <|?> (\es e -> foldl1 Apply (e:es))
-> <$> many (expr3 flat)
-
-> expr3 :: Bool -> Parser Token Expression a
-> expr3 flat = expr3'
-> where
-> expr3' = constant <|> variable <|> parenExpr flat
-> <|> listExpr flat <|> recordExpr flat
-
-> constant :: Parser Token Expression a
-> constant = Literal <$> literal
-
-> variable :: Parser Token Expression a
-> variable = Variable <$> qFunId
-
-> parenExpr :: Bool -> Parser Token Expression a
-> parenExpr flat = parens pExpr
-> where pExpr = (minus <|> fminus) <**> minusOrTuple
-> <|> Constructor <$> tupleCommas
-> <|> leftSectionOrTuple <\> minus <\> fminus
-> <|> opOrRightSection <\> minus <\> fminus
-> `opt` mk Tuple []
-> minusOrTuple = flip UnaryMinus <$> expr1 flat <.> infixOrTuple
-> `opt` Variable . qualify
-> leftSectionOrTuple = expr1 flat <**> infixOrTuple
-> infixOrTuple = ($ id) <$> infixOrTuple'
-> infixOrTuple' = infixOp <**> leftSectionOrExp
-> <|> (.) <$> (optType <.> tupleExpr)
-> leftSectionOrExp = expr1 flat <**> (infixApp <$> infixOrTuple')
-> `opt` leftSection
-> optType = flip Typed <$-> token DoubleColon <*> type0
-> `opt` id
-> tupleExpr = tuple <$> many1 (comma <-*> expr flat)
-> `opt` Paren
-> opOrRightSection = qFunSym <**> optRightSection
-> <|> colon <**> optCRightSection
-> <|> infixOp <\> colon <\> qFunSym <**> rightSection
-> optRightSection = (. InfixOp) <$> rightSection `opt` Variable
-> optCRightSection = (. InfixConstr) <$> rightSection `opt` Constructor
-> rightSection = flip RightSection <$> expr0 flat
-> infixApp f e2 op g e1 = f (g . InfixApply e1 op) e2
-> leftSection op f e = LeftSection (f e) op
-> tuple es e = mk Tuple (e:es)
-
-> infixOp :: Parser Token InfixOp a
-> infixOp = InfixOp <$> qfunop
-> <|> InfixConstr <$> colon
-
-> listExpr :: Bool -> Parser Token Expression a
-> listExpr flat = brackets (elements `opt` mk' List [])
-> where elements = expr flat <**> rest
-> rest = comprehension
-> <|> enumeration (flip EnumFromTo) EnumFrom
-> <|> comma <-*> expr flat <**>
-> (enumeration (flip3 EnumFromThenTo) (flip EnumFromThen)
-> <|> list <$> many (comma <-*> expr flat))
-> `opt` (\e -> mk' List [e])
-> comprehension = flip (mk ListCompr) <$-> bar <*> quals flat
-> enumeration enumTo enum =
-> token DotDot <-*> (enumTo <$> expr flat `opt` enum)
-> list es e2 e1 = mk' List (e1:e2:es)
-> flip3 f x y z = f z y x
-
-> recordExpr :: Bool -> Parser Token Expression a
-> recordExpr flat = layoutOff <-*> braces content
-> where content = RecordConstr <$> fieldConstr `sepBy` comma
-> <|?> RecordUpdate <$> fieldUpdate `sepBy` comma
-> <*-> checkBar <*> expr flat
-> fieldConstr = Field <$> position <*> labId
-> <*-> checkEquals <*> expr flat
-> fieldUpdate = Field <$> position <*> labId
-> <*-> checkBinds <*> expr flat
-
-> lambdaExpr :: Bool -> Parser Token Expression a
-> lambdaExpr flat =
-> mk Lambda <$-> token Backslash <*> many1 constrTerm2
-> <*-> (token RightArrow "-> expected") <*> expr flat
-
-> letExpr :: Bool -> Parser Token Expression a
-> letExpr flat = Let <$-> token KW_let <*> layout (valueDecls flat)
-> <*-> (token KW_in "in expected") <*> expr flat
-
-> doExpr :: Bool -> Parser Token Expression a
-> doExpr flat = uncurry Do <$-> token KW_do <*> layout (stmts flat)
-
-> ifExpr :: Bool -> Parser Token Expression a
-> ifExpr flat =
-> mk IfThenElse <$-> token KW_if <*> expr flat
-> <*-> (token KW_then "then expected") <*> expr flat
-> <*-> (token KW_else "else expected") <*> expr flat
-
-> caseExpr :: Bool -> Parser Token Expression a
-> caseExpr flat = mk Case <$-> token KW_case <*> expr flat
-> <*-> (token KW_of "of expected") <*> layout (alts flat)
-
-> alts :: Bool -> Parser Token [Alt] a
-> alts flat = alt flat `sepBy1` semicolon
-
-> alt :: Bool -> Parser Token Alt a
-> alt flat = Alt <$> position <*> constrTerm0
-> <*> rhs flat (token RightArrow "-> expected")
-
-\end{verbatim}
-\paragraph{Statements in list comprehensions and \texttt{do} expressions}
-Parsing statements is a bit difficult because the syntax of patterns
-and expressions largely overlaps. The parser will first try to
-recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement
-and if this fails fall back into parsing an expression statement. In
-addition, we have to be prepared that the sequence
-\texttt{let}~\emph{LocalDefs} can be either a let-statement or the
-prefix of a let expression.
-\begin{verbatim}
-
-> stmts :: Bool -> Parser Token ([Statement],Expression) a
-> stmts flat = stmt flat (reqStmts flat) (optStmts flat)
-
-> reqStmts :: Bool -> Parser Token (Statement -> ([Statement],Expression)) a
-> reqStmts flat = (\(sts,e) st -> (st : sts,e)) <$-> semicolon <*> stmts flat
-
-> optStmts :: Bool -> Parser Token (Expression -> ([Statement],Expression)) a
-> optStmts flat = succeed (mk StmtExpr) <.> reqStmts flat
-> `opt` (,) []
-
-> quals :: Bool -> Parser Token [Statement] a
-> quals flat = stmt flat (succeed id) (succeed $ mk StmtExpr) `sepBy1` comma
-
-> stmt :: Bool -> Parser Token (Statement -> a) b
-> -> Parser Token (Expression -> a) b -> Parser Token a b
-> stmt flat stmtCont exprCont = letStmt flat stmtCont exprCont
-> <|> exprOrBindStmt flat stmtCont exprCont
-
-> letStmt :: Bool -> Parser Token (Statement -> a) b
-> -> Parser Token (Expression -> a) b -> Parser Token a b
-> letStmt flat stmtCont exprCont =
-> token KW_let <-*> layout (valueDecls flat) <**> optExpr
-> where optExpr = flip Let <$-> token KW_in <*> expr flat <.> exprCont
-> <|> succeed StmtDecl <.> stmtCont
-
-> exprOrBindStmt :: Bool -> Parser Token (Statement -> a) b
-> -> Parser Token (Expression -> a) b
-> -> Parser Token a b
-> exprOrBindStmt flat stmtCont exprCont =
-> mk StmtBind <$> constrTerm0 <*-> leftArrow <*> expr flat <**> stmtCont
-> <|?> expr flat <\> token KW_let <**> exprCont
-
-\end{verbatim}
-\paragraph{Literals, identifiers, and (infix) operators}
-\begin{verbatim}
-
-> char :: Parser Token Char a
-> char = cval <$> token CharTok
-
-> int, checkInt :: Parser Token Int a
-> int = ival <$> token IntTok
-> checkInt = int "integer number expected"
-
-> float, checkFloat :: Parser Token Double a
-> float = fval <$> token FloatTok
-> checkFloat = float "floating point number expected"
-
-> integer, checkInteger :: Parser Token Integer a
-> integer = intval <$> token IntegerTok
-> checkInteger = integer "integer number expected"
-
-> string :: Parser Token String a
-> string = sval <$> token StringTok
-
-> tycon, tyvar :: Parser Token Ident a
-> tycon = conId
-> tyvar = varId
-
-> qtycon :: Parser Token QualIdent a
-> qtycon = qConId
-
-> varId, funId, conId, labId :: Parser Token Ident a
-> varId = ident
-> funId = ident
-> conId = ident
-> labId = renameLabel <$> ident
-
-> funSym, conSym :: Parser Token Ident a
-> funSym = sym
-> conSym = sym
-
-> var, fun, con :: Parser Token Ident a
-> var = varId <|> parens (funSym "operator symbol expected")
-> fun = funId <|> parens (funSym "operator symbol expected")
-> con = conId <|> parens (conSym "operator symbol expected")
-
-> funop, conop :: Parser Token Ident a
-> funop = funSym <|> backquotes (funId "operator name expected")
-> conop = conSym <|> backquotes (conId "operator name expected")
-
-> qFunId, qConId, qLabId :: Parser Token QualIdent a
-> qFunId = qIdent
-> qConId = qIdent
-> qLabId = qIdent
-
-> qFunSym, qConSym :: Parser Token QualIdent a
-> qFunSym = qSym
-> qConSym = qSym
-> gConSym = qConSym <|> colon
-
-> qfun, qcon :: Parser Token QualIdent a
-> qfun = qFunId <|> parens (qFunSym "operator symbol expected")
-> qcon = qConId <|> parens (qConSym "operator symbol expected")
-
-> qfunop, qconop, gconop :: Parser Token QualIdent a
-> qfunop = qFunSym <|> backquotes (qFunId "operator name expected")
-> qconop = qConSym <|> backquotes (qConId "operator name expected")
-> gconop = gConSym <|> backquotes (qConId "operator name expected")
-
-> ident :: Parser Token Ident a
-> ident = (\ pos t -> mkIdentPosition pos $ sval t) <$> position <*>
-> tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,
-> Id_interface,Id_primitive,Id_qualified]
-
-> qIdent :: Parser Token QualIdent a
-> qIdent = qualify <$> ident <|> mkQIdent <$> position <*> token QId
-> where mkQIdent p a = qualifyWith (mkMIdent (modul a))
-> (mkIdentPosition p (sval a))
-
-> mIdent :: Parser Token ModuleIdent a
-> mIdent = mIdent <$> position <*>
-> tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,
-> Id_interface,Id_primitive,Id_qualified]
-> where mIdent p a = addPositionModuleIdent p $
-> mkMIdent (modul a ++ [sval a])
-
-> sym :: Parser Token Ident a
-> sym = (\ pos t -> mkIdentPosition pos $ sval t) <$> position <*>
-> tokens [Sym,Sym_Dot,Sym_Minus,Sym_MinusDot]
-
-> qSym :: Parser Token QualIdent a
-> qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym
-> where mkQIdent p a = qualifyWith (mkMIdent (modul a))
-> (mkIdentPosition p (sval a))
-
-> colon :: Parser Token QualIdent a
-> colon = (\ p _ -> qualify $ addPositionIdent p consId) <$>
-> position <*> token Colon
-
-> minus :: Parser Token Ident a
-> minus = (\ p _ -> addPositionIdent p minusId) <$>
-> position <*> token Sym_Minus
-
-> fminus :: Parser Token Ident a
-> fminus = (\ p _ -> addPositionIdent p fminusId) <$>
-> position <*> token Sym_MinusDot
-
-> tupleCommas :: Parser Token QualIdent a
-> tupleCommas = (\ p str -> qualify $
-> addPositionIdent p (tupleId $
-> (1 + ) $
-> length str))
-> <$> position <*> many1 comma
-
-\end{verbatim}
-\paragraph{Layout}
-\begin{verbatim}
-
-> layout :: Parser Token a b -> Parser Token a b
-> layout p = layoutOff <-*> bracket leftBraceSemicolon p rightBrace
-> <|> layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd)
-
-\end{verbatim}
-\paragraph{More combinators}
-\begin{verbatim}
-
-> braces, brackets, parens, backquotes :: Parser Token a b -> Parser Token a b
-> braces p = bracket leftBrace p rightBrace
-> brackets p = bracket leftBracket p rightBracket
-> parens p = bracket leftParen p rightParen
-> backquotes p = bracket backquote p checkBackquote
-
-\end{verbatim}
-\paragraph{Simple token parsers}
-\begin{verbatim}
-
-> token :: Category -> Parser Token Attributes a
-> token c = attr <$> symbol (Token c NoAttributes)
-> where attr (Token _ a) = a
-
-> tokens :: [Category] -> Parser Token Attributes a
-> tokens cs = foldr1 (<|>) (map token cs)
-
-> tokenOps :: [(Category,a)] -> Parser Token a b
-> tokenOps cs = ops [(Token c NoAttributes,x) | (c,x) <- cs]
-
-> dot, comma, semicolon, bar, equals, binds :: Parser Token Attributes a
-> dot = token Sym_Dot
-> comma = token Comma
-> semicolon = token Semicolon <|> token VSemicolon
-> bar = token Bar
-> equals = token Equals
-> binds = token Binds
-
-> checkBar, checkEquals, checkBinds :: Parser Token Attributes a
-> checkBar = bar "| expected"
-> checkEquals = equals "= expected"
-> checkBinds = binds ":= expected"
-
-> backquote, checkBackquote :: Parser Token Attributes a
-> backquote = token Backquote
-> checkBackquote = backquote "backquote (`) expected"
-
-> leftParen, rightParen :: Parser Token Attributes a
-> leftParen = token LeftParen
-> rightParen = token RightParen
-
-> leftBracket, rightBracket :: Parser Token Attributes a
-> leftBracket = token LeftBracket
-> rightBracket = token RightBracket
-
-> leftBrace, leftBraceSemicolon, rightBrace :: Parser Token Attributes a
-> leftBrace = token LeftBrace
-> leftBraceSemicolon = token LeftBraceSemicolon
-> rightBrace = token RightBrace
-
-> leftArrow :: Parser Token Attributes a
-> leftArrow = token LeftArrow
-
-\end{verbatim}
-\paragraph{Ident}
-\begin{verbatim}
-
-> mkIdentPosition :: Position -> String -> Ident
-> mkIdentPosition pos str = addPositionIdent pos $ mkIdent str
-
-\end{verbatim}
diff --git a/src/CurrySyntax.lhs b/src/CurrySyntax.lhs
deleted file mode 100644
--- a/src/CurrySyntax.lhs
+++ /dev/null
@@ -1,323 +0,0 @@
-> {-# LANGUAGE DeriveDataTypeable #-}
-
-% $Id: CurrySyntax.lhs,v 1.43 2004/02/15 22:10:31 wlux Exp $
-%
-% Copyright (c) 1999-2004, Wolfgang Lux
-% See LICENSE for the full license.
-%
-% Modified by Martin Engelke (men@informatik.uni-kiel.de)
-%
-\nwfilename{CurrySyntax.lhs}
-\section{The Parse Tree}
-This module provides the necessary data structures to maintain the
-parsed representation of a Curry program.
-
-\em{Note:} this modified version uses haskell type \texttt{Integer}
-instead of \texttt{Int} for representing integer values. This allows
-an unlimited range of integer constants in Curry programs.
-\begin{verbatim}
-
-> module CurrySyntax where
-> import Ident
-> import Position
-> import Data.Generics
-> import Control.Monad.State
-
-\end{verbatim}
-\paragraph{Modules}
-\begin{verbatim}
-
-> data Module = Module ModuleIdent (Maybe ExportSpec) [Decl]
-> deriving (Eq,Show,Read,Typeable,Data)
-
-> data ExportSpec = Exporting Position [Export] deriving (Eq,Show,Read,Typeable,Data)
-> data Export =
-> Export QualIdent -- f/T
-> | ExportTypeWith QualIdent [Ident] -- T(C1,...,Cn)
-> | ExportTypeAll QualIdent -- T(..)
-> | ExportModule ModuleIdent
-> deriving (Eq,Show,Read,Typeable,Data)
-
-\end{verbatim}
-\paragraph{Module declarations}
-\begin{verbatim}
-
-> data ImportSpec =
-> Importing Position [Import]
-> | Hiding Position [Import]
-> deriving (Eq,Show,Read,Typeable,Data)
-> data Import =
-> Import Ident -- f/T
-> | ImportTypeWith Ident [Ident] -- T(C1,...,Cn)
-> | ImportTypeAll Ident -- T(..)
-> deriving (Eq,Show,Read,Typeable,Data)
-
-> data Decl =
-> ImportDecl Position ModuleIdent Qualified (Maybe ModuleIdent)
-> (Maybe ImportSpec)
-> | InfixDecl Position Infix Integer [Ident]
-> | DataDecl Position Ident [Ident] [ConstrDecl]
-> | NewtypeDecl Position Ident [Ident] NewConstrDecl
-> | TypeDecl Position Ident [Ident] TypeExpr
-> | TypeSig Position [Ident] TypeExpr
-> | EvalAnnot Position [Ident] EvalAnnotation
-> | FunctionDecl Position Ident [Equation]
-> | ExternalDecl Position CallConv (Maybe String) Ident TypeExpr
-> | FlatExternalDecl Position [Ident]
-> | PatternDecl Position ConstrTerm Rhs
-> | ExtraVariables Position [Ident]
-> deriving (Eq,Show,Read,Typeable,Data)
-
-> data ConstrDecl =
-> ConstrDecl Position [Ident] Ident [TypeExpr]
-> | ConOpDecl Position [Ident] TypeExpr Ident TypeExpr
-> deriving (Eq,Show,Read,Typeable,Data)
-> data NewConstrDecl =
-> NewConstrDecl Position [Ident] Ident TypeExpr
-> deriving (Eq,Show,Read,Typeable,Data)
-
-> type Qualified = Bool
-> data Infix = InfixL | InfixR | Infix deriving (Eq,Show,Read,Typeable,Data)
-> data EvalAnnotation = EvalRigid | EvalChoice deriving (Eq,Show,Read,Typeable,Data)
-> data CallConv = CallConvPrimitive | CallConvCCall deriving (Eq,Show,Read,Typeable,Data)
-
-\end{verbatim}
-\paragraph{Module interfaces}
-Interface declarations are restricted to type declarations and signatures.
-Note that an interface function declaration additionaly contains the
-function arity (= number of parameters) in order to generate
-correct FlatCurry function applications.
-\begin{verbatim}
-
-> data Interface = Interface ModuleIdent [IDecl] deriving (Eq,Show,Read,Typeable,Data)
-
-> data IDecl =
-> IImportDecl Position ModuleIdent
-> | IInfixDecl Position Infix Integer QualIdent
-> | HidingDataDecl Position Ident [Ident]
-> | IDataDecl Position QualIdent [Ident] [Maybe ConstrDecl]
-> | INewtypeDecl Position QualIdent [Ident] NewConstrDecl
-> | ITypeDecl Position QualIdent [Ident] TypeExpr
-> | IFunctionDecl Position QualIdent Int TypeExpr
-> deriving (Eq,Show,Read,Typeable,Data)
-
-\end{verbatim}
-\paragraph{Types}
-\begin{verbatim}
-
-> data TypeExpr =
-> ConstructorType QualIdent [TypeExpr]
-> | VariableType Ident
-> | TupleType [TypeExpr]
-> | ListType TypeExpr
-> | ArrowType TypeExpr TypeExpr
-> | RecordType [([Ident],TypeExpr)] (Maybe TypeExpr)
-> -- {l1 :: t1,...,ln :: tn | r}
-> deriving (Eq,Show,Read,Typeable,Data)
-
-\end{verbatim}
-\paragraph{Functions}
-\begin{verbatim}
-
-> data Equation = Equation Position Lhs Rhs deriving (Eq,Show,Read,Typeable,Data)
-> data Lhs =
-> FunLhs Ident [ConstrTerm]
-> | OpLhs ConstrTerm Ident ConstrTerm
-> | ApLhs Lhs [ConstrTerm]
-> deriving (Eq,Show,Read,Typeable,Data)
-> data Rhs =
-> SimpleRhs Position Expression [Decl]
-> | GuardedRhs [CondExpr] [Decl]
-> deriving (Eq,Show,Read,Typeable,Data)
-> data CondExpr = CondExpr Position Expression Expression deriving (Eq,Show,Read,Typeable,Data)
-
-> flatLhs :: Lhs -> (Ident,[ConstrTerm])
-> flatLhs lhs = flat lhs []
-> where flat (FunLhs f ts) ts' = (f,ts ++ ts')
-> flat (OpLhs t1 op t2) ts = (op,t1:t2:ts)
-> flat (ApLhs lhs ts) ts' = flat lhs (ts ++ ts')
-
-\end{verbatim}
-\paragraph{Literals} The \texttt{Ident} argument of an \texttt{Int}
-literal is used for supporting ad-hoc polymorphism on integer
-numbers. An integer literal can be used either as an integer number or
-as a floating-point number depending on its context. The compiler uses
-the identifier of the \texttt{Int} literal for maintaining its type.
-\begin{verbatim}
-
-> data Literal =
-> Char SrcRef Char -- should be Int to handle Unicode
-> | Int Ident Integer
-> | Float SrcRef Double
-> | String SrcRef String -- should be [Int] to handle Unicode
-> deriving (Eq,Show,Read,Typeable,Data)
-
-> mk' :: ([SrcRef] -> a) -> a
-> mk' = ($[])
-
-> mk :: (SrcRef -> a) -> a
-> mk = ($noRef)
-
-> mkInt :: Integer -> Literal
-> mkInt i = mk (\r -> Int (addPositionIdent (AST r) anonId) i)
-
-\end{verbatim}
-\paragraph{Patterns}
-\begin{verbatim}
-
-> data ConstrTerm =
-> LiteralPattern Literal
-> | NegativePattern Ident Literal
-> | VariablePattern Ident
-> | ConstructorPattern QualIdent [ConstrTerm]
-> | InfixPattern ConstrTerm QualIdent ConstrTerm
-> | ParenPattern ConstrTerm
-> | TuplePattern SrcRef [ConstrTerm]
-> | ListPattern [SrcRef] [ConstrTerm]
-> | AsPattern Ident ConstrTerm
-> | LazyPattern SrcRef ConstrTerm
-> | FunctionPattern QualIdent [ConstrTerm]
-> | InfixFuncPattern ConstrTerm QualIdent ConstrTerm
-> | RecordPattern [Field ConstrTerm] (Maybe ConstrTerm)
-> -- {l1 = p1, ..., ln = pn} oder {l1 = p1, ..., ln = pn | p}
-> deriving (Eq,Show,Read,Typeable,Data)
-
-\end{verbatim}
-\paragraph{Expressions}
-\begin{verbatim}
-
-> data Expression =
-> Literal Literal
-> | Variable QualIdent
-> | Constructor QualIdent
-> | Paren Expression
-> | Typed Expression TypeExpr
-> | Tuple SrcRef [Expression]
-> | List [SrcRef] [Expression]
-> | ListCompr SrcRef Expression [Statement] -- the ref corresponds to the main list
-> | EnumFrom Expression
-> | EnumFromThen Expression Expression
-> | EnumFromTo Expression Expression
-> | EnumFromThenTo Expression Expression Expression
-> | UnaryMinus Ident Expression
-> | Apply Expression Expression
-> | InfixApply Expression InfixOp Expression
-> | LeftSection Expression InfixOp
-> | RightSection InfixOp Expression
-> | Lambda SrcRef [ConstrTerm] Expression
-> | Let [Decl] Expression
-> | Do [Statement] Expression
-> | IfThenElse SrcRef Expression Expression Expression
-> | Case SrcRef Expression [Alt]
-> | RecordConstr [Field Expression] -- {l1 = e1,...,ln = en}
-> | RecordSelection Expression Ident -- e -> l
-> | RecordUpdate [Field Expression] Expression -- {l1 := e1,...,ln := en | e}
-> deriving (Eq,Show,Read,Typeable,Data)
-
-> data InfixOp = InfixOp QualIdent | InfixConstr QualIdent deriving (Eq,Show,Read,Typeable,Data)
-
-> data Statement =
-> StmtExpr SrcRef Expression
-> | StmtDecl [Decl]
-> | StmtBind SrcRef ConstrTerm Expression
-> deriving (Eq,Show,Read,Typeable,Data)
-
-> data Alt = Alt Position ConstrTerm Rhs deriving (Eq,Show,Read,Typeable,Data)
-
-> data Field a = Field Position Ident a deriving (Eq, Show,Read,Typeable,Data)
-
-> fieldLabel :: Field a -> Ident
-> fieldLabel (Field _ l _) = l
-
-> fieldTerm :: Field a -> a
-> fieldTerm (Field _ _ t) = t
-
-> field2Tuple :: Field a -> (Ident,a)
-> field2Tuple (Field _ l t) = (l,t)
-
-> opName :: InfixOp -> QualIdent
-> opName (InfixOp op) = op
-> opName (InfixConstr c) = c
-
-\end{verbatim}
-\paragraph{Goals}
-A goal is equivalent to an unconditional right hand side of an equation.
-\begin{verbatim}
-
-> data Goal = Goal Position Expression [Decl] deriving (Eq,Show,Read,Typeable,Data)
-
-\end{verbatim}
-
-> instance SrcRefOf ConstrTerm where
-> srcRefOf (LiteralPattern l) = srcRefOf l
-> srcRefOf (NegativePattern i _) = srcRefOf i
-> srcRefOf (VariablePattern i) = srcRefOf i
-> srcRefOf (ConstructorPattern i _) = srcRefOf i
-> srcRefOf (InfixPattern _ i _) = srcRefOf i
-> srcRefOf (ParenPattern c) = srcRefOf c
-> srcRefOf (TuplePattern s _) = s
-> srcRefOf (ListPattern s _) = error "list pattern has several source refs"
-> srcRefOf (AsPattern i _) = srcRefOf i
-> srcRefOf (LazyPattern s _) = s
-> srcRefOf (FunctionPattern i _) = srcRefOf i
-> srcRefOf (InfixFuncPattern _ i _) = srcRefOf i
-
-> instance SrcRefOf CurrySyntax.Literal where
-> srcRefOf (Char s _) = s
-> srcRefOf (Int i _) = srcRefOf i
-> srcRefOf (Float s _) = s
-> srcRefOf (String s _) = s
-
----------------------------
--- add source references
----------------------------
-
-> type M a = a -> State Int a
->
-> addSrcRefs :: Module -> Module
-> addSrcRefs x = evalState (addRef x) 0
-> where
-> addRef :: Data a' => M a'
-> addRef = down `extM` addRefPos
-> `extM` addRefSrc
-> `extM` addRefIdent
-> `extM` addRefListPat
-> `extM` addRefListExp
-> where
-> down :: Data a' => M a'
-> down = gmapM addRef
->
-> addRefPos :: M [SrcRef]
-> addRefPos _ = liftM (:[]) next
->
-> addRefSrc :: M SrcRef
-> addRefSrc _ = next
->
-> addRefIdent :: M Ident
-> addRefIdent ident = liftM (flip addRefId ident) next
->
-> addRefListPat :: M ConstrTerm
-> addRefListPat (ListPattern _ ts) = do
-> liftM (uncurry ListPattern) (addRefList ts)
-> addRefListPat ct = gmapM addRef ct
->
-> addRefListExp :: M Expression
-> addRefListExp (List _ ts) = do
-> liftM (uncurry List) (addRefList ts)
-> addRefListExp ct = gmapM addRef ct
->
-> addRefList :: Data a' => [a'] -> State Int ([SrcRef],[a'])
-> addRefList ts = do
-> i <- next
-> let add t = do t' <- addRef t;j <- next; return (j,t')
-> ists <- sequence (map add ts)
-> let (is,ts') = unzip ists
-> return (i:is,ts')
->
-> current,next :: State Int SrcRef
-> current = liftM (SrcRef . (:[])) get
->
-> next = do
-> i <- get
-> put $! i+1
-> return (SrcRef [i])
diff --git a/src/Desugar.lhs b/src/Desugar.lhs
--- a/src/Desugar.lhs
+++ b/src/Desugar.lhs
@@ -1,4 +1,3 @@
-
% $Id: Desugar.lhs,v 1.42 2004/02/15 22:10:32 wlux Exp $
%
% Copyright (c) 2001-2004, Wolfgang Lux
@@ -60,19 +59,25 @@
all names must be properly qualified before calling this module.}
\begin{verbatim}
-> module Desugar(desugar,desugarGoal) where
+> module Desugar(desugar) where
> import Data.Maybe
-> import Control.Monad
+> import Control.Arrow(second)
+> import Control.Monad.State as S
> import Data.List
+> import Curry.Base.Position
+> import Curry.Base.Ident
+> import Curry.Syntax.Utils
+> import Curry.Syntax
+
+> import Types
> import Base
-> import Combined
> import Typing
> import Utils
-> import Ident
+
posE = undefined
\end{verbatim}
@@ -84,10 +89,10 @@
variables.
\begin{verbatim}
-> type DesugarState a = StateT ValueEnv (St Int) a
+> type DesugarState a = S.StateT ValueEnv (S.State Int) a
> run :: DesugarState a -> ValueEnv -> a
-> run m tyEnv = runSt (callSt m tyEnv) 1
+> run m tyEnv = S.evalState (S.evalStateT m tyEnv) 1
\end{verbatim}
The desugaring phase keeps only the type, function, and value
@@ -115,90 +120,12 @@
> dss <- mapM (desugarRecordDecl m tcEnv) ds
> let ds' = concat dss
> ds'' <- desugarDeclGroup m tcEnv ds'
-> tyEnv' <- fetchSt
+> tyEnv' <- S.get
> return (filter isTypeDecl ds' ++ ds'', tyEnv')
\end{verbatim}
-While a goal of type \texttt{IO \_} is executed directly by the
-runtime system, all other goals are evaluated under an interactive
-top-level which displays the solutions of the goal and in particular
-the bindings of the free variables. For this reason, the free
-variables declared in the \texttt{where} clause of a goal are
-translated into free variables of the goal. In addition, the goal
-is transformed into a first order expression by performing a
-unification with another variable. Thus, a goal
-\begin{quote}
- \emph{expr}
- \texttt{where} $v_1$,\dots,$v_n$ \texttt{free}; \emph{decls}
-\end{quote}
-where no free variable declarations occur in \emph{decls} is
-translated into the function
-\begin{quote}
- \emph{f} $v_0$ $v_1$ \dots{} $v_n$ \texttt{=}
- $v_0$ \texttt{=:=} \emph{expr}
- \texttt{where} \emph{decls}
-\end{quote}
-where $v_0$ is a fresh variable.
-\textbf{Note:} The debugger assumes that the goal is always a nullary
-function. This means that we must not $\eta$-expand functional goal
-expressions. In order to avoid the $\eta$-expansion we cheat a little
-bit here and change the type of the goal into $\forall\alpha.\alpha$
-if it really has a functional type.
-\ToDo{Fix the debugger to handle functional goals so that this
-hack is no longer needed.}
-\begin{verbatim}
-
-> desugarGoal :: Bool -> ValueEnv -> TCEnv -> ModuleIdent -> Ident -> Goal
-> -> (Maybe [Ident],Module,ValueEnv)
-> desugarGoal debug tyEnv tcEnv m g (Goal p e ds)
-> | debug || isIO ty =
-> desugarGoalIO tyEnv tcEnv p m g (Let ds e)
-> (if debug && arrowArity ty > 0 then typeVar 0 else ty)
-> | otherwise = desugarGoal' tyEnv tcEnv p m g vs e' ty
-> where ty = typeOf tyEnv e
-> (vs,e') = liftGoalVars (if null ds then e else Let ds e)
-> isIO (TypeConstructor tc [_]) = tc == qIOId
-> isIO _ = False
-
-> desugarGoalIO :: ValueEnv -> TCEnv -> Position -> ModuleIdent -> Ident
-> -> Expression -> Type -> (Maybe [Ident],Module,ValueEnv)
-> desugarGoalIO tyEnv tcEnv p m g e ty =
-> (Nothing,
-> Module m Nothing [goalDecl p g [] e'],
-> bindFun m g (polyType ty) tyEnv')
-> where (e',tyEnv') = run (desugarGoalExpr m tcEnv e) tyEnv
-
-> desugarGoal' :: ValueEnv -> TCEnv -> Position -> ModuleIdent -> Ident -> [Ident]
-> -> Expression -> Type -> (Maybe [Ident],Module,ValueEnv)
-> desugarGoal' tyEnv tcEnv p m g vs e ty =
-> (Just vs',
-> Module m Nothing [goalDecl p g (v0:vs') (apply prelUnif [mkVar v0,e'])],
-> bindFun m v0 (monoType ty) (bindFun m g (polyType ty') tyEnv'))
-> where (e',tyEnv') = run (desugarGoalExpr m tcEnv e) tyEnv
-> v0 = anonId
-> vs' = filter (`elem` qfv m e') vs
-> ty' = TypeArrow ty (foldr (TypeArrow . typeOf tyEnv) successType vs')
-
-> goalDecl :: Position -> Ident -> [Ident] -> Expression -> Decl
-> goalDecl p g vs e = funDecl p g (map VariablePattern vs) e
-
-> desugarGoalExpr :: ModuleIdent -> TCEnv -> Expression
-> -> DesugarState (Expression,ValueEnv)
-> desugarGoalExpr m tcEnv e =
-> do
-> e' <- desugarExpr m tcEnv (first "") e
-> tyEnv' <- fetchSt
-> return (e',tyEnv')
-
-> liftGoalVars :: Expression -> ([Ident],Expression)
-> liftGoalVars (Let ds e) =
-> (concat [vs | ExtraVariables _ vs <- vds],Let ds' e)
-> where (vds,ds') = partition isExtraVariables ds
-> liftGoalVars e = ([],e)
-
-\end{verbatim}
Within a declaration group, all type signatures and evaluation
annotations are discarded. First, the patterns occurring in the left
hand sides are desugared. Due to lazy patterns this may add further
@@ -219,7 +146,7 @@
> return (PatternDecl p t' rhs : concat dss')
> desugarDeclLhs m tcEnv (FlatExternalDecl p fs) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> return (map (externalDecl tyEnv p) fs)
> where externalDecl tyEnv p f =
> ExternalDecl p CallConvPrimitive (Just (name f)) f
@@ -243,7 +170,7 @@
> desugarDeclRhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState Decl
> desugarDeclRhs m tcEnv (FunctionDecl p f eqs) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> let ty = (flip typeOf (Variable (qual f))) tyEnv
> liftM (FunctionDecl p f)
> (mapM (desugarEquation m tcEnv (arrowArgs ty)) eqs)
@@ -278,7 +205,7 @@
> desugarLiteral :: Literal -> DesugarState (Either Literal ([SrcRef],[Literal]))
> desugarLiteral (Char p c) = return (Left (Char p c))
-> desugarLiteral (Int v i) = liftM (Left . fixType) fetchSt
+> desugarLiteral (Int v i) = liftM (Left . fixType) S.get
> where
> fixType tyEnv
> | typeOf tyEnv v == floatType
@@ -312,12 +239,12 @@
> desugarTerm _ _ _ ds (VariablePattern v) = return (ds,VariablePattern v)
> desugarTerm m tcEnv p ds (ConstructorPattern c [t]) =
> do
-> tyEnv <- fetchSt
-> liftM (if isNewtypeConstr tyEnv c then id else apSnd (constrPat c))
+> tyEnv <- S.get
+> liftM (if isNewtypeConstr tyEnv c then id else second (constrPat c))
> (desugarTerm m tcEnv p ds t)
> where constrPat c t = ConstructorPattern c [t]
> desugarTerm m tcEnv p ds (ConstructorPattern c ts) =
-> liftM (apSnd (ConstructorPattern c)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
+> liftM (second (ConstructorPattern c)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
> desugarTerm m tcEnv p ds (InfixPattern t1 op t2) =
> desugarTerm m tcEnv p ds (ConstructorPattern op [t1,t2])
> desugarTerm m tcEnv p ds (ParenPattern t) = desugarTerm m tcEnv p ds t
@@ -326,7 +253,7 @@
> where tupleConstr ts = addRef pos $
> if null ts then qUnitId else qTupleId (length ts)
> desugarTerm m tcEnv p ds (ListPattern pos ts) =
-> liftM (apSnd (desugarList pos cons nil)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
+> liftM (second (desugarList pos cons nil)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
> where nil p' = ConstructorPattern (addRef p' qNilId) []
> cons p' t ts = ConstructorPattern (addRef p' qConsId) [t,ts]
@@ -334,13 +261,13 @@
> liftM (desugarAs p v) (desugarTerm m tcEnv p ds t)
> desugarTerm m tcEnv p ds (LazyPattern pos t) = desugarLazy pos m p ds t
> desugarTerm m tcEnv p ds (FunctionPattern f ts) =
-> liftM (apSnd (FunctionPattern f)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
+> liftM (second (FunctionPattern f)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
> desugarTerm m tcEnv p ds (InfixFuncPattern t1 f t2) =
> desugarTerm m tcEnv p ds (FunctionPattern f [t1,t2])
> desugarTerm m tcEnv p ds (RecordPattern fs _)
> | null fs = internalError "desugarTerm: empty record"
> | otherwise =
-> do tyEnv <- fetchSt
+> do tyEnv <- S.get
> case (lookupValue (fieldLabel (head fs)) tyEnv) of
> [Label _ r _] ->
> desugarRecordPattern m tcEnv p ds (map field2Tuple fs) r
@@ -363,7 +290,7 @@
> LazyPattern pos t' -> desugarLazy pos m p ds t'
> _ ->
> do
-> v0 <- fetchSt >>= freshIdent m "_#lazy" . monoType . flip typeOf t
+> v0 <- S.get >>= freshIdent m "_#lazy" . monoType . flip typeOf t
> let v' = addPositionIdent (AST pos) v0
> return (patDecl p{ast=pos} t (mkVar v') : ds,VariablePattern v')
@@ -381,7 +308,7 @@
> desugarRhs :: ModuleIdent -> TCEnv -> Position -> Rhs -> DesugarState Rhs
> desugarRhs m tcEnv p rhs =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> e' <- desugarExpr m tcEnv p (expandRhs tyEnv prelFailed rhs)
> return (SimpleRhs p e' [])
@@ -431,7 +358,7 @@
> liftM (apply prelEnumFromThenTo) (mapM (desugarExpr m tcEnv p) [e1,e2,e3])
> desugarExpr m tcEnv p (UnaryMinus op e) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> liftM (Apply (unaryMinus op (typeOf tyEnv e))) (desugarExpr m tcEnv p e)
> where unaryMinus op ty
> | op == minusId =
@@ -440,7 +367,7 @@
> | otherwise = internalError "unaryMinus"
> desugarExpr m tcEnv p (Apply (Constructor c) e) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> liftM (if isNewtypeConstr tyEnv c then id else (Apply (Constructor c)))
> (desugarExpr m tcEnv p e)
> desugarExpr m tcEnv p (Apply e1 e2) =
@@ -466,7 +393,7 @@
> return (Apply (Apply prelFlip op') e')
> desugarExpr m tcEnv p exp@(Lambda r ts e) =
> do
-> f <- fetchSt >>=
+> f <- S.get >>=
> freshIdent m "_#lambda" . polyType . flip typeOf exp
> desugarExpr m tcEnv p (Let [funDecl (AST r) f ts e] (mkVar f))
> desugarExpr m tcEnv p (Let ds e) =
@@ -490,9 +417,9 @@
> | otherwise =
> do
> e' <- desugarExpr m tcEnv p e
-> v <- fetchSt >>= freshIdent m "_#case" . monoType . flip typeOf e
+> v <- S.get >>= freshIdent m "_#case" . monoType . flip typeOf e
> alts' <- mapM (desugarAltLhs m tcEnv) alts
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> alts'' <- mapM (desugarAltRhs m tcEnv)
> (map (expandAlt tyEnv v) (init (tails alts')))
> return (mkCase m v e' alts'')
@@ -504,12 +431,12 @@
> | otherwise =
> do let l = fieldLabel (head fs)
> fs' = map field2Tuple fs
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> case (lookupValue l tyEnv) of
> [Label l' r _] -> desugarRecordConstr m tcEnv p r fs'
> _ -> internalError "desugarExpr: illegal record construction"
> desugarExpr m tcEnv p (RecordSelection e l) =
-> do tyEnv <- fetchSt
+> do tyEnv <- S.get
> case (lookupValue l tyEnv) of
> [Label _ r _] -> desugarRecordSelection m tcEnv p r l e
> _ -> internalError "desugarExpr: illegal record selection"
@@ -518,7 +445,7 @@
> | otherwise =
> do let l = fieldLabel (head fs)
> fs' = map field2Tuple fs
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> case (lookupValue l tyEnv) of
> [Label _ r _] -> desugarRecordUpdate m tcEnv p r rexpr fs'
> _ -> internalError "desugarExpr: illegal record update"
@@ -582,14 +509,14 @@
> desugarRecordDecl m tcEnv (TypeDecl p r vs (RecordType fss _)) =
> case (qualLookupTC r' tcEnv) of
> [AliasType _ n (TypeRecord fs' _)] ->
-> do tyEnv <- fetchSt
+> do tyEnv <- S.get
> let tys = concatMap (\ (ls,ty) -> replicate (length ls) ty) fss
> --tys' = map (elimRecordTypes tyEnv) tys
> rdecl = DataDecl p r vs [ConstrDecl p [] r tys]
> rty' = TypeConstructor r' (map TypeVariable [0 .. n-1])
> rcts' = ForAllExist 0 n (foldr TypeArrow rty' (map snd fs'))
> rfuncs <- mapM (genRecordFuncs m tcEnv p r' rty' (map fst fs')) fs'
-> updateSt_ (bindGlobalInfo DataConstructor m r rcts')
+> S.modify (bindGlobalInfo DataConstructor m r rcts')
> return (rdecl:(concat rfuncs))
> _ -> internalError "desugarRecordDecl: no record"
> where r' = qualifyWith m r
@@ -637,7 +564,7 @@
> elimFunctionPattern m p [] = return ([],[])
> elimFunctionPattern m p (t:ts)
> | containsFunctionPattern t
-> = do tyEnv <- fetchSt
+> = do tyEnv <- S.get
> ident <- freshIdent m "_#funpatt" (monoType (typeOf tyEnv t))
> (ts',its') <- elimFunctionPattern m p ts
> return ((VariablePattern ident):ts', (ident,t):its')
@@ -734,7 +661,7 @@
> (updId, updFunc) = genUpdateFunc m p r ls l
> selType = polyType (TypeArrow rty ty)
> updType = polyType (TypeArrow rty (TypeArrow ty rty))
-> updateSt_ (bindFun m selId selType . bindFun m updId updType)
+> S.modify (bindFun m selId selType . bindFun m updId updType)
> return [selFunc,updFunc]
> _ -> internalError "genRecordFuncs: wrong type"
@@ -805,7 +732,7 @@
> | isVarPattern t = desugarExpr m tcEnv p (qualExpr t e l)
> | otherwise =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> v0 <- freshIdent m "_#var" (monoType (typeOf tyEnv t))
> l0 <- freshIdent m "_#var" (monoType (typeOf tyEnv e))
> let v = addRefId refBind v0
@@ -835,8 +762,8 @@
> freshIdent :: ModuleIdent -> String -> TypeScheme -> DesugarState Ident
> freshIdent m prefix ty =
> do
-> x <- liftM (mkName prefix) (liftSt (updateSt (1 +)))
-> updateSt_ (bindFun m x ty)
+> x <- liftM (mkName prefix) (S.lift (S.modify succ >> S.get))
+> S.modify (bindFun m x ty)
> return x
> where mkName pre n = mkIdent (pre ++ show n)
@@ -844,7 +771,6 @@
Prelude entities
\begin{verbatim}
-> prelUnif = Variable $ preludeIdent "=:="
> prelBind = prel ">>="
> prelBind_ = prel ">>"
> prelFlip = Variable $ preludeIdent "flip"
@@ -867,7 +793,7 @@
> truePattern = ConstructorPattern qTrueId []
> falsePattern = ConstructorPattern qFalseId []
-> successPattern = ConstructorPattern (qualify successId) []
+
> preludeIdent :: String -> QualIdent
> preludeIdent = qualifyWith preludeMIdent . mkIdent
diff --git a/src/Env.lhs b/src/Env.lhs
deleted file mode 100644
--- a/src/Env.lhs
+++ /dev/null
@@ -1,55 +0,0 @@
-% -*- LaTeX -*-
-% $Id: Env.lhs,v 1.9 2002/12/20 15:07:56 lux Exp $
-%
-% Copyright (c) 2002, Wolfgang Lux
-% See LICENSE for the full license.
-%
-\nwfilename{Env.lhs}
-\section{Environments}
-The module \texttt{Env} implements environments. An environment
-$\rho = \left\{x_1\mapsto t_1,\dots,x_n\mapsto t_n\right\}$ is a
-finite mapping from (finitely many) variables $x_1,\dots,x_n$ to
-some kind of expression or term. For any environment we have the
-following definitions:
-\begin{displaymath}
- \begin{array}{l}
- \rho(x) = \left\{\begin{array}{ll}
- t_i&\mbox{if $x=x_i$}\\
- \bot&\mbox{otherwise}\end{array}\right. \\
- \mathop{{\mathcal D}om}(\rho) = \left\{x_1,\dots,x_n\right\} \\
- \mathop{{\mathcal C}odom}(\rho) = \left\{t_1,\dots,t_n\right\}
- \end{array}
-\end{displaymath}
-
-Unfortunately we cannot define \texttt{Env} as a \texttt{newtype}
-because of a bug in the nhc compiler.
-\begin{verbatim}
-
-> module Env where
-
-> import qualified Data.Map as Map
-
-> newtype Env a b = Env (Map.Map a b) deriving Show
-
-> emptyEnv :: Ord a => Env a b
-> emptyEnv = Env Map.empty
-
-> envToList :: Ord v => Env v e -> [(v,e)]
-> envToList (Env rho) = Map.toList rho
-
-> bindEnv :: Ord v => v -> e -> Env v e -> Env v e
-> bindEnv v e (Env rho) = Env (Map.insert v e rho)
-
-> unbindEnv :: Ord v => v -> Env v e -> Env v e
-> unbindEnv v (Env rho) = Env (Map.delete v rho)
-
-> lookupEnv :: Ord v => v -> Env v e -> Maybe e
-> lookupEnv v (Env rho) = Map.lookup v rho
-
-> envSize :: Ord v => Env v e -> Int
-> envSize (Env rho) = Map.size rho
-
-> instance Ord a => Functor (Env a) where
-> fmap f (Env rho) = Env (fmap f rho)
-
-\end{verbatim}
diff --git a/src/Error.lhs b/src/Error.lhs
deleted file mode 100644
--- a/src/Error.lhs
+++ /dev/null
@@ -1,35 +0,0 @@
-% -*- LaTeX -*-
-% $Id: Error.lhs,v 1.1 2003/05/07 22:38:42 wlux Exp $
-%
-% Copyright (c) 2003, Wolfgang Lux
-% See LICENSE for the full license.
-%
-\nwfilename{Error.lhs}
-\section{Errors}\label{sec:error}
-The \texttt{Error} type is used for describing the result of a
-computation that can fail. In contrast to the standard \texttt{Maybe}
-type, its \texttt{Error} case provides for an error message that
-describes the failure.
-\begin{verbatim}
-
-> module Error where
-> import Control.Monad
-
-> data Error a = Ok a | Error String deriving (Eq,Ord,Show)
-
-> instance Functor Error where
-> fmap f (Ok x) = Ok (f x)
-> fmap f (Error e) = Error e
-
-> instance Monad Error where
-> return x = Ok x
-> fail s = Error s
-> Ok x >>= f = f x
-> Error e >>= _ = Error e
-
-> ok :: Error a -> a
-> ok (Ok x) = x
-> ok (Error e) = error e
-
-
-\end{verbatim}
diff --git a/src/Eval.lhs b/src/Eval.lhs
--- a/src/Eval.lhs
+++ b/src/Eval.lhs
@@ -11,24 +11,24 @@
happens already while checking the definitions of the module.
\begin{verbatim}
-> module Eval(evalEnv,evalEnvGoal) where
+> module Eval(evalEnv) where
+
+> import qualified Data.Map as Map
+
+> import Curry.Syntax
> import Base
-> import Env
+
\end{verbatim}
The function \texttt{evalEnv} collects all evaluation annotations of
the module by traversing the syntax tree.
\begin{verbatim}
> evalEnv :: [Decl] -> EvalEnv
-> evalEnv = foldr collectAnnotsDecl emptyEnv
-
-> evalEnvGoal :: Goal -> EvalEnv
-> evalEnvGoal (Goal _ e ds) =
-> collectAnnotsExpr e (foldr collectAnnotsDecl emptyEnv ds)
+> evalEnv = foldr collectAnnotsDecl Map.empty
> collectAnnotsDecl :: Decl -> EvalEnv -> EvalEnv
-> collectAnnotsDecl (EvalAnnot _ fs ev) env = foldr (flip bindEval ev) env fs
+> collectAnnotsDecl (EvalAnnot _ fs ev) env = foldr (flip Map.insert ev) env fs
> collectAnnotsDecl (FunctionDecl _ _ eqs) env = foldr collectAnnotsEqn env eqs
> collectAnnotsDecl (PatternDecl _ _ rhs) env = collectAnnotsRhs rhs env
> collectAnnotsDecl _ env = env
diff --git a/src/Exports.lhs b/src/Exports.lhs
--- a/src/Exports.lhs
+++ b/src/Exports.lhs
@@ -19,6 +19,10 @@
> import qualified Data.Set as Set
> import qualified Data.Map as Map
+> import Curry.Syntax
+> import Types
+> import Curry.Base.Position
+> import Curry.Base.Ident
> import Base
> import TopEnv
@@ -40,7 +44,7 @@
> Linear ->
> case linear ([c | ExportTypeWith _ cs <- es', c <- cs] ++
> [unqualify f | Export f <- es']) of
-> Linear -> Module m (Just (Exporting noPos es')) ds
+> Linear -> Module m (Just (Exporting NoPos es')) ds
> NonLinear v -> errorAt' (ambiguousExportValue v)
> NonLinear tc -> errorAt' (ambiguousExportType tc)
> where ms = Set.fromList [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds]
@@ -197,7 +201,7 @@
> exportInterface :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface
> exportInterface (Module m (Just (Exporting _ es)) _) pEnv tcEnv tyEnv =
> Interface m (imports ++ precs ++ hidden ++ ds)
-> where imports = map (IImportDecl noPos) (usedModules ds)
+> where imports = map (IImportDecl NoPos) (usedModules ds)
> precs = foldr (infixDecl m pEnv) [] es
> hidden = map (hiddenTypeDecl m tcEnv) (hiddenTypes ds)
> ds = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es
@@ -206,7 +210,7 @@
> infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]
> infixDecl m pEnv (Export f) ds = iInfixDecl m pEnv f ds
> infixDecl m pEnv (ExportTypeWith tc cs) ds =
-> foldr (iInfixDecl m pEnv . qualifyLike (fst (splitQualIdent tc))) ds cs
+> foldr (iInfixDecl m pEnv . qualifyLike (qualidMod tc)) ds cs
> where qualifyLike = maybe qualify qualifyWith
> iInfixDecl :: ModuleIdent -> PEnv -> QualIdent -> [IDecl] -> [IDecl]
@@ -214,7 +218,7 @@
> case qualLookupP op pEnv of
> [] -> ds
> [PrecInfo _ (OpPrec fix pr)] ->
-> IInfixDecl noPos fix pr (qualUnqualify m op) : ds
+> IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
> _ -> internalError "infixDecl"
> typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
@@ -226,7 +230,7 @@
> (constrDecls m (drop n nameSupply) cs cs') : ds
> [RenamingType tc n (Data c n' ty)]
> | c `elem` cs ->
-> iTypeDecl INewtypeDecl m tc n (NewConstrDecl noPos tvs c ty') : ds
+> iTypeDecl INewtypeDecl m tc n (NewConstrDecl NoPos tvs c ty') : ds
> | otherwise -> iTypeDecl IDataDecl m tc n [] : ds
> where tvs = take n' (drop n nameSupply)
> ty' = fromQualType m ty
@@ -240,7 +244,7 @@
> iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> IDecl)
> -> ModuleIdent -> QualIdent -> Int -> a -> IDecl
-> iTypeDecl f m tc n = f noPos (qualUnqualify m tc) (take n nameSupply)
+> iTypeDecl f m tc n = f NoPos (qualUnqualify m tc) (take n nameSupply)
> constrDecls :: ModuleIdent -> [Ident] -> [Ident] -> [Maybe (Data [Type])]
> -> [Maybe ConstrDecl]
@@ -253,14 +257,14 @@
> iConstrDecl :: [Ident] -> Ident -> [TypeExpr] -> ConstrDecl
> iConstrDecl tvs op [ty1,ty2]
-> | isInfixOp op = ConOpDecl noPos tvs ty1 op ty2
-> iConstrDecl tvs c tys = ConstrDecl noPos tvs c tys
+> | isInfixOp op = ConOpDecl NoPos tvs ty1 op ty2
+> iConstrDecl tvs c tys = ConstrDecl NoPos tvs c tys
> funDecl :: ModuleIdent -> ValueEnv -> Export -> [IDecl] -> [IDecl]
> funDecl m tyEnv (Export f) ds =
> case qualLookupValue f tyEnv of
> [Value _ (ForAll _ ty)] ->
-> IFunctionDecl noPos (qualUnqualify m f) (arrowArity ty)
+> IFunctionDecl NoPos (qualUnqualify m f) (arrowArity ty)
> (fromQualType m ty) : ds
> _ -> internalError ("funDecl: " ++ show f)
> funDecl _ _ (ExportTypeWith _ _) ds = ds
@@ -286,9 +290,8 @@
\begin{verbatim}
> usedModules :: [IDecl] -> [ModuleIdent]
-> usedModules ds = nub (catMaybes (map modul (foldr identsDecl [] ds)))
+> usedModules ds = nub (catMaybes (map qualidMod (foldr identsDecl [] ds)))
> where nub = Set.toList . Set.fromList
-> modul = fst . splitQualIdent
> identsDecl :: IDecl -> [QualIdent] -> [QualIdent]
> identsDecl (IDataDecl _ tc _ cs) xs =
@@ -329,7 +332,7 @@
> [RenamingType _ n _] -> hidingDataDecl tc n
> _ -> internalError "hiddenTypeDecl"
> where hidingDataDecl tc n =
-> HidingDataDecl noPos (unqualify tc) (take n nameSupply)
+> HidingDataDecl NoPos (unqualify tc) (take n nameSupply)
> hiddenTypes :: [IDecl] -> [QualIdent]
> hiddenTypes ds = [tc | tc <- Set.toList tcs, not (isQualified tc)]
diff --git a/src/ExtendedFlat.hs b/src/ExtendedFlat.hs
deleted file mode 100644
--- a/src/ExtendedFlat.hs
+++ /dev/null
@@ -1,517 +0,0 @@
-------------------------------------------------------------------------------
---- Library to support meta-programming in Curry.
----
---- This library contains a definition for representing FlatCurry programs
---- in Haskell (type "Prog").
----
---- @author Michael Hanus
---- @version September 2003
----
---- Version for Haskell (slightly modified):
---- December 2004, Martin Engelke (men@informatik.uni-kiel.de)
----
---- Added part calls for constructors, Bernd Brassel, August 2005
---- Added source references, Bernd Brassel, May 2009
-------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
-
-module ExtendedFlat (SrcRef,Prog(..), QName(..), Visibility(..),
- TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),
- OpDecl(..), Fixity(..),
- VarIndex(..),
- FuncDecl(..), Rule(..),
- CaseType(..), CombType(..), Expr(..), BranchExpr(..),
- Pattern(..), Literal(..),
- readFlatCurry, readFlatInterface, readFlat,
- writeFlatCurry,writeExtendedFlat,gshowsPrec,
- qnOf,mkQName,
- mkIdx,idxOf) where
-
-import PathUtils (writeModule,maybeReadModule)
-import Data.List(intersperse)
-import Control.Monad (liftM)
-import Data.Generics hiding (Fixity)
-import Position (SrcRef)
-import System.FilePath
-
-
-------------------------------------------------------------------------------
--- Definition of data types for representing FlatCurry programs:
--- =============================================================
-
---- Data type for representing a Curry module in the intermediate form.
---- A value of this data type has the form
----
---- (Prog modname imports typedecls functions opdecls translation_table)
----
---- where modname: name of this module,
---- imports: list of modules names that are imported,
---- typedecls, opdecls, functions, translation of type names
---- and constructor/function names: see below
-
-data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
- deriving (Read, Show, Eq,Data,Typeable)
-
-
--------------------------------------------------------------------------
---- The data type for representing qualified names.
---- In FlatCurry all names are qualified to avoid name clashes.
---- The first component is the module name and the second component the
---- unqualified name as it occurs in the source program.
---- The additional information about source references and types should
---- be invisible for the normal usage of QName.
--------------------------------------------------------------------------
-
-data QName = QName {srcRef :: Maybe SrcRef,
- typeofQName :: Maybe TypeExpr,
- modName :: String,
- localName :: String} deriving (Data,Typeable)
-
-
-app_prec = 10
-hi_prec = app_prec+1
-
-instance Read QName where
- readsPrec d r =
- [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]
- ++ readParen (d > app_prec)
- (\r' -> [ (QName ref typ n m,res)
- | ("QName",s0) <- lex r',
- (ref,s1) <- readsPrec hi_prec s0,
- (typ,s2) <- readsPrec hi_prec s1,
- (n,s3) <- readsPrec hi_prec s2,
- (m,res) <- readsPrec hi_prec s3 ]) r
-
-
-instance Show QName where
- showsPrec d (QName r t m n)=
- showParen (d > app_prec) $ showString "QName " .
- showsPrec hi_prec r . showChar ' ' .
- showsPrec hi_prec t . showChar ' ' .
- showsPrec hi_prec m . showChar ' ' .
- showsPrec hi_prec n
-
-instance Eq QName where (==) = onName (==)
-instance Ord QName where compare = onName compare
-
-mkQName :: (String,String) -> QName
-mkQName = uncurry (QName Nothing Nothing)
-
-qnOf :: QName -> (String,String)
-qnOf QName{modName=m,localName=n} = (m,n)
-
-onName :: ((String,String) -> (String,String) -> a) -> QName -> QName -> a
-onName f QName{modName=m,localName=l} QName{modName=m',localName=l'} =
- f (m,l) (m',l')
-
-
--------------------------------------------------------------------------
---- The data type for representing variable names.
---- The additional information should
---- be invisible for the normal usage of VarIndex.
--------------------------------------------------------------------------
-
-data VarIndex = VarIndex {
- typeofVar :: Maybe TypeExpr,
- index :: Int
- } deriving (Data,Typeable)
-
-onIndex :: (Int -> a) -> VarIndex -> a
-onIndex f VarIndex{index=i} = f i
-
-(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
-f .: g = \x -> f . g x
-
-onIndexes :: (Int -> Int -> a) -> VarIndex -> VarIndex -> a
-onIndexes = onIndex .: onIndex
-
-mkIdx :: Int -> VarIndex
-mkIdx = VarIndex Nothing
-
-idxOf :: VarIndex -> Int
-idxOf VarIndex{index=i}= i
-
-instance Read VarIndex where
- readsPrec d r =
- [ (mkIdx i,s) | (i,s) <- readsPrec d r ]
- ++ readParen (d > app_prec)
- (\r' -> [ (VarIndex typ i,res)
- | ("VarIndex",s0) <- lex r',
- (typ,s1) <- readsPrec hi_prec s0,
- (i,res) <- readsPrec hi_prec s1]) r
-
-
-instance Show VarIndex where
- showsPrec d (VarIndex t i)=
- showParen (d > app_prec) $ showString "VarIndex " .
- showsPrec hi_prec t . showChar ' ' .
- showsPrec hi_prec i
-
-
-instance Eq VarIndex where (==) = onIndexes (==)
-instance Ord VarIndex where compare = onIndexes compare
-
-instance Num VarIndex where
- (+) = mkIdx .: onIndexes (+)
- (*) = mkIdx .: onIndexes (*)
- (-) = mkIdx .: onIndexes (-)
- abs = mkIdx . onIndex abs
- signum = mkIdx . onIndex signum
- fromInteger = mkIdx . fromInteger
-
-------------------------------------------------------------
---- Data type to specify the visibility of various entities.
-------------------------------------------------------------
-
-data Visibility = Public -- public (exported) entity
- | Private -- private entity
- deriving (Read, Show, Eq,Data,Typeable)
-
---- The data type for representing type variables.
---- They are represented by (TVar i) where i is a type variable index.
-
-type TVarIndex = Int
-
---- Data type for representing definitions of algebraic data types.
----
---- A data type definition of the form
----
---- data t x1...xn = ...| c t1....tkc |...
----
---- is represented by the FlatCurry term
----
---- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
----
---- where each ij is the index of the type variable xj
----
---- Note: the type variable indices are unique inside each type declaration
---- and are usually numbered from 0
----
---- Thus, a data type declaration consists of the name of the data type,
---- a list of type parameters and a list of constructor declarations.
----
-
-data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]
- | TypeSyn QName Visibility [TVarIndex] TypeExpr
- deriving (Read, Show, Eq,Data,Typeable)
-
---- A constructor declaration consists of the name and arity of the
---- constructor and a list of the argument types of the constructor.
-
-data ConsDecl = Cons QName Int Visibility [TypeExpr]
- deriving (Read, Show, Eq,Data,Typeable)
-
-
---- Data type for type expressions.
---- A type expression is either a type variable, a function type,
---- or a type constructor application.
----
---- Note: the names of the predefined type constructors are
---- "Int", "Float", "Bool", "Char", "IO", "Success",
---- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
-
-data TypeExpr =
- TVar TVarIndex -- type variable
- | FuncType TypeExpr TypeExpr -- function type t1->t2
- | TCons QName [TypeExpr] -- type constructor application
- deriving (Read, Show, Eq,Data,Typeable) -- TCons module name typeargs
-
-
---- Data type for operator declarations.
---- An operator declaration "fix p n" in Curry corresponds to the
---- FlatCurry term (Op n fix p).
---- Note: the constructor definition of 'Op' differs from the original
---- PAKCS definition using Haskell type 'Integer' instead of 'Int'
---- for representing the precedence.
-
-data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)
-
---- Data types for the different choices for the fixity of an operator.
-
-data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)
-
-
---- Data type for representing object variables.
---- Object variables occurring in expressions are represented by (Var i)
---- where i is a variable index.
-
---- Data type for representing function declarations.
----
---- A function declaration in FlatCurry is a term of the form
----
---- (Func name arity type (Rule [i_1,...,i_arity] e))
----
---- and represents the function "name" with definition
----
---- name :: type
---- name x_1...x_arity = e
----
---- where each i_j is the index of the variable x_j
----
---- Note: the variable indices are unique inside each function declaration
---- and are usually numbered from 0
----
---- External functions are represented as (Func name arity type (External s))
---- where s is the external name associated to this function.
----
---- Thus, a function declaration consists of the name, arity, type, and rule.
----
-
-data FuncDecl = Func QName Int Visibility TypeExpr Rule
- deriving (Read, Show, Eq,Data,Typeable)
-
-
---- A rule is either a list of formal parameters together with an expression
---- or an "External" tag.
-
-data Rule = Rule [VarIndex] Expr
- | External String
- deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for classifying case expressions.
---- Case expressions can be either flexible or rigid in Curry.
-
-data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for classifying combinations
---- (i.e., a function/constructor applied to some arguments).
---- @cons FuncCall - a call to a function all arguments are provided
---- @cons ConsCall - a call with a constructor at the top,
---- all arguments are provided
---- @cons FuncPartCall - a partial call to a function
---- (i.e., not all arguments are provided)
---- where the parameter is the number of
---- missing arguments
---- @cons ConsPartCall - a partial call to a constructor along with
---- number of missing arguments
-
-data CombType = FuncCall
- | ConsCall
- | FuncPartCall Int
- | ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for representing expressions.
----
---- Remarks:
----
---- 1. if-then-else expressions are represented as function calls:
---- (if e1 then e2 else e3)
---- is represented as
---- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])
----
---- 2. Higher order applications are represented as calls to the (external)
---- function "apply". For instance, the rule
---- app f x = f x
---- is represented as
---- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))
----
---- 3. A conditional rule is represented as a call to an external function
---- "cond" where the first argument is the condition (a constraint).
---- For instance, the rule
---- equal2 x | x=:=2 = success
---- is represented as
---- (Rule [0]
---- (Comb FuncCall ("Prelude","cond")
---- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
---- Comb FuncCall ("Prelude","success") []]))
----
---- 4. Functions with evaluation annotation "choice" are represented
---- by a rule whose right-hand side is enclosed in a call to the
---- external function "Prelude.commit".
---- Furthermore, all rules of the original definition must be
---- represented by conditional expressions (i.e., (cond [c,e]))
---- after pattern matching.
---- Example:
----
---- m eval choice
---- m [] y = y
---- m x [] = x
----
---- is translated into (note that the conditional branches can be also
---- wrapped with Free declarations in general):
----
---- Rule [0,1]
---- (Comb FuncCall ("Prelude","commit")
---- [Or (Case Rigid (Var 0)
---- [(Pattern ("Prelude","[]") []
---- (Comb FuncCall ("Prelude","cond")
---- [Comb FuncCall ("Prelude","success") [],
---- Var 1]))] )
---- (Case Rigid (Var 1)
---- [(Pattern ("Prelude","[]") []
---- (Comb FuncCall ("Prelude","cond")
---- [Comb FuncCall ("Prelude","success") [],
---- Var 0]))] )])
----
---- Operational meaning of (Prelude.commit e):
---- evaluate e with local search spaces and commit to the first
---- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c
---- is satisfied
----
---- @cons Var - variable (represented by unique index)
---- @cons Lit - literal (Integer/Float/Char constant)
---- @cons Comb - application (f e1 ... en) of function/constructor f
---- with n<=arity(f)
---- @cons Free - introduction of free local variables
---- @cons Or - disjunction of two expressions (used to translate rules
---- with overlapping left-hand sides)
---- @cons Case - case distinction (rigid or flex)
-
-data Expr = Var VarIndex
- | Lit Literal
- | Comb CombType QName [Expr]
- | Free [VarIndex] Expr
- | Let [(VarIndex,Expr)] Expr
- | Or Expr Expr
- | Case SrcRef CaseType Expr [BranchExpr]
- deriving (Read, Show, Eq,Data,Typeable)
-
-
---- Data type for representing branches in a case expression.
----
---- Branches "(m.c x1...xn) -> e" in case expressions are represented as
----
---- (Branch (Pattern (m,c) [i1,...,in]) e)
----
---- where each ij is the index of the pattern variable xj, or as
----
---- (Branch (LPattern (Intc i)) e)
----
---- for integers as branch patterns (similarly for other literals
---- like float or character constants).
----
-
-data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for representing patterns in case expressions.
-
-data Pattern = Pattern QName [VarIndex]
- | LPattern Literal
- deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for representing literals occurring in an expression
---- or case branch. It is either an integer, a float, or a character constant.
---- Note: the constructor definition of 'Intc' differs from the original
---- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
---- to provide an unlimited range of integer numbers. Furthermore
---- float values are represented with Haskell type 'Double' instead of
---- 'Float'.
-
-data Literal = Intc SrcRef Integer
- | Floatc SrcRef Double
- | Charc SrcRef Char
- deriving (Read, Show, Eq,Data,Typeable)
-
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
--- Reads a FlatCurry file (extension ".fcy") and returns the corresponding
--- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
-readFlatCurry :: FilePath -> IO (Maybe Prog)
-readFlatCurry fn
- = do let filename = genFlatFilename ".fcy" fn
- readFlat filename
-
--- Reads a FlatInterface file (extension ".fint") and returns the
--- corresponding term (type 'Prog') as a value of type 'Maybe'.
-readFlatInterface :: String -> IO (Maybe Prog)
-readFlatInterface fn
- = do let filename = genFlatFilename ".fint" fn
- readFlat filename
-
--- Reads a Flat file and returns the corresponding term (type 'Prog') as
--- a value of type 'Maybe'.
-readFlat :: FilePath -> IO (Maybe Prog)
-readFlat = liftM (fmap read) . maybeReadModule
-
--- Writes a FlatCurry program term into a file.
-writeFlatCurry :: String -> Prog -> IO ()
-writeFlatCurry filename prog
- = writeModule filename (showFlatCurry' False prog)
-
--- Writes a FlatCurry program term with source references into a file.
-writeExtendedFlat :: String -> Prog -> IO ()
-writeExtendedFlat filename prog =
- writeModule (replaceExtension filename ".efc") (showFlatCurry' True prog)
-
--- Shows FlatCurry program in a more nicely way.
-showFlatCurry :: Prog -> String
-showFlatCurry (Prog mname imps types funcs ops) =
- "Prog "++show mname++"\n "++
- show imps ++"\n ["++
- concat (intersperse ",\n " (map (\t->show t) types)) ++"]\n ["++
- concat (intersperse ",\n " (map (\f->show f) funcs)) ++"]\n "++
- show ops ++"\n"
-
-
--- Add the extension 'ext' to the filename 'fn' if it doesn't
--- already exist.
-genFlatFilename :: String -> FilePath -> FilePath
-genFlatFilename ext fn
- | drop (length fn - length ext) fn == ext
- = fn
- | otherwise
- = fn ++ ext
-
-showFlatCurry' :: Bool -> Prog -> String
-showFlatCurry' b x = gshowsPrec b False x ""
-
-gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS
-gshowsPrec showType d =
- genericShowsPrec d `ext1Q` showsList
- `ext2Q` showsTuple
- `extQ` (const id :: SrcRef -> ShowS)
- `extQ` (const id :: [SrcRef] -> ShowS)
- `extQ` (shows :: String -> ShowS)
- `extQ` (shows :: Char -> ShowS)
- `extQ` showsQName d
- `extQ` showsVarIndex d
-
- where
- showsQName :: Bool -> QName -> ShowS
- showsQName d qn@QName{modName=m,localName=n,typeofQName=t} =
- if showType then showParen d (shows qn{srcRef=Nothing})
- else shows (m,n)
-
- showsVarIndex :: Bool -> VarIndex -> ShowS
- showsVarIndex d v@VarIndex{index=i} =
- if showType then showParen d (shows v)
- else shows i
-
- genericShowsPrec :: Data a => Bool -> a -> ShowS
- genericShowsPrec d t = let args = intersperse (showChar ' ') $
- gmapQ (gshowsPrec showType True) t in
- showParen (d && not (null args)) $
- showString (showConstr (toConstr t)) .
- (if null args then id else showChar ' ') .
- foldr (.) id args
-
- showsList :: Data a => [a] -> ShowS
- showsList xs = showChar '[' .
- foldr (.) (showChar ']')
- (intersperse (showChar ',') $
- map (gshowsPrec showType False) xs)
-
-
- showsTuple :: (Data a,Data b) => (a,b) -> ShowS
- showsTuple (x,y) = showChar '(' .
- gshowsPrec showType False x .
- showChar ',' .
- gshowsPrec showType False y .
- showChar ')'
-
-
-newtype Q r a = Q (a -> r)
-
-ext2Q :: (Data d, Typeable2 t) => (d -> q) ->
- (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
-ext2Q def ext arg =
- case dataCast2 (Q ext) of
- Just (Q ext') -> ext' arg
- Nothing -> def arg
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
diff --git a/src/Frontend.hs b/src/Frontend.hs
--- a/src/Frontend.hs
+++ b/src/Frontend.hs
@@ -7,37 +7,27 @@
-- December 2005,
-- Martin Engelke (men@informatik.uni-kiel.de)
--
-module Frontend (lex, parse, fullParse, typingParse, abstractIO, flatIO,
- Result(..), Message(..)
- )where
+module Frontend (lex, parse, fullParse, typingParse)where
-import Data.List
import Data.Maybe
-import Control.Monad
+import qualified Data.Map as Map
+import Control.Monad.Writer
+import Control.Monad.Error
import Prelude hiding (lex)
import Modules
import CurryBuilder
import CurryCompilerOpts
-import CurryParser
-import CurryLexer
-import GenAbstractCurry
-import GenFlatCurry
-import CaseCompletion
-import CurryDeps hiding (unlitLiterate)
-import qualified CurrySyntax as CS
-import qualified AbstractCurry as ACY
-import qualified ExtendedFlat as FCY
-import qualified Error as Err
-import CompilerResults
-import Message
-import CurryEnv
-import Unlit
-import Ident
-import Position
-import PathUtils
-import Env
+import Curry.Base.MessageMonad
+import qualified Curry.Syntax as CS
+import Curry.Syntax.Lexer
+import CurryDeps
+import Curry.Base.Ident
+import Curry.Base.Position
+import Filenames
+import PathUtils
+import Base(ModuleEnv)
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
@@ -45,18 +35,15 @@
-- Returns the result of a lexical analysis of the source program 'src'.
-- The result is a list of tuples consisting of a position and a token
-- (see Modules "Position" and "CurryLexer")
-lex :: FilePath -> String -> Result [(Position,Token)]
-lex fn src = genToks (lexFile (first fn) src False [])
+lex :: FilePath -> String -> MsgMonad [(Position,Token)]
+lex fn src = lexFile (first fn) src False []
-- Returns the result of a syntactical analysis of the source program 'src'.
-- The result is the syntax tree of the program (type 'Module'; see Module
-- "CurrySyntax").
-parse :: FilePath -> String -> Result CS.Module
-parse fn src = let (err, src') = unlitLiterate fn src
- in if null err
- then genCurrySyntax fn (parseSource True fn src')
- else Failure [message_ Error err]
+parse :: FilePath -> String -> MsgMonad CS.Module
+parse fn src = CS.parseModule True fn src >>= genCurrySyntax fn
-- Returns the syntax tree of the source program 'src' (type 'Module'; see
@@ -65,26 +52,25 @@
-- searches for standard Curry libraries in the path defined in the
-- environment variable "PAKCSLIBPATH". Additional search paths can
-- be defined using the argument 'paths'.
-fullParse :: [FilePath] -> FilePath -> String -> IO (Result CS.Module)
-fullParse paths fn src =
- genFullCurrySyntax simpleCheckModule paths fn (parse fn src)
+fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad CS.Module)
+fullParse paths fn src = -- liftM msgmonad2result $
+ genFullCurrySyntax simpleCheckModule paths fn (parse fn src)
-- Behaves like 'fullParse', but Returns the syntax tree of the source
-- program 'src' (type 'Module'; see Module "CurrySyntax") after inferring
-- the types of identifiers.
-typingParse :: [FilePath] -> FilePath -> String -> IO (Result CS.Module)
-typingParse paths fn src =
- genFullCurrySyntax checkModule paths fn (parse fn src)
+typingParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad CS.Module)
+typingParse paths fn src = genFullCurrySyntax checkModule paths fn (parse fn src)
+{-
-- Compiles the source programm 'src' to an AbstractCurry program.
-- 'fullParse' always searches for standard Curry libraries in the path
-- defined in the environment variable "PAKCSLIBPATH". Additional search
-- paths can be defined using the argument 'paths'.
-- Notes: Due to the lack of error handling in the current version of the
-- front end, this function may fail when an error occurs
-abstractIO :: [FilePath] -> FilePath -> String -> IO (Result ACY.CurryProg)
-abstractIO paths fn src =
- genAbstractIO paths fn (parse fn src)
+abstractIO :: [FilePath] -> FilePath -> String -> IO (MsgMonad ACY.CurryProg)
+abstractIO paths fn src = genAbstractIO paths fn (parse fn src)
-- Compiles the source program 'src' to a FlatCurry program.
-- 'fullParse' always searches for standard Curry libraries in the path
@@ -92,17 +78,9 @@
-- paths can be defined using the argument 'paths'.
-- Note: Due to the lack of error handling in the current version of the
-- front end, this function may fail when an error occurs
-flatIO :: [FilePath] -> FilePath -> String -> IO (Result FCY.Prog)
-flatIO paths fn src =
- genFlatIO paths fn (parse fn src)
-
-
--------------------------------------------------------------------------------
--- Result handling
-
-data Result a = Result [Message] a | Failure [Message] deriving Show
-
--- See module "Message":
+flatIO :: [FilePath] -> FilePath -> String -> IO (MsgMonad FCY.Prog)
+flatIO paths fn src = genFlatIO paths fn (parse fn src)
+-}
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
@@ -118,52 +96,45 @@
--
-genToks :: Err.Error [(Position,Token)] -> Result [(Position,Token)]
-genToks (Err.Ok toks) = Result [] toks
-genToks (Err.Error err) = Failure [message_ Error err]
-
-
---
-genCurrySyntax :: FilePath -> Err.Error CS.Module -> Result (CS.Module)
-genCurrySyntax fn (Err.Ok mod)
- = let mod'@(CS.Module mid _ _) = patchModuleId fn (importPrelude fn mod)
- in if isValidModuleId fn mid
- then Result [] mod'
- else Failure [message_ Error (err_invalidModuleName mid)]
-genCurrySyntax _ (Err.Error err)
- = Failure [message_ Error err]
+genCurrySyntax :: FilePath -> CS.Module -> MsgMonad (CS.Module)
+genCurrySyntax fn mod
+ = let mod'@(CS.Module mid _ _) = patchModuleId fn (importPrelude fn mod)
+ in if isValidModuleId fn mid
+ then return mod'
+ else failWith $ err_invalidModuleName mid
--
-genFullCurrySyntax check paths fn (Result msgs mod)
- = do errs <- makeInterfaces paths mod
- if null errs
- then do mEnv <- loadInterfaces paths mod
- (_, _, _, mod', _, msgs') <- check (opts paths) mEnv mod
- return (Result (msgs ++ msgs') mod')
- else return (Failure (msgs ++ map (message_ Error) errs))
-genFullCurrySyntax _ _ _ (Failure msgs) = return (Failure msgs)
+genFullCurrySyntax :: (Options -> Base.ModuleEnv -> CS.Module -> IO (t1, t2, t3, CS.Module, t4, [WarnMsg]))
+ -> [FilePath] -> t -> MsgMonad CS.Module -> IO (MsgMonad CS.Module)
+genFullCurrySyntax check paths fn m
+ = runMsgIO m $ \mod -> do errs <- makeInterfaces paths mod
+ if null errs
+ then do mEnv <- loadInterfaces paths mod
+ (_, _, _, mod', _, msgs') <- check (opts paths) mEnv mod
+ return (tell msgs' >> return mod')
+ else return (failWith (head errs))
---
-genAbstractIO :: [FilePath] -> FilePath -> Result CS.Module
- -> IO (Result ACY.CurryProg)
-genAbstractIO paths fn (Result msgs mod)
- = do errs <- makeInterfaces paths mod
+{-
+genAbstractIO :: [FilePath] -> FilePath -> MsgMonad CS.Module
+ -> IO (MsgMonad ACY.CurryProg)
+genAbstractIO paths fn m
+ = runMsgIO m $ \mod ->
+ do errs <- makeInterfaces paths mod
if null errs
then do mEnv <- loadInterfaces paths mod
(tyEnv, tcEnv, _, mod', _, msgs')
<- simpleCheckModule (opts paths) mEnv mod
- return (Result (msgs ++ msgs')
- (genTypedAbstract tyEnv tcEnv mod'))
- else return (Failure (msgs ++ map (message_ Error) errs))
-genAbstractIO _ _ (Failure msgs) = return (Failure msgs)
+ return (tell msgs' >> return (genTypedAbstract tyEnv tcEnv mod'))
+ else return (failWith $ head errs)
--
-genFlatIO :: [FilePath] -> FilePath -> Result CS.Module -> IO (Result FCY.Prog)
-genFlatIO paths fn (Result msgs mod)
- = do errs <- makeInterfaces paths mod
+genFlatIO :: [FilePath] -> FilePath -> MsgMonad CS.Module -> IO (MsgMonad FCY.Prog)
+genFlatIO paths fn m
+ = runMsgIO m $ \ mod ->
+ do errs <- makeInterfaces paths mod
if null errs then
(do mEnv <- loadInterfaces paths mod
(tyEnv, tcEnv, aEnv, mod', intf, msgs') <-
@@ -174,10 +145,10 @@
cEnv = curryEnv mEnv tcEnv intf mod'
(prog,msgs'') = genFlatCurry (opts paths) cEnv mEnv
tyEnv tcEnv aEnv' il'
- return (Result (msgs'' ++ msgs ++ msgs') prog)
+ return (tell msgs'' >> tell msgs' >> return prog)
)
- else return (Failure (msgs ++ map (message_ Error) errs))
-genFlatIO _ _ (Failure msgs) = return (Failure msgs)
+ else return (failWith $ head errs)
+-}
-------------------------------------------------------------------------------
@@ -188,16 +159,15 @@
makeInterfaces paths (CS.Module mid _ decls)
= do let imports = [preludeMIdent | mid /= preludeMIdent]
++ [imp | CS.ImportDecl _ imp _ _ _ <- decls]
- (deps, errs) <- fmap (flattenDeps . sortDeps)
- (foldM (moduleDeps paths []) emptyEnv imports)
+ (deps, errs) <- fmap flattenDeps (foldM (moduleDeps paths []) Map.empty imports)
when (null errs) (mapM_ (compile deps . snd) deps)
return errs
where
compile deps (Source file' mods)
= do smake [flatName file', flatIntName file']
- (file':catMaybes (map (flatInterface deps) mods))
- (compileCurry (opts paths) file')
- (return defaultResults)
+ (file':mapMaybe (flatInterface deps) mods)
+ (compileModule (opts paths) file')
+ (return Nothing)
return ()
compile _ _ = return ()
@@ -207,47 +177,12 @@
Just (Interface file) -> Just (flatIntName (dropExtension file))
_ -> Nothing
--- Declares the filename as module name, if the module name is not
--- explicitly declared in the module.
-patchModuleId :: FilePath -> CS.Module -> CS.Module
-patchModuleId fn (CS.Module mid mexports decls)
- | (moduleName mid) == "main"
- = CS.Module (mkMIdent [takeBaseName fn]) mexports decls
- | otherwise
- = CS.Module mid mexports decls
-
--- Adds an import declaration for the prelude to the module, if
--- it is not the prelude itself. If the module already has an explicit
--- import for the prelude, then a qualified import is added.
-importPrelude :: FilePath -> CS.Module -> CS.Module
-importPrelude fn (CS.Module m es ds)
- = CS.Module m es (if m == preludeMIdent then ds else ds')
- where ids = [decl | decl@(CS.ImportDecl _ _ _ _ _) <- ds]
- ds' = CS.ImportDecl (first fn) preludeMIdent
- (preludeMIdent `elem` map importedModule ids)
- Nothing Nothing : ds
- importedModule (CS.ImportDecl _ m q asM is) = fromMaybe m asM
-
-
-- Returns 'True', if file name and module name are equal.
isValidModuleId :: FilePath -> ModuleIdent -> Bool
isValidModuleId fn mid
= last (moduleQualifiers mid) == takeBaseName fn
-
--- Converts a literate source program to a non-literate source program
-unlitLiterate :: FilePath -> String -> (String,String)
-unlitLiterate fn src
- | isLiterateSource fn = unlit fn src
- | otherwise = ("",src)
-
-isLiterateSource :: FilePath -> Bool
-isLiterateSource fn = litExt `isSuffixOf` fn
-
-litExt = ".lcurry"
-
-compileCurry = compileModule_
-------------------------------------------------------------------------------
-- Messages
diff --git a/src/GenAbstractCurry.hs b/src/GenAbstractCurry.hs
--- a/src/GenAbstractCurry.hs
+++ b/src/GenAbstractCurry.hs
@@ -10,17 +10,20 @@
module GenAbstractCurry (genTypedAbstract,
genUntypedAbstract) where
+import qualified Data.Map as Map
+import qualified Data.Set as Set
import Data.Maybe
import Data.List
import Data.Char
-import AbstractCurry
+import Curry.Syntax
+import Curry.AbstractCurry
+
import Base
import Types
-import Ident
-import Position
+import Curry.Base.Ident
+import Curry.Base.Position
import TopEnv
-import Env
-------------------------------------------------------------------------------
@@ -54,13 +57,13 @@
= mapfoldl genImportDecl env (reverse (importDecls partitions))
(types, _)
= mapfoldl genTypeDecl env (reverse (typeDecls partitions))
- (funcs, _)
- = mapfoldl (genFuncDecl False)
+ (_, funcs)
+ = Map.mapAccumWithKey (genFuncDecl False)
env
(funcDecls partitions)
(ops, _)
= mapfoldl genOpDecl env (reverse (opDecls partitions))
- in CurryProg modname imps types funcs ops
+ in CurryProg modname imps types (Map.elems funcs) ops
-------------------------------------------------------------------------------
@@ -87,16 +90,16 @@
partitionDecl partitions (FlatExternalDecl pos ids)
= partitionFuncDecls (\id -> FlatExternalDecl pos [id]) partitions ids
partitionDecl partitions (InfixDecl pos fix prec idents)
- = partitions {opDecls = (map (\id -> (InfixDecl pos fix prec [id])) idents)
- ++ (opDecls partitions)}
+ = partitions {opDecls = map (\id -> (InfixDecl pos fix prec [id])) idents
+ ++ opDecls partitions }
partitionDecl partitions decl
= case decl of
ImportDecl _ _ _ _ _
- -> partitions {importDecls = decl:(importDecls partitions)}
+ -> partitions {importDecls = decl: importDecls partitions }
DataDecl _ _ _ _
- -> partitions {typeDecls = decl:(typeDecls partitions)}
+ -> partitions {typeDecls = decl : typeDecls partitions }
TypeDecl _ _ _ _
- -> partitions {typeDecls = decl:(typeDecls partitions)}
+ -> partitions {typeDecls = decl : typeDecls partitions }
_ -> partitions
@@ -106,7 +109,7 @@
= partitions {funcDecls = foldl partitionFuncDecl (funcDecls partitions) ids}
where
partitionFuncDecl funcs' id
- = insertEntry id ((genDecl id):(fromMaybe [] (lookup id funcs'))) funcs'
+ = Map.insert id (genDecl id : fromMaybe [] (Map.lookup id funcs')) funcs'
-- Data type for representing partitions of CurrySyntax declarations
@@ -117,14 +120,14 @@
-- to collect them within an association list
data Partitions = Partitions {importDecls :: [Decl],
typeDecls :: [Decl],
- funcDecls :: [(Ident,[Decl])],
+ funcDecls :: Map.Map Ident [Decl],
opDecls :: [Decl]
} deriving Show
-- Generates initial partitions.
emptyPartitions = Partitions {importDecls = [],
typeDecls = [],
- funcDecls = [],
+ funcDecls = Map.empty,
opDecls = []
}
@@ -202,15 +205,15 @@
(ls,ts) = unzip fs
(ts',env1) = mapfoldl genTypeExpr env ts
ls' = map name ls
- in case mr of
+ in case mr of
Nothing
-> (CRecordType (zip ls' ts') Nothing, env1)
Just tvar@(VariableType _)
-> let (CTVar iname, env2) = genTypeExpr env1 tvar
in (CRecordType (zip ls' ts') (Just iname), env2)
- Just rec@(RecordType _ _)
- -> let (CRecordType fields rbase, env2) = genTypeExpr env1 rec
- fields' = foldr (\ (l,t) -> insertEntry l t)
+ (Just r@(RecordType _ _))
+ -> let (CRecordType fields rbase, env2) = genTypeExpr env1 r
+ fields' = foldr (uncurry insertEntry)
fields
(zip ls' ts')
in (CRecordType fields' rbase, env2)
@@ -240,8 +243,8 @@
-- - since infered types are internally represented in flat style,
-- all type variables are renamed with generated symbols when
-- generating typed AbstractCurry.
-genFuncDecl :: Bool -> AbstractEnv -> (Ident, [Decl]) -> (CFuncDecl, AbstractEnv)
-genFuncDecl isLocal env (ident, decls)
+genFuncDecl :: Bool -> AbstractEnv -> Ident -> [Decl] -> (AbstractEnv, CFuncDecl)
+genFuncDecl isLocal env ident decls
| not (null decls)
= let name = genQName False env (qualify ident)
visibility = genVisibility env ident
@@ -255,21 +258,21 @@
(\ (FunctionDecl _ _ equs)
-> mapfoldl genRule env1 equs)
(find isFunctionDecl decls)
- mexternal = applyMaybe genExternal (find isExternal decls)
+ mexternal = fmap genExternal (find isExternal decls)
arity = compArity mtype rules
typeexpr = fromMaybe (CTCons ("Prelude","untyped") []) mtype
rule = compRule evalannot rules mexternal
env3 = if isLocal then env1 else resetScope env2
- in (CFunc name arity visibility typeexpr rule, env3)
+ in (env3, CFunc name arity visibility typeexpr rule)
| otherwise
= internalError ("missing declaration for function \""
++ show ident ++ "\"")
where
genFuncType env decls
| acytype == UntypedAcy
- = applyMaybe (genTypeSig env) (find isTypeSig decls)
+ = fmap (genTypeSig env) (find isTypeSig decls)
| acytype == TypedAcy
- = applyMaybe (genTypeExpr env) mftype
+ = fmap (genTypeExpr env) mftype
| otherwise
= Nothing
where
@@ -300,7 +303,7 @@
mtypeexpr
compArityFromType (CTVar _) = 0
- compArityFromType (CFuncType _ t2) = 1 + (compArityFromType t2)
+ compArityFromType (CFuncType _ t2) = 1 + compArityFromType t2
compArityFromType (CTCons _ _) = 0
compRule evalannot rules mexternal
@@ -371,7 +374,7 @@
-- The association list 'fdecls' is necessary because function
-- rules may not be together in the declaration list
- genLocals :: AbstractEnv -> [(Ident,[Decl])] -> [Decl]
+ genLocals :: AbstractEnv -> Map.Map Ident [Decl] -> [Decl]
-> ([CLocalDecl], AbstractEnv)
genLocals env _ [] = ([], env)
genLocals env fdecls ((FunctionDecl _ ident _):decls)
@@ -390,15 +393,15 @@
(locals, env2)
= genLocals (endScope env1)
fdecls
- ((FlatExternalDecl pos (tail idents)):decls)
+ (FlatExternalDecl pos (tail idents):decls)
in (funcdecl:locals, env2)
- genLocals env fdecls ((PatternDecl pos constr rhs):decls)
+ genLocals env fdecls (PatternDecl pos constr rhs : decls)
= let (patt, env1) = genLocalPattern pos env constr
(plocals, env2) = genLocalDecls (beginScope env1)
(simplifyRhsLocals rhs)
(expr, env3) = genLocalPattRhs pos env2 (simplifyRhsExpr rhs)
(locals, env4) = genLocals (endScope env3) fdecls decls
- in ((CLocalPat patt expr plocals):locals, env4)
+ in (CLocalPat patt expr plocals:locals, env4)
genLocals env fdecls ((ExtraVariables pos idents):decls)
| null idents = genLocals env fdecls decls
| otherwise
@@ -408,23 +411,23 @@
++ " for free variable \""
++ show ident ++ "\""))
(getVarIndex env ident)
- decls' = (ExtraVariables pos (tail idents)):decls
+ decls' = ExtraVariables pos (tail idents) : decls
(locals, env') = genLocals env fdecls decls'
- in ((CLocalVar (idx, name ident)):locals, env')
+ in (CLocalVar (idx, name ident) : locals, env')
genLocals env fdecls ((TypeSig _ _ _):decls)
= genLocals env fdecls decls
genLocals _ _ decl = internalError ("unexpected local declaration: \n"
++ show (head decl))
- genLocalFuncDecl :: AbstractEnv -> [(Ident,[Decl])] -> Ident
+ genLocalFuncDecl :: AbstractEnv -> Map.Map Ident [Decl] -> Ident
-> (CLocalDecl, AbstractEnv)
genLocalFuncDecl env fdecls ident
= let fdecl = fromMaybe
(internalError ("missing declaration"
++ " for local function \""
++ show ident ++ "\""))
- (lookup ident fdecls)
- (funcdecl, _) = genFuncDecl True env (ident,fdecl)
+ (Map.lookup ident fdecls)
+ (_, funcdecl) = genFuncDecl True env ident fdecl
in (CLocalFunc funcdecl, env)
genLocalPattern pos env (LiteralPattern lit)
@@ -477,7 +480,7 @@
= let (fields', env1) = mapfoldl (genField genLocalPattern) env fields
(mr', env2)
= maybe (Nothing, env1)
- ((applyFst Just) . (genLocalPattern pos env1))
+ (applyFst Just . genLocalPattern pos env1)
mr
in (CPRecord fields' mr', env2)
@@ -518,7 +521,7 @@
genExpr pos env (List _ args)
= let cons = Constructor qConsId
nil = Constructor qNilId
- in genExpr pos env (foldr (\e1 e2 -> Apply (Apply cons e1) e2) nil args)
+ in genExpr pos env (foldr (Apply . Apply cons) nil args)
genExpr pos env (ListCompr _ expr stmts)
= let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts
(expr', env2) = genExpr pos env1 expr
@@ -659,7 +662,7 @@
genPattern pos env (RecordPattern fields mr)
= let (fields', env1) = mapfoldl (genField genPattern) env fields
(mr', env2) = maybe (Nothing, env1)
- ((applyFst Just) . (genPattern pos env1))
+ (applyFst Just . genPattern pos env1)
mr
in (CPRecord fields' mr', env2)
@@ -693,12 +696,10 @@
| otherwise
= genQualName qident
where
- ident = unqualify qident
-
genQualName qid
- = let (mmid, id) = splitQualIdent qid
+ = let (mmid, id) = (qualidMod qid, qualidId qid)
mid = maybe (moduleId env)
- (\mid' -> fromMaybe mid' (lookupEnv mid' (imports env)))
+ (\mid' -> fromMaybe mid' (Map.lookup mid' (imports env)))
mmid
in (moduleName mid, name id)
@@ -749,12 +750,12 @@
data AbstractEnv = AbstractEnv {moduleId :: ModuleIdent,
typeEnv :: ValueEnv,
tconsEnv :: TCEnv,
- exports :: Env Ident (),
- imports :: Env ModuleIdent ModuleIdent,
+ exports :: Set.Set Ident,
+ imports :: Map.Map ModuleIdent ModuleIdent,
varIndex :: Int,
tvarIndex :: Int,
- varScope :: [Env Ident Int],
- tvarScope :: [Env Ident Int],
+ varScope :: [Map.Map Ident Int],
+ tvarScope :: [Map.Map Ident Int],
acyType :: AbstractType
} deriving Show
@@ -770,12 +771,12 @@
{moduleId = mid,
typeEnv = tyEnv,
tconsEnv = tcEnv,
- exports = foldl (buildExportTable mid decls) emptyEnv exps',
- imports = foldl buildImportTable emptyEnv decls,
+ exports = foldl (buildExportTable mid decls) Set.empty exps',
+ imports = foldl buildImportTable Map.empty decls,
varIndex = 0,
tvarIndex = 0,
- varScope = [emptyEnv],
- tvarScope = [emptyEnv],
+ varScope = [Map.empty],
+ tvarScope = [Map.empty],
acyType = absType
}
where
@@ -785,25 +786,25 @@
-- Generates a list of exports for all specified top level declarations
buildExports :: ModuleIdent -> [Decl] -> [Export]
buildExports _ [] = []
-buildExports mid ((DataDecl _ ident _ _):ds)
- = (ExportTypeAll (qualifyWith mid ident)):(buildExports mid ds)
+buildExports mid (DataDecl _ ident _ _:ds)
+ = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds
buildExports mid ((NewtypeDecl _ ident _ _):ds)
- = (ExportTypeAll (qualifyWith mid ident)):(buildExports mid ds)
+ = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds
buildExports mid ((TypeDecl _ ident _ _):ds)
- = (Export (qualifyWith mid ident)):(buildExports mid ds)
+ = Export (qualifyWith mid ident) : buildExports mid ds
buildExports mid ((FunctionDecl _ ident _):ds)
- = (Export (qualifyWith mid ident)):(buildExports mid ds)
-buildExports mid ((ExternalDecl _ _ _ ident _):ds)
- = (Export (qualifyWith mid ident)):(buildExports mid ds)
-buildExports mid ((FlatExternalDecl _ idents):ds)
- = (map (Export . (qualifyWith mid)) idents) ++ (buildExports mid ds)
+ = Export (qualifyWith mid ident) : buildExports mid ds
+buildExports mid (ExternalDecl _ _ _ ident _ : ds)
+ = Export (qualifyWith mid ident) : buildExports mid ds
+buildExports mid (FlatExternalDecl _ idents : ds)
+ = map (Export . qualifyWith mid) idents ++ buildExports mid ds
buildExports mid (_:ds) = buildExports mid ds
-- Builds a table containing all exported (i.e. public) identifiers
-- from a module.
-buildExportTable :: ModuleIdent -> [Decl] -> Env Ident () -> Export
- -> Env Ident ()
+buildExportTable :: ModuleIdent -> [Decl] -> Set.Set Ident -> Export
+ -> Set.Set Ident
buildExportTable mid _ exptab (Export qident)
| isJust (localIdent mid qident)
= insertExportedIdent exptab (unqualify qident)
@@ -826,8 +827,8 @@
buildExportTable _ _ exptab (ExportModule _) = exptab
--
-insertExportedIdent :: Env Ident () -> Ident -> Env Ident ()
-insertExportedIdent env ident = bindEnv ident () env
+insertExportedIdent :: Set.Set Ident -> Ident -> Set.Set Ident
+insertExportedIdent env ident = Set.insert ident env
--
getConstrIdents :: Decl -> [Ident]
@@ -839,16 +840,16 @@
-- Builds a table for dereferencing import aliases
-buildImportTable :: Env ModuleIdent ModuleIdent -> Decl
- -> Env ModuleIdent ModuleIdent
+buildImportTable :: Map.Map ModuleIdent ModuleIdent -> Decl
+ -> Map.Map ModuleIdent ModuleIdent
buildImportTable env (ImportDecl _ mid _ malias _)
- = bindEnv (fromMaybe mid malias) mid env
+ = Map.insert (fromMaybe mid malias) mid env
buildImportTable env _ = env
-- Checks whether an identifier is exported or not.
isExported :: AbstractEnv -> Ident -> Bool
-isExported env ident = isJust (lookupEnv ident (exports env))
+isExported env ident = Set.member ident (exports env)
-- Generates an unique index for the variable 'ident' and inserts it
@@ -857,9 +858,9 @@
genVarIndex env ident
= let idx = varIndex env
vtabs = varScope env
- vtab = head vtabs --if null vtabs then emptyEnv else head vtabs
+ vtab = head vtabs --if null vtabs then Map.empty else head vtabs
in (idx, env {varIndex = idx + 1,
- varScope = (bindEnv ident idx vtab):(sureTail vtabs)})
+ varScope = Map.insert ident idx vtab : sureTail vtabs})
-- Generates an unique index for the type variable 'ident' and inserts it
-- into the type variable table of the current scope.
@@ -867,20 +868,20 @@
genTVarIndex env ident
= let idx = tvarIndex env
vtabs = tvarScope env
- vtab = head vtabs --if null vtabs then emptyEnv else head vtabs
+ vtab = head vtabs --if null vtabs then Map.empty else head vtabs
in (idx, env {tvarIndex = idx + 1,
- tvarScope = (bindEnv ident idx vtab):(sureTail vtabs)})
+ tvarScope = Map.insert ident idx vtab : sureTail vtabs })
-- Looks up the unique index for the variable 'ident' in the
-- variable table of the current scope.
getVarIndex :: AbstractEnv -> Ident -> Maybe Int
-getVarIndex env ident = lookupEnv ident (head (varScope env))
+getVarIndex env ident = Map.lookup ident (head (varScope env))
-- Looks up the unique index for the type variable 'ident' in the type
-- variable table of the current scope.
getTVarIndex :: AbstractEnv -> Ident -> Maybe Int
-getTVarIndex env ident = lookupEnv ident (head (tvarScope env))
+getTVarIndex env ident = Map.lookup ident (head (tvarScope env))
-- Generates an indentifier which doesn't occur in the variable table
@@ -895,31 +896,18 @@
= ident
where ident = mkIdent (name ++ show idx)
--- Generates an indentifier which doesn't occur in the type variable table
--- of the current scope.
-freshTVar :: AbstractEnv -> String -> Ident
-freshTVar env name = genFreshTVar env name 0
- where
- genFreshTVar env name idx
- | isJust (getTVarIndex env ident)
- = genFreshTVar env name (idx + 1)
- | otherwise
- = ident
- where ident = mkIdent (name ++ show idx)
-
-
-- Sets the index counter back to zero and deletes all stack entries.
resetScope :: AbstractEnv -> AbstractEnv
resetScope env = env {varIndex = 0,
tvarIndex = 0,
- varScope = [emptyEnv],
- tvarScope = [emptyEnv]}
+ varScope = [Map.empty],
+ tvarScope = [Map.empty]}
-- Starts a new scope, i.e. copies and pushes the variable table of the current
-- scope onto the top of the stack
beginScope :: AbstractEnv -> AbstractEnv
-beginScope env = env {varScope = (head vs):vs,
- tvarScope = (head tvs):tvs}
+beginScope env = env {varScope = head vs :vs,
+ tvarScope = head tvs :tvs }
where
vs = varScope env
tvs = tvarScope env
@@ -969,7 +957,7 @@
-- Checks, whether a symbol is defined in the Prelude.
isPreludeSymbol :: QualIdent -> Bool
isPreludeSymbol qident
- = let (mmid, ident) = splitQualIdent qident
+ = let (mmid, ident) = (qualidMod qident, qualidId qident)
in (isJust mmid && preludeMIdent == fromJust mmid)
|| elem ident [unitId, listId, nilId, consId]
|| isTupleId ident
@@ -986,7 +974,7 @@
qualLookupType :: QualIdent -> ValueEnv -> Maybe TypeExpr
qualLookupType qident tyEnv
= case (qualLookupValue qident tyEnv) of
- [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts
+ [Value _ ts] -> (\ (ForAll _ ty) -> Just (fromType ty)) ts
_ -> Nothing
-- Looks up the type of a symbol in the type environment and
@@ -994,66 +982,14 @@
lookupType :: Ident -> ValueEnv -> Maybe TypeExpr
lookupType ident tyEnv
= case (lookupValue ident tyEnv) of
- [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts
+ [Value _ ts] -> (\ (ForAll _ ty) -> Just (fromType ty)) ts
_ -> Nothing
--- Converts the internal representation of the types from the type
--- envorinment to CurrySyntax representation
-toCSType :: Type -> TypeExpr
-toCSType = fromType
-{-
-toCSType (TypeConstructor qident types)
- = ConstructorType qident (map toCSType types)
-toCSType (TypeVariable idx)
- = VariableType (mkVarIdent idx)
-toCSType (TypeConstrained types _)
- = toCSType (head types)
-toCSType (TypeArrow type1 type2)
- = ArrowType (toCSType type1) (toCSType type2)
-toCSType (TypeSkolem idx)
- = VariableType (mkVarIdent idx)
--}
-
-{-
---
-solveTypeSyn :: TCEnv -> QualIdent -> [TypeExpr] -> Maybe TypeExpr
-solveTypeSyn tcEnv qident args
- = case (qualLookupTC qident tcEnv) of
- [AliasType _ _ t] -> Just (adaptType args t)
- _ -> case (lookupTC (unqualify qident) tcEnv) of
- [AliasType _ _ t] -> Just (adaptType args t)
- _ -> Nothing
-
---
-adaptType :: [TypeExpr] -> Type -> TypeExpr
-adaptType args texpr = adapt (zip [0 .. ((length args) - 1)] args) texpr
- where
- adapt its (TypeConstructor qident types)
- = ConstructorType qident (map (adapt its) types)
- adapt its (TypeVariable idx)
- = fromMaybe (internalError "cannot adapt type variable")
- (lookup idx its)
- adapt its (TypeConstrained types _)
- = adapt its (head types)
- adapt its (TypeArrow type1 type2)
- = ArrowType (adapt its type1) (adapt its type2)
- adapt its (TypeSkolem idx)
- = adapt its (TypeVariable idx)
--}
-
--- Generates a variable name from an index.
-mkVarIdent :: Int -> Ident
-mkVarIdent i | i < 0 = mkIdent ('b':(show (i * (-1))))
- | i < 26 = mkIdent [chr (i + ord 'a')]
- | otherwise = mkIdent ('a':(show i))
-
-
-
-- The following functions transform left-hand-side and right-hand-side terms
-- for a better handling
simplifyLhs :: Lhs -> [ConstrTerm]
-simplifyLhs lhs = snd (flatLhs lhs)
+simplifyLhs = snd . flatLhs
simplifyRhsExpr :: Rhs -> [(Expression, Expression)]
simplifyRhsExpr (SimpleRhs _ expr _)
@@ -1066,11 +1002,7 @@
simplifyRhsLocals (GuardedRhs _ locals) = locals
--- Applies the function 'f' on the value which is wrapped in 'Just'.
-applyMaybe :: (a -> b) -> Maybe a -> Maybe b
-applyMaybe f (Just x) = Just (f x)
-applyMaybe _ Nothing = Nothing
-
+-- FIXME This mapfold is a twisted mapAccumL
-- A combination of 'map' and 'foldl'. It maps a function to a list
-- from left to right while updating the argument 'e' continously.
mapfoldl :: (a -> b -> (c,a)) -> a -> [b] -> ([c], a)
@@ -1084,7 +1016,7 @@
insertEntry k e [] = [(k,e)]
insertEntry k e ((x,y):xys)
| k == x = (k,e):xys
- | otherwise = (x,y):(insertEntry k e xys)
+ | otherwise = (x,y) : insertEntry k e xys
-- Returns the list without the first element. If the list is empty, an
diff --git a/src/GenFlatCurry.hs b/src/GenFlatCurry.hs
--- a/src/GenFlatCurry.hs
+++ b/src/GenFlatCurry.hs
@@ -15,32 +15,27 @@
import Data.Maybe
import Data.List
import qualified Data.Map as Map
-import Base (ArityEnv, ArityInfo(..), ModuleEnv, PEnv, PrecInfo(..),
- OpPrec(..), TCEnv, TypeInfo(..), ValueEnv, ValueInfo(..),
- lookupValue, qualLookupTC,
- qualLookupArity, lookupArity, internalError)
---import FlatWithSrcRefs
-import ExtendedFlat
-
-import qualified IL
-import qualified CurrySyntax as CS
+import Curry.Base.MessageMonad
+import Curry.Base.Ident as Id
+import Base {-(ArityEnv, ArityInfo(..), ModuleEnv,
+ TCEnv, TypeInfo(..), ValueEnv, ValueInfo(..),
+ lookupValue, qualLookupTC,
+ qualLookupArity, lookupArity, internalError,
+ qualLookupValue)-}
+import Curry.ExtendedFlat
+import qualified IL.Type as IL
+import qualified IL.CurryToIL as IL
+import qualified Curry.Syntax as CS
import CurryEnv (CurryEnv)
import qualified CurryEnv
-
import ScopeEnv (ScopeEnv)
import qualified ScopeEnv
-
-
import Types
import CurryCompilerOpts
-import Message
import PatchPrelude
-import Ident as Id
-import Env
---import Debug.Trace
trace _ x = x
@@ -48,7 +43,7 @@
-- transforms intermediate language code (IL) to FlatCurry code
genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
- -> ArityEnv -> IL.Module -> (Prog, [Message])
+ -> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv mod
= (patchPreludeFCY prog, messages)
where (prog, messages)
@@ -57,7 +52,7 @@
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
- -> ArityEnv -> IL.Module -> (Prog, [Message])
+ -> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv mod
= (patchPreludeFCY intf, messages)
where (intf, messages)
@@ -177,16 +172,19 @@
= liftM Var (lookupVarIndex ident)
visitExpression (IL.Function qident _)
= do arity_ <- lookupIdArity qident
+ qname <- visitQualIdent qident
+ -- ftype <- lookupIdType qident
+ -- let qident' = qname{ typeofQName = ftype }
maybe (internalError (funcArity qident))
- (\arity -> genFuncCall qident arity [])
+ (\arity -> genFuncCall qname arity [])
arity_
visitExpression (IL.Constructor qident arity)
= do arity_ <- lookupIdArity qident
maybe (internalError (consArity qident))
(\arity -> genConsCall qident arity [])
arity_
-visitExpression (IL.Apply expression1 expression2)
- = genFlatApplication (IL.Apply expression1 expression2)
+visitExpression (IL.Apply e1 e2)
+ = genFlatApplication e1 e2
visitExpression (IL.Case r evalannot expression alts)
= do ea <- visitEval evalannot
expr <- visitExpression expression
@@ -208,12 +206,10 @@
newVarIndex (bindingIdent binding)
bind <- visitBinding binding
expr <- visitExpression expression
- case expr of
- Let binds expr' -> return (Let (bind:binds) expr')
- _ -> return (Let [bind] expr)
+ return (Let [bind] expr)
visitExpression (IL.Letrec bindings expression)
= do beginScope
- mapM_ newVarIndex (map bindingIdent bindings)
+ mapM_ (newVarIndex . bindingIdent) bindings
binds <- mapM visitBinding bindings
expr <- visitExpression expression
endScope
@@ -275,8 +271,8 @@
--
visitEval :: IL.Eval -> FlatState CaseType
-visitEval IL.Rigid = return (Rigid)
-visitEval IL.Flex = return (Flex)
+visitEval IL.Rigid = return Rigid
+visitEval IL.Flex = return Flex
--
visitBinding :: IL.Binding -> FlatState (VarIndex, Expr)
@@ -300,8 +296,8 @@
visitTypeIDecl :: CS.IDecl -> FlatState TypeDecl
visitTypeIDecl (CS.IDataDecl _ qident params constrs_)
= do let mid = fromMaybe (internalError "GenFlatCurry: no module name")
- (fst (splitQualIdent qident))
- is = [0 .. (length params) - 1]
+ (qualidMod qident)
+ is = [0 .. length params - 1]
cdecls <- mapM (visitConstrIDecl mid (zip params is))
(catMaybes constrs_)
qname <- visitQualIdent qident
@@ -317,7 +313,7 @@
visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl
-> FlatState ConsDecl
visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs)
- = do texprs <- mapM visitType (map (fst . cs2ilType tis) typeexprs)
+ = do texprs <- mapM (visitType . (fst . cs2ilType tis)) typeexprs
qname <- visitQualIdent (qualifyWith mid ident)
return (Cons qname (length typeexprs) Public texprs)
visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
@@ -338,13 +334,13 @@
--
visitModuleIdent :: ModuleIdent -> FlatState String
-visitModuleIdent mident = return (Id.moduleName mident)
+visitModuleIdent = return . Id.moduleName
--
visitQualIdent :: QualIdent -> FlatState QName
visitQualIdent qident
= do mid <- moduleId
- let (mmod, ident) = splitQualIdent qident
+ let (mmod, ident) = (qualidMod qident, qualidId qident)
mod | elem ident [listId, consId, nilId, unitId] || isTupleId ident
= Id.moduleName preludeMIdent
| otherwise
@@ -354,7 +350,7 @@
--
visitExternalName :: String -> FlatState String
visitExternalName name
- = moduleId >>= (\mid -> return ((Id.moduleName mid) ++ "." ++ name))
+ = moduleId >>= \mid -> return (Id.moduleName mid ++ "." ++ name)
-------------------------------------------------------------------------------
@@ -372,11 +368,11 @@
getExportedImports
= do mid <- moduleId
exps <- exports
- genExportedIDecls (envToList (getExpImports mid emptyEnv exps))
+ genExportedIDecls (Map.toList (getExpImports mid Map.empty exps))
--
-getExpImports :: ModuleIdent -> Env ModuleIdent [CS.Export] -> [CS.Export]
- -> Env ModuleIdent [CS.Export]
+getExpImports :: ModuleIdent -> Map.Map ModuleIdent [CS.Export] -> [CS.Export]
+ -> Map.Map ModuleIdent [CS.Export]
getExpImports mident expenv [] = expenv
getExpImports mident expenv ((CS.Export qident):exps)
= getExpImports mident
@@ -394,20 +390,19 @@
(bindExpImport mident qident (CS.ExportTypeAll qident) expenv)
exps
getExpImports mident expenv ((CS.ExportModule mident'):exps)
- = getExpImports mident (bindEnv mident' [] expenv) exps
+ = getExpImports mident (Map.insert mident' [] expenv) exps
--
bindExpImport :: ModuleIdent -> QualIdent -> CS.Export
- -> Env ModuleIdent [CS.Export] -> Env ModuleIdent [CS.Export]
+ -> Map.Map ModuleIdent [CS.Export] -> Map.Map ModuleIdent [CS.Export]
bindExpImport mident qident export expenv
| isJust (localIdent mident qident)
= expenv
| otherwise
- = let (mmod, _) = splitQualIdent qident
- mod = fromJust mmod
- in maybe (bindEnv mod [export] expenv)
- (\es -> bindEnv mod (export:es) expenv)
- (lookupEnv mod expenv)
+ = let (Just mod) = qualidMod qident
+ in maybe (Map.insert mod [export] expenv)
+ (\es -> Map.insert mod (export:es) expenv)
+ (Map.lookup mod expenv)
--
genExportedIDecls :: [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]
@@ -477,9 +472,9 @@
-------------------------------------------------------------------------------
--
-genFlatApplication :: IL.Expression -> FlatState Expr
-genFlatApplication applicexpr
- = genFlatApplic [] applicexpr
+genFlatApplication :: IL.Expression -> IL.Expression -> FlatState Expr
+genFlatApplication e1 e2
+ = genFlatApplic [e2] e1
where
genFlatApplic args expression
= case expression of
@@ -487,8 +482,9 @@
-> genFlatApplic (expr2:args) expr1
(IL.Function qident _)
-> do arity_ <- lookupIdArity qident
+ qname <- visitQualIdent qident
maybe (internalError (funcArity qident))
- (\arity -> genFuncCall qident arity args)
+ (\arity -> genFuncCall qname arity args)
arity_
(IL.Constructor qident _)
-> do arity_ <- lookupIdArity qident
@@ -499,36 +495,39 @@
genApplicComb expr args
--
-genFuncCall :: QualIdent -> Int -> [IL.Expression] -> FlatState Expr
-genFuncCall qident arity args
+genFuncCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
+genFuncCall qname arity args
| arity > cnt
- = genComb qident args (FuncPartCall (arity - cnt))
+ = genComb qname args (FuncPartCall (arity - cnt))
| arity < cnt
= do let (funcargs, applicargs) = splitAt arity args
- funccall <- genComb qident funcargs FuncCall
+ funccall <- genComb qname funcargs FuncCall
genApplicComb funccall applicargs
| otherwise
- = genComb qident args FuncCall
+ = genComb qname args FuncCall
where cnt = length args
--
genConsCall :: QualIdent -> Int -> [IL.Expression] -> FlatState Expr
genConsCall qident arity args
| arity > cnt
- = genComb qident args (ConsPartCall (arity - cnt))
+ = do qname <- visitQualIdent qident
+ genComb qname args (ConsPartCall (arity - cnt))
| arity < cnt
= do let (funcargs, applicargs) = splitAt arity args
- conscall <- genComb qident funcargs ConsCall
+ qname <- visitQualIdent qident
+ conscall <- genComb qname funcargs ConsCall
genApplicComb conscall applicargs
| otherwise
- = genComb qident args ConsCall
+ = do qname <- visitQualIdent qident
+ genComb qname args ConsCall
where cnt = length args
--
-genComb :: QualIdent -> [IL.Expression] -> CombType -> FlatState Expr
-genComb qident args combtype
+genComb :: QName -> [IL.Expression] -> CombType -> FlatState Expr
+genComb qname args combtype
= do exprs <- mapM visitExpression args
- qname <- visitQualIdent qident
+-- qname <- visitQualIdent qident
return (Comb combtype qname exprs)
--
@@ -544,7 +543,7 @@
--
genOpDecls :: FlatState [OpDecl]
-genOpDecls = fixities >>= (\fix -> mapM genOpDecl fix)
+genOpDecls = fixities >>= mapM genOpDecl
--
genOpDecl :: CS.IDecl -> FlatState OpDecl
@@ -604,7 +603,7 @@
genRecordType :: CS.IDecl -> FlatState TypeDecl
genRecordType (CS.ITypeDecl _ qident params (CS.RecordType fields _))
= do let is = [0 .. (length params) - 1]
- (mod,ident) = splitQualIdent qident
+ (mod,ident) = (qualidMod qident, qualidId qident)
qname <- visitQualIdent ((maybe qualify qualifyWith mod)
(recordExtId ident))
labels <- mapM (genRecordLabel mod (zip params is)) fields
@@ -682,17 +681,14 @@
= internalError ("GenFlatCurry.matchTypeVars: "
++ show ty ++ "\n" ++ show typeexpr)
- matchList ms tys typeexprs
- = foldl (\ms' (ty,typeexpr) -> match ms' ty typeexpr)
- ms
- (zip tys typeexprs)
+ matchList ms tys
+ = foldl (\ms' (ty,typeexpr) -> match ms' ty typeexpr) ms . zip tys
flattenRecordTypeFields :: [([Ident],CS.TypeExpr)] -> [(Ident,CS.TypeExpr)]
-flattenRecordTypeFields fss
+flattenRecordTypeFields
= concatMap (\ (labels, typeexpr)
-> map (\label -> (label,typeexpr)) labels)
- fss
-------------------------------------------------------------------------------
@@ -756,29 +752,10 @@
missingVarIndex id = "GenFlatCurry: missing index for \"" ++ show id ++ "\""
-overlappingRules qid = (OverlapRules,
- "function \""
- ++ show qid
+overlappingRules qid = "function \""
+ ++ qualName qid
++ "\" is non-deterministic due to non-trivial "
- ++ "overlapping rules")
-
-
--------------------------------------------------------------------------------
-prelude_types :: [TypeDecl]
-prelude_types = [(Type (preludeName "()") Public []
- [(Cons (preludeName "()") 0 Public [])]),
- (Type (preludeName "[]") Public [0]
- [(Cons (preludeName "[]") 0 Public []),
- (Cons (preludeName ":") 2 Public
- [(TVar 0),(TCons (preludeName "[]") [(TVar 0)])])])]
- ++ map mkTupleType [2..15]
- where
- preludeName = curry mkQName "Prelude"
- mkTupleType n = let last = n-1
- name = preludeName("(" ++ replicate last ',' ++ ")")
- idxs = [0..last]
- vars = map TVar idxs
- in Type name Public idxs [Cons name n Public vars]
+ ++ "overlapping rules"
-------------------------------------------------------------------------------
@@ -851,13 +828,13 @@
-- Data type for representing an environment which contains information needed
-- for generating FlatCurry code.
data FlatEnv = FlatEnv{ moduleIdE :: ModuleIdent,
- functionIdE :: QualIdent,
+ functionIdE :: QualIdent, -- function name for error messages
compilerOptsE :: Options,
moduleEnvE :: ModuleEnv,
arityEnvE :: ArityEnv,
typeEnvE :: ValueEnv,
tConsEnvE :: TCEnv,
- publicEnvE :: Env Ident IdentExport,
+ publicEnvE :: Map.Map Ident IdentExport,
fixitiesE :: [CS.IDecl],
typeSynonymsE :: [CS.IDecl],
importsE :: [CS.IDecl],
@@ -867,7 +844,7 @@
varIdsE :: ScopeEnv Ident VarIndex,
tvarIndexE :: Int,
tvarIdsE :: ScopeEnv Ident TVarIndex,
- messagesE :: [Message],
+ messagesE :: [WarnMsg],
genInterfaceE :: Bool
}
@@ -884,7 +861,7 @@
-- Runs a 'FlatState' action and returns the result
run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
- -> Bool -> FlatState a -> (a, [Message])
+ -> Bool -> FlatState a -> (a, [WarnMsg])
run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f
= (result, messagesE env)
where
@@ -955,7 +932,7 @@
--
isPublic :: Bool -> QualIdent -> FlatState Bool
isPublic isConstr qid = gets (\env -> maybe False isP
- (lookupEnv (unqualify qid)
+ (Map.lookup (unqualify qid)
(publicEnvE env)))
where
isP NotConstr = not isConstr
@@ -965,7 +942,7 @@
--
lookupModuleIntf :: ModuleIdent -> FlatState (Maybe [CS.IDecl])
lookupModuleIntf mid
- = gets (lookupEnv mid . moduleEnvE)
+ = gets (Map.lookup mid . moduleEnvE)
--
lookupIdArity :: QualIdent -> FlatState (Maybe Int)
@@ -980,6 +957,20 @@
_ -> Nothing
_ -> Nothing
+--
+lookupIdType :: QualIdent -> FlatState (Maybe TypeExpr)
+lookupIdType qid
+ = do aEnv <- gets typeEnvE
+ lookupT qid aEnv
+ where
+ lookupT qid aEnv = let vals = qualLookupValue qid aEnv
+ ts = [ t | Value _ (ForAll _ t) <- vals]
+ in case ts of
+ t : _ -> do t' <- visitType (IL.translType t)
+ return (Just t')
+ [] -> error ("no type for " ++ show qid ++ show vals ++ show aEnv) -- return Nothing
+
+
-- Generates a new index for a variable
newVarIndex :: Ident -> FlatState VarIndex
newVarIndex id
@@ -1005,46 +996,11 @@
varIdsE = ScopeEnv.new
})
--- Generates a new index for a type variable
-newTVarIndex :: Ident -> FlatState Int
-newTVarIndex id
- = do idx0 <- gets tvarIndexE
- let idx = 1 + idx0
- vids <- gets tvarIdsE
- modify (\env -> env{ tvarIndexE = idx,
- tvarIdsE = ScopeEnv.insert id idx vids
- })
- return idx
-
--- Looks up the index of an existing type variable or generates a new index,
--- if the type variable doesn't exist
-getTVarIndex :: Ident -> FlatState Int
-getTVarIndex id
- = do idx0 <- gets tvarIndexE
- let idx = idx0 + 1
- vids <- gets tvarIdsE
- maybe (do modify (\env -> env{ tvarIndexE = idx,
- tvarIdsE = ScopeEnv.insert id idx vids })
- return idx)
- return
- (ScopeEnv.lookup id vids)
-
--
-lookupTVarIndex :: Ident -> FlatState (Maybe Int)
-lookupTVarIndex id
- = gets (ScopeEnv.lookup id . tvarIdsE)
-
---
-clearTVarIndices :: FlatState ()
-clearTVarIndices = modify (\env -> env { tvarIndexE = 0,
- tvarIdsE = ScopeEnv.new
- })
-
---
-genWarning :: (WarningType,String) -> FlatState ()
-genWarning (warnType,msg)
+genWarning :: String -> FlatState ()
+genWarning msg
= modify (\env -> env{ messagesE = warnMsg:(messagesE env) })
- where warnMsg = message_ (Warning warnType) msg
+ where warnMsg = WarnMsg Nothing msg
--
genInterface :: FlatState Bool
@@ -1076,14 +1032,14 @@
-- Note: Currently the record functions (selection and update) for all public
-- record labels are inserted into the environment, though they are not
-- explicitly declared in the export specifications.
-genPubEnv :: ModuleIdent -> [CS.IDecl] -> Env Ident IdentExport
-genPubEnv mid idecls = foldl (bindEnvIDecl mid) emptyEnv idecls
+genPubEnv :: ModuleIdent -> [CS.IDecl] -> Map.Map Ident IdentExport
+genPubEnv mid idecls = foldl (bindEnvIDecl mid) Map.empty idecls
-bindIdentExport :: Ident -> Bool -> Env Ident IdentExport -> Env Ident IdentExport
+bindIdentExport :: Ident -> Bool -> Map.Map Ident IdentExport -> Map.Map Ident IdentExport
bindIdentExport id isConstr env =
- maybe (bindEnv id (if isConstr then OnlyConstr else NotConstr) env)
- (\ ie -> bindEnv id (updateIdentExport ie isConstr) env)
- (lookupEnv id env)
+ maybe (Map.insert id (if isConstr then OnlyConstr else NotConstr) env)
+ (\ ie -> Map.insert id (updateIdentExport ie isConstr) env)
+ (Map.lookup id env)
where
updateIdentExport OnlyConstr True = OnlyConstr
updateIdentExport OnlyConstr False = NotOnlyConstr
@@ -1093,7 +1049,7 @@
--
-bindEnvIDecl :: ModuleIdent -> Env Ident IdentExport -> CS.IDecl -> Env Ident IdentExport
+bindEnvIDecl :: ModuleIdent -> Map.Map Ident IdentExport -> CS.IDecl -> Map.Map Ident IdentExport
bindEnvIDecl mid env (CS.IDataDecl _ qid _ mcdecls)
= maybe env
(\id -> foldl bindEnvConstrDecl
@@ -1111,30 +1067,24 @@
bindEnvIDecl _ env _ = env
--
-bindEnvITypeDecl :: Env Ident IdentExport -> Ident -> CS.TypeExpr
- -> Env Ident IdentExport
+bindEnvITypeDecl :: Map.Map Ident IdentExport -> Ident -> CS.TypeExpr
+ -> Map.Map Ident IdentExport
bindEnvITypeDecl env id (CS.RecordType fs _)
= bindIdentExport id False (foldl (bindEnvRecordLabel id) env fs)
bindEnvITypeDecl env id texpr
= bindIdentExport id False env
--
-bindEnvConstrDecl :: Env Ident IdentExport -> CS.ConstrDecl -> Env Ident IdentExport
+bindEnvConstrDecl :: Map.Map Ident IdentExport -> CS.ConstrDecl -> Map.Map Ident IdentExport
bindEnvConstrDecl env (CS.ConstrDecl _ _ id _) = bindIdentExport id True env
bindEnvConstrDecl env (CS.ConOpDecl _ _ _ id _) = bindIdentExport id True env
--
-bindEnvNewConstrDecl :: Env Ident IdentExport -> CS.NewConstrDecl -> Env Ident IdentExport
+bindEnvNewConstrDecl :: Map.Map Ident IdentExport -> CS.NewConstrDecl -> Map.Map Ident IdentExport
bindEnvNewConstrDecl env (CS.NewConstrDecl _ _ id _) = bindIdentExport id False env
--
-bindEnvRecordLabel :: Ident -> Env Ident IdentExport -> ([Ident],CS.TypeExpr)
- -> Env Ident IdentExport
-bindEnvRecordLabel rec env ([lab],_)
- = bindIdentExport (recSelectorId (qualify rec) lab)
- False
- (bindIdentExport (recUpdateId (qualify rec) lab) False env)
-
-
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
+bindEnvRecordLabel :: Ident -> Map.Map Ident IdentExport -> ([Ident],CS.TypeExpr) -> Map.Map Ident IdentExport
+bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo
+ where
+ expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)
diff --git a/src/IL.lhs b/src/IL.lhs
deleted file mode 100644
--- a/src/IL.lhs
+++ /dev/null
@@ -1,108 +0,0 @@
-% $Id: IL.lhs,v 1.18 2003/10/28 05:43:38 wlux Exp $
-%
-% Copyright (c) 1999-2003 Wolfgang Lux
-% See LICENSE for the full license.
-%
-% Modified by Martin Engelke (men@informatik.uni-kiel.de)
-%
-\nwfilename{IL.lhs}
-\section{The intermediate language}
-The module \texttt{IL} defines the intermediate language which will be
-compiled into abstract machine code. The intermediate language removes
-a lot of syntactic sugar from the Curry source language. Top-level
-declarations are restricted to data type and function definitions. A
-newtype definition serves mainly as a hint to the backend that it must
-provide an auxiliary function for partial applications of the
-constructor. \textbf{Newtype constructors must not occur in patterns
-and may be used in expressions only as partial applications.}
-
-Type declarations use a de-Bruijn indexing scheme (starting at 0) for
-type variables. In the type of a function, all type variables are
-numbered in the order of their occurence from left to right, i.e., a
-type \texttt{(Int -> b) -> (a,b) -> c -> (a,c)} is translated into the
-type (using integer numbers to denote the type variables)
-\texttt{(Int -> 0) -> (1,0) -> 2 -> (1,2)}.
-
-Pattern matching in an equation is handled via flexible and rigid
-\texttt{Case} expressions. Overlapping rules are translated with the
-help of \texttt{Or} expressions. The intermediate language has three
-kinds of binding expressions, \texttt{Exist} expressions introduce a
-new logical variable, \texttt{Let} expression support a single
-non-recursive variable binding, and \texttt{Letrec} expressions
-introduce multiple variables with recursive initializer expressions.
-The intermediate language explicitly distinguishes (local) variables
-and (global) functions in expressions.
-
-\em{Note:} this modified version uses haskell type \texttt{Integer}
-instead of \texttt{Int} for representing integer values. This provides
-an unlimited range of integer constants in Curry programs.
-\begin{verbatim}
-
-> module IL where
-> import Ident
-> import Position (SrcRef(..))
-
-> data Module = Module ModuleIdent [ModuleIdent] [Decl] deriving (Eq,Show)
-
-> data Decl =
-> DataDecl QualIdent Int [ConstrDecl [Type]]
-> | NewtypeDecl QualIdent Int (ConstrDecl Type)
-> | FunctionDecl QualIdent [Ident] Type Expression
-> | ExternalDecl QualIdent CallConv String Type
-> deriving (Eq,Show)
-
-> data ConstrDecl a = ConstrDecl QualIdent a deriving (Eq,Show)
-> data CallConv = Primitive | CCall deriving (Eq,Show)
-
-> data Type =
-> TypeConstructor QualIdent [Type]
-> | TypeVariable Int
-> | TypeArrow Type Type
-> deriving (Eq,Show)
-
-> data Literal = Char SrcRef Char | Int SrcRef Integer | Float SrcRef Double deriving (Eq,Show)
-
-> data ConstrTerm =
-> -- literal patterns
-> LiteralPattern Literal
-> -- constructors
-> | ConstructorPattern QualIdent [Ident]
-> -- default
-> | VariablePattern Ident
-> deriving (Eq,Show)
-
-> data Expression =
-> -- literal constants
-> Literal Literal
-> -- variables, functions, constructors
-> | Variable Ident | Function QualIdent Int | Constructor QualIdent Int
-> -- applications
-> | Apply Expression Expression
-> -- case expressions
-> | Case SrcRef Eval Expression [Alt]
-> -- non-determinisismic or
-> | Or Expression Expression
-> -- binding forms
-> | Exist Ident Expression
-> | Let Binding Expression
-> | Letrec [Binding] Expression
-> deriving (Eq,Show)
-
-> data Eval = Rigid | Flex deriving (Eq,Show)
-> data Alt = Alt ConstrTerm Expression deriving (Eq,Show)
-> data Binding = Binding Ident Expression deriving (Eq,Show)
-
-\end{verbatim}
-
-> instance SrcRefOf ConstrTerm where
-> srcRefOf (LiteralPattern l) = srcRefOf l
-> srcRefOf (ConstructorPattern i _) = srcRefOf i
-> srcRefOf (VariablePattern i) = srcRefOf i
-
-
-> instance SrcRefOf Literal where
-> srcRefOf (Char s _) = s
-> srcRefOf (Int s _) = s
-> srcRefOf (Float s _) = s
-
-
diff --git a/src/IL/CurryToIL.lhs b/src/IL/CurryToIL.lhs
new file mode 100644
--- /dev/null
+++ b/src/IL/CurryToIL.lhs
@@ -0,0 +1,598 @@
+
+% $Id: ILTrans.lhs,v 1.86 2004/02/13 19:23:58 wlux Exp $
+%
+% Copyright (c) 1999-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{ILTrans.lhs}
+\section{Translating Curry into the Intermediate Language}
+After desugaring and lifting have been performed, the source code is
+translated into the intermediate language. Besides translating from
+source terms and expressions into intermediate language terms and
+expressions this phase in particular has to implement the pattern
+matching algorithm for equations and case expressions.
+
+Because of name conflicts between the source and intermediate language
+data structures, we can use only a qualified import for the
+\texttt{IL} module.
+\begin{verbatim}
+
+> module IL.CurryToIL(ilTrans,ilTransIntf, translType) where
+
+> import Data.Maybe
+> import Data.List
+> import qualified Data.Set as Set
+> import qualified Data.Map as Map
+
+> import Curry.Base.Position
+> import Curry.Base.Ident
+> import Curry.Syntax
+> import Curry.Syntax.Utils
+
+> import Types
+> import Base
+> import qualified IL.Type as IL
+> import Utils
+
+
+
+\end{verbatim}
+\paragraph{Modules}
+At the top-level, the compiler has to translate data type, newtype,
+function, and external declarations. When translating a data type or
+newtype declaration, we ignore the types in the declaration and lookup
+the types of the constructors in the type environment instead because
+these types are already fully expanded, i.e., they do not include any
+alias types.
+\begin{verbatim}
+
+> ilTrans :: Bool -> ValueEnv -> TCEnv -> EvalEnv -> Module -> IL.Module
+> ilTrans flat tyEnv tcEnv evEnv (Module m _ ds) =
+> IL.Module m (imports m ds') ds'
+> where ds' = concatMap (translGlobalDecl flat m tyEnv tcEnv evEnv) ds
+
+> translGlobalDecl :: Bool -> ModuleIdent -> ValueEnv -> TCEnv -> EvalEnv
+> -> Decl -> [IL.Decl]
+> translGlobalDecl _ m tyEnv tcEnv _ (DataDecl _ tc tvs cs) =
+> [translData m tyEnv tcEnv tc tvs cs]
+> translGlobalDecl _ m tyEnv tcEnv _ (NewtypeDecl _ tc tvs nc) =
+> [translNewtype m tyEnv tcEnv tc tvs nc]
+> translGlobalDecl flat m tyEnv tcEnv evEnv (FunctionDecl pos f eqs) =
+> [translFunction pos flat m tyEnv tcEnv evEnv f eqs]
+> translGlobalDecl _ m tyEnv tcEnv _ (ExternalDecl _ cc ie f _) =
+> [translExternal m tyEnv tcEnv f cc (fromJust ie)]
+> translGlobalDecl _ _ _ _ _ _ = []
+
+> translData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] -> [ConstrDecl]
+> -> IL.Decl
+> translData m tyEnv tcEnv tc tvs cs =
+> IL.DataDecl (qualifyWith m tc) (length tvs)
+> (map (translConstrDecl m tyEnv tcEnv) cs)
+
+> translNewtype :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident]
+> -> NewConstrDecl -> IL.Decl
+> translNewtype m tyEnv tcEnv tc tvs (NewConstrDecl _ _ c _) =
+> IL.NewtypeDecl (qualifyWith m tc) (length tvs)
+> (IL.ConstrDecl c' (translType' m tyEnv tcEnv ty))
+> -- (IL.ConstrDecl c' (translType ty))
+> where c' = qualifyWith m c
+> TypeArrow ty _ = constrType tyEnv c'
+
+> translConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> ConstrDecl
+> -> IL.ConstrDecl [IL.Type]
+> translConstrDecl m tyEnv tcEnv d =
+> IL.ConstrDecl c' (map (translType' m tyEnv tcEnv)
+> (arrowArgs (constrType tyEnv c')))
+> -- IL.ConstrDecl c' (map translType (arrowArgs (constrType tyEnv c')))
+> where c' = qualifyWith m (constr d)
+> constr (ConstrDecl _ _ c _) = c
+> constr (ConOpDecl _ _ _ op _) = op
+
+> translExternal :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> CallConv
+> -> String -> IL.Decl
+> translExternal m tyEnv tcEnv f cc ie =
+> IL.ExternalDecl f' (callConv cc) ie
+> (translType' m tyEnv tcEnv (varType tyEnv f'))
+> -- IL.ExternalDecl f' (callConv cc) ie (translType (varType tyEnv f'))
+> where f' = qualifyWith m f
+> callConv CallConvPrimitive = IL.Primitive
+> callConv CallConvCCall = IL.CCall
+
+\end{verbatim}
+\paragraph{Interfaces}
+In order to generate code, the compiler also needs to know the tags
+and arities of all imported data constructors. For that reason we
+compile the data type declarations of all interfaces into the
+intermediate language, too. In this case we do not lookup the
+types in the environment because the types in the interfaces are
+already fully expanded. Note that we do not translate data types
+which are imported into the interface from some other module.
+\begin{verbatim}
+
+> ilTransIntf :: ValueEnv -> TCEnv -> Interface -> [IL.Decl]
+> ilTransIntf tyEnv tcEnv (Interface m ds) =
+> foldr (translIntfDecl m tyEnv tcEnv) [] ds
+
+> translIntfDecl :: ModuleIdent -> ValueEnv -> TCEnv -> IDecl -> [IL.Decl]
+> -> [IL.Decl]
+> translIntfDecl m tyEnv tcEnv (IDataDecl _ tc tvs cs) ds
+> | not (isQualified tc) =
+> translIntfData m tyEnv tcEnv (unqualify tc) tvs cs : ds
+> translIntfDecl _ _ _ _ ds = ds
+
+> translIntfData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident]
+> -> [Maybe ConstrDecl] -> IL.Decl
+> translIntfData m tyEnv tcEnv tc tvs cs =
+> IL.DataDecl (qualifyWith m tc) (length tvs)
+> (map (maybe hiddenConstr
+> (translIntfConstrDecl m tyEnv tcEnv tvs)) cs)
+> where hiddenConstr = IL.ConstrDecl qAnonId []
+> qAnonId = qualify anonId
+
+> translIntfConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> [Ident]
+> -> ConstrDecl -> IL.ConstrDecl [IL.Type]
+> translIntfConstrDecl m tyEnv tcEnv tvs (ConstrDecl _ _ c tys) =
+> IL.ConstrDecl (qualifyWith m c) (map (translType' m tyEnv tcEnv)
+> (toQualTypes m tvs tys))
+> -- IL.ConstrDecl (qualifyWith m c) (map translType (toQualTypes m tvs tys))
+> translIntfConstrDecl m tyEnv tcEnv tvs (ConOpDecl _ _ ty1 op ty2) =
+> IL.ConstrDecl (qualifyWith m op)
+> (map (translType' m tyEnv tcEnv)
+> (toQualTypes m tvs [ty1,ty2]))
+> -- IL.ConstrDecl (qualifyWith m op)
+> -- (map translType (toQualTypes m tvs [ty1,ty2]))
+
+\end{verbatim}
+\paragraph{Types}
+The type representation in the intermediate language is the same as
+the internal representation except that it does not support
+constrained type variables and skolem types. The former are fixed and
+the later are replaced by fresh type constructors.
+
+Due to possible occurrence of record types, it is necessary to transform
+them back into their corresponding type constructors.
+\begin{verbatim}
+
+> translType' :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
+> translType' m tyEnv tcEnv ty =
+> translType (elimRecordTypes m tyEnv tcEnv (maximum (0:(typeVars ty))) ty)
+
+> translType :: Type -> IL.Type
+> translType (TypeConstructor tc tys) =
+> IL.TypeConstructor tc (map translType tys)
+> translType (TypeVariable tv) = IL.TypeVariable tv
+> translType (TypeConstrained tys _) = translType (head tys)
+> translType (TypeArrow ty1 ty2) =
+> IL.TypeArrow (translType ty1) (translType ty2)
+> translType (TypeSkolem k) =
+> IL.TypeConstructor (qualify (mkIdent ("_" ++ show k))) []
+
+> elimRecordTypes :: ModuleIdent -> ValueEnv -> TCEnv -> Int -> Type -> Type
+> elimRecordTypes m tyEnv tcEnv n (TypeConstructor t tys) =
+> TypeConstructor t (map (elimRecordTypes m tyEnv tcEnv n) tys)
+> elimRecordTypes m tyEnv tcEnv n (TypeVariable v) =
+> TypeVariable v
+> elimRecordTypes m tyEnv tcEnv n (TypeConstrained tys v) =
+> TypeConstrained (map (elimRecordTypes m tyEnv tcEnv n) tys) v
+> elimRecordTypes m tyEnv tcEnv n (TypeArrow t1 t2) =
+> TypeArrow (elimRecordTypes m tyEnv tcEnv n t1)
+> (elimRecordTypes m tyEnv tcEnv n t2)
+> elimRecordTypes m tyEnv tcEnv n (TypeSkolem v) =
+> TypeSkolem v
+> elimRecordTypes m tyEnv tcEnv n (TypeRecord fs _)
+> | null fs = internalError "elimRecordTypes: empty record type"
+> | otherwise =
+> case (lookupValue (fst (head fs)) tyEnv) of
+> [Label _ r _] ->
+> case (qualLookupTC r tcEnv) of
+> [AliasType _ n' (TypeRecord fs' _)] ->
+> let is = [0 .. n'-1]
+> vs = foldl (matchTypeVars fs)
+> Map.empty
+> fs'
+> tys = map (\i -> maybe (TypeVariable (i+n))
+> (elimRecordTypes m tyEnv tcEnv n)
+> (Map.lookup i vs))
+> is
+> in TypeConstructor r tys
+> _ -> internalError "elimRecordTypes: no record type"
+> _ -> internalError "elimRecordTypes: no label"
+
+> matchTypeVars :: [(Ident,Type)] -> Map.Map Int Type -> (Ident,Type)
+> -> Map.Map Int Type
+> matchTypeVars fs vs (l,ty) =
+> maybe vs (match vs ty) (lookup l fs)
+> where
+> match vs (TypeVariable i) ty' = Map.insert i ty' vs
+> match vs (TypeConstructor _ tys) (TypeConstructor _ tys') =
+> matchList vs tys tys'
+> match vs (TypeConstrained tys _) (TypeConstrained tys' _) =
+> matchList vs tys tys'
+> match vs (TypeArrow ty1 ty2) (TypeArrow ty1' ty2') =
+> matchList vs [ty1,ty2] [ty1',ty2']
+> match vs (TypeSkolem _) (TypeSkolem _) = vs
+> match vs (TypeRecord fs _) (TypeRecord fs' _) =
+> foldl (matchTypeVars fs') vs fs
+> match vs ty ty' =
+> internalError ("matchTypeVars: " ++ show ty ++ "\n" ++ show ty')
+>
+> matchList vs tys tys' =
+> foldl (\vs' (ty,ty') -> match vs' ty ty') vs (zip tys tys')
+
+\end{verbatim}
+\paragraph{Functions}
+Each function in the program is translated into a function of the
+intermediate language. The arguments of the function are renamed such
+that all variables occurring in the same position (in different
+equations) have the same name. This is necessary in order to
+facilitate the translation of pattern matching into a \texttt{case}
+expression. We use the following simple convention here: The top-level
+arguments of the function are named from left to right \texttt{\_1},
+\texttt{\_2}, and so on. The names of nested arguments are constructed
+by appending \texttt{\_1}, \texttt{\_2}, etc. from left to right to
+the name that were assigned to a variable occurring at the position of
+the constructor term.
+
+Some special care is needed for the selector functions introduced by
+the compiler in place of pattern bindings. In order to generate the
+code for updating all pattern variables, the equality of names between
+the pattern variables in the first argument of the selector function
+and their repeated occurrences in the remaining arguments must be
+preserved. This means that the second and following arguments of a
+selector function have to be renamed according to the name mapping
+computed for its first argument.
+
+If an evaluation annotation is available for a function, it determines
+the evaluation mode of the case expression. Otherwise, the function
+uses flexible matching.
+\begin{verbatim}
+
+> type RenameEnv = Map.Map Ident Ident
+
+> translFunction :: Position -> Bool -> ModuleIdent -> ValueEnv -> TCEnv
+> -> EvalEnv -> Ident -> [Equation] -> IL.Decl
+> translFunction pos flat m tyEnv tcEnv evEnv f eqs =
+> -- | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))
+> -- | otherwise =
+> IL.FunctionDecl f' vs (translType' m tyEnv tcEnv ty) expr
+> -- = IL.FunctionDecl f' vs (translType ty)
+> -- (match ev vs (map (translEquation tyEnv vs vs'') eqs))
+> where f' = qualifyWith m f
+> ty = varType tyEnv f'
+> -- ty' = elimRecordType m tyEnv tcEnv (maximum (0:(typeVars ty))) ty
+> ev' = Map.lookup f evEnv
+> ev = maybe (defaultMode ty) evalMode ev'
+> vs = if not flat && isFpSelectorId f then translArgs eqs vs' else vs'
+> (vs',vs'') = splitAt (equationArity (head eqs))
+> (argNames (mkIdent ""))
+> expr | ev' == Just EvalChoice
+> = IL.Apply
+> (IL.Function
+> (qualifyWith preludeMIdent (mkIdent "commit"))
+> 1)
+> (match (ast pos) IL.Rigid vs
+> (map (translEquation tyEnv vs vs'') eqs))
+> | otherwise
+> = match (ast pos) ev vs (map (translEquation tyEnv vs vs'') eqs)
+> ---
+> -- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent ""))
+
+> evalMode :: EvalAnnotation -> IL.Eval
+> evalMode EvalRigid = IL.Rigid
+> evalMode EvalChoice = error "eval choice is not yet supported"
+
+> defaultMode :: Type -> IL.Eval
+> defaultMode _ = IL.Flex
+>
+> --defaultMode ty = if isIO (arrowBase ty) then IL.Rigid else IL.Flex
+> -- where TypeConstructor qIOId _ = ioType undefined
+> -- isIO (TypeConstructor tc [_]) = tc == qIOId
+> -- isIO _ = False
+
+> translArgs :: [Equation] -> [Ident] -> [Ident]
+> translArgs [Equation _ (FunLhs _ (t:ts)) _] (v:_) =
+> v : map (translArg (bindRenameEnv v t Map.empty)) ts
+> where translArg env (VariablePattern v) = fromJust (Map.lookup v env)
+
+> translEquation :: ValueEnv -> [Ident] -> [Ident] -> Equation
+> -> ([NestedTerm],IL.Expression)
+> translEquation tyEnv vs vs' (Equation _ (FunLhs _ ts) rhs) =
+> (zipWith translTerm vs ts,
+> translRhs tyEnv vs' (foldr2 bindRenameEnv Map.empty vs ts) rhs)
+
+> translRhs :: ValueEnv -> [Ident] -> RenameEnv -> Rhs -> IL.Expression
+> translRhs tyEnv vs env (SimpleRhs _ e _) = translExpr tyEnv vs env e
+
+
+> equationArity :: Equation -> Int
+> equationArity (Equation _ lhs _) = p_equArity lhs
+> where
+> p_equArity (FunLhs _ ts) = length ts
+> p_equArity (OpLhs _ _ _) = 2
+> p_equArity _ = error "ILTrans - illegal equation"
+
+
+\end{verbatim}
+\paragraph{Pattern Matching}
+The pattern matching code searches for the left-most inductive
+argument position in the left hand sides of all rules defining an
+equation. An inductive position is a position where all rules have a
+constructor rooted term. If such a position is found, a \texttt{case}
+expression is generated for the argument at that position. The
+matching code is then computed recursively for all of the alternatives
+independently. If no inductive position is found, the algorithm looks
+for the left-most demanded argument position, i.e., a position where
+at least one of the rules has a constructor rooted term. If such a
+position is found, an \texttt{or} expression is generated with those
+cases that have a variable at the argument position in one branch and
+all other rules in the other branch. If there is no demanded position,
+the pattern matching is finished and the compiler translates the right
+hand sides of the remaining rules, eventually combining them using
+\texttt{or} expressions.
+
+Actually, the algorithm below combines the search for inductive and
+demanded positions. The function \texttt{match} scans the argument
+lists for the left-most demanded position. If this turns out to be
+also an inductive position, the function \texttt{matchInductive} is
+called in order to generate a \texttt{case} expression. Otherwise, the
+function \texttt{optMatch} is called that tries to find an inductive
+position in the remaining arguments. If one is found,
+\texttt{matchInductive} is called, otherwise the function
+\texttt{optMatch} uses the demanded argument position found by
+\texttt{match}.
+\begin{verbatim}
+
+> data NestedTerm = NestedTerm IL.ConstrTerm [NestedTerm] deriving Show
+
+> pattern (NestedTerm t _) = t
+> arguments (NestedTerm _ ts) = ts
+
+> translLiteral :: Literal -> IL.Literal
+> translLiteral (Char p c) = IL.Char p c
+> translLiteral (Int id i) = IL.Int (ast (positionOfIdent id)) i
+> translLiteral (Float p f) = IL.Float p f
+> translLiteral _ = internalError "translLiteral"
+
+> translTerm :: Ident -> ConstrTerm -> NestedTerm
+> translTerm _ (LiteralPattern l) =
+> NestedTerm (IL.LiteralPattern (translLiteral l)) []
+> translTerm v (VariablePattern _) = NestedTerm (IL.VariablePattern v) []
+> translTerm v (ConstructorPattern c ts) =
+> NestedTerm (IL.ConstructorPattern c (take (length ts) vs))
+> (zipWith translTerm vs ts)
+> where vs = argNames v
+> translTerm v (AsPattern _ t) = translTerm v t
+> translTerm _ _ = internalError "translTerm"
+
+> bindRenameEnv :: Ident -> ConstrTerm -> RenameEnv -> RenameEnv
+> bindRenameEnv _ (LiteralPattern _) env = env
+> bindRenameEnv v (VariablePattern v') env = Map.insert v' v env
+> bindRenameEnv v (ConstructorPattern _ ts) env =
+> foldr2 bindRenameEnv env (argNames v) ts
+> bindRenameEnv v (AsPattern v' t) env = Map.insert v' v (bindRenameEnv v t env)
+> bindRenameEnv _ _ env = internalError "bindRenameEnv"
+
+> argNames :: Ident -> [Ident]
+> argNames v = [mkIdent (prefix ++ show i) | i <- [1..]]
+> where prefix = name v ++ "_"
+
+> type Match = ([NestedTerm],IL.Expression)
+> type Match' = ([NestedTerm] -> [NestedTerm],[NestedTerm],IL.Expression)
+
+> isDefaultPattern :: IL.ConstrTerm -> Bool
+> isDefaultPattern (IL.VariablePattern _) = True
+> isDefaultPattern _ = False
+
+> isDefaultMatch :: (IL.ConstrTerm,a) -> Bool
+> isDefaultMatch = isDefaultPattern . fst
+
+> match :: SrcRef -> IL.Eval -> [Ident] -> [Match] -> IL.Expression
+> match _ ev [] alts = foldl1 IL.Or (map snd alts)
+> match pos ev (v:vs) alts
+> | null vars = e1
+> | null nonVars = e2
+> | otherwise = optMatch pos ev (IL.Or e1 e2) (v:) vs (map skipArg alts)
+> where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
+> e1 = matchInductive pos ev id v vs nonVars
+> e2 = match pos ev vs (map snd vars)
+> tagAlt (t:ts,e) = (pattern t,(arguments t ++ ts,e))
+> skipArg (t:ts,e) = ((t:),ts,e)
+
+> optMatch :: SrcRef -> IL.Eval -> IL.Expression -> ([Ident] -> [Ident])
+> -> [Ident] ->[Match'] -> IL.Expression
+> optMatch _ ev e prefix [] alts = e
+> optMatch pos ev e prefix (v:vs) alts
+> | null vars = matchInductive pos ev prefix v vs nonVars
+> | otherwise = optMatch pos ev e (prefix . (v:)) vs (map skipArg alts)
+> where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
+> tagAlt (prefix,t:ts,e) = (pattern t,(prefix (arguments t ++ ts),e))
+> skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)
+
+> matchInductive :: SrcRef -> IL.Eval -> ([Ident] -> [Ident]) -> Ident
+> -> [Ident] ->[(IL.ConstrTerm,Match)] -> IL.Expression
+> matchInductive pos ev prefix v vs alts =
+> IL.Case pos ev (IL.Variable v) (matchAlts ev prefix vs alts)
+
+> matchAlts :: IL.Eval -> ([Ident] -> [Ident]) -> [Ident] ->
+> [(IL.ConstrTerm,Match)] -> [IL.Alt]
+> matchAlts ev prefix vs [] = []
+> matchAlts ev prefix vs ((t,alt):alts) =
+> IL.Alt t (match (srcRefOf t)
+> ev (prefix (vars t ++ vs)) (alt : map snd same)) :
+> matchAlts ev prefix vs others
+> where (same,others) = partition ((t ==) . fst) alts
+> vars (IL.ConstructorPattern _ vs) = vs
+> vars _ = []
+
+\end{verbatim}
+Matching in a \texttt{case}-expression works a little bit differently.
+In this case, the alternatives are matched from the first to the last
+alternative and the first matching alternative is chosen. All
+remaining alternatives are discarded.
+
+\ToDo{The case matching algorithm should use type information in order
+to detect total matches and immediately discard all alternatives which
+cannot be reached.}
+\begin{verbatim}
+
+> caseMatch :: SrcRef -> ([Ident] -> [Ident]) -> [Ident] -> [Match']
+> -> IL.Expression
+> caseMatch _ prefix [] alts = thd3 (head alts)
+> caseMatch r prefix (v:vs) alts
+> | isDefaultMatch (head alts') =
+> caseMatch r (prefix . (v:)) vs (map skipArg alts)
+> | otherwise =
+> IL.Case r IL.Rigid (IL.Variable v) (caseMatchAlts prefix vs alts')
+> where alts' = map tagAlt alts
+> tagAlt (prefix,t:ts,e) = (pattern t,(prefix,arguments t ++ ts,e))
+> skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)
+
+> caseMatchAlts ::
+> ([Ident] -> [Ident]) -> [Ident] -> [(IL.ConstrTerm,Match')] -> [IL.Alt]
+> caseMatchAlts prefix vs alts = map caseAlt (ts ++ ts')
+> where (ts',ts) = partition isDefaultPattern (nub (map fst alts))
+> caseAlt t =
+> IL.Alt t (caseMatch (srcRefOf t) id (prefix (vars t ++ vs))
+> (matchingCases t alts))
+> matchingCases t =
+> map (joinArgs (vars t)) . filter (matches t . fst)
+> matches t t' = t == t' || isDefaultPattern t'
+> joinArgs vs (IL.VariablePattern _,(prefix,ts,e)) =
+> (id,prefix (map varPattern vs ++ ts),e)
+> joinArgs _ (_,(prefix,ts,e)) = (id,prefix ts,e)
+> varPattern v = NestedTerm (IL.VariablePattern v) []
+> vars (IL.ConstructorPattern _ vs) = vs
+> vars _ = []
+
+\end{verbatim}
+\paragraph{Expressions}
+Note that the case matching algorithm assumes that the matched
+expression is accessible through a variable. The translation of case
+expressions therefore introduces a let binding for the scrutinized
+expression and immediately throws it away after the matching -- except
+if the matching algorithm has decided to use that variable in the
+right hand sides of the case expression. This may happen, for
+instance, if one of the alternatives contains an \texttt{@}-pattern.
+\begin{verbatim}
+
+> translExpr :: ValueEnv -> [Ident] -> RenameEnv -> Expression -> IL.Expression
+> translExpr _ _ _ (Literal l) = IL.Literal (translLiteral l)
+> translExpr tyEnv _ env (Variable v) =
+> case lookupVar v env of
+> Just v' -> IL.Variable v'
+> Nothing -> IL.Function v (arrowArity (varType tyEnv v))
+> where lookupVar v env
+> | isQualified v = Nothing
+> | otherwise = Map.lookup (unqualify v) env
+> translExpr tyEnv _ _ (Constructor c) =
+> IL.Constructor c (arrowArity (constrType tyEnv c))
+> translExpr tyEnv vs env (Apply e1 e2) =
+> IL.Apply (translExpr tyEnv vs env e1) (translExpr tyEnv vs env e2)
+> translExpr tyEnv vs env (Let ds e) =
+> case ds of
+> [ExtraVariables _ vs] -> foldr IL.Exist e' vs
+> [d] | all (`notElem` bv d) (qfv emptyMIdent d) ->
+> IL.Let (translBinding env' d) e'
+> _ -> IL.Letrec (map (translBinding env') ds) e'
+> where e' = translExpr tyEnv vs env' e
+> env' = foldr2 Map.insert env bvs bvs
+> bvs = bv ds
+> translBinding env (PatternDecl _ (VariablePattern v) rhs) =
+> IL.Binding v (translRhs tyEnv vs env rhs)
+> translBinding env p = error $ "unexpected binding: "++show p
+> translExpr tyEnv ~(v:vs) env (Case r e alts) =
+> case caseMatch r id [v] (map (translAlt v) alts) of
+> IL.Case r mode (IL.Variable v') alts'
+> | v == v' && v `notElem` fv alts' -> IL.Case r mode e' alts'
+> e''
+> | v `elem` fv e'' -> IL.Let (IL.Binding v e') e''
+> | otherwise -> e''
+> where e' = translExpr tyEnv vs env e
+> translAlt v (Alt _ t rhs) =
+> (id,
+> [translTerm v t],
+> translRhs tyEnv vs (bindRenameEnv v t env) rhs)
+> translExpr _ _ _ _ = internalError "translExpr"
+
+> instance Expr IL.Expression where
+> fv (IL.Variable v) = [v]
+> fv (IL.Apply e1 e2) = fv e1 ++ fv e2
+> fv (IL.Case _ _ e alts) = fv e ++ fv alts
+> fv (IL.Or e1 e2) = fv e1 ++ fv e2
+> fv (IL.Exist v e) = filter (/= v) (fv e)
+> fv (IL.Let (IL.Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
+> fv (IL.Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
+> where (vs,es) = unzip [(v,e) | IL.Binding v e <- bds]
+> fv _ = []
+
+> instance Expr IL.Alt where
+> fv (IL.Alt (IL.ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
+> fv (IL.Alt (IL.VariablePattern v) e) = filter (v /=) (fv e)
+> fv (IL.Alt _ e) = fv e
+
+\end{verbatim}
+\paragraph{Auxiliary Definitions}
+The functions \texttt{varType} and \texttt{constrType} return the type
+of variables and constructors, respectively. The quantifiers are
+stripped from the types.
+\begin{verbatim}
+
+> varType :: ValueEnv -> QualIdent -> Type
+> varType tyEnv f =
+> case qualLookupValue f tyEnv of
+> [Value _ (ForAll _ ty)] -> ty
+> _ -> internalError ("varType: " ++ show f)
+
+> constrType :: ValueEnv -> QualIdent -> Type
+> constrType tyEnv c =
+> case qualLookupValue c tyEnv of
+> [DataConstructor _ (ForAllExist _ _ ty)] -> ty
+> [NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty
+> _ -> internalError ("constrType: " ++ show c)
+
+\end{verbatim}
+The list of import declarations in the intermediate language code is
+determined by collecting all module qualifiers used in the current
+module.
+\begin{verbatim}
+
+> imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]
+> imports m = Set.toList . Set.delete m . Set.fromList . foldr modulesDecl []
+
+> modulesDecl :: IL.Decl -> [ModuleIdent] -> [ModuleIdent]
+> modulesDecl (IL.DataDecl _ _ cs) ms = foldr modulesConstrDecl ms cs
+> where modulesConstrDecl (IL.ConstrDecl _ tys) ms = foldr modulesType ms tys
+> modulesDecl (IL.NewtypeDecl _ _ (IL.ConstrDecl _ ty)) ms = modulesType ty ms
+> modulesDecl (IL.FunctionDecl _ _ ty e) ms = modulesType ty (modulesExpr e ms)
+> modulesDecl (IL.ExternalDecl _ _ _ ty) ms = modulesType ty ms
+
+> modulesType :: IL.Type -> [ModuleIdent] -> [ModuleIdent]
+> modulesType (IL.TypeConstructor tc tys) ms =
+> modules tc (foldr modulesType ms tys)
+> modulesType (IL.TypeVariable _) ms = ms
+> modulesType (IL.TypeArrow ty1 ty2) ms = modulesType ty1 (modulesType ty2 ms)
+
+> modulesExpr :: IL.Expression -> [ModuleIdent] -> [ModuleIdent]
+> modulesExpr (IL.Function f _) ms = modules f ms
+> modulesExpr (IL.Constructor c _) ms = modules c ms
+> modulesExpr (IL.Apply e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
+> modulesExpr (IL.Case _ _ e as) ms = modulesExpr e (foldr modulesAlt ms as)
+> where modulesAlt (IL.Alt t e) ms = modulesConstrTerm t (modulesExpr e ms)
+> modulesConstrTerm (IL.ConstructorPattern c _) ms = modules c ms
+> modulesConstrTerm _ ms = ms
+> modulesExpr (IL.Or e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
+> modulesExpr (IL.Exist _ e) ms = modulesExpr e ms
+> modulesExpr (IL.Let b e) ms = modulesBinding b (modulesExpr e ms)
+> modulesExpr (IL.Letrec bs e) ms = foldr modulesBinding (modulesExpr e ms) bs
+> modulesExpr _ ms = ms
+
+> modulesBinding :: IL.Binding -> [ModuleIdent] -> [ModuleIdent]
+> modulesBinding (IL.Binding _ e) = modulesExpr e
+
+> modules :: QualIdent -> [ModuleIdent] -> [ModuleIdent]
+> modules x ms = maybe ms (: ms) (qualidMod x)
+
+\end{verbatim}
+
diff --git a/src/IL/Pretty.lhs b/src/IL/Pretty.lhs
new file mode 100644
--- /dev/null
+++ b/src/IL/Pretty.lhs
@@ -0,0 +1,167 @@
+% $Id: ILPP.lhs,v 1.22 2003/10/28 05:43:43 wlux Exp $
+%
+% Copyright (c) 1999-2003 Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{ILPP.lhs}
+\section{A pretty printer for the intermediate language}
+This module implements just another pretty printer, this time for the
+intermediate language. It was mainly adapted from the Curry pretty
+printer (see sect.~\ref{sec:CurryPP}) which, in turn, is based on Simon
+Marlow's pretty printer for Haskell.
+\begin{verbatim}
+
+> module IL.Pretty(ppModule) where
+>
+> import Curry.Base.Ident
+>
+> import IL.Type
+> import PrettyCombinators
+
+> default(Int,Double)
+
+> dataIndent = 2
+> bodyIndent = 2
+> exprIndent = 2
+> caseIndent = 2
+> altIndent = 2
+
+> ppModule :: Module -> Doc
+> ppModule (Module m is ds) =
+> vcat (text "module" <+> text (show m) <+> text "where" :
+> map ppImport is ++ map ppDecl ds)
+
+> ppImport :: ModuleIdent -> Doc
+> ppImport m = text "import" <+> text (show m)
+
+> ppDecl :: Decl -> Doc
+> ppDecl (DataDecl tc n cs) =
+> sep (text "data" <+> ppTypeLhs tc n :
+> map (nest dataIndent)
+> (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs)))
+> ppDecl (NewtypeDecl tc n (ConstrDecl c ty)) =
+> sep [text "newtype" <+> ppTypeLhs tc n <+> equals,
+> nest dataIndent (ppConstr (ConstrDecl c [ty]))]
+> ppDecl (FunctionDecl f vs ty exp) =
+> ppTypeSig f ty $$
+> sep [ppQIdent f <+> hsep (map ppIdent vs) <+> equals,
+> nest bodyIndent (ppExpr 0 exp)]
+> ppDecl (ExternalDecl f cc ie ty) =
+> sep [text "external" <+> ppCallConv cc <+> text (show ie),
+> nest bodyIndent (ppTypeSig f ty)]
+> where ppCallConv Primitive = text "primitive"
+> ppCallConv CCall = text "ccall"
+
+> ppTypeLhs :: QualIdent -> Int -> Doc
+> ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))
+
+> ppConstr :: ConstrDecl [Type] -> Doc
+> ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys)
+
+> ppTypeSig :: QualIdent -> Type -> Doc
+> ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty
+
+> ppType :: Int -> Type -> Doc
+> ppType p (TypeConstructor tc tys)
+> | isQTupleId tc = parens (fsep (punctuate comma (map (ppType 0) tys)))
+> | unqualify tc == nilId = brackets (ppType 0 (head tys))
+> | otherwise =
+> ppParen (p > 1 && not (null tys))
+> (ppQIdent tc <+> fsep (map (ppType 2) tys))
+> ppType _ (TypeVariable n)
+> | n >= 0 = text (typeVars !! n)
+> | otherwise = text ('_':show (-n))
+> ppType p (TypeArrow ty1 ty2) =
+> ppParen (p > 0) (fsep (ppArrow (TypeArrow ty1 ty2)))
+> where ppArrow (TypeArrow ty1 ty2) =
+> ppType 1 ty1 <+> text "->" : ppArrow ty2
+> ppArrow ty = [ppType 0 ty]
+
+> ppBinding :: Binding -> Doc
+> ppBinding (Binding v exp) =
+> sep [ppIdent v <+> equals,nest bodyIndent (ppExpr 0 exp)]
+
+> ppAlt :: Alt -> Doc
+> ppAlt (Alt pat exp) =
+> sep [ppConstrTerm pat <+> text "->",nest altIndent (ppExpr 0 exp)]
+
+> ppLiteral :: Literal -> Doc
+> ppLiteral (Char _ c) = text (show c)
+> ppLiteral (Int _ i) = integer i
+> ppLiteral (Float _ f) = double f
+
+> ppConstrTerm :: ConstrTerm -> Doc
+> ppConstrTerm (LiteralPattern l) = ppLiteral l
+> ppConstrTerm (ConstructorPattern c [v1,v2])
+> | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2
+> ppConstrTerm (ConstructorPattern c vs)
+> | isQTupleId c = parens (fsep (punctuate comma (map ppIdent vs)))
+> | otherwise = ppQIdent c <+> fsep (map ppIdent vs)
+> ppConstrTerm (VariablePattern v) = ppIdent v
+
+> ppExpr :: Int -> Expression -> Doc
+> ppExpr p (Literal l) = ppLiteral l
+> ppExpr p (Variable v) = ppIdent v
+> ppExpr p (Function f _) = ppQIdent f
+> ppExpr p (Constructor c _) = ppQIdent c
+> ppExpr p (Apply (Apply (Function f _) e1) e2)
+> | isQInfixOp f = ppInfixApp p e1 f e2
+> ppExpr p (Apply (Apply (Constructor c _) e1) e2)
+> | isQInfixOp c = ppInfixApp p e1 c e2
+> ppExpr p (Apply e1 e2) =
+> ppParen (p > 2) (sep [ppExpr 2 e1,nest exprIndent (ppExpr 3 e2)])
+> ppExpr p (Case _ ev e alts) =
+> ppParen (p > 0)
+> (text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of" $$
+> nest caseIndent (vcat (map ppAlt alts)))
+> where ppEval Rigid = text "rigid"
+> ppEval Flex = text "flex"
+> ppExpr p (Or e1 e2) =
+> ppParen (p > 0) (sep [ppExpr 0 e1,char '|' <+> ppExpr 0 e2])
+> ppExpr p (Exist v e) =
+> ppParen (p > 0)
+> (sep [text "let" <+> ppIdent v <+> text "free" <+> text "in",
+> ppExpr 0 e])
+> ppExpr p (Let b e) =
+> ppParen (p > 0) (sep [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e])
+> ppExpr p (Letrec bs e) =
+> ppParen (p > 0)
+> (sep [text "letrec" <+> vcat (map ppBinding bs) <+> text "in",
+> ppExpr 0 e])
+
+> ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
+> ppInfixApp p e1 op e2 =
+> ppParen (p > 1)
+> (sep [ppExpr 2 e1 <+> ppQInfixOp op,nest exprIndent (ppExpr 2 e2)])
+
+> ppIdent :: Ident -> Doc
+> ppIdent ident
+> | isInfixOp ident = parens (ppName ident)
+> | otherwise = ppName ident
+
+> ppQIdent :: QualIdent -> Doc
+> ppQIdent ident
+> | isQInfixOp ident = parens (ppQual ident)
+> | otherwise = ppQual ident
+
+> ppQInfixOp :: QualIdent -> Doc
+> ppQInfixOp op
+> | isQInfixOp op = ppQual op
+> | otherwise = char '`' <> ppQual op <> char '`'
+
+> ppName :: Ident -> Doc
+> ppName x = text (name x)
+
+> ppQual :: QualIdent -> Doc
+> ppQual x = text (qualName x)
+
+> typeVars :: [String]
+> typeVars = [mkTypeVar c i | i <- [0..], c <- ['a' .. 'z']]
+> where mkTypeVar c i = c : if i == 0 then [] else show i
+
+> ppParen :: Bool -> Doc -> Doc
+> ppParen p = if p then parens else id
+
+\end{verbatim}
diff --git a/src/IL/Scope.hs b/src/IL/Scope.hs
new file mode 100644
--- /dev/null
+++ b/src/IL/Scope.hs
@@ -0,0 +1,124 @@
+module IL.Scope (getModuleScope,
+ insertDeclScope, insertConstrDeclScope,
+ insertCallConvScope, insertTypeScope,
+ insertLiteralScope, insertConstrTermScope,
+ insertExprScope, insertAltScope,
+ insertBindingScope) where
+
+import Curry.Base.Ident
+
+import IL.Type
+import OldScopeEnv as ScopeEnv
+
+
+-------------------------------------------------------------------------------
+
+--
+getModuleScope :: Module -> ScopeEnv
+getModuleScope (Module _ _ decls) = foldl insertDecl newScopeEnv decls
+
+
+--
+insertDeclScope :: ScopeEnv -> Decl -> ScopeEnv
+insertDeclScope env (DataDecl _ _ _) = env
+insertDeclScope env (NewtypeDecl _ _ _) = env
+insertDeclScope env (FunctionDecl _ params _ _)
+ = foldr ScopeEnv.insertIdent (ScopeEnv.beginScope env) params
+insertDeclScope env (ExternalDecl _ _ _ _) = env
+
+
+--
+insertConstrDeclScope :: ScopeEnv -> ConstrDecl [Type] -> ScopeEnv
+insertConstrDeclScope env _ = env
+
+
+--
+insertCallConvScope :: ScopeEnv -> CallConv -> ScopeEnv
+insertCallConvScope env _ = env
+
+
+--
+insertTypeScope :: ScopeEnv -> Type -> ScopeEnv
+insertTypeScope env _ = env
+
+
+--
+insertLiteralScope :: ScopeEnv -> Literal -> ScopeEnv
+insertLiteralScope env _ = env
+
+
+--
+insertConstrTermScope :: ScopeEnv -> ConstrTerm -> ScopeEnv
+insertConstrTermScope env _ = env
+
+
+--
+insertExprScope :: ScopeEnv -> Expression -> ScopeEnv
+insertExprScope env (Literal _) = env
+insertExprScope env (Variable _) = env
+insertExprScope env (Function _ _) = env
+insertExprScope env (Constructor _ _) = env
+insertExprScope env (Apply _ _) = env
+insertExprScope env (Case _ _ _ _) = env
+insertExprScope env (Or _ _) = env
+insertExprScope env (Exist ident _)
+ = ScopeEnv.insertIdent ident (ScopeEnv.beginScope env)
+insertExprScope env (Let bind _)
+ = insertBinding (beginScope env) bind
+insertExprScope env (Letrec binds _)
+ = foldl insertBinding (beginScope env) binds
+
+
+--
+insertAltScope :: ScopeEnv -> Alt -> ScopeEnv
+insertAltScope env (Alt cterm _)
+ = insertConstrTerm (ScopeEnv.beginScope env) cterm
+
+
+--
+insertBindingScope :: ScopeEnv -> Binding -> ScopeEnv
+insertBindingScope env _ = env
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+insertDecl :: ScopeEnv -> Decl -> ScopeEnv
+insertDecl env (DataDecl qident _ cdecls)
+ = foldl insertConstrDecl
+ (ScopeEnv.insertIdent (unqualify qident) env)
+ cdecls
+
+insertDecl env (NewtypeDecl qident _ cdecl)
+ = insertConstrDecl (ScopeEnv.insertIdent (unqualify qident) env) cdecl
+
+insertDecl env (FunctionDecl qident _ _ _)
+ = ScopeEnv.insertIdent (unqualify qident) env
+
+insertDecl env (ExternalDecl qident _ _ _)
+ = ScopeEnv.insertIdent (unqualify qident) env
+
+
+--
+insertConstrDecl :: ScopeEnv -> ConstrDecl a -> ScopeEnv
+insertConstrDecl env (ConstrDecl qident _)
+ = ScopeEnv.insertIdent (unqualify qident) env
+
+
+--
+insertConstrTerm :: ScopeEnv -> ConstrTerm -> ScopeEnv
+insertConstrTerm env (LiteralPattern _) = env
+insertConstrTerm env (ConstructorPattern _ params)
+ = foldr ScopeEnv.insertIdent env params
+insertConstrTerm env (VariablePattern ident)
+ = ScopeEnv.insertIdent ident env
+
+
+--
+insertBinding :: ScopeEnv -> Binding -> ScopeEnv
+insertBinding env (Binding ident _) = ScopeEnv.insertIdent ident env
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/IL/Type.lhs b/src/IL/Type.lhs
new file mode 100644
--- /dev/null
+++ b/src/IL/Type.lhs
@@ -0,0 +1,109 @@
+% $Id: IL.lhs,v 1.18 2003/10/28 05:43:38 wlux Exp $
+%
+% Copyright (c) 1999-2003 Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{IL.lhs}
+\section{The intermediate language}
+The module \texttt{IL} defines the intermediate language which will be
+compiled into abstract machine code. The intermediate language removes
+a lot of syntactic sugar from the Curry source language. Top-level
+declarations are restricted to data type and function definitions. A
+newtype definition serves mainly as a hint to the backend that it must
+provide an auxiliary function for partial applications of the
+constructor. \textbf{Newtype constructors must not occur in patterns
+and may be used in expressions only as partial applications.}
+
+Type declarations use a de-Bruijn indexing scheme (starting at 0) for
+type variables. In the type of a function, all type variables are
+numbered in the order of their occurence from left to right, i.e., a
+type \texttt{(Int -> b) -> (a,b) -> c -> (a,c)} is translated into the
+type (using integer numbers to denote the type variables)
+\texttt{(Int -> 0) -> (1,0) -> 2 -> (1,2)}.
+
+Pattern matching in an equation is handled via flexible and rigid
+\texttt{Case} expressions. Overlapping rules are translated with the
+help of \texttt{Or} expressions. The intermediate language has three
+kinds of binding expressions, \texttt{Exist} expressions introduce a
+new logical variable, \texttt{Let} expression support a single
+non-recursive variable binding, and \texttt{Letrec} expressions
+introduce multiple variables with recursive initializer expressions.
+The intermediate language explicitly distinguishes (local) variables
+and (global) functions in expressions.
+
+\em{Note:} this modified version uses haskell type \texttt{Integer}
+instead of \texttt{Int} for representing integer values. This provides
+an unlimited range of integer constants in Curry programs.
+\begin{verbatim}
+
+> module IL.Type where
+
+> import Curry.Base.Ident
+> import Curry.Base.Position (SrcRef(..))
+
+> data Module = Module ModuleIdent [ModuleIdent] [Decl] deriving (Eq,Show)
+
+> data Decl =
+> DataDecl QualIdent Int [ConstrDecl [Type]]
+> | NewtypeDecl QualIdent Int (ConstrDecl Type)
+> | FunctionDecl QualIdent [Ident] Type Expression
+> | ExternalDecl QualIdent CallConv String Type
+> deriving (Eq,Show)
+
+> data ConstrDecl a = ConstrDecl QualIdent a deriving (Eq,Show)
+> data CallConv = Primitive | CCall deriving (Eq,Show)
+
+> data Type =
+> TypeConstructor QualIdent [Type]
+> | TypeVariable Int
+> | TypeArrow Type Type
+> deriving (Eq,Show)
+
+> data Literal = Char SrcRef Char | Int SrcRef Integer | Float SrcRef Double deriving (Eq,Show)
+
+> data ConstrTerm =
+> -- literal patterns
+> LiteralPattern Literal
+> -- constructors
+> | ConstructorPattern QualIdent [Ident]
+> -- default
+> | VariablePattern Ident
+> deriving (Eq,Show)
+
+> data Expression =
+> -- literal constants
+> Literal Literal
+> -- variables, functions, constructors
+> | Variable Ident | Function QualIdent Int | Constructor QualIdent Int
+> -- applications
+> | Apply Expression Expression
+> -- case expressions
+> | Case SrcRef Eval Expression [Alt]
+> -- non-determinisismic or
+> | Or Expression Expression
+> -- binding forms
+> | Exist Ident Expression
+> | Let Binding Expression
+> | Letrec [Binding] Expression
+> deriving (Eq,Show)
+
+> data Eval = Rigid | Flex deriving (Eq,Show)
+> data Alt = Alt ConstrTerm Expression deriving (Eq,Show)
+> data Binding = Binding Ident Expression deriving (Eq,Show)
+
+\end{verbatim}
+
+> instance SrcRefOf ConstrTerm where
+> srcRefOf (LiteralPattern l) = srcRefOf l
+> srcRefOf (ConstructorPattern i _) = srcRefOf i
+> srcRefOf (VariablePattern i) = srcRefOf i
+
+
+> instance SrcRefOf Literal where
+> srcRefOf (Char s _) = s
+> srcRefOf (Int s _) = s
+> srcRefOf (Float s _) = s
+
+
diff --git a/src/IL/XML.lhs b/src/IL/XML.lhs
new file mode 100644
--- /dev/null
+++ b/src/IL/XML.lhs
@@ -0,0 +1,518 @@
+
+% $Id: ILxml.lhs,v 1.0 2001/06/19 12:19:18 rafa Exp $
+%
+% $Log: ILxml.lhs,v $
+%
+% Revision 1.1 2001/06/19 12:19:18 rafa
+% Pretty printer in XML for the intermediate language added.
+%
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{ILxml.lhs}
+\section{A pretty printer in XML for the intermediate language}
+This module implements just another pretty printer, this time in XML and for
+the intermediate language. It was mainly adapted from the Curry pretty
+printer (see sect.~\ref{sec:CurryPP}), which in turn is based on Simon
+Marlow's pretty printer for Haskell. The format of the output intends to be
+similar to that of Flat-Curry XML representation.
+\begin{verbatim}
+
+> module IL.XML(module IL.XML) where
+
+> import Data.Maybe
+
+> import Curry.Base.Ident
+> import qualified Curry.Syntax as CS
+
+> import IL.Type
+> import CurryEnv
+> import PrettyCombinators
+
+
+
+> -- identation level
+> level::Int
+> level = 3
+
+> xmlModule :: CurryEnv -> Module -> Doc
+> xmlModule cEnv m = text "" $$ nest level (xmlBody cEnv m)
+> $$ text ""
+
+> xmlBody :: CurryEnv -> Module -> Doc
+> xmlBody cEnv (Module name imports decls) =
+> xmlElement "module" xmlModuleDecl moduleDecl $$
+> xmlElement "import" xmlImportDecl importDecl $$
+> xmlElement "types" xmlTypeDecl typeDecl $$
+> xmlElement "functions" xmlFunctionDecl functionDecl $$
+> xmlElement "operators" xmlOperatorDecl operatorDecl $$
+> xmlElement "translation" xmlTranslationDecl translationDecl
+> where
+> moduleDecl = [name]
+> importDecl = imports
+> operatorDecl = infixDecls cEnv
+> translationDecl = foldl (qualIDeclId (moduleId cEnv))
+> []
+> (interface cEnv)
+> (functionDecl,typeDecl) = splitDecls decls
+
+> -- =========================================================================
+
+> xmlModuleDecl :: ModuleIdent -> Doc
+> xmlModuleDecl name = xmlModuleIdent name
+
+> -- =========================================================================
+
+> xmlImportDecl :: ModuleIdent -> Doc
+> xmlImportDecl name = xmlElement "module" xmlModuleDecl [name]
+
+
+> -- =========================================================================
+> -- T Y P E S
+> -- =========================================================================
+
+> xmlTypeDecl :: Decl -> Doc
+> xmlTypeDecl (DataDecl tc arity cs) =
+> beginType $$
+> nest level (xmlTypeParams arity) $$
+> xmlLines xmlConstructor cs $$
+> endType
+> where
+> beginType = text " (xmlQualIdent tc) <> text "\">"
+> endType = text ""
+
+> xmlTypeParams :: Int -> Doc
+> xmlTypeParams n = xmlElement "params" xmlTypeVar [0..(n-1)]
+
+> xmlConstructor :: ConstrDecl [Type] -> Doc
+> xmlConstructor (ConstrDecl ident []) = xmlConstructorBegin ident 0
+> xmlConstructor (ConstrDecl ident l) =
+> xmlConstructorBegin ident (length l) $$
+> xmlLines xmlType l $$
+> xmlConstructorEnd
+> where
+> xmlConstructorEnd = text ""
+
+> xmlConstructorBegin :: QualIdent -> Int -> Doc
+> xmlConstructorBegin ident n = xmlHeadingWithArity "cons" ident n (n==0)
+
+> xmlHeadingWithArity :: String -> QualIdent -> Int -> Bool -> Doc
+> xmlHeadingWithArity tagName ident n single =
+> if single
+> then prefix<>text "/>"
+> else prefix<> text ">"
+> where
+> prefix = text ("<"++tagName++" name=\"") <> name <> text "\" " <> arity
+> arity = text "arity=\"" <> xmlInt n <> text "\""
+> name = xmlQualIdent ident
+
+
+> xmlType :: Type -> Doc
+> xmlType (TypeConstructor ident []) = xmlTypeConsBegin ident True
+> xmlType (TypeConstructor ident l) = xmlTypeConsBegin ident False $$
+> xmlLines xmlType l $$
+> xmlTypeConsEnd
+> where
+> xmlTypeConsEnd = text ""
+
+> xmlType (TypeVariable n) = xmlTypeVar n
+> xmlType (TypeArrow a b) = xmlTypeFun a b
+
+> xmlTypeConsBegin :: QualIdent -> Bool -> Doc
+> xmlTypeConsBegin ident single =
+> if single
+> then prefix <> text "/>"
+> else prefix <> text ">"
+> where
+> name = xmlQualIdent ident
+> prefix = text " name <> text "\""
+
+> xmlTypeVar :: Int -> Doc
+> xmlTypeVar n = text ""<> xmlInt n <> text ""
+
+> xmlTypeFun :: Type -> Type -> Doc
+> xmlTypeFun a b = xmlElement "functype" xmlType [a,b]
+
+
+> -- =========================================================================
+> -- F U N C T I O N S
+> -- =========================================================================
+
+> xmlFunctionDecl :: Decl -> Doc
+> xmlFunctionDecl (NewtypeDecl tc arity (ConstrDecl ident ty)) =
+> xmlFunctionDecl (FunctionDecl ident [arg] ftype (Variable arg))
+> where
+> arg = mkIdent "_1"
+> ftype = TypeArrow ty (TypeConstructor tc (map TypeVariable [0..arity-1]))
+
+> xmlFunctionDecl (FunctionDecl ident largs fType expr) =
+> heading $$ nest level (xmlRule largs expr) $$ end
+> where
+> heading = xmlBeginFunction ident (length largs) fType
+> end = text ""
+
+> xmlFunctionDecl (ExternalDecl ident callConv internalName fType) =
+> heading $$ external $$ end
+> where
+> heading = xmlBeginFunction ident (xmlFunctionArity fType) fType
+> external = text (""
+> ++ xmlFormat internalName
+> ++ "")
+> end = text ""
+
+> xmlBeginFunction :: QualIdent -> Int -> Type -> Doc
+> xmlBeginFunction ident n fType =
+> heading $$ typeDecls
+> where
+> heading = xmlHeadingWithArity "func" ident n False
+> typeDecls = nest level (xmlType fType)
+
+> xmlEndFunction :: Doc
+> xmlEndFunction = text ""
+
+> xmlFunctionArity :: Type -> Int
+> xmlFunctionArity (TypeConstructor ident l) = 0
+> xmlFunctionArity (TypeVariable n) = 0
+> xmlFunctionArity (TypeArrow a b) = 1 + (xmlFunctionArity b)
+
+> xmlRule :: [Ident] -> Expression -> Doc
+> xmlRule lArgs e = text "" $$
+> nest level (xmlLhs lArgs) $$
+> nest level (xmlRhs lArgs e) $$
+> text ""
+
+> xmlLhs :: [Ident] -> Doc
+> xmlLhs l = xmlElement "lhs" xmlVar [0..((length l)-1)]
+
+> xmlRhs :: [Ident] -> Expression -> Doc
+> xmlRhs l e = text "" $$ nest level rhs $$ text ""
+> where
+> varDicc = xmlBuildDicc l
+> (rhs, _) = xmlExpr varDicc e
+
+> -- =========================================================================
+
+> -- =========================================================================
+> -- E X P R E S S I O N S
+> -- =========================================================================
+
+> xmlExpr :: [(Int,Ident)] -> Expression -> (Doc,[(Int,Ident)])
+> xmlExpr d (Literal lit) = (xmlLiteral (xmlLit lit),d)
+> xmlExpr d (Variable ident) = xmlExprVar d ident
+> xmlExpr d (Function ident arity) = (xmlSingleApp ident arity True,d)
+> xmlExpr d (Constructor ident arity) = (xmlSingleApp ident arity False,d)
+> xmlExpr d exp@(Apply e1 e2) = xmlApply d exp (xmlAppArgs exp)
+> xmlExpr d (Case _ eval expr alt) = xmlCase d eval expr alt
+> xmlExpr d (Or expr1 expr2) = xmlOr d expr1 expr2
+> xmlExpr d (Exist ident expr) = xmlFree d ident expr
+> xmlExpr d (Let binding expr) = xmlLet d binding expr
+> xmlExpr d (Letrec lBinding expr) = xmlLetrec d lBinding expr
+> --error "Recursive let bindings not supported in FlatCurry"
+
+> -- =========================================================================
+
+> xmlSingleApp :: QualIdent -> Int -> Bool -> Doc
+> xmlSingleApp ident arity isFunction =
+> if arity>0
+> then xmlCombHeading identDoc (text "PartCall") True
+> else xmlCombHeading identDoc (text totalApp) True
+> where
+> identDoc = xmlQualIdent ident
+> totalApp = if isFunction then "FuncCall" else "ConsCall"
+
+
+> xmlCombHeading :: Doc -> Doc -> Bool -> Doc
+> xmlCombHeading name cType single =
+> if single
+> then prefix <> text " />"
+> else prefix <> text ">"
+> where
+> prefix = text "cType<>text "\" name=\""<>name<>text "\""
+
+> -- =========================================================================
+
+> xmlExprVar :: [(Int,Ident)] -> Ident -> (Doc,[(Int,Ident)])
+> xmlExprVar d ident =
+> if isNew
+> then (xmlVar newVar, (newVar,ident):d)
+> else (xmlVar var, d)
+> where
+> var = xmlLookUp ident d
+> isNew = var == -1
+> newVar = xmlNewVar d
+
+> -- =========================================================================
+
+
+> xmlApply :: [(Int,Ident)] -> Expression -> (Expression,[Expression]) ->
+> (Doc,[(Int,Ident)])
+
+> xmlApply d exp ((Function ident arity),lExp) =
+> xmlApplyFunctor d ident arity lExp True
+
+> xmlApply d exp ((Constructor ident arity),lExp) =
+> xmlApplyFunctor d ident arity lExp False
+
+> xmlApply d (Apply expr1 expr2) e' =
+> (text "" $$ nest level e1 $$ nest level e2 $$ text "", d2)
+> where
+> (e1,d1) = xmlExpr d expr1
+> (e2,d2) = xmlExpr d1 expr2
+
+> xmlApplyFunctor ::[(Int,Ident)] -> QualIdent -> Int -> [Expression] ->
+> Bool -> (Doc,[(Int,Ident)])
+> xmlApplyFunctor d ident arity lArgs isFunction =
+> xmlCombApply d (xmlQualIdent ident) (text cTypeS) n lArgs
+> where
+> n = length (lArgs)
+> cTypeS = if n==arity
+> then if isFunction
+> then "FuncCall"
+> else "ConsCall"
+> else "PartCall"
+
+
+> xmlCombApply :: [(Int,Ident)] -> Doc -> Doc -> Int ->
+> [Expression] -> (Doc,[(Int,Ident)])
+> xmlCombApply d name cType 0 lArgs =
+> (xmlCombHeading name cType True,d)
+> xmlCombApply d name cType n lArgs =
+> (xmlCombHeading name cType False $$ xmlLines id lDocs$$ text "", d1)
+> where
+> (lDocs,d1) = xmlMapDicc d xmlExpr lArgs
+
+
+> xmlAppArgs :: Expression -> (Expression,[Expression])
+> xmlAppArgs (Apply e1 e2) = (e,lArgs++[e2])
+> where
+> (e,lArgs) = (xmlAppArgs e1)
+> xmlAppArgs e = (e,[])
+> -- =========================================================================
+
+
+> -- =========================================================================
+
+> xmlCase :: [(Int,Ident)] -> Eval -> Expression -> [Alt] -> (Doc,[(Int,Ident)])
+> xmlCase d eval expr lAlt =
+> (heading $$ nest level e1 $$ xmlLines id lDocs$$ end,d2)
+> where
+> sEval = if eval==Rigid then "\"Rigid\"" else "\"Flex\""
+> heading = text ""
+> end = text ""
+> (e1,_) = xmlExpr d expr
+> (lDocs,d2) = xmlMapDicc d xmlBranch lAlt
+
+> xmlOr :: [(Int,Ident)] -> Expression -> Expression -> (Doc,[(Int,Ident)])
+> xmlOr d expr1 expr2 =
+> (text "" $$ nest level e1 $$ nest level e2 $$ text "",d2)
+> where
+> (e1,d1) = xmlExpr d expr1
+> (e2,d2) = xmlExpr d1 expr2
+
+
+> xmlBranch :: [(Int,Ident)] -> Alt -> (Doc,[(Int,Ident)])
+> xmlBranch d (Alt pattern expr) =
+> (text "" $$ nest level e1 $$ nest level e2 $$ text "",d2)
+> where
+> (e1,d1) = xmlPattern d pattern
+> (e2,d2) = xmlExpr d1 expr
+
+
+> xmlPattern :: [(Int,Ident)] -> ConstrTerm -> (Doc,[(Int,Ident)])
+> xmlPattern d (LiteralPattern lit) = (xmlLitPattern (xmlLit lit),d)
+> xmlPattern d (ConstructorPattern ident lArgs) = xmlConsPattern d ident lArgs
+> xmlPattern d (VariablePattern _) = error "Variable patterns not allowed in Flat Curry"
+
+> xmlConsPattern :: [(Int,Ident)] -> QualIdent -> [Ident] -> (Doc,[(Int,Ident)])
+> xmlConsPattern d ident lArgs =
+> (heading $$ xmlLines id lDocs $$ end,d2)
+> where
+> heading = text " (xmlQualIdent ident) <>
+> text "\"" <> endh
+> endh = if (length lArgs)>0 then text ">" else text "/>"
+> end = if (length lArgs)>0 then text "" else empty
+> (lDocs,d2) = xmlMapDicc d xmlExprVar lArgs
+
+> -- =========================================================================
+
+
+> xmlFree :: [(Int,Ident)] -> Ident -> Expression -> (Doc,[(Int,Ident)])
+> xmlFree d ident exp =
+> (text "" $$ nest level v $$ nest level e $$ text "",d2)
+> where
+> (v,d1) = xmlExprVar d ident
+> (e,d2) = xmlExpr d1 exp
+
+
+> -- =========================================================================
+
+> xmlLet :: [(Int,Ident)] -> Binding -> Expression -> (Doc,[(Int,Ident)])
+> xmlLet d binding exp =
+> (text "" $$ nest level b $$ nest level e $$ text "", d2)
+> where
+> (b,d1) = xmlBinding d binding
+> (e,d2) = xmlExpr d1 exp
+
+> xmlBinding :: [(Int,Ident)] -> Binding -> (Doc,[(Int,Ident)])
+> xmlBinding d (Binding ident exp) =
+> (text "" $$ nest level v $$ nest level e $$ text "",d2)
+> where
+> (v,_) = xmlExprVar d ident
+> (e,d2) = xmlExpr d exp
+
+> -- =========================================================================
+
+> xmlLetrec :: [(Int,Ident)] -> [Binding] -> Expression -> (Doc,[(Int,Ident)])
+> xmlLetrec d lB exp =
+> (text "" $$ xmlLines id b $$ nest level e $$ text "",d2)
+> where
+> (b,d1) = xmlMapDicc d xmlBinding lB
+> (e,d2) = xmlExpr d1 exp
+
+> -- =========================================================================
+
+
+> -- =========================================================================
+> -- A U X I L I A R Y F U N C T I O N S
+> -- =========================================================================
+
+> splitDecls :: [Decl] -> ([Decl],[Decl])
+> splitDecls [] = ([],[])
+> splitDecls (x:xs) = case x of
+> DataDecl _ _ _ -> (functionDecl,x:typeDecl)
+> NewtypeDecl _ _ _ -> (x:functionDecl,typeDecl)
+> FunctionDecl _ _ _ _ -> (x:functionDecl,typeDecl)
+> ExternalDecl _ _ _ _ -> (x:functionDecl,typeDecl)
+> where
+> (functionDecl,typeDecl) = splitDecls xs
+
+
+
+
+> xmlElement :: Eq a => String -> (a -> Doc) -> [a] -> Doc
+> xmlElement name f [] = text ("<"++name++" />")
+> xmlElement name f lDecls = beginElement $$ xmlLines f lDecls $$ endElement
+> where
+> beginElement = text ("<"++name++">")
+> endElement = text ("")
+>
+
+> xmlLines :: (a -> Doc) -> [a] -> Doc
+> xmlLines f = (nest level).vcat.(map f)
+
+
+> xmlMapDicc::[(Int,Ident)] -> ([(Int,Ident)] -> a -> (Doc,[(Int,Ident)])) ->
+> [a] -> ([Doc],[(Int,Ident)])
+> xmlMapDicc d f lArgs = foldl newArg ([],d) lArgs
+> where
+> newArg (l,d) e = (l++[v'],d')
+> where (v',d') = f d e
+>
+
+
+> -- The dictionary identifies var names with integers
+> -- it will be ordered starting at the greatest integer
+> xmlBuildDicc :: [Ident] -> [(Int,Ident)]
+> xmlBuildDicc l = reverse (zip [0..((length l)-1)] l)
+
+> -- looks for a ident in the dictorionary. If it appears returns its
+> -- associated value. Otherwise, -1 is returned
+> xmlLookUp :: Ident -> [(Int,Ident)] -> Int
+> xmlLookUp ident [] = -1
+> xmlLookUp ident ((n,name):xs) = if ident==name
+> then n
+> else xmlLookUp ident xs
+
+> -- generates a integer corresponding to a new var
+> xmlNewVar :: [(Int,Ident)] -> Int
+> xmlNewVar [] = 0
+> xmlNewVar ((n,ident):xs) = n+1
+
+> xmlVar :: Int -> Doc
+> xmlVar n = text "" <> xmlInt n <> text ""
+
+> xmlLiteral :: Doc -> Doc
+> xmlLiteral d = text "" $$ nest level d $$ text ""
+
+> xmlLitPattern :: Doc -> Doc
+> xmlLitPattern d = text "" $$ nest level d $$ text ""
+
+
+> xmlLit :: Literal -> Doc
+> xmlLit (Char _ c) = text "" <> xmlInt (fromEnum c) <> text ""
+> xmlLit (Int _ n) = text "" <> xmlInteger n <> text ""
+> xmlLit (Float _ n) = text "" <> xmlFloat n <> text ""
+
+> xmlOperatorDecl :: CS.IDecl -> Doc
+> xmlOperatorDecl (CS.IInfixDecl _ fixity prec qident) =
+> text " xmlFixity fixity
+> <> text "\" prec=\"" <> xmlInteger prec <> text "\">"
+> <> xmlIdent (unqualify qident)
+> <> text ""
+
+> xmlFixity :: CS.Infix -> Doc
+> xmlFixity CS.InfixL = text "InfixlOp"
+> xmlFixity CS.InfixR = text "InfixrOp"
+> xmlFixity CS.Infix = text "InfixOp"
+
+
+> xmlTranslationDecl :: QualIdent -> Doc
+> xmlTranslationDecl expId =
+> text ""
+> $$ nest level ( text "" <> xmlIdent (unqualify expId) <> text ""
+> $$ text "" <> xmlQualIdent expId <> text "")
+> $$ text ""
+
+
+> xmlIdent :: Ident -> Doc
+> xmlIdent ident = text (xmlFormat (name ident))
+
+> xmlInt :: Int -> Doc
+> xmlInt n = text (show n)
+
+> xmlInteger :: Integer -> Doc
+> xmlInteger n = text (show n)
+
+> xmlFloat :: Double -> Doc
+> xmlFloat n = text (show n)
+
+> xmlQualIdent :: QualIdent -> Doc
+> xmlQualIdent ident = text (xmlFormat (qualName ident))
+
+> xmlModuleIdent:: ModuleIdent -> Doc
+> xmlModuleIdent name = text (xmlFormat (moduleName name))
+
+> xmlFormat :: String -> String
+> xmlFormat [] = []
+> xmlFormat ('>':xs) = ">"++xmlFormat xs
+> xmlFormat ('<':xs) = "<"++xmlFormat xs
+> xmlFormat ('&':xs) = "&"++xmlFormat xs
+> xmlFormat (x:xs) = x:(xmlFormat xs)
+
+> -- =========================================================================
+
+> qualIDeclId :: ModuleIdent -> [QualIdent] -> CS.IDecl -> [QualIdent]
+> qualIDeclId mid qids (CS.IDataDecl _ qid _ mcdecls)
+> = foldl (qualConstrDeclId mid) (qid:qids) (catMaybes mcdecls)
+> qualIDeclId mid qids (CS.INewtypeDecl _ qid _ ncdecl)
+> = qualNewConstrDeclId mid (qid:qids) ncdecl
+> qualIDeclId mid qids (CS.ITypeDecl _ qid _ _)
+> = qid:qids
+> qualIDeclId mid qids (CS.IFunctionDecl _ qid _ _)
+> = qid:qids
+> qualIDeclId mid qids _ = qids
+
+> qualConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.ConstrDecl
+> -> [QualIdent]
+> qualConstrDeclId mid qids (CS.ConstrDecl _ _ id _)
+> = (qualifyWith mid id):qids
+> qualConstrDeclId mid qids (CS.ConOpDecl _ _ _ id _)
+> = (qualifyWith mid id):qids
+
+> qualNewConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.NewConstrDecl
+> -> [QualIdent]
+> qualNewConstrDeclId mid qids (CS.NewConstrDecl _ _ id _)
+> = (qualifyWith mid id):qids
+
+
+\end{verbatim}
diff --git a/src/ILPP.lhs b/src/ILPP.lhs
deleted file mode 100644
--- a/src/ILPP.lhs
+++ /dev/null
@@ -1,166 +0,0 @@
-% -*- LaTeX -*-
-% $Id: ILPP.lhs,v 1.22 2003/10/28 05:43:43 wlux Exp $
-%
-% Copyright (c) 1999-2003 Wolfgang Lux
-% See LICENSE for the full license.
-%
-% Modified by Martin Engelke (men@informatik.uni-kiel.de)
-%
-\nwfilename{ILPP.lhs}
-\section{A pretty printer for the intermediate language}
-This module implements just another pretty printer, this time for the
-intermediate language. It was mainly adapted from the Curry pretty
-printer (see sect.~\ref{sec:CurryPP}) which, in turn, is based on Simon
-Marlow's pretty printer for Haskell.
-\begin{verbatim}
-
-> module ILPP(module ILPP, Doc) where
-> import Ident
-> import IL
-> import Pretty
-
-> default(Int,Double)
-
-> dataIndent = 2
-> bodyIndent = 2
-> exprIndent = 2
-> caseIndent = 2
-> altIndent = 2
-
-> ppModule :: Module -> Doc
-> ppModule (Module m is ds) =
-> vcat (text "module" <+> text (show m) <+> text "where" :
-> map ppImport is ++ map ppDecl ds)
-
-> ppImport :: ModuleIdent -> Doc
-> ppImport m = text "import" <+> text (show m)
-
-> ppDecl :: Decl -> Doc
-> ppDecl (DataDecl tc n cs) =
-> sep (text "data" <+> ppTypeLhs tc n :
-> map (nest dataIndent)
-> (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs)))
-> ppDecl (NewtypeDecl tc n (ConstrDecl c ty)) =
-> sep [text "newtype" <+> ppTypeLhs tc n <+> equals,
-> nest dataIndent (ppConstr (ConstrDecl c [ty]))]
-> ppDecl (FunctionDecl f vs ty exp) =
-> ppTypeSig f ty $$
-> sep [ppQIdent f <+> hsep (map ppIdent vs) <+> equals,
-> nest bodyIndent (ppExpr 0 exp)]
-> ppDecl (ExternalDecl f cc ie ty) =
-> sep [text "external" <+> ppCallConv cc <+> text (show ie),
-> nest bodyIndent (ppTypeSig f ty)]
-> where ppCallConv Primitive = text "primitive"
-> ppCallConv CCall = text "ccall"
-
-> ppTypeLhs :: QualIdent -> Int -> Doc
-> ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))
-
-> ppConstr :: ConstrDecl [Type] -> Doc
-> ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys)
-
-> ppTypeSig :: QualIdent -> Type -> Doc
-> ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty
-
-> ppType :: Int -> Type -> Doc
-> ppType p (TypeConstructor tc tys)
-> | isQTupleId tc = parens (fsep (punctuate comma (map (ppType 0) tys)))
-> | unqualify tc == nilId = brackets (ppType 0 (head tys))
-> | otherwise =
-> ppParen (p > 1 && not (null tys))
-> (ppQIdent tc <+> fsep (map (ppType 2) tys))
-> ppType _ (TypeVariable n)
-> | n >= 0 = text (typeVars !! n)
-> | otherwise = text ('_':show (-n))
-> ppType p (TypeArrow ty1 ty2) =
-> ppParen (p > 0) (fsep (ppArrow (TypeArrow ty1 ty2)))
-> where ppArrow (TypeArrow ty1 ty2) =
-> ppType 1 ty1 <+> text "->" : ppArrow ty2
-> ppArrow ty = [ppType 0 ty]
-
-> ppBinding :: Binding -> Doc
-> ppBinding (Binding v exp) =
-> sep [ppIdent v <+> equals,nest bodyIndent (ppExpr 0 exp)]
-
-> ppAlt :: Alt -> Doc
-> ppAlt (Alt pat exp) =
-> sep [ppConstrTerm pat <+> text "->",nest altIndent (ppExpr 0 exp)]
-
-> ppLiteral :: Literal -> Doc
-> ppLiteral (Char _ c) = text (show c)
-> ppLiteral (Int _ i) = integer i
-> ppLiteral (Float _ f) = double f
-
-> ppConstrTerm :: ConstrTerm -> Doc
-> ppConstrTerm (LiteralPattern l) = ppLiteral l
-> ppConstrTerm (ConstructorPattern c [v1,v2])
-> | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2
-> ppConstrTerm (ConstructorPattern c vs)
-> | isQTupleId c = parens (fsep (punctuate comma (map ppIdent vs)))
-> | otherwise = ppQIdent c <+> fsep (map ppIdent vs)
-> ppConstrTerm (VariablePattern v) = ppIdent v
-
-> ppExpr :: Int -> Expression -> Doc
-> ppExpr p (Literal l) = ppLiteral l
-> ppExpr p (Variable v) = ppIdent v
-> ppExpr p (Function f _) = ppQIdent f
-> ppExpr p (Constructor c _) = ppQIdent c
-> ppExpr p (Apply (Apply (Function f _) e1) e2)
-> | isQInfixOp f = ppInfixApp p e1 f e2
-> ppExpr p (Apply (Apply (Constructor c _) e1) e2)
-> | isQInfixOp c = ppInfixApp p e1 c e2
-> ppExpr p (Apply e1 e2) =
-> ppParen (p > 2) (sep [ppExpr 2 e1,nest exprIndent (ppExpr 3 e2)])
-> ppExpr p (Case _ ev e alts) =
-> ppParen (p > 0)
-> (text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of" $$
-> nest caseIndent (vcat (map ppAlt alts)))
-> where ppEval Rigid = text "rigid"
-> ppEval Flex = text "flex"
-> ppExpr p (Or e1 e2) =
-> ppParen (p > 0) (sep [ppExpr 0 e1,char '|' <+> ppExpr 0 e2])
-> ppExpr p (Exist v e) =
-> ppParen (p > 0)
-> (sep [text "let" <+> ppIdent v <+> text "free" <+> text "in",
-> ppExpr 0 e])
-> ppExpr p (Let b e) =
-> ppParen (p > 0) (sep [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e])
-> ppExpr p (Letrec bs e) =
-> ppParen (p > 0)
-> (sep [text "letrec" <+> vcat (map ppBinding bs) <+> text "in",
-> ppExpr 0 e])
-
-> ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
-> ppInfixApp p e1 op e2 =
-> ppParen (p > 1)
-> (sep [ppExpr 2 e1 <+> ppQInfixOp op,nest exprIndent (ppExpr 2 e2)])
-
-> ppIdent :: Ident -> Doc
-> ppIdent ident
-> | isInfixOp ident = parens (ppName ident)
-> | otherwise = ppName ident
-
-> ppQIdent :: QualIdent -> Doc
-> ppQIdent ident
-> | isQInfixOp ident = parens (ppQual ident)
-> | otherwise = ppQual ident
-
-> ppQInfixOp :: QualIdent -> Doc
-> ppQInfixOp op
-> | isQInfixOp op = ppQual op
-> | otherwise = char '`' <> ppQual op <> char '`'
-
-> ppName :: Ident -> Doc
-> ppName x = text (name x)
-
-> ppQual :: QualIdent -> Doc
-> ppQual x = text (qualName x)
-
-> typeVars :: [String]
-> typeVars = [mkTypeVar c i | i <- [0..], c <- ['a' .. 'z']]
-> where mkTypeVar c i = c : if i == 0 then [] else show i
-
-> ppParen :: Bool -> Doc -> Doc
-> ppParen p = if p then parens else id
-
-\end{verbatim}
diff --git a/src/ILScope.hs b/src/ILScope.hs
deleted file mode 100644
--- a/src/ILScope.hs
+++ /dev/null
@@ -1,124 +0,0 @@
-module ILScope (getModuleScope,
- insertDeclScope, insertConstrDeclScope,
- insertCallConvScope, insertTypeScope,
- insertLiteralScope, insertConstrTermScope,
- insertExprScope, insertAltScope,
- insertBindingScope) where
-
-
-import IL
-import Ident
-import OldScopeEnv as ScopeEnv
-
-
--------------------------------------------------------------------------------
-
---
-getModuleScope :: Module -> ScopeEnv
-getModuleScope (Module _ _ decls) = foldl insertDecl newScopeEnv decls
-
-
---
-insertDeclScope :: ScopeEnv -> Decl -> ScopeEnv
-insertDeclScope env (DataDecl _ _ _) = env
-insertDeclScope env (NewtypeDecl _ _ _) = env
-insertDeclScope env (FunctionDecl _ params _ _)
- = foldr ScopeEnv.insertIdent (ScopeEnv.beginScope env) params
-insertDeclScope env (ExternalDecl _ _ _ _) = env
-
-
---
-insertConstrDeclScope :: ScopeEnv -> ConstrDecl [Type] -> ScopeEnv
-insertConstrDeclScope env _ = env
-
-
---
-insertCallConvScope :: ScopeEnv -> CallConv -> ScopeEnv
-insertCallConvScope env _ = env
-
-
---
-insertTypeScope :: ScopeEnv -> Type -> ScopeEnv
-insertTypeScope env _ = env
-
-
---
-insertLiteralScope :: ScopeEnv -> Literal -> ScopeEnv
-insertLiteralScope env _ = env
-
-
---
-insertConstrTermScope :: ScopeEnv -> ConstrTerm -> ScopeEnv
-insertConstrTermScope env _ = env
-
-
---
-insertExprScope :: ScopeEnv -> Expression -> ScopeEnv
-insertExprScope env (Literal _) = env
-insertExprScope env (Variable _) = env
-insertExprScope env (Function _ _) = env
-insertExprScope env (Constructor _ _) = env
-insertExprScope env (Apply _ _) = env
-insertExprScope env (Case _ _ _ _) = env
-insertExprScope env (Or _ _) = env
-insertExprScope env (Exist ident _)
- = ScopeEnv.insertIdent ident (ScopeEnv.beginScope env)
-insertExprScope env (Let bind _)
- = insertBinding (beginScope env) bind
-insertExprScope env (Letrec binds _)
- = foldl insertBinding (beginScope env) binds
-
-
---
-insertAltScope :: ScopeEnv -> Alt -> ScopeEnv
-insertAltScope env (Alt cterm _)
- = insertConstrTerm (ScopeEnv.beginScope env) cterm
-
-
---
-insertBindingScope :: ScopeEnv -> Binding -> ScopeEnv
-insertBindingScope env _ = env
-
-
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-
---
-insertDecl :: ScopeEnv -> Decl -> ScopeEnv
-insertDecl env (DataDecl qident _ cdecls)
- = foldl insertConstrDecl
- (ScopeEnv.insertIdent (unqualify qident) env)
- cdecls
-
-insertDecl env (NewtypeDecl qident _ cdecl)
- = insertConstrDecl (ScopeEnv.insertIdent (unqualify qident) env) cdecl
-
-insertDecl env (FunctionDecl qident _ _ _)
- = ScopeEnv.insertIdent (unqualify qident) env
-
-insertDecl env (ExternalDecl qident _ _ _)
- = ScopeEnv.insertIdent (unqualify qident) env
-
-
---
-insertConstrDecl :: ScopeEnv -> ConstrDecl a -> ScopeEnv
-insertConstrDecl env (ConstrDecl qident _)
- = ScopeEnv.insertIdent (unqualify qident) env
-
-
---
-insertConstrTerm :: ScopeEnv -> ConstrTerm -> ScopeEnv
-insertConstrTerm env (LiteralPattern _) = env
-insertConstrTerm env (ConstructorPattern _ params)
- = foldr ScopeEnv.insertIdent env params
-insertConstrTerm env (VariablePattern ident)
- = ScopeEnv.insertIdent ident env
-
-
---
-insertBinding :: ScopeEnv -> Binding -> ScopeEnv
-insertBinding env (Binding ident _) = ScopeEnv.insertIdent ident env
-
-
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
diff --git a/src/ILTrans.lhs b/src/ILTrans.lhs
deleted file mode 100644
--- a/src/ILTrans.lhs
+++ /dev/null
@@ -1,595 +0,0 @@
-
-% $Id: ILTrans.lhs,v 1.86 2004/02/13 19:23:58 wlux Exp $
-%
-% Copyright (c) 1999-2003, Wolfgang Lux
-% See LICENSE for the full license.
-%
-% Modified by Martin Engelke (men@informatik.uni-kiel.de)
-%
-\nwfilename{ILTrans.lhs}
-\section{Translating Curry into the Intermediate Language}
-After desugaring and lifting have been performed, the source code is
-translated into the intermediate language. Besides translating from
-source terms and expressions into intermediate language terms and
-expressions this phase in particular has to implement the pattern
-matching algorithm for equations and case expressions.
-
-Because of name conflicts between the source and intermediate language
-data structures, we can use only a qualified import for the
-\texttt{IL} module.
-\begin{verbatim}
-
-> module ILTrans(ilTrans,ilTransIntf) where
-
-> import Data.Maybe
-> import Data.List
-> import qualified Data.Set as Set
-> import qualified Data.Map as Map
-
-> import Base
-> import qualified IL
-> import Utils
-> import Env
-
-
-
-
-\end{verbatim}
-\paragraph{Modules}
-At the top-level, the compiler has to translate data type, newtype,
-function, and external declarations. When translating a data type or
-newtype declaration, we ignore the types in the declaration and lookup
-the types of the constructors in the type environment instead because
-these types are already fully expanded, i.e., they do not include any
-alias types.
-\begin{verbatim}
-
-> ilTrans :: Bool -> ValueEnv -> TCEnv -> EvalEnv -> Module -> IL.Module
-> ilTrans flat tyEnv tcEnv evEnv (Module m _ ds) =
-> IL.Module m (imports m ds') ds'
-> where ds' = concatMap (translGlobalDecl flat m tyEnv tcEnv evEnv) ds
-
-> translGlobalDecl :: Bool -> ModuleIdent -> ValueEnv -> TCEnv -> EvalEnv
-> -> Decl -> [IL.Decl]
-> translGlobalDecl _ m tyEnv tcEnv _ (DataDecl _ tc tvs cs) =
-> [translData m tyEnv tcEnv tc tvs cs]
-> translGlobalDecl _ m tyEnv tcEnv _ (NewtypeDecl _ tc tvs nc) =
-> [translNewtype m tyEnv tcEnv tc tvs nc]
-> translGlobalDecl flat m tyEnv tcEnv evEnv (FunctionDecl pos f eqs) =
-> [translFunction pos flat m tyEnv tcEnv evEnv f eqs]
-> translGlobalDecl _ m tyEnv tcEnv _ (ExternalDecl _ cc ie f _) =
-> [translExternal m tyEnv tcEnv f cc (fromJust ie)]
-> translGlobalDecl _ _ _ _ _ _ = []
-
-> translData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] -> [ConstrDecl]
-> -> IL.Decl
-> translData m tyEnv tcEnv tc tvs cs =
-> IL.DataDecl (qualifyWith m tc) (length tvs)
-> (map (translConstrDecl m tyEnv tcEnv) cs)
-
-> translNewtype :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident]
-> -> NewConstrDecl -> IL.Decl
-> translNewtype m tyEnv tcEnv tc tvs (NewConstrDecl _ _ c _) =
-> IL.NewtypeDecl (qualifyWith m tc) (length tvs)
-> (IL.ConstrDecl c' (translType' m tyEnv tcEnv ty))
-> -- (IL.ConstrDecl c' (translType ty))
-> where c' = qualifyWith m c
-> TypeArrow ty _ = constrType tyEnv c'
-
-> translConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> ConstrDecl
-> -> IL.ConstrDecl [IL.Type]
-> translConstrDecl m tyEnv tcEnv d =
-> IL.ConstrDecl c' (map (translType' m tyEnv tcEnv)
-> (arrowArgs (constrType tyEnv c')))
-> -- IL.ConstrDecl c' (map translType (arrowArgs (constrType tyEnv c')))
-> where c' = qualifyWith m (constr d)
-> constr (ConstrDecl _ _ c _) = c
-> constr (ConOpDecl _ _ _ op _) = op
-
-> translExternal :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> CallConv
-> -> String -> IL.Decl
-> translExternal m tyEnv tcEnv f cc ie =
-> IL.ExternalDecl f' (callConv cc) ie
-> (translType' m tyEnv tcEnv (varType tyEnv f'))
-> -- IL.ExternalDecl f' (callConv cc) ie (translType (varType tyEnv f'))
-> where f' = qualifyWith m f
-> callConv CallConvPrimitive = IL.Primitive
-> callConv CallConvCCall = IL.CCall
-
-\end{verbatim}
-\paragraph{Interfaces}
-In order to generate code, the compiler also needs to know the tags
-and arities of all imported data constructors. For that reason we
-compile the data type declarations of all interfaces into the
-intermediate language, too. In this case we do not lookup the
-types in the environment because the types in the interfaces are
-already fully expanded. Note that we do not translate data types
-which are imported into the interface from some other module.
-\begin{verbatim}
-
-> ilTransIntf :: ValueEnv -> TCEnv -> Interface -> [IL.Decl]
-> ilTransIntf tyEnv tcEnv (Interface m ds) =
-> foldr (translIntfDecl m tyEnv tcEnv) [] ds
-
-> translIntfDecl :: ModuleIdent -> ValueEnv -> TCEnv -> IDecl -> [IL.Decl]
-> -> [IL.Decl]
-> translIntfDecl m tyEnv tcEnv (IDataDecl _ tc tvs cs) ds
-> | not (isQualified tc) =
-> translIntfData m tyEnv tcEnv (unqualify tc) tvs cs : ds
-> translIntfDecl _ _ _ _ ds = ds
-
-> translIntfData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident]
-> -> [Maybe ConstrDecl] -> IL.Decl
-> translIntfData m tyEnv tcEnv tc tvs cs =
-> IL.DataDecl (qualifyWith m tc) (length tvs)
-> (map (maybe hiddenConstr
-> (translIntfConstrDecl m tyEnv tcEnv tvs)) cs)
-> where hiddenConstr = IL.ConstrDecl qAnonId []
-> qAnonId = qualify anonId
-
-> translIntfConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> [Ident]
-> -> ConstrDecl -> IL.ConstrDecl [IL.Type]
-> translIntfConstrDecl m tyEnv tcEnv tvs (ConstrDecl _ _ c tys) =
-> IL.ConstrDecl (qualifyWith m c) (map (translType' m tyEnv tcEnv)
-> (toQualTypes m tvs tys))
-> -- IL.ConstrDecl (qualifyWith m c) (map translType (toQualTypes m tvs tys))
-> translIntfConstrDecl m tyEnv tcEnv tvs (ConOpDecl _ _ ty1 op ty2) =
-> IL.ConstrDecl (qualifyWith m op)
-> (map (translType' m tyEnv tcEnv)
-> (toQualTypes m tvs [ty1,ty2]))
-> -- IL.ConstrDecl (qualifyWith m op)
-> -- (map translType (toQualTypes m tvs [ty1,ty2]))
-
-\end{verbatim}
-\paragraph{Types}
-The type representation in the intermediate language is the same as
-the internal representation except that it does not support
-constrained type variables and skolem types. The former are fixed and
-the later are replaced by fresh type constructors.
-
-Due to possible occurrence of record types, it is necessary to transform
-them back into their corresponding type constructors.
-\begin{verbatim}
-
-> translType' :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
-> translType' m tyEnv tcEnv ty =
-> translType (elimRecordTypes m tyEnv tcEnv (maximum (0:(typeVars ty))) ty)
-
-> translType :: Type -> IL.Type
-> translType (TypeConstructor tc tys) =
-> IL.TypeConstructor tc (map translType tys)
-> translType (TypeVariable tv) = IL.TypeVariable tv
-> translType (TypeConstrained tys _) = translType (head tys)
-> translType (TypeArrow ty1 ty2) =
-> IL.TypeArrow (translType ty1) (translType ty2)
-> translType (TypeSkolem k) =
-> IL.TypeConstructor (qualify (mkIdent ("_" ++ show k))) []
-
-> elimRecordTypes :: ModuleIdent -> ValueEnv -> TCEnv -> Int -> Type -> Type
-> elimRecordTypes m tyEnv tcEnv n (TypeConstructor t tys) =
-> TypeConstructor t (map (elimRecordTypes m tyEnv tcEnv n) tys)
-> elimRecordTypes m tyEnv tcEnv n (TypeVariable v) =
-> TypeVariable v
-> elimRecordTypes m tyEnv tcEnv n (TypeConstrained tys v) =
-> TypeConstrained (map (elimRecordTypes m tyEnv tcEnv n) tys) v
-> elimRecordTypes m tyEnv tcEnv n (TypeArrow t1 t2) =
-> TypeArrow (elimRecordTypes m tyEnv tcEnv n t1)
-> (elimRecordTypes m tyEnv tcEnv n t2)
-> elimRecordTypes m tyEnv tcEnv n (TypeSkolem v) =
-> TypeSkolem v
-> elimRecordTypes m tyEnv tcEnv n (TypeRecord fs _)
-> | null fs = internalError "elimRecordTypes: empty record type"
-> | otherwise =
-> case (lookupValue (fst (head fs)) tyEnv) of
-> [Label _ r _] ->
-> case (qualLookupTC r tcEnv) of
-> [AliasType _ n' (TypeRecord fs' _)] ->
-> let is = [0 .. n'-1]
-> vs = foldl (matchTypeVars fs)
-> Map.empty
-> fs'
-> tys = map (\i -> maybe (TypeVariable (i+n))
-> (elimRecordTypes m tyEnv tcEnv n)
-> (Map.lookup i vs))
-> is
-> in TypeConstructor r tys
-> _ -> internalError "elimRecordTypes: no record type"
-> _ -> internalError "elimRecordTypes: no label"
-
-> matchTypeVars :: [(Ident,Type)] -> Map.Map Int Type -> (Ident,Type)
-> -> Map.Map Int Type
-> matchTypeVars fs vs (l,ty) =
-> maybe vs (match vs ty) (lookup l fs)
-> where
-> match vs (TypeVariable i) ty' = Map.insert i ty' vs
-> match vs (TypeConstructor _ tys) (TypeConstructor _ tys') =
-> matchList vs tys tys'
-> match vs (TypeConstrained tys _) (TypeConstrained tys' _) =
-> matchList vs tys tys'
-> match vs (TypeArrow ty1 ty2) (TypeArrow ty1' ty2') =
-> matchList vs [ty1,ty2] [ty1',ty2']
-> match vs (TypeSkolem _) (TypeSkolem _) = vs
-> match vs (TypeRecord fs _) (TypeRecord fs' _) =
-> foldl (matchTypeVars fs') vs fs
-> match vs ty ty' =
-> internalError ("matchTypeVars: " ++ show ty ++ "\n" ++ show ty')
->
-> matchList vs tys tys' =
-> foldl (\vs' (ty,ty') -> match vs' ty ty') vs (zip tys tys')
-
-\end{verbatim}
-\paragraph{Functions}
-Each function in the program is translated into a function of the
-intermediate language. The arguments of the function are renamed such
-that all variables occurring in the same position (in different
-equations) have the same name. This is necessary in order to
-facilitate the translation of pattern matching into a \texttt{case}
-expression. We use the following simple convention here: The top-level
-arguments of the function are named from left to right \texttt{\_1},
-\texttt{\_2}, and so on. The names of nested arguments are constructed
-by appending \texttt{\_1}, \texttt{\_2}, etc. from left to right to
-the name that were assigned to a variable occurring at the position of
-the constructor term.
-
-Some special care is needed for the selector functions introduced by
-the compiler in place of pattern bindings. In order to generate the
-code for updating all pattern variables, the equality of names between
-the pattern variables in the first argument of the selector function
-and their repeated occurrences in the remaining arguments must be
-preserved. This means that the second and following arguments of a
-selector function have to be renamed according to the name mapping
-computed for its first argument.
-
-If an evaluation annotation is available for a function, it determines
-the evaluation mode of the case expression. Otherwise, the function
-uses flexible matching.
-\begin{verbatim}
-
-> type RenameEnv = Env Ident Ident
-
-> translFunction :: Position -> Bool -> ModuleIdent -> ValueEnv -> TCEnv
-> -> EvalEnv -> Ident -> [Equation] -> IL.Decl
-> translFunction pos flat m tyEnv tcEnv evEnv f eqs =
-> -- | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))
-> -- | otherwise =
-> IL.FunctionDecl f' vs (translType' m tyEnv tcEnv ty) expr
-> -- = IL.FunctionDecl f' vs (translType ty)
-> -- (match ev vs (map (translEquation tyEnv vs vs'') eqs))
-> where f' = qualifyWith m f
-> ty = varType tyEnv f'
-> -- ty' = elimRecordType m tyEnv tcEnv (maximum (0:(typeVars ty))) ty
-> ev' = lookupEval f evEnv
-> ev = maybe (defaultMode ty) evalMode ev'
-> vs = if not flat && isFpSelectorId f then translArgs eqs vs' else vs'
-> (vs',vs'') = splitAt (equationArity (head eqs))
-> (argNames (mkIdent ""))
-> expr | ev' == Just EvalChoice
-> = IL.Apply
-> (IL.Function
-> (qualifyWith preludeMIdent (mkIdent "commit"))
-> 1)
-> (match (ast pos) IL.Rigid vs
-> (map (translEquation tyEnv vs vs'') eqs))
-> | otherwise
-> = match (ast pos) ev vs (map (translEquation tyEnv vs vs'') eqs)
-> ---
-> -- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent ""))
-
-> evalMode :: EvalAnnotation -> IL.Eval
-> evalMode EvalRigid = IL.Rigid
-> evalMode EvalChoice = error "eval choice is not yet supported"
-
-> defaultMode :: Type -> IL.Eval
-> defaultMode _ = IL.Flex
->
-> --defaultMode ty = if isIO (arrowBase ty) then IL.Rigid else IL.Flex
-> -- where TypeConstructor qIOId _ = ioType undefined
-> -- isIO (TypeConstructor tc [_]) = tc == qIOId
-> -- isIO _ = False
-
-> translArgs :: [Equation] -> [Ident] -> [Ident]
-> translArgs [Equation _ (FunLhs _ (t:ts)) _] (v:_) =
-> v : map (translArg (bindRenameEnv v t emptyEnv)) ts
-> where translArg env (VariablePattern v) = fromJust (lookupEnv v env)
-
-> translEquation :: ValueEnv -> [Ident] -> [Ident] -> Equation
-> -> ([NestedTerm],IL.Expression)
-> translEquation tyEnv vs vs' (Equation _ (FunLhs _ ts) rhs) =
-> (zipWith translTerm vs ts,
-> translRhs tyEnv vs' (foldr2 bindRenameEnv emptyEnv vs ts) rhs)
-
-> translRhs :: ValueEnv -> [Ident] -> RenameEnv -> Rhs -> IL.Expression
-> translRhs tyEnv vs env (SimpleRhs _ e _) = translExpr tyEnv vs env e
-
-
-> equationArity :: Equation -> Int
-> equationArity (Equation _ lhs _) = p_equArity lhs
-> where
-> p_equArity (FunLhs _ ts) = length ts
-> p_equArity (OpLhs _ _ _) = 2
-> p_equArity _ = error "ILTrans - illegal equation"
-
-
-\end{verbatim}
-\paragraph{Pattern Matching}
-The pattern matching code searches for the left-most inductive
-argument position in the left hand sides of all rules defining an
-equation. An inductive position is a position where all rules have a
-constructor rooted term. If such a position is found, a \texttt{case}
-expression is generated for the argument at that position. The
-matching code is then computed recursively for all of the alternatives
-independently. If no inductive position is found, the algorithm looks
-for the left-most demanded argument position, i.e., a position where
-at least one of the rules has a constructor rooted term. If such a
-position is found, an \texttt{or} expression is generated with those
-cases that have a variable at the argument position in one branch and
-all other rules in the other branch. If there is no demanded position,
-the pattern matching is finished and the compiler translates the right
-hand sides of the remaining rules, eventually combining them using
-\texttt{or} expressions.
-
-Actually, the algorithm below combines the search for inductive and
-demanded positions. The function \texttt{match} scans the argument
-lists for the left-most demanded position. If this turns out to be
-also an inductive position, the function \texttt{matchInductive} is
-called in order to generate a \texttt{case} expression. Otherwise, the
-function \texttt{optMatch} is called that tries to find an inductive
-position in the remaining arguments. If one is found,
-\texttt{matchInductive} is called, otherwise the function
-\texttt{optMatch} uses the demanded argument position found by
-\texttt{match}.
-\begin{verbatim}
-
-> data NestedTerm = NestedTerm IL.ConstrTerm [NestedTerm] deriving Show
-
-> pattern (NestedTerm t _) = t
-> arguments (NestedTerm _ ts) = ts
-
-> translLiteral :: Literal -> IL.Literal
-> translLiteral (Char p c) = IL.Char p c
-> translLiteral (Int id i) = IL.Int (ast (positionOfIdent id)) i
-> translLiteral (Float p f) = IL.Float p f
-> translLiteral _ = internalError "translLiteral"
-
-> translTerm :: Ident -> ConstrTerm -> NestedTerm
-> translTerm _ (LiteralPattern l) =
-> NestedTerm (IL.LiteralPattern (translLiteral l)) []
-> translTerm v (VariablePattern _) = NestedTerm (IL.VariablePattern v) []
-> translTerm v (ConstructorPattern c ts) =
-> NestedTerm (IL.ConstructorPattern c (take (length ts) vs))
-> (zipWith translTerm vs ts)
-> where vs = argNames v
-> translTerm v (AsPattern _ t) = translTerm v t
-> translTerm _ _ = internalError "translTerm"
-
-> bindRenameEnv :: Ident -> ConstrTerm -> RenameEnv -> RenameEnv
-> bindRenameEnv _ (LiteralPattern _) env = env
-> bindRenameEnv v (VariablePattern v') env = bindEnv v' v env
-> bindRenameEnv v (ConstructorPattern _ ts) env =
-> foldr2 bindRenameEnv env (argNames v) ts
-> bindRenameEnv v (AsPattern v' t) env = bindEnv v' v (bindRenameEnv v t env)
-> bindRenameEnv _ _ env = internalError "bindRenameEnv"
-
-> argNames :: Ident -> [Ident]
-> argNames v = [mkIdent (prefix ++ show i) | i <- [1..]]
-> where prefix = name v ++ "_"
-
-> type Match = ([NestedTerm],IL.Expression)
-> type Match' = ([NestedTerm] -> [NestedTerm],[NestedTerm],IL.Expression)
-
-> isDefaultPattern :: IL.ConstrTerm -> Bool
-> isDefaultPattern (IL.VariablePattern _) = True
-> isDefaultPattern _ = False
-
-> isDefaultMatch :: (IL.ConstrTerm,a) -> Bool
-> isDefaultMatch = isDefaultPattern . fst
-
-> match :: SrcRef -> IL.Eval -> [Ident] -> [Match] -> IL.Expression
-> match _ ev [] alts = foldl1 IL.Or (map snd alts)
-> match pos ev (v:vs) alts
-> | null vars = e1
-> | null nonVars = e2
-> | otherwise = optMatch pos ev (IL.Or e1 e2) (v:) vs (map skipArg alts)
-> where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
-> (nonArgs,args) = partition (null.fst) alts
-> e1 = matchInductive pos ev id v vs nonVars
-> e2 = match pos ev vs (map snd vars)
-> tagAlt (t:ts,e) = (pattern t,(arguments t ++ ts,e))
-> skipArg (t:ts,e) = ((t:),ts,e)
-
-> optMatch :: SrcRef -> IL.Eval -> IL.Expression -> ([Ident] -> [Ident])
-> -> [Ident] ->[Match'] -> IL.Expression
-> optMatch _ ev e prefix [] alts = e
-> optMatch pos ev e prefix (v:vs) alts
-> | null vars = matchInductive pos ev prefix v vs nonVars
-> | otherwise = optMatch pos ev e (prefix . (v:)) vs (map skipArg alts)
-> where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
-> tagAlt (prefix,t:ts,e) = (pattern t,(prefix (arguments t ++ ts),e))
-> skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)
-
-> matchInductive :: SrcRef -> IL.Eval -> ([Ident] -> [Ident]) -> Ident
-> -> [Ident] ->[(IL.ConstrTerm,Match)] -> IL.Expression
-> matchInductive pos ev prefix v vs alts =
-> IL.Case pos ev (IL.Variable v) (matchAlts ev prefix vs alts)
-
-> matchAlts :: IL.Eval -> ([Ident] -> [Ident]) -> [Ident] ->
-> [(IL.ConstrTerm,Match)] -> [IL.Alt]
-> matchAlts ev prefix vs [] = []
-> matchAlts ev prefix vs ((t,alt):alts) =
-> IL.Alt t (match (srcRefOf t)
-> ev (prefix (vars t ++ vs)) (alt : map snd same)) :
-> matchAlts ev prefix vs others
-> where (same,others) = partition ((t ==) . fst) alts
-> vars (IL.ConstructorPattern _ vs) = vs
-> vars _ = []
-
-\end{verbatim}
-Matching in a \texttt{case}-expression works a little bit differently.
-In this case, the alternatives are matched from the first to the last
-alternative and the first matching alternative is chosen. All
-remaining alternatives are discarded.
-
-\ToDo{The case matching algorithm should use type information in order
-to detect total matches and immediately discard all alternatives which
-cannot be reached.}
-\begin{verbatim}
-
-> caseMatch :: SrcRef -> ([Ident] -> [Ident]) -> [Ident] -> [Match']
-> -> IL.Expression
-> caseMatch _ prefix [] alts = thd3 (head alts)
-> caseMatch r prefix (v:vs) alts
-> | isDefaultMatch (head alts') =
-> caseMatch r (prefix . (v:)) vs (map skipArg alts)
-> | otherwise =
-> IL.Case r IL.Rigid (IL.Variable v) (caseMatchAlts prefix vs alts')
-> where alts' = map tagAlt alts
-> tagAlt (prefix,t:ts,e) = (pattern t,(prefix,arguments t ++ ts,e))
-> skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)
-
-> caseMatchAlts ::
-> ([Ident] -> [Ident]) -> [Ident] -> [(IL.ConstrTerm,Match')] -> [IL.Alt]
-> caseMatchAlts prefix vs alts = map caseAlt (ts ++ ts')
-> where (ts',ts) = partition isDefaultPattern (nub (map fst alts))
-> caseAlt t =
-> IL.Alt t (caseMatch (srcRefOf t) id (prefix (vars t ++ vs))
-> (matchingCases t alts))
-> matchingCases t =
-> map (joinArgs (vars t)) . filter (matches t . fst)
-> matches t t' = t == t' || isDefaultPattern t'
-> joinArgs vs (IL.VariablePattern _,(prefix,ts,e)) =
-> (id,prefix (map varPattern vs ++ ts),e)
-> joinArgs _ (_,(prefix,ts,e)) = (id,prefix ts,e)
-> varPattern v = NestedTerm (IL.VariablePattern v) []
-> vars (IL.ConstructorPattern _ vs) = vs
-> vars _ = []
-
-\end{verbatim}
-\paragraph{Expressions}
-Note that the case matching algorithm assumes that the matched
-expression is accessible through a variable. The translation of case
-expressions therefore introduces a let binding for the scrutinized
-expression and immediately throws it away after the matching -- except
-if the matching algorithm has decided to use that variable in the
-right hand sides of the case expression. This may happen, for
-instance, if one of the alternatives contains an \texttt{@}-pattern.
-\begin{verbatim}
-
-> translExpr :: ValueEnv -> [Ident] -> RenameEnv -> Expression -> IL.Expression
-> translExpr _ _ _ (Literal l) = IL.Literal (translLiteral l)
-> translExpr tyEnv _ env (Variable v) =
-> case lookupVar v env of
-> Just v' -> IL.Variable v'
-> Nothing -> IL.Function v (arrowArity (varType tyEnv v))
-> where lookupVar v env
-> | isQualified v = Nothing
-> | otherwise = lookupEnv (unqualify v) env
-> translExpr tyEnv _ _ (Constructor c) =
-> IL.Constructor c (arrowArity (constrType tyEnv c))
-> translExpr tyEnv vs env (Apply e1 e2) =
-> IL.Apply (translExpr tyEnv vs env e1) (translExpr tyEnv vs env e2)
-> translExpr tyEnv vs env (Let ds e) =
-> case ds of
-> [ExtraVariables _ vs] -> foldr IL.Exist e' vs
-> [d] | all (`notElem` bv d) (qfv emptyMIdent d) ->
-> IL.Let (translBinding env' d) e'
-> _ -> IL.Letrec (map (translBinding env') ds) e'
-> where e' = translExpr tyEnv vs env' e
-> env' = foldr2 bindEnv env bvs bvs
-> bvs = bv ds
-> translBinding env (PatternDecl _ (VariablePattern v) rhs) =
-> IL.Binding v (translRhs tyEnv vs env rhs)
-> translBinding env p = error $ "unexpected binding: "++show p
-> translExpr tyEnv ~(v:vs) env (Case r e alts) =
-> case caseMatch r id [v] (map (translAlt v) alts) of
-> IL.Case r mode (IL.Variable v') alts'
-> | v == v' && v `notElem` fv alts' -> IL.Case r mode e' alts'
-> e''
-> | v `elem` fv e'' -> IL.Let (IL.Binding v e') e''
-> | otherwise -> e''
-> where e' = translExpr tyEnv vs env e
-> translAlt v (Alt _ t rhs) =
-> (id,
-> [translTerm v t],
-> translRhs tyEnv vs (bindRenameEnv v t env) rhs)
-> translExpr _ _ _ _ = internalError "translExpr"
-
-> instance Expr IL.Expression where
-> fv (IL.Variable v) = [v]
-> fv (IL.Apply e1 e2) = fv e1 ++ fv e2
-> fv (IL.Case _ _ e alts) = fv e ++ fv alts
-> fv (IL.Or e1 e2) = fv e1 ++ fv e2
-> fv (IL.Exist v e) = filter (/= v) (fv e)
-> fv (IL.Let (IL.Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
-> fv (IL.Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
-> where (vs,es) = unzip [(v,e) | IL.Binding v e <- bds]
-> fv _ = []
-
-> instance Expr IL.Alt where
-> fv (IL.Alt (IL.ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
-> fv (IL.Alt (IL.VariablePattern v) e) = filter (v /=) (fv e)
-> fv (IL.Alt _ e) = fv e
-
-\end{verbatim}
-\paragraph{Auxiliary Definitions}
-The functions \texttt{varType} and \texttt{constrType} return the type
-of variables and constructors, respectively. The quantifiers are
-stripped from the types.
-\begin{verbatim}
-
-> varType :: ValueEnv -> QualIdent -> Type
-> varType tyEnv f =
-> case qualLookupValue f tyEnv of
-> [Value _ (ForAll _ ty)] -> ty
-> _ -> internalError ("varType: " ++ show f)
-
-> constrType :: ValueEnv -> QualIdent -> Type
-> constrType tyEnv c =
-> case qualLookupValue c tyEnv of
-> [DataConstructor _ (ForAllExist _ _ ty)] -> ty
-> [NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty
-> _ -> internalError ("constrType: " ++ show c)
-
-\end{verbatim}
-The list of import declarations in the intermediate language code is
-determined by collecting all module qualifiers used in the current
-module.
-\begin{verbatim}
-
-> imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]
-> imports m = Set.toList . Set.delete m . Set.fromList . foldr modulesDecl []
-
-> modulesDecl :: IL.Decl -> [ModuleIdent] -> [ModuleIdent]
-> modulesDecl (IL.DataDecl _ _ cs) ms = foldr modulesConstrDecl ms cs
-> where modulesConstrDecl (IL.ConstrDecl _ tys) ms = foldr modulesType ms tys
-> modulesDecl (IL.NewtypeDecl _ _ (IL.ConstrDecl _ ty)) ms = modulesType ty ms
-> modulesDecl (IL.FunctionDecl _ _ ty e) ms = modulesType ty (modulesExpr e ms)
-> modulesDecl (IL.ExternalDecl _ _ _ ty) ms = modulesType ty ms
-
-> modulesType :: IL.Type -> [ModuleIdent] -> [ModuleIdent]
-> modulesType (IL.TypeConstructor tc tys) ms =
-> modules tc (foldr modulesType ms tys)
-> modulesType (IL.TypeVariable _) ms = ms
-> modulesType (IL.TypeArrow ty1 ty2) ms = modulesType ty1 (modulesType ty2 ms)
-
-> modulesExpr :: IL.Expression -> [ModuleIdent] -> [ModuleIdent]
-> modulesExpr (IL.Function f _) ms = modules f ms
-> modulesExpr (IL.Constructor c _) ms = modules c ms
-> modulesExpr (IL.Apply e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
-> modulesExpr (IL.Case _ _ e as) ms = modulesExpr e (foldr modulesAlt ms as)
-> where modulesAlt (IL.Alt t e) ms = modulesConstrTerm t (modulesExpr e ms)
-> modulesConstrTerm (IL.ConstructorPattern c _) ms = modules c ms
-> modulesConstrTerm _ ms = ms
-> modulesExpr (IL.Or e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
-> modulesExpr (IL.Exist _ e) ms = modulesExpr e ms
-> modulesExpr (IL.Let b e) ms = modulesBinding b (modulesExpr e ms)
-> modulesExpr (IL.Letrec bs e) ms = foldr modulesBinding (modulesExpr e ms) bs
-> modulesExpr _ ms = ms
-
-> modulesBinding :: IL.Binding -> [ModuleIdent] -> [ModuleIdent]
-> modulesBinding (IL.Binding _ e) = modulesExpr e
-
-> modules :: QualIdent -> [ModuleIdent] -> [ModuleIdent]
-> modules x ms = maybe ms (: ms) (fst (splitQualIdent x))
-
-\end{verbatim}
-
diff --git a/src/ILxml.lhs b/src/ILxml.lhs
deleted file mode 100644
--- a/src/ILxml.lhs
+++ /dev/null
@@ -1,518 +0,0 @@
-
-% $Id: ILxml.lhs,v 1.0 2001/06/19 12:19:18 rafa Exp $
-%
-% $Log: ILxml.lhs,v $
-%
-% Revision 1.1 2001/06/19 12:19:18 rafa
-% Pretty printer in XML for the intermediate language added.
-%
-%
-% Modified by Martin Engelke (men@informatik.uni-kiel.de)
-%
-\nwfilename{ILxml.lhs}
-\section{A pretty printer in XML for the intermediate language}
-This module implements just another pretty printer, this time in XML and for
-the intermediate language. It was mainly adapted from the Curry pretty
-printer (see sect.~\ref{sec:CurryPP}), which in turn is based on Simon
-Marlow's pretty printer for Haskell. The format of the output intends to be
-similar to that of Flat-Curry XML representation.
-\begin{verbatim}
-
-> module ILxml(module ILxml, Doc) where
-
-> import Data.Maybe
-> import Data.Char(chr,ord,isAlphaNum)
-
-> import Ident
-> import IL
-> import qualified CurrySyntax as CS
-> import CurryEnv
-> import Pretty
-
-
-
-> -- identation level
-> level::Int
-> level = 3
-
-> xmlModule :: CurryEnv -> Module -> Doc
-> xmlModule cEnv m = text "" $$ nest level (xmlBody cEnv m)
-> $$ text ""
-
-> xmlBody :: CurryEnv -> Module -> Doc
-> xmlBody cEnv (Module name imports decls) =
-> xmlElement "module" xmlModuleDecl moduleDecl $$
-> xmlElement "import" xmlImportDecl importDecl $$
-> xmlElement "types" xmlTypeDecl typeDecl $$
-> xmlElement "functions" xmlFunctionDecl functionDecl $$
-> xmlElement "operators" xmlOperatorDecl operatorDecl $$
-> xmlElement "translation" xmlTranslationDecl translationDecl
-> where
-> moduleDecl = [name]
-> importDecl = imports
-> operatorDecl = infixDecls cEnv
-> translationDecl = foldl (qualIDeclId (moduleId cEnv))
-> []
-> (interface cEnv)
-> (functionDecl,typeDecl) = splitDecls decls
-
-> -- =========================================================================
-
-> xmlModuleDecl :: ModuleIdent -> Doc
-> xmlModuleDecl name = xmlModuleIdent name
-
-> -- =========================================================================
-
-> xmlImportDecl :: ModuleIdent -> Doc
-> xmlImportDecl name = xmlElement "module" xmlModuleDecl [name]
-
-
-> -- =========================================================================
-> -- T Y P E S
-> -- =========================================================================
-
-> xmlTypeDecl :: Decl -> Doc
-> xmlTypeDecl (DataDecl tc arity cs) =
-> beginType $$
-> nest level (xmlTypeParams arity) $$
-> xmlLines xmlConstructor cs $$
-> endType
-> where
-> beginType = text " (xmlQualIdent tc) <> text "\">"
-> endType = text ""
-
-> xmlTypeParams :: Int -> Doc
-> xmlTypeParams n = xmlElement "params" xmlTypeVar [0..(n-1)]
-
-> xmlConstructor :: ConstrDecl [Type] -> Doc
-> xmlConstructor (ConstrDecl ident []) = xmlConstructorBegin ident 0
-> xmlConstructor (ConstrDecl ident l) =
-> xmlConstructorBegin ident (length l) $$
-> xmlLines xmlType l $$
-> xmlConstructorEnd
-> where
-> xmlConstructorEnd = text ""
-
-> xmlConstructorBegin :: QualIdent -> Int -> Doc
-> xmlConstructorBegin ident n = xmlHeadingWithArity "cons" ident n (n==0)
-
-> xmlHeadingWithArity :: String -> QualIdent -> Int -> Bool -> Doc
-> xmlHeadingWithArity tagName ident n single =
-> if single
-> then prefix<>text "/>"
-> else prefix<> text ">"
-> where
-> prefix = text ("<"++tagName++" name=\"") <> name <> text "\" " <> arity
-> arity = text "arity=\"" <> xmlInt n <> text "\""
-> name = xmlQualIdent ident
-
-
-> xmlType :: Type -> Doc
-> xmlType (TypeConstructor ident []) = xmlTypeConsBegin ident True
-> xmlType (TypeConstructor ident l) = xmlTypeConsBegin ident False $$
-> xmlLines xmlType l $$
-> xmlTypeConsEnd
-> where
-> xmlTypeConsEnd = text ""
-
-> xmlType (TypeVariable n) = xmlTypeVar n
-> xmlType (TypeArrow a b) = xmlTypeFun a b
-
-> xmlTypeConsBegin :: QualIdent -> Bool -> Doc
-> xmlTypeConsBegin ident single =
-> if single
-> then prefix <> text "/>"
-> else prefix <> text ">"
-> where
-> name = xmlQualIdent ident
-> prefix = text " name <> text "\""
-
-> xmlTypeVar :: Int -> Doc
-> xmlTypeVar n = text ""<> xmlInt n <> text ""
-
-> xmlTypeFun :: Type -> Type -> Doc
-> xmlTypeFun a b = xmlElement "functype" xmlType [a,b]
-
-
-> -- =========================================================================
-> -- F U N C T I O N S
-> -- =========================================================================
-
-> xmlFunctionDecl :: Decl -> Doc
-> xmlFunctionDecl (NewtypeDecl tc arity (ConstrDecl ident ty)) =
-> xmlFunctionDecl (FunctionDecl ident [arg] ftype (Variable arg))
-> where
-> arg = mkIdent "_1"
-> ftype = TypeArrow ty (TypeConstructor tc (map TypeVariable [0..arity-1]))
-
-> xmlFunctionDecl (FunctionDecl ident largs fType expr) =
-> heading $$ nest level (xmlRule largs expr) $$ end
-> where
-> heading = xmlBeginFunction ident (length largs) fType
-> end = text ""
-
-> xmlFunctionDecl (ExternalDecl ident callConv internalName fType) =
-> heading $$ external $$ end
-> where
-> heading = xmlBeginFunction ident (xmlFunctionArity fType) fType
-> external = text (""
-> ++ xmlFormat internalName
-> ++ "")
-> end = text ""
-
-> xmlBeginFunction :: QualIdent -> Int -> Type -> Doc
-> xmlBeginFunction ident n fType =
-> heading $$ typeDecls
-> where
-> heading = xmlHeadingWithArity "func" ident n False
-> typeDecls = nest level (xmlType fType)
-
-> xmlEndFunction :: Doc
-> xmlEndFunction = text ""
-
-> xmlFunctionArity :: Type -> Int
-> xmlFunctionArity (TypeConstructor ident l) = 0
-> xmlFunctionArity (TypeVariable n) = 0
-> xmlFunctionArity (TypeArrow a b) = 1 + (xmlFunctionArity b)
-
-> xmlRule :: [Ident] -> Expression -> Doc
-> xmlRule lArgs e = text "" $$
-> nest level (xmlLhs lArgs) $$
-> nest level (xmlRhs lArgs e) $$
-> text ""
-
-> xmlLhs :: [Ident] -> Doc
-> xmlLhs l = xmlElement "lhs" xmlVar [0..((length l)-1)]
-
-> xmlRhs :: [Ident] -> Expression -> Doc
-> xmlRhs l e = text "" $$ nest level rhs $$ text ""
-> where
-> varDicc = xmlBuildDicc l
-> (rhs,dicc) = xmlExpr varDicc e
-
-> -- =========================================================================
-
-> -- =========================================================================
-> -- E X P R E S S I O N S
-> -- =========================================================================
-
-> xmlExpr :: [(Int,Ident)] -> Expression -> (Doc,[(Int,Ident)])
-> xmlExpr d (Literal lit) = (xmlLiteral (xmlLit lit),d)
-> xmlExpr d (Variable ident) = xmlExprVar d ident
-> xmlExpr d (Function ident arity) = (xmlSingleApp ident arity True,d)
-> xmlExpr d (Constructor ident arity) = (xmlSingleApp ident arity False,d)
-> xmlExpr d exp@(Apply e1 e2) = xmlApply d exp (xmlAppArgs exp)
-> xmlExpr d (Case _ eval expr alt) = xmlCase d eval expr alt
-> xmlExpr d (Or expr1 expr2) = xmlOr d expr1 expr2
-> xmlExpr d (Exist ident expr) = xmlFree d ident expr
-> xmlExpr d (Let binding expr) = xmlLet d binding expr
-> xmlExpr d (Letrec lBinding expr) = xmlLetrec d lBinding expr
-> --error "Recursive let bindings not supported in FlatCurry"
-
-> -- =========================================================================
-
-> xmlSingleApp :: QualIdent -> Int -> Bool -> Doc
-> xmlSingleApp ident arity isFunction =
-> if arity>0
-> then xmlCombHeading identDoc (text "PartCall") True
-> else xmlCombHeading identDoc (text totalApp) True
-> where
-> identDoc = xmlQualIdent ident
-> totalApp = if isFunction then "FuncCall" else "ConsCall"
-
-
-> xmlCombHeading :: Doc -> Doc -> Bool -> Doc
-> xmlCombHeading name cType single =
-> if single
-> then prefix <> text " />"
-> else prefix <> text ">"
-> where
-> prefix = text "cType<>text "\" name=\""<>name<>text "\""
-
-> -- =========================================================================
-
-> xmlExprVar :: [(Int,Ident)] -> Ident -> (Doc,[(Int,Ident)])
-> xmlExprVar d ident =
-> if isNew
-> then (xmlVar newVar, (newVar,ident):d)
-> else (xmlVar var, d)
-> where
-> var = xmlLookUp ident d
-> isNew = var == -1
-> newVar = xmlNewVar d
-
-> -- =========================================================================
-
-
-> xmlApply :: [(Int,Ident)] -> Expression -> (Expression,[Expression]) ->
-> (Doc,[(Int,Ident)])
-
-> xmlApply d exp ((Function ident arity),lExp) =
-> xmlApplyFunctor d ident arity lExp True
-
-> xmlApply d exp ((Constructor ident arity),lExp) =
-> xmlApplyFunctor d ident arity lExp False
-
-> xmlApply d (Apply expr1 expr2) e' =
-> (text "" $$ nest level e1 $$ nest level e2 $$ text "", d2)
-> where
-> (e1,d1) = xmlExpr d expr1
-> (e2,d2) = xmlExpr d1 expr2
-
-> xmlApplyFunctor ::[(Int,Ident)] -> QualIdent -> Int -> [Expression] ->
-> Bool -> (Doc,[(Int,Ident)])
-> xmlApplyFunctor d ident arity lArgs isFunction =
-> xmlCombApply d (xmlQualIdent ident) (text cTypeS) n lArgs
-> where
-> n = length (lArgs)
-> cTypeS = if n==arity
-> then if isFunction
-> then "FuncCall"
-> else "ConsCall"
-> else "PartCall"
-
-
-> xmlCombApply :: [(Int,Ident)] -> Doc -> Doc -> Int ->
-> [Expression] -> (Doc,[(Int,Ident)])
-> xmlCombApply d name cType 0 lArgs =
-> (xmlCombHeading name cType True,d)
-> xmlCombApply d name cType n lArgs =
-> (xmlCombHeading name cType False $$ xmlLines id lDocs$$ text "", d1)
-> where
-> (lDocs,d1) = xmlMapDicc d xmlExpr lArgs
-
-
-> xmlAppArgs :: Expression -> (Expression,[Expression])
-> xmlAppArgs (Apply e1 e2) = (e,lArgs++[e2])
-> where
-> (e,lArgs) = (xmlAppArgs e1)
-> xmlAppArgs e = (e,[])
-> -- =========================================================================
-
-
-> -- =========================================================================
-
-> xmlCase :: [(Int,Ident)] -> Eval -> Expression -> [Alt] -> (Doc,[(Int,Ident)])
-> xmlCase d eval expr lAlt =
-> (heading $$ nest level e1 $$ xmlLines id lDocs$$ end,d2)
-> where
-> sEval = if eval==Rigid then "\"Rigid\"" else "\"Flex\""
-> heading = text ""
-> end = text ""
-> (e1,d1) = xmlExpr d expr
-> (lDocs,d2) = xmlMapDicc d xmlBranch lAlt
-
-> xmlOr :: [(Int,Ident)] -> Expression -> Expression -> (Doc,[(Int,Ident)])
-> xmlOr d expr1 expr2 =
-> (text "" $$ nest level e1 $$ nest level e2 $$ text "",d2)
-> where
-> (e1,d1) = xmlExpr d expr1
-> (e2,d2) = xmlExpr d1 expr2
-
-
-> xmlBranch :: [(Int,Ident)] -> Alt -> (Doc,[(Int,Ident)])
-> xmlBranch d (Alt pattern expr) =
-> (text "" $$ nest level e1 $$ nest level e2 $$ text "",d2)
-> where
-> (e1,d1) = xmlPattern d pattern
-> (e2,d2) = xmlExpr d1 expr
-
-
-> xmlPattern :: [(Int,Ident)] -> ConstrTerm -> (Doc,[(Int,Ident)])
-> xmlPattern d (LiteralPattern lit) = (xmlLitPattern (xmlLit lit),d)
-> xmlPattern d (ConstructorPattern ident lArgs) = xmlConsPattern d ident lArgs
-> xmlPattern d (VariablePattern _) = error "Variable patterns not allowed in Flat Curry"
-
-> xmlConsPattern :: [(Int,Ident)] -> QualIdent -> [Ident] -> (Doc,[(Int,Ident)])
-> xmlConsPattern d ident lArgs =
-> (heading $$ xmlLines id lDocs $$ end,d2)
-> where
-> heading = text " (xmlQualIdent ident) <>
-> text "\"" <> endh
-> endh = if (length lArgs)>0 then text ">" else text "/>"
-> end = if (length lArgs)>0 then text "" else empty
-> (lDocs,d2) = xmlMapDicc d xmlExprVar lArgs
-
-> -- =========================================================================
-
-
-> xmlFree :: [(Int,Ident)] -> Ident -> Expression -> (Doc,[(Int,Ident)])
-> xmlFree d ident exp =
-> (text "" $$ nest level v $$ nest level e $$ text "",d2)
-> where
-> (v,d1) = xmlExprVar d ident
-> (e,d2) = xmlExpr d1 exp
-
-
-> -- =========================================================================
-
-> xmlLet :: [(Int,Ident)] -> Binding -> Expression -> (Doc,[(Int,Ident)])
-> xmlLet d binding exp =
-> (text "" $$ nest level b $$ nest level e $$ text "", d2)
-> where
-> (b,d1) = xmlBinding d binding
-> (e,d2) = xmlExpr d1 exp
-
-> xmlBinding :: [(Int,Ident)] -> Binding -> (Doc,[(Int,Ident)])
-> xmlBinding d (Binding ident exp) =
-> (text "" $$ nest level v $$ nest level e $$ text "",d2)
-> where
-> (v,d1) = xmlExprVar d ident
-> (e,d2) = xmlExpr d exp
-
-> -- =========================================================================
-
-> xmlLetrec :: [(Int,Ident)] -> [Binding] -> Expression -> (Doc,[(Int,Ident)])
-> xmlLetrec d lB exp =
-> (text "" $$ xmlLines id b $$ nest level e $$ text "",d2)
-> where
-> (b,d1) = xmlMapDicc d xmlBinding lB
-> (e,d2) = xmlExpr d1 exp
-
-> -- =========================================================================
-
-
-> -- =========================================================================
-> -- A U X I L I A R Y F U N C T I O N S
-> -- =========================================================================
-
-> splitDecls :: [Decl] -> ([Decl],[Decl])
-> splitDecls [] = ([],[])
-> splitDecls (x:xs) = case x of
-> DataDecl _ _ _ -> (functionDecl,x:typeDecl)
-> NewtypeDecl _ _ _ -> (x:functionDecl,typeDecl)
-> FunctionDecl _ _ _ _ -> (x:functionDecl,typeDecl)
-> ExternalDecl _ _ _ _ -> (x:functionDecl,typeDecl)
-> where
-> (functionDecl,typeDecl) = splitDecls xs
-
-
-
-
-> xmlElement :: Eq a => String -> (a -> Doc) -> [a] -> Doc
-> xmlElement name f [] = text ("<"++name++" />")
-> xmlElement name f lDecls = beginElement $$ xmlLines f lDecls $$ endElement
-> where
-> beginElement = text ("<"++name++">")
-> endElement = text ("")
->
-
-> xmlLines :: (a -> Doc) -> [a] -> Doc
-> xmlLines f = (nest level).vcat.(map f)
-
-
-> xmlMapDicc::[(Int,Ident)] -> ([(Int,Ident)] -> a -> (Doc,[(Int,Ident)])) ->
-> [a] -> ([Doc],[(Int,Ident)])
-> xmlMapDicc d f lArgs = foldl newArg ([],d) lArgs
-> where
-> newArg (l,d) e = (l++[v'],d')
-> where (v',d') = f d e
->
-
-
-> -- The dictionary identifies var names with integers
-> -- it will be ordered starting at the greatest integer
-> xmlBuildDicc :: [Ident] -> [(Int,Ident)]
-> xmlBuildDicc l = reverse (zip [0..((length l)-1)] l)
-
-> -- looks for a ident in the dictorionary. If it appears returns its
-> -- associated value. Otherwise, -1 is returned
-> xmlLookUp :: Ident -> [(Int,Ident)] -> Int
-> xmlLookUp ident [] = -1
-> xmlLookUp ident ((n,name):xs) = if ident==name
-> then n
-> else xmlLookUp ident xs
-
-> -- generates a integer corresponding to a new var
-> xmlNewVar :: [(Int,Ident)] -> Int
-> xmlNewVar [] = 0
-> xmlNewVar ((n,ident):xs) = n+1
-
-> xmlVar :: Int -> Doc
-> xmlVar n = text "" <> xmlInt n <> text ""
-
-> xmlLiteral :: Doc -> Doc
-> xmlLiteral d = text "" $$ nest level d $$ text ""
-
-> xmlLitPattern :: Doc -> Doc
-> xmlLitPattern d = text "" $$ nest level d $$ text ""
-
-
-> xmlLit :: Literal -> Doc
-> xmlLit (Char _ c) = text "" <> xmlInt (ord c) <> text ""
-> xmlLit (Int _ n) = text "" <> xmlInteger n <> text ""
-> xmlLit (Float _ n) = text "" <> xmlFloat n <> text ""
-
-> xmlOperatorDecl :: CS.IDecl -> Doc
-> xmlOperatorDecl (CS.IInfixDecl _ fixity prec qident) =
-> text " xmlFixity fixity
-> <> text "\" prec=\"" <> xmlInteger prec <> text "\">"
-> <> xmlIdent (unqualify qident)
-> <> text ""
-
-> xmlFixity :: CS.Infix -> Doc
-> xmlFixity CS.InfixL = text "InfixlOp"
-> xmlFixity CS.InfixR = text "InfixrOp"
-> xmlFixity CS.Infix = text "InfixOp"
-
-
-> xmlTranslationDecl :: QualIdent -> Doc
-> xmlTranslationDecl expId =
-> text ""
-> $$ nest level ( text "" <> xmlIdent (unqualify expId) <> text ""
-> $$ text "" <> xmlQualIdent expId <> text "")
-> $$ text ""
-
-
-> xmlIdent :: Ident -> Doc
-> xmlIdent ident = text (xmlFormat (name ident))
-
-> xmlInt :: Int -> Doc
-> xmlInt n = text (show n)
-
-> xmlInteger :: Integer -> Doc
-> xmlInteger n = text (show n)
-
-> xmlFloat :: Double -> Doc
-> xmlFloat n = text (show n)
-
-> xmlQualIdent :: QualIdent -> Doc
-> xmlQualIdent ident = text (xmlFormat (qualName ident))
-
-> xmlModuleIdent:: ModuleIdent -> Doc
-> xmlModuleIdent name = text (xmlFormat (moduleName name))
-
-> xmlFormat :: String -> String
-> xmlFormat [] = []
-> xmlFormat ('>':xs) = ">"++xmlFormat xs
-> xmlFormat ('<':xs) = "<"++xmlFormat xs
-> xmlFormat ('&':xs) = "&"++xmlFormat xs
-> xmlFormat (x:xs) = x:(xmlFormat xs)
-
-> -- =========================================================================
-
-> qualIDeclId :: ModuleIdent -> [QualIdent] -> CS.IDecl -> [QualIdent]
-> qualIDeclId mid qids (CS.IDataDecl _ qid _ mcdecls)
-> = foldl (qualConstrDeclId mid) (qid:qids) (catMaybes mcdecls)
-> qualIDeclId mid qids (CS.INewtypeDecl _ qid _ ncdecl)
-> = qualNewConstrDeclId mid (qid:qids) ncdecl
-> qualIDeclId mid qids (CS.ITypeDecl _ qid _ _)
-> = qid:qids
-> qualIDeclId mid qids (CS.IFunctionDecl _ qid _ _)
-> = qid:qids
-> qualIDeclId mid qids _ = qids
-
-> qualConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.ConstrDecl
-> -> [QualIdent]
-> qualConstrDeclId mid qids (CS.ConstrDecl _ _ id _)
-> = (qualifyWith mid id):qids
-> qualConstrDeclId mid qids (CS.ConOpDecl _ _ _ id _)
-> = (qualifyWith mid id):qids
-
-> qualNewConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.NewConstrDecl
-> -> [QualIdent]
-> qualNewConstrDeclId mid qids (CS.NewConstrDecl _ _ id _)
-> = (qualifyWith mid id):qids
-
-
-\end{verbatim}
diff --git a/src/Ident.lhs b/src/Ident.lhs
deleted file mode 100644
--- a/src/Ident.lhs
+++ /dev/null
@@ -1,415 +0,0 @@
-> {-# LANGUAGE DeriveDataTypeable #-}
-
-% $Id: Ident.lhs,v 1.21 2004/10/29 13:08:09 wlux Exp $
-%
-% Copyright (c) 1999-2004, Wolfgang Lux
-% See LICENSE for the full license.
-%
-\nwfilename{Ident.lhs}
-\section{Identifiers}
-This module provides the implementation of identifiers and some
-utility functions for identifiers, which are used at various places in
-the compiler.
-
-Identifiers comprise the name of the denoted entity and an \emph{id},
-which can be used for renaming identifiers, e.g., in order to resolve
-name conflicts between identifiers from different scopes. An
-identifier with an \emph{id} $0$ is considered as not being renamed
-and, hence, its \emph{id} will not be shown.
-
-\ToDo{Probably we should use \texttt{Integer} for the \emph{id}s.}
-
-Qualified identifiers may optionally be prefixed by a module
-name. \textbf{The order of the cases \texttt{UnqualIdent} and
-\texttt{QualIdent} is important. Some parts of the compiler rely on
-the fact that all qualified identifiers are greater than any
-unqualified identifier.}
-\begin{verbatim}
-
-> module Ident(Ident,QualIdent,ModuleIdent,SrcRefOf(..),
-> mkIdent,name,qualName,uniqueId,renameIdent,unRenameIdent,
-> mkMIdent,moduleName,moduleQualifiers,isInfixOp,isQInfixOp,
-> qualify,qualifyWith,qualQualify,isQualified,
-> unqualify,qualUnqualify,localIdent,splitQualIdent,
-> emptyMIdent,mainMIdent,preludeMIdent,
-> anonId,unitId,boolId,charId,intId,floatId,listId,ioId,
-> successId,trueId,falseId,nilId,consId,mainId,
-> tupleId,isTupleId,tupleArity,
-> minusId,fminusId,updIdentName,
-> qUnitId,qBoolId,qCharId,qIntId,qFloatId,qListId,qIOId,
-> qSuccessId,qTrueId,qFalseId,qNilId,qConsId,
-> qTupleId,isQTupleId,qTupleArity,
-> fpSelectorId,isFpSelectorId,isQualFpSelectorId,
-> recSelectorId,qualRecSelectorId,
-> recUpdateId, qualRecUpdateId, recordExtId, labelExtId,
-> isRecordExtId, isLabelExtId, fromRecordExtId, fromLabelExtId,
-> renameLabel, isLabel, fpSelExt, recSelExt, recUpdExt,
-> recordExt, labelExt, mkLabelIdent,hasPositionIdent,
-> showsIdent,showsQualIdent,showsModuleIdent,
-> addPositionIdent, removePositionIdent, positionOfIdent,
-> addPositionModuleIdent, removePositionModuleIdent,addRef,addRefId,
-> positionOfModuleIdent,positionOfQualIdent,updQualIdent ) where
-
-> import Data.Char
-> import Data.List
-> import Data.Maybe
-> import Data.Generics
-
-> import Position
-
-
-> data Ident = Ident String Int
-> | IdentPosition Position String Int deriving (Read,Data,Typeable)
-> data QualIdent = UnqualIdent Ident | QualIdent ModuleIdent Ident
-> deriving (Eq,Ord,Read,Data,Typeable)
-> data ModuleIdent = ModuleIdent [String]
-> |ModuleIdentPosition Position [String] deriving (Data,Typeable)
-
-> instance Eq Ident where
-> ident1 == ident2 = name ident1 == name ident2 &&
-> uniqueId ident1 == uniqueId ident2
-
-> instance Ord ModuleIdent where
-> mident1 `compare` mident2 =
-> moduleQualifiers mident1 `compare` moduleQualifiers mident2
-
-> instance Eq ModuleIdent where
-> mident1 == mident2 = moduleQualifiers mident1 == moduleQualifiers mident2
-
-> instance Read ModuleIdent where
-> readsPrec p s = [ (mkMIdent [m],s') | (m,s') <- readsPrec p s ]
-
-> instance Ord Ident where
-> ident1 `compare` ident2 =
-> (name ident1,uniqueId ident1) `compare` (name ident2,uniqueId ident2)
-
-> instance Show Ident where
-> showsPrec _ (Ident x n)
-> | n == 0 = showString x
-> | otherwise = showString x . showChar '.' . shows n
-> showsPrec _ (IdentPosition _ x n)
-> | n == 0 = showString x
-> | otherwise = showString x . showChar '.' . shows n
-> instance Show QualIdent where
-> showsPrec _ (UnqualIdent x) = shows x
-> showsPrec _ (QualIdent m x) = shows m . showChar '.' . shows x
-> instance Show ModuleIdent where
-> showsPrec _ m = showString (moduleName m)
-
-> hasPositionIdent :: Ident -> Bool
-> hasPositionIdent (Ident _ _ ) = False
-> hasPositionIdent (IdentPosition _ _ _) = True
-
-> addPositionIdent :: Position -> Ident -> Ident
-> addPositionIdent pos (Ident x n) = IdentPosition pos x n
-> addPositionIdent AST{ast=sr} (IdentPosition pos x n) =
-> IdentPosition pos{ast=sr} x n
-> addPositionIdent pos (IdentPosition _ x n) =
-> IdentPosition pos x n
-
-> removePositionIdent :: Ident -> Ident
-> removePositionIdent (Ident x n) = (Ident x n)
-> removePositionIdent (IdentPosition _ x n) = (Ident x n)
-
-> positionOfIdent :: Ident -> Position
-> positionOfIdent (Ident _ _) = noPos
-> positionOfIdent (IdentPosition pos _ _) = pos
-
-> addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent
-> addPositionModuleIdent pos (ModuleIdent x) = ModuleIdentPosition pos x
-> addPositionModuleIdent pos (ModuleIdentPosition _ x) = ModuleIdentPosition pos x
-
-> removePositionModuleIdent :: ModuleIdent -> ModuleIdent
-> removePositionModuleIdent (ModuleIdent x) = (ModuleIdent x)
-> removePositionModuleIdent (ModuleIdentPosition _ x) = (ModuleIdent x)
-
-> positionOfModuleIdent :: ModuleIdent -> Position
-> positionOfModuleIdent (ModuleIdent _) = noPos
-> positionOfModuleIdent (ModuleIdentPosition pos _) = pos
-
-> positionOfQualIdent :: QualIdent -> Position
-> positionOfQualIdent = positionOfIdent . snd . splitQualIdent
-
-> mkIdent :: String -> Ident
-> mkIdent x = Ident x 0
-
-> name :: Ident -> String
-> name (Ident x _) = x
-> name (IdentPosition _ x _) = x
-
-> qualName :: QualIdent -> String
-> qualName (UnqualIdent x) = name x
-> qualName (QualIdent m x) = moduleName m ++ "." ++ name x
-
-> uniqueId :: Ident -> Int
-> uniqueId (Ident _ n) = n
-> uniqueId (IdentPosition _ _ n) = n
-
-> renameIdent :: Ident -> Int -> Ident
-> renameIdent (Ident x _) n = Ident x n
-> renameIdent (IdentPosition p x _) n = IdentPosition p x n
-
-> unRenameIdent :: Ident -> Ident
-> unRenameIdent (Ident x _) = Ident x 0
-> unRenameIdent (IdentPosition p x _) = IdentPosition p x 0
-
-> mkMIdent :: [String] -> ModuleIdent
-> mkMIdent = ModuleIdent
-
-> moduleName :: ModuleIdent -> String
-> moduleName (ModuleIdent xs) = concat (intersperse "." xs)
-> moduleName (ModuleIdentPosition _ xs) = concat (intersperse "." xs)
-
-> moduleQualifiers :: ModuleIdent -> [String]
-> moduleQualifiers (ModuleIdent xs) = xs
-> moduleQualifiers (ModuleIdentPosition _ xs) = xs
-
-> isInfixOp :: Ident -> Bool
-> isInfixOp (Ident ('<':c:cs) _)=
-> last (c:cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["
-> isInfixOp (Ident (c:_) _) = not (isAlphaNum c) && c `notElem` "_(["
-> isInfixOp (Ident _ _) = False -- error "Zero-length identifier"
-> isInfixOp x@(IdentPosition _ _ _) = isInfixOp $ removePositionIdent x
-
-> isQInfixOp :: QualIdent -> Bool
-> isQInfixOp (UnqualIdent x) = isInfixOp x
-> isQInfixOp (QualIdent _ x) = isInfixOp x
-
-\end{verbatim}
-The functions \texttt{qualify} and \texttt{qualifyWith} convert an
-unqualified identifier into a qualified identifier (without and with a
-given module prefix, respectively).
-\begin{verbatim}
-
-> qualify :: Ident -> QualIdent
-> qualify = UnqualIdent
-
-> qualifyWith :: ModuleIdent -> Ident -> QualIdent
-> qualifyWith = QualIdent
-
-> qualQualify :: ModuleIdent -> QualIdent -> QualIdent
-> qualQualify m (UnqualIdent x) = QualIdent m x
-> qualQualify _ x = x
-
-> isQualified :: QualIdent -> Bool
-> isQualified (UnqualIdent _) = False
-> isQualified (QualIdent _ _) = True
-
-> unqualify :: QualIdent -> Ident
-> unqualify (UnqualIdent x) = x
-> unqualify (QualIdent _ x) = x
-
-> qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent
-> qualUnqualify m (UnqualIdent x) = UnqualIdent x
-> qualUnqualify m (QualIdent m' x)
-> | m == m' = UnqualIdent x
-> | otherwise = QualIdent m' x
-
-> localIdent :: ModuleIdent -> QualIdent -> Maybe Ident
-> localIdent _ (UnqualIdent x) = Just x
-> localIdent m (QualIdent m' x)
-> | m == m' = Just x
-> | otherwise = Nothing
-
-> splitQualIdent :: QualIdent -> (Maybe ModuleIdent,Ident)
-> splitQualIdent (UnqualIdent x) = (Nothing,x)
-> splitQualIdent (QualIdent m x) = (Just m,x)
-
-> updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident) -> QualIdent -> QualIdent
-> updQualIdent _ g (UnqualIdent x) = UnqualIdent (g x)
-> updQualIdent f g (QualIdent m x) = QualIdent (f m) (g x)
-
-> addRef :: SrcRef -> QualIdent -> QualIdent
-> addRef r = updQualIdent id (addRefId r)
-
-> addRefId :: SrcRef -> Ident -> Ident
-> addRefId r = addPositionIdent (AST r)
-
-\end{verbatim}
-A few identifiers a predefined here.
-\begin{verbatim}
-
-> emptyMIdent, mainMIdent, preludeMIdent :: ModuleIdent
-> emptyMIdent = ModuleIdent []
-> mainMIdent = ModuleIdent ["main"]
-> preludeMIdent = ModuleIdent ["Prelude"]
-
-> anonId :: Ident
-> anonId = Ident "_" 0
-
-> unitPId :: Position -> Ident
-> unitPId p = IdentPosition p "()" 0
-
-> unitId, boolId, charId, intId, floatId, listId, ioId, successId :: Ident
-> unitId = Ident "()" 0
-> boolId = Ident "Bool" 0
-> charId = Ident "Char" 0
-> intId = Ident "Int" 0
-> floatId = Ident "Float" 0
-> listId = Ident "[]" 0
-> ioId = Ident "IO" 0
-> successId = Ident "Success" 0
-
-> trueId, falseId, nilId, consId :: Ident
-> trueId = Ident "True" 0
-> falseId = Ident "False" 0
-> nilId = Ident "[]" 0
-> consId = Ident ":" 0
-
-> tupleId :: Int -> Ident
-> tupleId n
-> | n >= 2 = Ident ("(" ++ replicate (n - 1) ',' ++ ")") 0
-> | otherwise = error "internal error: tupleId"
-
-> isTupleId :: Ident -> Bool
-> isTupleId x = n > 1 && x == tupleId n
-> where n = length (name x) - 1
-
-> tupleArity :: Ident -> Int
-> tupleArity x
-> | n > 1 && x == tupleId n = n
-> | otherwise = error "internal error: tupleArity"
-> where n = length (name x) - 1
-
-> mainId, minusId, fminusId :: Ident
-> mainId = Ident "main" 0
-> minusId = Ident "-" 0
-> fminusId = Ident "-." 0
-
-> qUnitId, qNilId, qConsId, qListId :: QualIdent
-> qUnitId = UnqualIdent unitId
-> qListId = UnqualIdent listId
-> qNilId = UnqualIdent nilId
-> qConsId = UnqualIdent consId
-
-> qBoolId, qCharId, qIntId, qFloatId, qSuccessId, qIOId :: QualIdent
-> qBoolId = QualIdent preludeMIdent boolId
-> qCharId = QualIdent preludeMIdent charId
-> qIntId = QualIdent preludeMIdent intId
-> qFloatId = QualIdent preludeMIdent floatId
-> qSuccessId = QualIdent preludeMIdent successId
-> qIOId = QualIdent preludeMIdent ioId
-
-> qTrueId, qFalseId :: QualIdent
-> qTrueId = QualIdent preludeMIdent trueId
-> qFalseId = QualIdent preludeMIdent falseId
-
-> qTupleId :: Int -> QualIdent
-> qTupleId = UnqualIdent . tupleId
-
-> isQTupleId :: QualIdent -> Bool
-> isQTupleId = isTupleId . unqualify
-
-> qTupleArity :: QualIdent -> Int
-> qTupleArity = tupleArity . unqualify
-
-\end{verbatim}
-Micellaneous function for generating and testing extended identifiers.
-\begin{verbatim}
-
-> fpSelectorId :: Int -> Ident
-> fpSelectorId n = Ident (fpSelExt ++ show n) 0
-
-> isFpSelectorId :: Ident -> Bool
-> isFpSelectorId f = any (fpSelExt `isPrefixOf`) (tails (name f))
-
-> isQualFpSelectorId :: QualIdent -> Bool
-> isQualFpSelectorId = isFpSelectorId . unqualify
-
-> recSelectorId :: QualIdent -> Ident -> Ident
-> recSelectorId r l =
-> mkIdent (recSelExt ++ name (unqualify r) ++ "." ++ name l)
-
-> qualRecSelectorId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
-> qualRecSelectorId m r l = qualifyWith m' (recSelectorId r l)
-> where m' = (fromMaybe m (fst (splitQualIdent r)))
-
-> recUpdateId :: QualIdent -> Ident -> Ident
-> recUpdateId r l =
-> mkIdent (recUpdExt ++ name (unqualify r) ++ "." ++ name l)
-
-> qualRecUpdateId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
-> qualRecUpdateId m r l = qualifyWith m' (recUpdateId r l)
-> where m' = (fromMaybe m (fst (splitQualIdent r)))
-
-> recordExtId :: Ident -> Ident
-> recordExtId r = mkIdent (recordExt ++ name r)
-
-> labelExtId :: Ident -> Ident
-> labelExtId l = mkIdent (labelExt ++ name l)
-
-> fromRecordExtId :: Ident -> Ident
-> fromRecordExtId r
-> | p == recordExt = mkIdent r'
-> | otherwise = r
-> where (p,r') = splitAt (length recordExt) (name r)
-
-> fromLabelExtId :: Ident -> Ident
-> fromLabelExtId l
-> | p == labelExt = mkIdent l'
-> | otherwise = l
-> where (p,l') = splitAt (length labelExt) (name l)
-
-> isRecordExtId :: Ident -> Bool
-> isRecordExtId r = recordExt `isPrefixOf` name r
-
-> isLabelExtId :: Ident -> Bool
-> isLabelExtId l = labelExt `isPrefixOf` name l
-
-> mkLabelIdent :: String -> Ident
-> mkLabelIdent c = renameIdent (mkIdent c) (-1)
-
-> renameLabel :: Ident -> Ident
-> renameLabel l = renameIdent l (-1)
-
-> isLabel :: Ident -> Bool
-> isLabel l = uniqueId l == (-1)
-
-
-> fpSelExt = "_#selFP"
-> recSelExt = "_#selR@"
-> recUpdExt = "_#updR@"
-> recordExt = "_#Rec:"
-> labelExt = "_#Lab:"
-
-> showsString :: String -> ShowS
-> showsString = (++)
-
-> space :: ShowS
-> space = showsString " "
-
-> showsIdent :: Ident -> ShowS
-> showsIdent x@(IdentPosition _ _ _) = showsIdent $ removePositionIdent x
-> showsIdent (Ident name n)
-> = showsString "(Ident " . shows name . space . shows n . showsString ")"
-
-> showsQualIdent :: QualIdent -> ShowS
-> showsQualIdent (UnqualIdent ident)
-> = showsString "(UnqualIdent " . showsIdent ident . showsString ")"
-> showsQualIdent (QualIdent mident ident)
-> = showsString "(QualIdent "
-> . showsModuleIdent mident . space
-> . showsIdent ident
-> . showsString ")"
-
-> showsModuleIdent :: ModuleIdent -> ShowS
-> showsModuleIdent = shows . moduleName
-
-showsModuleIdent x@(ModuleIdentPosition _ _) =
- showsModuleIdent $ removePositionModuleIdent x
-showsModuleIdent (ModuleIdent []) = showsString "(ModuleIdent [])"
-showsModuleIdent (ModuleIdent (s:strs))
- = showsString "(ModuleIdent ["
- . foldl (\sys y -> sys . showsString "," . shows y) (shows s) strs
- . showsString "])"
-
-\end{verbatim}
-
-> instance SrcRefOf Ident where srcRefOf = srcRefOf . positionOfIdent
-> instance SrcRefOf QualIdent where srcRefOf = srcRefOf . unqualify
-
-> updIdentName :: (String -> String) -> Ident -> Ident
-> updIdentName f ident = let p=positionOfIdent ident
-> i=uniqueId ident
-> n=name ident in
-> addPositionIdent p $ flip renameIdent i $ mkIdent (f n)
diff --git a/src/Imports.lhs b/src/Imports.lhs
--- a/src/Imports.lhs
+++ b/src/Imports.lhs
@@ -16,8 +16,11 @@
> import qualified Data.Set as Set
> import qualified Data.Map as Map
+> import Curry.Syntax
+> import Types
+> import Curry.Base.Position
+> import Curry.Base.Ident
> import Base
-> import Env
> import TopEnv
@@ -31,10 +34,10 @@
The same is true for type expressions.
\begin{verbatim}
-> type ExpPEnv = Env Ident PrecInfo
-> type ExpTCEnv = Env Ident TypeInfo
-> type ExpValueEnv = Env Ident ValueInfo
-> type ExpArityEnv = Env Ident ArityInfo
+> type ExpPEnv = Map.Map Ident PrecInfo
+> type ExpTCEnv = Map.Map Ident TypeInfo
+> type ExpValueEnv = Map.Map Ident ValueInfo
+> type ExpArityEnv = Map.Map Ident ArityInfo
\end{verbatim}
When an interface is imported, the compiler first transforms the
@@ -69,10 +72,10 @@
> isVisible _ _ = const True
> importEntities :: Entity a => ModuleIdent -> Bool -> (Ident -> Bool)
-> -> (a -> a) -> Env Ident a -> TopEnv a -> TopEnv a
+> -> (a -> a) -> Map.Map Ident a -> TopEnv a -> TopEnv a
> importEntities m q isVisible f mEnv env =
> foldr (uncurry (if q then qualImportTopEnv m else importUnqual m)) env
-> [(x,f y) | (x,y) <- envToList mEnv, isVisible x]
+> [(x,f y) | (x,y) <- Map.toList mEnv, isVisible x]
> where importUnqual m x y = importTopEnv m x y . qualImportTopEnv m x y
> importData :: (Ident -> Bool) -> TypeInfo -> TypeInfo
@@ -111,18 +114,18 @@
module name.
\begin{verbatim}
-> intfEnv :: (ModuleIdent -> IDecl -> Env Ident a -> Env Ident a)
-> -> Interface -> Env Ident a
-> intfEnv bind (Interface m ds) = foldr (bind m) emptyEnv ds
+> intfEnv :: (ModuleIdent -> IDecl -> Map.Map Ident a -> Map.Map Ident a)
+> -> Interface -> Map.Map Ident a
+> intfEnv bind (Interface m ds) = foldr (bind m) Map.empty ds
> bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv
> bindPrec m (IInfixDecl _ fix p op) =
-> bindEnv (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p))
+> Map.insert (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p))
> bindPrec _ _ = id
> bindTC :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
> bindTC m (IDataDecl _ tc tvs cs) mTCEnv
-> | isJust (lookupEnv (unqualify tc) mTCEnv) =
+> | isJust (Map.lookup (unqualify tc) mTCEnv) =
> mTCEnv
> | otherwise =
> bindType DataType m tc tvs (map (fmap mkData) cs) mTCEnv
@@ -150,7 +153,7 @@
> bindType :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent -> QualIdent
> -> [Ident] -> a -> ExpTCEnv -> ExpTCEnv
> bindType f m tc tvs =
-> bindEnv (unqualify tc) . f (qualQualify m tc) (length tvs)
+> Map.insert (unqualify tc) . f (qualQualify m tc) (length tvs)
> bindTy :: ModuleIdent -> IDecl -> ExpValueEnv -> ExpValueEnv
> bindTy m (IDataDecl _ tc tvs cs) =
@@ -163,7 +166,7 @@
> -- flip (foldr (bindRecLabel m r')) fs
> -- where r' = qualifyWith m (fromRecordExtId (unqualify r))
> bindTy m (IFunctionDecl _ f _ ty) =
-> bindEnv (unqualify f)
+> Map.insert (unqualify f)
> (Value (qualQualify m f) (polyType (toQualType m [] ty)))
> bindTy m _ = id
@@ -183,27 +186,27 @@
> --bindRecLabel :: ModuleIdent -> QualIdent -> ([Ident],TypeExpr)
> -- -> ExpValueEnv -> ExpValueEnv
> --bindRecLabel m r ([l],ty) =
-> -- bindEnv l (Label (qualify l) r (polyType (toQualType m [] ty)))
+> -- Map.insert l (Label (qualify l) r (polyType (toQualType m [] ty)))
> bindValue :: (QualIdent -> ExistTypeScheme -> ValueInfo) -> ModuleIdent
> -> QualIdent -> [Ident] -> Ident -> [Ident] -> TypeExpr
> -> ExpValueEnv -> ExpValueEnv
-> bindValue f m tc tvs c evs ty = bindEnv c (f (qualifyLike tc c) sigma)
+> bindValue f m tc tvs c evs ty = Map.insert c (f (qualifyLike tc c) sigma)
> where sigma = ForAllExist (length tvs) (length evs) (toQualType m tvs ty)
-> qualifyLike x = maybe qualify qualifyWith (fst (splitQualIdent x))
+> qualifyLike x = maybe qualify qualifyWith (qualidMod x)
> bindA :: ModuleIdent -> IDecl -> ExpArityEnv -> ExpArityEnv
> bindA m (IDataDecl _ _ _ cs) expAEnv
> = foldr (bindConstrA m) expAEnv (catMaybes cs)
> bindA m (IFunctionDecl _ f a _) expAEnv
-> = bindEnv (unqualify f) (ArityInfo (qualQualify m f) a) expAEnv
+> = Map.insert (unqualify f) (ArityInfo (qualQualify m f) a) expAEnv
> bindA _ _ expAEnv = expAEnv
> bindConstrA :: ModuleIdent -> ConstrDecl -> ExpArityEnv -> ExpArityEnv
> bindConstrA m (ConstrDecl _ _ c tys) expAEnv
-> = bindEnv c (ArityInfo (qualifyWith m c) (length tys)) expAEnv
+> = Map.insert c (ArityInfo (qualifyWith m c) (length tys)) expAEnv
> bindConstrA m (ConOpDecl _ _ _ c _) expAEnv
-> = bindEnv c (ArityInfo (qualifyWith m c) 2) expAEnv
+> = Map.insert c (ArityInfo (qualifyWith m c) 2) expAEnv
\end{verbatim}
After the environments have been initialized, the optional import
@@ -262,14 +265,14 @@
> expandThing :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident
> -> [Import]
> expandThing m tcEnv tyEnv tc =
-> case lookupEnv tc tcEnv of
+> case Map.lookup tc tcEnv of
> Just _ -> expandThing' m tyEnv tc (Just [ImportTypeWith tc []])
> Nothing -> expandThing' m tyEnv tc Nothing
> expandThing' :: ModuleIdent -> ExpValueEnv -> Ident
> -> Maybe [Import] -> [Import]
> expandThing' m tyEnv f tcImport =
-> case lookupEnv f tyEnv of
+> case Map.lookup f tyEnv of
> Just v
> | isConstr v -> maybe (errorAt' (importDataConstr m f)) id tcImport
> | otherwise -> Import f : maybe [] id tcImport
@@ -281,21 +284,21 @@
> expandHide :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident
> -> [Import]
> expandHide m tcEnv tyEnv tc =
-> case lookupEnv tc tcEnv of
+> case Map.lookup tc tcEnv of
> Just _ -> expandHide' m tyEnv tc (Just [ImportTypeWith tc []])
> Nothing -> expandHide' m tyEnv tc Nothing
> expandHide' :: ModuleIdent -> ExpValueEnv -> Ident
> -> Maybe [Import] -> [Import]
> expandHide' m tyEnv f tcImport =
-> case lookupEnv f tyEnv of
+> case Map.lookup f tyEnv of
> Just _ -> Import f : maybe [] id tcImport
> Nothing -> maybe (errorAt' (undefinedEntity m f)) id tcImport
> expandTypeWith :: ModuleIdent -> ExpTCEnv -> Ident -> [Ident]
> -> Import
> expandTypeWith m tcEnv tc cs =
-> case lookupEnv tc tcEnv of
+> case Map.lookup tc tcEnv of
> Just (DataType _ _ cs') ->
> ImportTypeWith tc (map (checkConstr [c | Just (Data c _ _) <- cs']) cs)
> Just (RenamingType _ _ (Data c _ _)) ->
@@ -308,7 +311,7 @@
> expandTypeAll :: ModuleIdent -> ExpTCEnv -> Ident -> Import
> expandTypeAll m tcEnv tc =
-> case lookupEnv tc tcEnv of
+> case Map.lookup tc tcEnv of
> Just (DataType _ _ cs) -> ImportTypeWith tc [c | Just (Data c _ _) <- cs]
> Just (RenamingType _ _ (Data c _ _)) -> ImportTypeWith tc [c]
> Just _ -> errorAt' (nonDataType m tc)
@@ -357,11 +360,6 @@
> undefinedEntity m x =
> (positionOfIdent x,
> "Module " ++ moduleName m ++ " does not export " ++ name x)
-
-> undefinedType :: ModuleIdent -> Ident -> (Position,String)
-> undefinedType m tc =
-> (positionOfIdent tc,
-> "Module " ++ moduleName m ++ " does not export a type " ++ name tc)
> undefinedDataConstr :: ModuleIdent -> Ident -> Ident -> (Position,String)
> undefinedDataConstr m tc c =
diff --git a/src/InterfaceCheck.hs b/src/InterfaceCheck.hs
--- a/src/InterfaceCheck.hs
+++ b/src/InterfaceCheck.hs
@@ -11,7 +11,7 @@
import Data.List
-import ExtendedFlat
+import Curry.ExtendedFlat
diff --git a/src/KindCheck.lhs b/src/KindCheck.lhs
--- a/src/KindCheck.lhs
+++ b/src/KindCheck.lhs
@@ -23,10 +23,13 @@
is defined more than once.
\begin{verbatim}
-> module KindCheck(kindCheck,kindCheckGoal) where
+> module KindCheck(kindCheck) where
> import Data.Maybe
+> import Curry.Syntax
+> import Curry.Base.Position
+> import Curry.Base.Ident
> import Base hiding (bindArity)
> import TopEnv
@@ -44,16 +47,10 @@
> kindCheck m tcEnv ds =
> case linear (map tconstr ds') of
> Linear -> map (checkDecl m kEnv) ds
-> NonLinear (PIdent p tc) -> errorAt' (duplicateType tc)
+> NonLinear tc -> errorAt' (duplicateType tc)
> where ds' = filter isTypeDecl ds
> kEnv = foldr (bindArity m) (fmap tcArity tcEnv) ds'
-> kindCheckGoal :: TCEnv -> Goal -> Goal
-> kindCheckGoal tcEnv (Goal p e ds) =
-> Goal p (checkExpr m kEnv e) (map (checkDecl m kEnv) ds)
-> where kEnv = fmap tcArity tcEnv
-> m = mkMIdent []
-
\end{verbatim}
The kind environment only needs to record the arity of each type constructor.
\begin{verbatim}
@@ -113,7 +110,7 @@
> | tv `elem` tvs = errorAt' (nonLinear tv)
> | otherwise = tv : checkTypeLhs kEnv tvs
> where isTypeConstr tv = not (null (lookupKind tv kEnv))
-> checkTypeLhs kEnv [] = []
+> checkTypeLhs _ [] = []
> checkConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> ConstrDecl -> ConstrDecl
> checkConstrDecl m kEnv tvs (ConstrDecl p evs c tys) =
@@ -268,10 +265,10 @@
Auxiliary definitions
\begin{verbatim}
-> tconstr :: Decl -> PIdent
-> tconstr (DataDecl p tc _ _) = PIdent p tc
-> tconstr (NewtypeDecl p tc _ _) = PIdent p tc
-> tconstr (TypeDecl p tc _ _) = PIdent p tc
+> tconstr :: Decl -> Ident
+> tconstr (DataDecl p tc _ _) = tc
+> tconstr (NewtypeDecl p tc _ _) = tc
+> tconstr (TypeDecl p tc _ _) = tc
> tconstr _ = internalError "tconstr"
\end{verbatim}
diff --git a/src/LLParseComb.lhs b/src/LLParseComb.lhs
deleted file mode 100644
--- a/src/LLParseComb.lhs
+++ /dev/null
@@ -1,292 +0,0 @@
-% -*- LaTeX -*-
-% $Id: LLParseComb.lhs,v 1.26 2004/02/15 23:11:30 wlux Exp $
-%
-% Copyright (c) 1999-2004, Wolfgang Lux
-% See LICENSE for the full license.
-%
-\nwfilename{LLParseComb.lhs}
-\section{Parsing Combinators}\label{sec:ll-parsecomb}
-The parsing combinators implemented in the module \texttt{LLParseComb}
-are based on the LL(1) parsing combinators developed by Swierstra and
-Duponcheel~\cite{SwierstraDuponcheel96:Parsers}. They have been
-adapted to using continuation passing style in order to work with the
-lexing combinators described in the previous section. In addition, the
-facilities for error correction are omitted in this implementation.
-
-The two functions \texttt{applyParser} and \texttt{prefixParser} use
-the specified parser for parsing a string. When \texttt{applyParser}
-is used, an error is reported if the parser does not consume the whole
-string, whereas \texttt{prefixParser} discards the rest of the input
-string in this case.
-\begin{verbatim}
-
-> module LLParseComb(Symbol(..),Parser,
-> applyParser,prefixParser, position,succeed,symbol,
-> (),(<|>),(<|?>),(<*>),(<\>),(<\\>),
-> opt,(<$>),(<$->),(<*->),(<-*>),(<**>),(),(<.>),
-> many,many1, sepBy,sepBy1, chainr,chainr1,chainl,chainl1,
-> bracket,ops, layoutOn,layoutOff,layoutEnd) where
-
-> import Control.Monad
-> import Data.Maybe
-> import qualified Data.Set as Set
-> import qualified Data.Map as Map
-
-
-> import Position
-
-
-> import Error
-> import LexComb
-
-> infixl 5 <\>, <\\>
-> infixl 4 <*>, <$>, <$->, <*->, <-*>, <**>, , <.>
-> infixl 3 <|>, <|?>
-> infixl 2 , `opt`
-
-\end{verbatim}
-\paragraph{Parser types}
-\begin{verbatim}
-
-> class (Ord s,Show s) => Symbol s where
-> isEOF :: s -> Bool
-
-> type Empty = Bool
-> type SuccessCont s a = Position -> s -> P a
-> type FailureCont a = Position -> String -> P a
-> type Lexer s a = SuccessCont s a -> FailureCont a -> P a
-> type ParseFun s a b = (a -> SuccessCont s b) -> FailureCont b
-> -> SuccessCont s b
-
-> data Parser s a b = Parser (Maybe (ParseFun s a b))
-> (Map.Map s (Lexer s b -> ParseFun s a b))
-
-> instance Symbol s => Show (Parser s a b) where
-> showsPrec p (Parser e ps) = showParen (p >= 10) $ -- $
-> showString "Parser " . shows (isJust e) .
-> showChar ' ' . shows (Map.keysSet ps)
-
-> applyParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String
-> -> Error a
-> applyParser p lexer = parse (lexer (choose p lexer done failP) failP)
-> where done x pos s
-> | isEOF s = returnP x
-> | otherwise = failP pos (unexpected s)
-
-> prefixParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String
-> -> Error a
-> prefixParser p lexer = parse (lexer (choose p lexer discard failP) failP)
-> where discard x _ _ = returnP x
-
-> choose :: Symbol s => Parser s a b -> Lexer s b -> ParseFun s a b
-> choose (Parser e ps) lexer success fail pos s =
-> case Map.lookup s ps of
-> Just p -> p lexer success fail pos s
-> Nothing ->
-> case e of
-> Just p -> p success fail pos s
-> Nothing -> fail pos (unexpected s)
-
-> unexpected :: Symbol s => s -> String
-> unexpected s
-> | isEOF s = "Unexpected end-of-file"
-> | otherwise = "Unexpected token " ++ show s
-
-\end{verbatim}
-\paragraph{Basic combinators}
-\begin{verbatim}
-
-> position :: Symbol s => Parser s Position b
-> position = Parser (Just p) Map.empty
-> where p success _ pos = success pos pos
-
-> succeed :: Symbol s => a -> Parser s a b
-> succeed x = Parser (Just p) Map.empty
-> where p success _ = success x
-
-> symbol :: Symbol s => s -> Parser s s a
-> symbol s = Parser Nothing (Map.singleton s p)
-> where p lexer success fail pos s = lexer (success s) fail
-
-> () :: Symbol s => Parser s a b -> String -> Parser s a b
-> p msg = p <|> Parser (Just pfail) Map.empty
-> where pfail _ fail pos _ = fail pos msg
-
-> (<|>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b
-> Parser e1 ps1 <|> Parser e2 ps2
-> | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"
-> | not (Set.null common) = error ("Ambiguous parser for " ++ show common)
-> | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2)
-> where common = Map.keysSet ps1 `Set.intersection` Map.keysSet ps2
-
-\end{verbatim}
-The parsing combinators presented so far require that the grammar
-being parsed is LL(1). In some cases it may be difficult or even
-impossible to transform a grammar into LL(1) form. As a remedy, we
-include a non-deterministic version of the choice combinator in
-addition to the deterministic combinator adapted from the paper. For
-every symbol from the intersection of the parser's first sets, the
-combinator \texttt{(<|?>)} applies both parsing functions to the input
-stream and uses that one which processes the longer prefix of the
-input stream irrespective of whether it succeeds or fails. If both
-functions recognize the same prefix, we choose the one that succeeds
-and report an ambiguous parse error if both succeed.
-\begin{verbatim}
-
-> (<|?>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b
-> Parser e1 ps1 <|?> Parser e2 ps2
-> | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"
-> | otherwise = Parser (e1 `mplus` e2) (Map.union ps1' ps2)
-> where ps1' = Map.fromList [(s,maybe p (try p) (Map.lookup s ps2))
-> | (s,p) <- Map.toList ps1]
-> try p1 p2 lexer success fail pos s =
-> closeP1 p2s `thenP` \p2s' ->
-> closeP1 p2f `thenP` \p2f' ->
-> parse p1 (retry p2s') (retry p2f')
-> where p2s r1 = parse p2 (select True r1) (select False r1)
-> p2f r1 = parse p2 (flip (select False) r1) (select False r1)
-> parse p psucc pfail =
-> p lexer (successK psucc) (failK pfail) pos s
-> successK k x pos s = k (pos,success x pos s)
-> failK k pos msg = k (pos,fail pos msg)
-> retry k (pos,p) = closeP0 p `thenP` curry k pos
-> select suc (pos1,p1) (pos2,p2) =
-> case pos1 `compare` pos2 of
-> GT -> p1
-> EQ
-> | suc -> error ("Ambiguous parse before " ++ show pos1)
-> | otherwise -> p1
-> LT -> p2
-
-> (<*>) :: Symbol s => Parser s (a -> b) c -> Parser s a c -> Parser s b c
-> Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) =
-> Parser (fmap (seqEE p1) e2)
-> (Map.union (fmap (flip seqPP p2) ps1) (fmap (seqEP p1) ps2))
-> Parser Nothing ps1 <*> p2 = Parser Nothing (fmap (flip seqPP p2) ps1)
-
-> seqEE :: Symbol s => ParseFun s (a -> b) c -> ParseFun s a c
-> -> ParseFun s b c
-> seqEE p1 p2 success fail = p1 (\f -> p2 (success . f) fail) fail
-
-> seqEP :: Symbol s => ParseFun s (a -> b) c -> (Lexer s c -> ParseFun s a c)
-> -> Lexer s c -> ParseFun s b c
-> seqEP p1 p2 lexer success fail = p1 (\f -> p2 lexer (success . f) fail) fail
-
-> seqPP :: Symbol s => (Lexer s c -> ParseFun s (a -> b) c) -> Parser s a c
-> -> Lexer s c -> ParseFun s b c
-> seqPP p1 p2 lexer success fail =
-> p1 lexer (\f -> choose p2 lexer (success . f) fail) fail
-
-\end{verbatim}
-The combinators \verb|<\\>| and \verb|<\>| can be used to restrict
-the first set of a parser. This is useful for combining two parsers
-with an overlapping first set with the deterministic combinator <|>.
-\begin{verbatim}
-
-> (<\>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c
-> p <\> Parser _ ps = p <\\> Map.keys ps
-
-> (<\\>) :: Symbol s => Parser s a b -> [s] -> Parser s a b
-> Parser e ps <\\> xs = Parser e (foldr Map.delete ps xs)
-
-\end{verbatim}
-\paragraph{Other combinators.}
-Note that some of these combinators have not been published in the
-paper, but were taken from the implementation found on the web.
-\begin{verbatim}
-
-> opt :: Symbol s => Parser s a b -> a -> Parser s a b
-> p `opt` x = p <|> succeed x
-
-> (<$>) :: Symbol s => (a -> b) -> Parser s a c -> Parser s b c
-> f <$> p = succeed f <*> p
-
-> (<$->) :: Symbol s => a -> Parser s b c -> Parser s a c
-> f <$-> p = const f <$> p {-$-}
-
-> (<*->) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c
-> p <*-> q = const <$> p <*> q {-$-}
-
-> (<-*>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s b c
-> p <-*> q = const id <$> p <*> q {-$-}
-
-> (<**>) :: Symbol s => Parser s a c -> Parser s (a -> b) c -> Parser s b c
-> p <**> q = flip ($) <$> p <*> q
-
-> () :: Symbol s => Parser s a b -> Parser s (a -> a) b -> Parser s a b
-> p q = p <**> (q `opt` id)
-
-> (<.>) :: Symbol s => Parser s (a -> b) d -> Parser s (b -> c) d
-> -> Parser s (a -> c) d
-> p1 <.> p2 = p1 <**> ((.) <$> p2)
-
-> many :: Symbol s => Parser s a b -> Parser s [a] b
-> many p = many1 p `opt` []
-
-> many1 :: Symbol s => Parser s a b -> Parser s [a] b
-> -- many1 p = (:) <$> p <*> many p
-> many1 p = (:) <$> p <*> (many1 p `opt` [])
-
-\end{verbatim}
-The first definition of \texttt{many1} is commented out because it
-does not compile under nhc. This is due to a -- known -- bug in the
-type checker of nhc which expects a default declaration when compiling
-mutually recursive functions with class constraints. However, no such
-default can be given in the above case because neither of the types
-involved is a numeric type.
-\begin{verbatim}
-
-> sepBy :: Symbol s => Parser s a c -> Parser s b c -> Parser s [a] c
-> p `sepBy` q = p `sepBy1` q `opt` []
-
-> sepBy1 :: Symbol s => Parser s a c -> Parser s b c -> Parser s [a] c
-> p `sepBy1` q = (:) <$> p <*> many (q <-*> p) {-$-}
-
-> chainr :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a
-> -> Parser s a b
-> chainr p op x = chainr1 p op `opt` x
-
-> chainr1 :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b
-> -> Parser s a b
-> chainr1 p op = r
-> where r = p <**> (flip <$> op <*> r `opt` id) {-$-}
-
-> chainl :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a
-> -> Parser s a b
-> chainl p op x = chainl1 p op `opt` x
-
-> chainl1 :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b
-> -> Parser s a b
-> chainl1 p op = foldF <$> p <*> many (flip <$> op <*> p)
-> where foldF x [] = x
-> foldF x (f:fs) = foldF (f x) fs
-
-> bracket :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c
-> -> Parser s b c
-> bracket open p close = open <-*> p <*-> close
-
-> ops :: Symbol s => [(s,a)] -> Parser s a b
-> ops [] = error "internal error: ops"
-> ops [(s,x)] = x <$-> symbol s
-> ops ((s,x):rest) = x <$-> symbol s <|> ops rest
-
-\end{verbatim}
-\paragraph{Layout combinators}
-Note that the layout functions grab the next token (and its position).
-After modifying the layout context, the continuation is called with
-the same token and an undefined result.
-\begin{verbatim}
-
-> layoutOn :: Symbol s => Parser s a b
-> layoutOn = Parser (Just on) Map.empty
-> where on success _ pos = pushContext (column pos) . success undefined pos
-
-> layoutOff :: Symbol s => Parser s a b
-> layoutOff = Parser (Just off) Map.empty
-> where off success _ pos = pushContext (-1) . success undefined pos
-
-> layoutEnd :: Symbol s => Parser s a b
-> layoutEnd = Parser (Just end) Map.empty
-> where end success _ pos = popContext . success undefined pos
-
-\end{verbatim}
diff --git a/src/LexComb.lhs b/src/LexComb.lhs
deleted file mode 100644
--- a/src/LexComb.lhs
+++ /dev/null
@@ -1,102 +0,0 @@
-% -*- LaTeX -*-
-% $Id: LexComb.lhs,v 1.16 2004/01/20 16:44:14 wlux Exp $
-%
-% Copyright (c) 1999-2004, Wolfgang Lux
-% See LICENSE for the full license.
-%
-\nwfilename{LexComb.lhs}
-\section{Lexing combinators}
-The module \texttt{LexComb} provides the basic types and combinators
-to implement the lexers. The combinators use continuation passing code
-in a monadic style. The first argument of the continuation function is
-the string to be parsed, the second is the current position, and the
-third is a flag which signals the lexer that it is lexing the
-beginning of a line and therefore has to check for layout tokens. The
-fourth argument is a stack of indentations that is used to handle
-nested layout groups.
-\begin{verbatim}
-
-> module LexComb where
-> import Position
-> import Error
-> import Data.Char
-
-> infixl 1 `thenP`, `thenP_`
-
-> type Indent = Int
-> type Context = [Indent]
-> type P a = Position -> String -> Bool -> Context -> Error a
-
-> parse :: P a -> FilePath -> String -> Error a
-> parse p fn s = p (first fn) s False []
-
-\end{verbatim}
-Monad functions for the lexer.
-\begin{verbatim}
-
-> returnP :: a -> P a
-> returnP x _ _ _ _ = Ok x
-
-> thenP :: P a -> (a -> P b) -> P b
-> thenP lex k pos s bol ctxt = lex pos s bol ctxt >>= \x -> k x pos s bol ctxt
-
-> thenP_ :: P a -> P b -> P b
-> p1 `thenP_` p2 = p1 `thenP` \_ -> p2
-
-> failP :: Position -> String -> P a
-> failP pos msg _ _ _ _ = Error (parseError pos msg)
-
-> closeP0 :: P a -> P (P a)
-> closeP0 lex pos s bol ctxt = Ok (\_ _ _ _ -> lex pos s bol ctxt)
-
-> closeP1 :: (a -> P b) -> P (a -> P b)
-> closeP1 f pos s bol ctxt = Ok (\x _ _ _ _ -> f x pos s bol ctxt)
-
-> parseError :: Position -> String -> String
-> parseError p what = "\n" ++ show p ++ ": " ++ what
-
-\end{verbatim}
-Combinators that handle layout.
-\begin{verbatim}
-
-> pushContext :: Int -> P a -> P a
-> pushContext col cont pos s bol ctxt = cont pos s bol (col:ctxt)
-
-> popContext :: P a -> P a
-> popContext cont pos s bol (_:ctxt) = cont pos s bol ctxt
-> popContext cont pos s bol [] =
-> error "parse error: popping layout from empty context stack. \
-> \Perhaps you have inserted too many '}'?"
-
-\end{verbatim}
-Conversions from strings into numbers.
-\begin{verbatim}
-
-> convertSignedIntegral :: Num a => a -> String -> a
-> convertSignedIntegral b ('+':s) = convertIntegral b s
-> convertSignedIntegral b ('-':s) = - convertIntegral b s
-> convertSignedIntegral b s = convertIntegral b s
-
-> convertIntegral :: Num a => a -> String -> a
-> convertIntegral b = foldl op 0
-> where m `op` n | isDigit n = b * m + fromIntegral (ord n - ord0)
-> | isUpper n = b * m + fromIntegral (ord n - ordA)
-> | otherwise = b * m + fromIntegral (ord n - orda)
-> ord0 = ord '0'
-> ordA = ord 'A' - 10
-> orda = ord 'a' - 10
-
-> convertSignedFloating :: Fractional a => String -> String -> Int -> a
-> convertSignedFloating ('+':m) f e = convertFloating m f e
-> convertSignedFloating ('-':m) f e = - convertFloating m f e
-> convertSignedFloating m f e = convertFloating m f e
-
-> convertFloating :: Fractional a => String -> String -> Int -> a
-> convertFloating m f e
-> | e' == 0 = m'
-> | e' > 0 = m' * 10^e'
-> | otherwise = m' / 10^(-e')
-> where m' = convertIntegral 10 (m ++ f)
-> e' = e - length f
-
-\end{verbatim}
diff --git a/src/Lift.lhs b/src/Lift.lhs
--- a/src/Lift.lhs
+++ b/src/Lift.lhs
@@ -20,23 +20,24 @@
> module Lift(lift) where
> import Control.Monad
+> import qualified Control.Monad.State as S
> import Data.List
+> import qualified Data.Map as Map
> import qualified Data.Set as Set
+> import Curry.Syntax
+> import Curry.Syntax.Utils
+> import Types
+> import Curry.Base.Ident
> import Base
-> import Env
> import TopEnv
-
-
-
-> import Combined
> import SCC
> lift :: ValueEnv -> EvalEnv -> Module -> (Module,ValueEnv,EvalEnv)
> lift tyEnv evEnv (Module m es ds) =
> (Module m es (concatMap liftFunDecl ds'),tyEnv',evEnv')
> where (ds',tyEnv',evEnv') =
-> runSt (callSt (abstractModule m ds) tyEnv) evEnv
+> S.evalState (S.evalStateT (abstractModule m ds) tyEnv) evEnv
\end{verbatim}
\paragraph{Abstraction}
@@ -49,16 +50,16 @@
i.e. the function applied to its free variables.
\begin{verbatim}
-> type AbstractState a = StateT ValueEnv (St EvalEnv) a
-> type AbstractEnv = Env Ident Expression
+> type AbstractState a = S.StateT ValueEnv (S.State EvalEnv) a
+> type AbstractEnv = Map.Map Ident Expression
> abstractModule :: ModuleIdent -> [Decl]
> -> AbstractState ([Decl],ValueEnv,EvalEnv)
> abstractModule m ds =
> do
-> ds' <- mapM (abstractDecl m "" [] emptyEnv) ds
-> tyEnv' <- fetchSt
-> evEnv' <- liftSt fetchSt
+> ds' <- mapM (abstractDecl m "" [] Map.empty) ds
+> tyEnv' <- S.get
+> evEnv' <- S.lift S.get
> return (ds',tyEnv',evEnv')
> abstractDecl :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Decl
@@ -149,9 +150,9 @@
> return (Let vds' e')
> abstractFunDecls m pre lvs env (fds:fdss) vds e =
> do
-> fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) fetchSt
-> updateSt_ (abstractFunTypes m pre fvs fs')
-> liftSt (updateSt_ (abstractFunAnnots m pre fs'))
+> fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) S.get
+> S.modify (abstractFunTypes m pre fvs fs')
+> S.lift (S.modify (abstractFunAnnots m pre fs'))
> fds' <- mapM (abstractFunDecl m pre fvs lvs env')
> [d | d <- fds, any (`elem` fs') (bv d)]
> e' <- abstractFunDecls m pre lvs env' fdss vds e
@@ -160,8 +161,8 @@
> fvs = filter (`elem` lvs) (Set.toList fvsRhs)
> env' = foldr (bindF (map mkVar fvs)) env fs
> fvsRhs = Set.unions
-> [Set.fromList (maybe [v] (qfv m) (lookupEnv v env)) | v <- qfv m fds]
-> bindF fvs f = bindEnv f (apply (mkFun m pre f) fvs)
+> [Set.fromList (maybe [v] (qfv m) (Map.lookup v env)) | v <- qfv m fds]
+> bindF fvs f = Map.insert f (apply (mkFun m pre f) fvs)
> isLifted tyEnv f = null (lookupValue f tyEnv)
> abstractFunTypes :: ModuleIdent -> String -> [Ident] -> [Ident]
@@ -176,8 +177,8 @@
> abstractFunAnnots :: ModuleIdent -> String -> [Ident] -> EvalEnv -> EvalEnv
> abstractFunAnnots m pre fs evEnv = foldr abstractFunAnnot evEnv fs
> where abstractFunAnnot f evEnv =
-> case lookupEnv f evEnv of
-> Just ev -> bindEnv (liftIdent pre f) ev (unbindEnv f evEnv)
+> case Map.lookup f evEnv of
+> Just ev -> Map.insert (liftIdent pre f) ev (Map.delete f evEnv)
> Nothing -> evEnv
> abstractFunDecl :: ModuleIdent -> String -> [Ident] -> [Ident]
@@ -196,7 +197,7 @@
> abstractExpr m pre lvs env (Variable v)
> | isQualified v = return (Variable v)
> | otherwise = maybe (return (Variable v)) (abstractExpr m pre lvs env)
-> (lookupEnv (unqualify v) env)
+> (Map.lookup (unqualify v) env)
> abstractExpr _ _ _ _ (Constructor c) = return (Constructor c)
> abstractExpr m pre lvs env (Apply e1 e2) =
> do
@@ -216,14 +217,6 @@
> abstractAlt m pre lvs env (Alt p t rhs) =
> liftM (Alt p t) (abstractRhs m pre (lvs ++ bv t) env rhs)
-> abstractCondExpr :: ModuleIdent -> String -> [Ident] -> AbstractEnv
-> -> CondExpr -> AbstractState CondExpr
-> abstractCondExpr m pre lvs env (CondExpr p g e) =
-> do
-> g' <- abstractExpr m pre lvs env g
-> e' <- abstractExpr m pre lvs env e
-> return (CondExpr p g' e')
-
\end{verbatim}
\paragraph{Lifting}
After the abstraction pass, all local function declarations are lifted
@@ -273,10 +266,6 @@
> liftAlt (Alt p t rhs) = (Alt p t rhs',ds')
> where (rhs',ds') = liftRhs rhs
-> liftCondExpr :: CondExpr -> (CondExpr,[Decl])
-> liftCondExpr (CondExpr p g e) = (CondExpr p g' e',ds' ++ ds'')
-> where (g',ds') = liftExpr g
-> (e',ds'') = liftExpr e
\end{verbatim}
\paragraph{Auxiliary definitions}
diff --git a/src/Message.hs b/src/Message.hs
deleted file mode 100644
--- a/src/Message.hs
+++ /dev/null
@@ -1,74 +0,0 @@
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
---
--- Message - A library for dealing with compiler messages
---
--- Note: This module overwrites the functions declared in "Message"
---
--- January 2006,
--- Martin Engelke (men@informatik.uni-kiel.de)
---
-module Message where
-
-import Position
-
-
--------------------------------------------------------------------------------
-
--- Type for representing compiler messages (currently errors and warnings)
-data Message = Message MessageType (Maybe Position) String
-
--- Data type for representing available compiler message types
-data MessageType = Warning WarningType | Error deriving Eq
-
--- the different warnings are categorized by WarningType
-data WarningType = UnrefTypeVar
- | UnrefVar
- | ShadowingVar
- | IdleCaseAlt
- | OverlapCase
- | OverlapRules
- | RulesNotTogether
- | MultipleImportModule
- | MultipleImportSymbol
- | MultipleHiding
- deriving Eq
-
--- An instance of Show for converting messages to readable strings
-instance Show Message where
- show (Message (Warning _) mpos msg) = showMessage "Warning" mpos msg
- show (Message Error mpos msg) = showMessage "ERROR" mpos msg
-
-
--------------------------------------------------------------------------------
-
---
-message :: MessageType -> Position -> String -> Message
-message mtype pos msg = Message mtype (Just pos) msg
-
---
-message_ :: MessageType -> String -> Message
-message_ mtype msg = Message mtype Nothing msg
-
---
-countMessages :: MessageType -> [Message] -> Int
-countMessages mtype msgs = length (filter (((==) mtype) . messageType) msgs)
-
---
-messageType :: Message -> MessageType
-messageType (Message mtype _ _) = mtype
-
-
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-
---
-showMessage :: String -> (Maybe Position) -> String -> String
-showMessage what mpos msg
- = what ++ ": " ++ pos ++ msg
- where
- pos = maybe "" (\p -> show p ++ ": ") mpos
-
-
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
diff --git a/src/Modules.lhs b/src/Modules.lhs
--- a/src/Modules.lhs
+++ b/src/Modules.lhs
@@ -15,54 +15,59 @@
import declarations are commented out
\begin{verbatim}
-> module Modules(compileModule, compileModule_,
+> module Modules(compileModule,
+> importPrelude, patchModuleId,
> loadInterfaces, transModule,
> simpleCheckModule, checkModule
> ) where
+
> import Data.List
+> import qualified Data.Map as Map
> import System.IO
> import Data.Maybe
> import Control.Monad
+> import Curry.Base.MessageMonad
+> import Curry.Base.Position
+> import Curry.Base.Ident
+> import Curry.Syntax
+> import Curry.Syntax.Pretty(ppModule,ppIDecl)
+> import Curry.Syntax.ShowModule(showModule)
+
> import Base
-> import Unlit(unlit)
-> import CurryParser(parseSource,parseGoal) -- xxxGoal entfernen
-> import ShowCurrySyntax(showModule)
-> import KindCheck(kindCheck,kindCheckGoal)
+> import Types
+> import KindCheck(kindCheck)
> import SyntaxCheck(syntaxCheck)
-> import PrecCheck(precCheck,precCheckGoal)
-> import TypeCheck(typeCheck,typeCheckGoal)
-> import WarnCheck
-> import Message
+> import PrecCheck(precCheck)
+> import TypeCheck(typeCheck)
+> import WarnCheck(warnCheck)
> import Arity
> import Imports(importInterface,importInterfaceIntf,importUnifyData)
> import Exports(expandInterface,exportInterface)
-> import Eval(evalEnv,evalEnvGoal)
-> import Qual(qual,qualGoal)
-> import Desugar(desugar,desugarGoal)
+> import Eval(evalEnv)
+> import Qual(qual)
+> import Desugar(desugar)
> import Simplify(simplify)
> import Lift(lift)
-> import qualified IL
-> import ILTrans(ilTrans,ilTransIntf)
-> import ILxml(xmlModule) -- check
-> import ExtendedFlat
+> import qualified IL.Type as IL
+> import IL.CurryToIL(ilTrans)
+> import IL.XML(xmlModule)
+> import Curry.ExtendedFlat
> import GenFlatCurry (genFlatCurry,genFlatInterface)
-> import AbstractCurry
+> import qualified Curry.AbstractCurry as AC
> import GenAbstractCurry
> import InterfaceCheck
> import CurryEnv
-> import CurryPP(ppModule,ppInterface,ppIDecl,ppGoal)
-> import qualified ILPP(ppModule)
+> import qualified IL.Pretty(ppModule)
> import CurryCompilerOpts(Options(..),Dump(..))
-> import CompilerResults
> import CaseCompletion
> import PathUtils
+> import Filenames
> import TypeSubst
-> import Pretty
-> import Error
-> import Env
+> import PrettyCombinators
> import TopEnv
+> import qualified Curry.ExtendedFlat as EF
\end{verbatim}
The function \texttt{compileModule} is the main entry-point of this
@@ -88,13 +93,10 @@
code are obsolete and commented out.
\begin{verbatim}
-> compileModule :: Options -> FilePath -> IO ()
-> compileModule opts fn = compileModule_ opts fn >> return ()
-
-> compileModule_ :: Options -> FilePath -> IO CompilerResults
-> compileModule_ opts fn =
+> compileModule :: Options -> FilePath -> IO (Maybe FilePath)
+> compileModule opts fn =
> do
-> mod <- liftM (parseModule likeFlat fn) (readModule fn)
+> mod <- liftM (importPrelude fn . ok . parseModule likeFlat fn) (readModule fn)
> let m = patchModuleId fn mod
> checkModuleId fn m
> mEnv <- loadInterfaces (importPaths opts) m
@@ -103,12 +105,12 @@
> do (tyEnv, tcEnv, aEnv, m', intf, _) <- simpleCheckModule opts mEnv m
> if uacy then genAbstract opts fn tyEnv tcEnv m'
> else do
-> let outputFile = maybe (replaceExtension fn sourceRepExt)
+> let outputFile = maybe (sourceRepName fn)
> id
> (output opts)
> outputMod = showModule m'
> writeModule outputFile outputMod
-> return defaultResults
+> return Nothing
> else
> do (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m
> let (il,aEnv',dumps) = transModule fcy False False
@@ -125,15 +127,11 @@
> genCode opts fn mEnv tyEnv tcEnv aEnv intf m il
> | fcy || xml = genFlat opts fn mEnv tyEnv tcEnv aEnv intf m il
> | acy = genAbstract opts fn tyEnv tcEnv m
-> | otherwise = return defaultResults
-
-> parseModule :: Bool -> FilePath -> String -> Module
-> parseModule likeFlat fn =
-> importPrelude fn . ok . parseSource likeFlat fn . unlitLiterate fn
+> | otherwise = return Nothing
> loadInterfaces :: [FilePath] -> Module -> IO ModuleEnv
> loadInterfaces paths (Module m _ ds) =
-> foldM (loadInterface paths [m]) emptyEnv
+> foldM (loadInterface paths [m]) Map.empty
> [(p,m) | ImportDecl p m _ _ _ <- ds]
> checkModuleId :: Monad m => FilePath -> Module -> m ()
@@ -146,7 +144,7 @@
> ++ ".curry\"")
> simpleCheckModule :: Options -> ModuleEnv -> Module
-> -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[Message])
+> -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[WarnMsg])
> simpleCheckModule opts mEnv (Module m es ds) =
> do unless (noWarn opts) (printMessages msgs)
> return (tyEnv'', tcEnv, aEnv'', modul, intf, msgs)
@@ -160,12 +158,12 @@
> $ kindCheck m tcEnv topDs
> ds' = impDs ++ qual m tyEnv topDs'
> modul = (Module m es ds') --expandInterface (Module m es ds') tcEnv tyEnv
-> (pEnv'',tcEnv'',tyEnv'',aEnv'')
+> (_,tcEnv'',tyEnv'',aEnv'')
> = qualifyEnv mEnv pEnv' tcEnv tyEnv aEnv
> intf = exportInterface modul pEnv' tcEnv'' tyEnv''
> checkModule :: Options -> ModuleEnv -> Module
-> -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[Message])
+> -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[WarnMsg])
> checkModule opts mEnv (Module m es ds) =
> do unless (noWarn opts) (printMessages msgs)
> when (m == mkMIdent ["field114..."])
@@ -216,8 +214,8 @@
> (DumpDesugared,ppModule desugared),
> (DumpSimplified,ppModule simplified),
> (DumpLifted,ppModule lifted),
-> (DumpIL,ILPP.ppModule il),
-> (DumpCase,ILPP.ppModule il')
+> (DumpIL,IL.Pretty.ppModule il),
+> (DumpCase,IL.Pretty.ppModule il')
> ]
> qualifyEnv :: ModuleEnv -> PEnv -> TCEnv -> ValueEnv -> ArityEnv
@@ -228,7 +226,7 @@
> foldr bindGlobal tyEnv' (localBindings tyEnv),
> foldr bindQual aEnv' (localBindings aEnv))
> where (pEnv',tcEnv',tyEnv',aEnv') =
-> foldl importInterface initEnvs (envToList mEnv)
+> foldl importInterface initEnvs (Map.toList mEnv)
> importInterface (pEnv,tcEnv,tyEnv,aEnv) (m,ds) =
> importInterfaceIntf (Interface m ds) pEnv tcEnv tyEnv aEnv
> bindQual (_,y) = qualBindTopEnv "Modules.qualifyEnv" (origName y) y
@@ -236,30 +234,18 @@
> | uniqueId x == 0 = bindQual (x,y)
> | otherwise = bindTopEnv "Modules.qualifyEnv" x y
-> --ilImports :: ValueEnv -> TCEnv -> ModuleEnv -> IL.Module -> [IL.Decl]
-> --ilImports tyEnv tcEnv mEnv (IL.Module _ is _) =
-> -- concat [ilTransIntf tyEnv tcEnv (Interface m ds)
-> -- | (m,ds) <- envToList mEnv, m `elem` is]
-
> writeXML :: Maybe FilePath -> FilePath -> CurryEnv -> IL.Module -> IO ()
> writeXML tfn sfn cEnv il = writeModule ofn (showln code)
-> where ofn = fromMaybe (replaceExtension sfn xmlExt) tfn
+> where ofn = fromMaybe (xmlName sfn) tfn
> code = (xmlModule cEnv il)
> writeFlat :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv
> -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog
> writeFlat opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il
> = writeFlatFile opts (genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv il)
-> (fromMaybe (replaceExtension sfn flatExt) tfn)
-
-> writeFInt :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv
-> -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog
-> writeFInt opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il
-> = writeFlatFile opts{extendedFlat=False}
-> (genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il)
-> (fromMaybe (takeBaseName sfn ++ fintExt) tfn)
+> (fromMaybe (flatName sfn) tfn)
-> writeFlatFile :: (Show a) => Options -> (Prog, [a]) -> String -> IO Prog
+> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog
> writeFlatFile opts@Options{extendedFlat=ext} (res,msgs) fname = do
> unless (noWarn opts) (printMessages msgs)
> if ext then writeExtendedFlat fname res
@@ -270,125 +256,20 @@
> writeTypedAbs :: Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module
> -> IO ()
> writeTypedAbs tfn sfn tyEnv tcEnv mod
-> = writeCurry fname (genTypedAbstract tyEnv tcEnv mod)
-> where fname = fromMaybe (replaceExtension sfn acyExt) tfn
+> = AC.writeCurry fname (genTypedAbstract tyEnv tcEnv mod)
+> where fname = fromMaybe (acyName sfn) tfn
> writeUntypedAbs :: Maybe FilePath -> FilePath -> ValueEnv -> TCEnv
> -> Module -> IO ()
> writeUntypedAbs tfn sfn tyEnv tcEnv mod
-> = writeCurry fname (genUntypedAbstract tyEnv tcEnv mod)
-> where fname = fromMaybe (replaceExtension sfn uacyExt) tfn
+> = AC.writeCurry fname (genUntypedAbstract tyEnv tcEnv mod)
+> where fname = fromMaybe (uacyName sfn) tfn
> showln :: Show a => a -> String
> showln x = shows x "\n"
\end{verbatim}
-A goal is compiled with respect to a given module. If no module is
-specified the Curry prelude is used. The source module has to be
-parsed and type checked before the goal can be compiled. Otherwise
-compilation of a goal is similar to that of a module.
-\em{Note:} These functions are obsolete when using the MCC as frontend
-for PAKCS.
-\begin{verbatim}
-
-> --compileGoal :: Options -> Maybe String -> Maybe FilePath -> IO ()
-> --compileGoal opts g fn =
-> -- do
-> -- (ccode,dumps) <- maybe (return startupCode) goalCode g
-> -- mapM_ (doDump opts) dumps
-> -- writeCCode ofn ccode
-> -- where ofn = fromMaybe (internalError "No filename for startup code")
-> -- (output opts)
-> -- startupCode = (genMain "curry_run",[])
-> -- goalCode = doCompileGoal (debug opts) (importPath opts) fn
-
-> --doCompileGoal :: Bool -> [FilePath] -> Maybe FilePath -> String
-> -- -> IO (CFile,[(Dump,Doc)])
-> --doCompileGoal debug paths fn g =
-> -- do
-> -- (mEnv,_,ds) <- loadGoalModule paths fn
-> -- let (tyEnv,g') = checkGoal mEnv ds (ok (parseGoal g))
-> -- (ccode,dumps) =
-> -- transGoal debug runGoal mEnv tyEnv (mkIdent "goal") g'
-> -- ccode' = genMain runGoal
-> -- return (mergeCFile ccode ccode',dumps)
-> -- where runGoal = "curry_runGoal"
-
-> --typeGoal :: Options -> String -> Maybe FilePath -> IO ()
-> --typeGoal opts g fn =
-> -- do
-> -- (mEnv,m,ds) <- loadGoalModule (importPath opts) fn
-> -- let (tyEnv,Goal _ e _) = checkGoal mEnv ds (ok (parseGoal g))
-> -- print (ppType m (typeOf tyEnv e))
-
-> --loadGoalModule :: [FilePath] -> Maybe FilePath
-> -- -> IO (ModuleEnv,ModuleIdent,[Decl])
-> --loadGoalModule paths fn =
-> -- do
-> -- Module m _ ds <- maybe (return emptyModule) parseGoalModule fn
-> -- mEnv <- loadInterfaces paths (Module m Nothing ds)
-> -- let (_,_,_,_,intf) = checkModule mEnv (Module m Nothing ds)
-> -- return (bindModule intf mEnv,m,filter isImportDecl ds ++ [importMain m])
-> -- where emptyModule = importPrelude "" (Module emptyMIdent Nothing [])
-> -- parseGoalModule fn = liftM (parseModule False fn) (readFile fn)
-> -- importMain m = ImportDecl (first "") m False Nothing Nothing
-
-> --checkGoal :: ModuleEnv -> [Decl] -> Goal -> (ValueEnv,Goal)
-> --checkGoal mEnv impDs g = (tyEnv'',qualGoal tyEnv' g')
-> -- where (pEnv,tcEnv,tyEnv,aEnv) = importModules mEnv impDs
-> -- g' = precCheckGoal pEnv $ syntaxCheckGoal tyEnv
-> -- $ kindCheckGoal tcEnv g
-> -- tyEnv' = typeCheckGoal tcEnv tyEnv g'
-> -- (_,_,tyEnv'',_) = qualifyEnv mEnv pEnv tcEnv tyEnv' emptyTopEnv
-
-> --transGoal :: Bool -> String -> ModuleEnv -> ValueEnv -> Ident -> Goal
-> -- -> (CFile,[(Dump,Doc)])
-> --transGoal debug run mEnv tyEnv goalId g = (ccode,dumps)
-> -- where qGoalId = qualifyWith emptyMIdent goalId
-> -- evEnv = evalEnvGoal g
-> -- (vs,desugared,tyEnv') = desugarGoal debug tyEnv emptyMIdent goalId g
-> -- (simplified,tyEnv'') = simplify False tyEnv' evEnv desugared
-> -- (lifted,tyEnv''',evEnv') = lift tyEnv'' evEnv simplified
-> -- il = ilTrans False tyEnv''' evEnv' lifted
-> -- ilDbg = if debug then dAddMain goalId (dTransform False il) else il
-> -- ilNormal = liftProg ilDbg
-> -- cam = camCompile ilNormal
-> -- imports = camCompileData (ilImports mEnv ilDbg)
-> -- ccode =
-> -- genModule imports cam ++
-> -- genEntry run (fun qGoalId) (fmap (map name) vs)
-> -- dumps = [
-> -- (DumpRenamed,ppGoal g),
-> -- (DumpTypes,ppTypes emptyMIdent (localBindings tyEnv)),
-> -- (DumpDesugared,ppModule desugared),
-> -- (DumpSimplified,ppModule simplified),
-> -- (DumpLifted,ppModule lifted),
-> -- (DumpIL,ILPP.ppModule il),
-> -- (DumpTransformed,ILPP.ppModule ilDbg),
-> -- (DumpNormalized,ILPP.ppModule ilNormal),
-> -- (DumpCam,CamPP.ppModule cam)
-> -- ]
-
-\end{verbatim}
-The compiler adds a startup function for the default goal
-\texttt{main.main} to the \texttt{main} module. Thus, there is no need
-to determine the type of the goal when linking the program.
-\begin{verbatim}
-
-> --compileDefaultGoal :: Bool -> ModuleEnv -> Interface -> Maybe CFile
-> --compileDefaultGoal debug mEnv (Interface m ds)
-> -- | m == mainMIdent && any (qMainId ==) [f | IFunctionDecl _ f _ _ <- ds] =
-> -- Just ccode
-> -- | otherwise = Nothing
-> -- where qMainId = qualify mainId
-> -- mEnv' = bindModule (Interface m ds) mEnv
-> -- (tyEnv,g) =
-> -- checkGoal mEnv' [ImportDecl (first "") m False Nothing Nothing]
-> -- (Goal (first "") (Variable qMainId) [])
-> -- (ccode,_) = transGoal debug "curry_run" mEnv' tyEnv mainId g
-
-\end{verbatim}
The function \texttt{importModules} brings the declarations of all
imported modules into scope for the current module.
\begin{verbatim}
@@ -397,7 +278,7 @@
> importModules mEnv ds = (pEnv,importUnifyData tcEnv,tyEnv,aEnv)
> where (pEnv,tcEnv,tyEnv,aEnv) = foldl importModule initEnvs ds
> importModule (pEnv,tcEnv,tyEnv,aEnv) (ImportDecl p m q asM is) =
-> case lookupModule m mEnv of
+> case Map.lookup m mEnv of
> Just ds -> importInterface p (fromMaybe m asM) q is
> (Interface m ds) pEnv tcEnv tyEnv aEnv
> Nothing -> internalError "importModule"
@@ -421,7 +302,7 @@
> importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds
> where
> importLabelTypes lEnv (ImportDecl p m _ asM is) =
-> case (lookupModule m mEnv) of
+> case (Map.lookup m mEnv) of
> Just ds' -> foldl (importLabelType p (fromMaybe m asM) is) lEnv ds'
> Nothing -> internalError "importLabels"
> importLabelTypes lEnv _ = lEnv
@@ -449,10 +330,10 @@
> addImportedLabels :: ModuleIdent -> LabelEnv -> ValueEnv -> ValueEnv
> addImportedLabels m lEnv tyEnv =
-> foldr addLabelType tyEnv (concatMap snd (envToList lEnv))
+> foldr addLabelType tyEnv (concatMap snd (Map.toList lEnv))
> where
> addLabelType (LabelType l r ty) tyEnv =
-> let m' = fromMaybe m (fst (splitQualIdent r))
+> let m' = fromMaybe m (qualidMod r)
> in importTopEnv m' l
> (Label (qualify l) (qualQualify m' r) (polyType ty))
> tyEnv
@@ -511,7 +392,7 @@
> importPrelude :: FilePath -> Module -> Module
> importPrelude fn (Module m es ds) =
> Module m es (if m == preludeMIdent then ds else ds')
-> where ids = filter isImportDecl ds
+> where ids = [decl | decl@(ImportDecl _ _ _ _ _) <- ds]
> ds' = ImportDecl (first fn) preludeMIdent
> (preludeMIdent `elem` map importedModule ids)
> Nothing Nothing : ds
@@ -536,7 +417,7 @@
> lookupInterface paths m >>=
> maybe (errorAt p (interfaceNotFound m))
> (compileInterface paths ctxt mEnv m)
-> where isLoaded m mEnv = maybe False (const True) (lookupModule m mEnv)
+> where isLoaded m mEnv = maybe False (const True) (Map.lookup m mEnv)
\end{verbatim}
After reading an interface, all imported interfaces are recursively
@@ -571,18 +452,7 @@
> (map (\i -> (p, mkMIdent [i])) is)
> where p = first m
-> --checkInterface :: ModuleEnv -> Interface -> Interface
-> --checkInterface mEnv (Interface m ds) =
-> -- intfCheck pEnv tcEnv tyEnv (Interface m ds)
-> -- where (pEnv,tcEnv,tyEnv) = foldl importInterface initEnvs ds
-> -- importInterface (pEnv,tcEnv,tyEnv) (IImportDecl p m) =
-> -- case lookupModule m mEnv of
-> -- Just ds -> importInterfaceIntf (Interface m ds) pEnv tcEnv tyEnv
-> -- Nothing -> internalError "importInterface"
-> -- importInterface (pEnv,tcEnv,tyEnv) _ = (pEnv,tcEnv,tyEnv)
-
-\end{verbatim}
Interface files are updated by the Curry builder when necessary.
(see module \texttt{CurryBuilder}).
@@ -601,25 +471,6 @@
the file is closed.
\begin{verbatim}
-> --updateInterface :: FilePath -> Interface -> IO ()
-> --updateInterface sfn i =
-> -- do
-> -- eq <- catch (matchInterface ifn i) (const (return False))
-> -- unless eq (writeInterface ifn i)
-> -- where ifn = dropExtension sfn ++ intfExt
-
-> --matchInterface :: FilePath -> Interface -> IO Bool
-> --matchInterface ifn i =
-> -- do
-> -- h <- openFile ifn ReadMode
-> -- s <- hGetContents h
-> -- case parseInterface ifn s of
-> -- Ok i' | i `intfEquiv` fixInterface i' -> return True
-> -- _ -> hClose h >> return False
-
-> --writeInterface :: FilePath -> Interface -> IO ()
-> --writeInterface ifn = writeFile ifn . showln . ppInterface
-
\end{verbatim}
The compiler searches for interface files in the import search path
using the extension \texttt{".fint"}. Note that the current
@@ -627,24 +478,10 @@
\begin{verbatim}
> lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)
-> lookupInterface paths m = lookupFile ("":paths) [fintExt] ifn
+> lookupInterface paths m = lookupFile ("":paths) [flatIntExt] ifn
> where ifn = foldr1 catPath (moduleQualifiers m)
\end{verbatim}
-Literate source files use the extension \texttt{".lcurry"}.
-\begin{verbatim}
-
-> unlitLiterate :: FilePath -> String -> String
-> unlitLiterate fn s
-> | not (isLiterateSource fn) = s
-> | null es = s'
-> | otherwise = error es
-> where (es,s') = unlit fn s
-
-> isLiterateSource :: FilePath -> Bool
-> isLiterateSource fn = litExt `isSuffixOf` fn
-
-\end{verbatim}
The \texttt{doDump} function writes the selected information to the
standard output.
\begin{verbatim}
@@ -678,7 +515,7 @@
\begin{verbatim}
> genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
-> -> Interface -> Module -> IL.Module -> IO CompilerResults
+> -> Interface -> Module -> IL.Module -> IO (Maybe FilePath)
> genFlat opts fname mEnv tyEnv tcEnv aEnv intf mod il
> | flat opts
> = do writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il
@@ -686,7 +523,7 @@
> if force opts
> then
> do writeInterface flatInterface intMsgs
-> return defaultResults
+> return Nothing
> else
> do mfint <- readFlatInterface fintName
> let flatIntf = fromMaybe emptyIntf mfint
@@ -694,14 +531,14 @@
> && not (interfaceCheck flatIntf flatInterface)
> then
> do writeInterface flatInterface intMsgs
-> return defaultResults
-> else return defaultResults
+> return Nothing
+> else return Nothing
> | flatXml opts
-> = writeXML (output opts) fname cEnv il >> return defaultResults
+> = writeXML (output opts) fname cEnv il >> return Nothing
> | otherwise
> = internalError "@Modules.genFlat: illegal option"
> where
-> fintName = replaceExtension fname fintExt
+> fintName = flatIntName fname
> cEnv = curryEnv mEnv tcEnv intf mod
> emptyIntf = Prog "" [] [] [] []
> writeInterface intf msgs = do
@@ -710,20 +547,20 @@
> genAbstract :: Options -> FilePath -> ValueEnv -> TCEnv -> Module
-> -> IO CompilerResults
+> -> IO (Maybe FilePath)
> genAbstract opts fname tyEnv tcEnv mod
> | abstract opts
> = do writeTypedAbs Nothing fname tyEnv tcEnv mod
-> return defaultResults
+> return Nothing
> | untypedAbstract opts
> = do writeUntypedAbs Nothing fname tyEnv tcEnv mod
-> return defaultResults
+> return Nothing
> | otherwise
> = internalError "@Modules.genAbstract: illegal option"
-> printMessages :: Show a => [a] -> IO ()
+> printMessages :: [WarnMsg] -> IO ()
> printMessages [] = return ()
-> printMessages msgs = hPutStrLn stderr $ unlines $ map show msgs
+> printMessages msgs = hPutStrLn stderr $ unlines $ map showWarning msgs
\end{verbatim}
The function \texttt{ppTypes} is used for pretty-printing the types
@@ -756,20 +593,6 @@
\end{verbatim}
-Various filename extensions
-\begin{verbatim}
-
-> cExt = ".c"
-> xmlExt = "_flat.xml"
-> flatExt = ".fcy"
-> fintExt = ".fint"
-> acyExt = ".acy"
-> uacyExt = ".uacy"
-> sourceRepExt = ".cy"
-> intfExt = ".icurry"
-> litExt = ".lcurry"
-
-\end{verbatim}
Error functions.
\begin{verbatim}
@@ -789,3 +612,78 @@
> "Expected interface for " ++ show m ++ " but found " ++ show m'
\end{verbatim}
+
+
+
+
+> bindFlatInterface :: Prog -> ModuleEnv -> ModuleEnv
+> bindFlatInterface (Prog m imps ts fs os)
+> = Map.insert (mkMIdent [m])
+> ((map genIImportDecl imps)
+> ++ (map genITypeDecl ts')
+> ++ (map genIFuncDecl fs)
+> ++ (map genIOpDecl os))
+> where
+> genIImportDecl :: String -> IDecl
+> genIImportDecl imp = IImportDecl pos (mkMIdent [imp])
+>
+> genITypeDecl :: TypeDecl -> IDecl
+> genITypeDecl (Type qn _ is cs)
+> | recordExt `isPrefixOf` localName qn
+> = ITypeDecl pos
+> (genQualIdent qn)
+> (map (genVarIndexIdent "a") is)
+> (RecordType (map genLabeledType cs) Nothing)
+> | otherwise
+> = IDataDecl pos
+> (genQualIdent qn)
+> (map (genVarIndexIdent "a") is)
+> (map (Just . genConstrDecl) cs)
+> genITypeDecl (TypeSyn qn _ is t)
+> = ITypeDecl pos
+> (genQualIdent qn)
+> (map (genVarIndexIdent "a") is)
+> (genTypeExpr t)
+>
+> genIFuncDecl :: FuncDecl -> IDecl
+> genIFuncDecl (Func qn a _ t _)
+> = IFunctionDecl pos (genQualIdent qn) a (genTypeExpr t)
+>
+> genIOpDecl :: OpDecl -> IDecl
+> genIOpDecl (Op qn f p) = IInfixDecl pos (genInfix f) p (genQualIdent qn)
+>
+> genConstrDecl :: ConsDecl -> ConstrDecl
+> genConstrDecl (Cons qn _ _ ts)
+> = ConstrDecl pos [] (mkIdent (localName qn)) (map genTypeExpr ts)
+>
+> genLabeledType :: EF.ConsDecl -> ([Ident],Curry.Syntax.TypeExpr)
+> genLabeledType (Cons qn _ _ [t])
+> = ([renameLabel (fromLabelExtId (mkIdent $ localName qn))], genTypeExpr t)
+>
+> genTypeExpr :: EF.TypeExpr -> Curry.Syntax.TypeExpr
+> genTypeExpr (TVar i)
+> = VariableType (genVarIndexIdent "a" i)
+> genTypeExpr (FuncType t1 t2)
+> = ArrowType (genTypeExpr t1) (genTypeExpr t2)
+> genTypeExpr (TCons qn ts)
+> = ConstructorType (genQualIdent qn) (map genTypeExpr ts)
+>
+> genInfix :: EF.Fixity -> Infix
+> genInfix EF.InfixOp = Infix
+> genInfix EF.InfixlOp = InfixL
+> genInfix EF.InfixrOp = InfixR
+>
+> genQualIdent :: EF.QName -> QualIdent
+> genQualIdent EF.QName{modName=mod,localName=name} =
+> qualifyWith (mkMIdent [mod]) (mkIdent name)
+>
+> genVarIndexIdent :: String -> Int -> Ident
+> genVarIndexIdent v i = mkIdent (v ++ show i)
+>
+> isSpecialPreludeType :: TypeDecl -> Bool
+> isSpecialPreludeType (Type EF.QName{modName=mod,localName=name} _ _ _)
+> = (name == "[]" || name == "()") && mod == "Prelude"
+> isSpecialPreludeType _ = False
+>
+> pos = first m
+> ts' = filter (not . isSpecialPreludeType) ts
diff --git a/src/NestEnv.lhs b/src/NestEnv.lhs
--- a/src/NestEnv.lhs
+++ b/src/NestEnv.lhs
@@ -18,13 +18,17 @@
> module NestEnv(module TopEnv, NestEnv, bindNestEnv,qualBindNestEnv,
> lookupNestEnv,qualLookupNestEnv,
> toplevelEnv,globalEnv,nestEnv) where
-> import Env
+
+> import qualified Data.Map as Map
+
+> import Curry.Base.Ident
+
> import TopEnv
-> import Ident
-> data NestEnv a = GlobalEnv (TopEnv a) | LocalEnv (NestEnv a) (Env Ident a)
-> deriving Show
+> data NestEnv a = GlobalEnv (TopEnv a) | LocalEnv (NestEnv a) (Map.Map Ident a)
+> -- deriving Show
+
> instance Functor NestEnv where
> fmap f (GlobalEnv env) = GlobalEnv (fmap f env)
> fmap f (LocalEnv genv env) = LocalEnv (fmap f genv) (fmap f env)
@@ -33,9 +37,9 @@
> bindNestEnv x y (GlobalEnv env)
> = GlobalEnv (bindTopEnv "NestEnv.bindNestEnv" x y env)
> bindNestEnv x y (LocalEnv genv env) =
-> case lookupEnv x env of
+> case Map.lookup x env of
> Just _ -> error "internal error: bindNestEnv"
-> Nothing -> LocalEnv genv (bindEnv x y env)
+> Nothing -> LocalEnv genv (Map.insert x y env)
> qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
> qualBindNestEnv x y (GlobalEnv env)
@@ -43,15 +47,15 @@
> qualBindNestEnv x y (LocalEnv genv env)
> | isQualified x = error "internal error: qualBindNestEnv"
> | otherwise =
-> case lookupEnv x' env of
+> case Map.lookup x' env of
> Just _ -> error "internal error: qualBindNestEnv"
-> Nothing -> LocalEnv genv (bindEnv x' y env)
+> Nothing -> LocalEnv genv (Map.insert x' y env)
> where x' = unqualify x
> lookupNestEnv :: Ident -> NestEnv a -> [a]
> lookupNestEnv x (GlobalEnv env) = lookupTopEnv x env
> lookupNestEnv x (LocalEnv genv env) =
-> case lookupEnv x env of
+> case Map.lookup x env of
> Just y -> [y]
> Nothing -> lookupNestEnv x genv
@@ -68,6 +72,6 @@
> globalEnv = GlobalEnv
> nestEnv :: NestEnv a -> NestEnv a
-> nestEnv env = LocalEnv env emptyEnv
+> nestEnv env = LocalEnv env Map.empty
\end{verbatim}
diff --git a/src/OldScopeEnv.hs b/src/OldScopeEnv.hs
--- a/src/OldScopeEnv.hs
+++ b/src/OldScopeEnv.hs
@@ -7,10 +7,9 @@
genIdent, genIdentList) where
import Data.Maybe
-
-import Ident
-import Env
+import qualified Data.Map as Map
+import Curry.Base.Ident
-------------------------------------------------------------------------------
@@ -23,7 +22,7 @@
-- Generates a new instance of a scope table
newScopeEnv :: ScopeEnv
-newScopeEnv = (newIdEnv, [], 0)
+newScopeEnv = (Map.empty, [], 0)
-- Inserts an identifier into the current level of the scope environment
@@ -66,7 +65,7 @@
beginScope (topleveltab, leveltabs, level)
= case leveltabs of
(lt:lts) -> (topleveltab, (lt:lt:lts), level + 1)
- [] -> (topleveltab, [newIdEnv], 1)
+ [] -> (topleveltab, [Map.empty], 1)
-- Decreases the level of the scope. Identifier from higher levels
@@ -116,24 +115,20 @@
-------------------------------------------------------------------------------
-- Private declarations...
-type IdEnv = Env IdRep Int
+type IdEnv = Map.Map IdRep Int
data IdRep = Name String | Index Int deriving (Eq, Ord)
-------------------------------------------------------------------------------
---
-newIdEnv :: IdEnv
-newIdEnv = emptyEnv
-
--
insertId :: Int -> Ident -> IdEnv -> IdEnv
insertId level ident env
- = bindEnv (Name (name ident))
+ = Map.insert (Name (name ident))
level
- (bindEnv (Index (uniqueId ident)) level env)
+ (Map.insert (Index (uniqueId ident)) level env)
--
@@ -143,7 +138,7 @@
--
getIdLevel :: Ident -> IdEnv -> Maybe Int
-getIdLevel ident env = lookupEnv (Index (uniqueId ident)) env
+getIdLevel ident env = Map.lookup (Index (uniqueId ident)) env
--
@@ -158,12 +153,12 @@
--
nameExists :: String -> IdEnv -> Bool
-nameExists name env = isJust (lookupEnv (Name name) env)
+nameExists name env = isJust (Map.lookup (Name name) env)
--
indexExists :: Int -> IdEnv -> Bool
-indexExists index env = isJust (lookupEnv (Index index) env)
+indexExists index env = isJust (Map.lookup (Index index) env)
-------------------------------------------------------------------------------
diff --git a/src/PatchPrelude.hs b/src/PatchPrelude.hs
--- a/src/PatchPrelude.hs
+++ b/src/PatchPrelude.hs
@@ -1,7 +1,7 @@
module PatchPrelude where
-import ExtendedFlat
+import Curry.ExtendedFlat
-- the prelude has to be extended by data declarations for list and tuples
diff --git a/src/PathUtils.hs b/src/PathUtils.hs
--- a/src/PathUtils.hs
+++ b/src/PathUtils.hs
@@ -6,12 +6,13 @@
-}
module PathUtils(-- re-exports from System.FilePath:
- takeBaseName, replaceExtension, dropExtension,
+ takeBaseName, -- replaceExtension,
+ dropExtension,
takeDirectory, takeExtension,
pathSeparator,
catPath,
- lookupFile,
+ lookupModule, lookupFile, getCurryPath,
writeModule,readModule,
doesModuleExist,maybeReadModule,getModuleModTime) where
@@ -21,7 +22,16 @@
import Control.Monad (unless)
+import Curry.Base.Ident
+import Filenames
+
+lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent
+ -> IO (Maybe FilePath)
+lookupModule paths libraryPaths m
+ = lookupFile ("" : paths ++ libraryPaths) moduleExts fn
+ where fn = foldr1 catPath (moduleQualifiers m)
+
catPath :: FilePath -> FilePath -> FilePath
catPath = combine
@@ -65,7 +75,7 @@
writeModule filename contents = do
let filename' = inCurrySubdir filename
subdir = takeDirectory filename'
- ensureDirectoryExists (takeDirectory filename')
+ ensureDirectoryExists subdir
writeFile filename' contents
ensureDirectoryExists :: FilePath -> IO ()
@@ -93,3 +103,20 @@
getModuleModTime :: FilePath -> IO ClockTime
getModuleModTime = onExistingFileDo getModificationTime
+
+
+{-
+ The function \verb|getCurryPath| searches in predefined paths
+ for the corresponding \texttt{.curry} or \texttt{.lcurry} file,
+ if the given file name has no extension.
+-}
+getCurryPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+getCurryPath paths fn = lookupFile filepaths exts fn
+ where
+ filepaths = "":paths'
+ fnext = takeExtension fn
+ exts | null fnext = sourceExts
+ | otherwise = [fnext]
+ paths' | pathSeparator `elem` fn = []
+ | otherwise = paths
+
diff --git a/src/Position.lhs b/src/Position.lhs
deleted file mode 100644
--- a/src/Position.lhs
+++ /dev/null
@@ -1,94 +0,0 @@
-> {-# LANGUAGE DeriveDataTypeable #-}
-
-% -*- LaTeX -*-
-% $Id: Position.lhs,v 1.2 2000/10/08 09:55:43 lux Exp $
-%
-% $Log: Position.lhs,v $
-% Revision 1.2 2000/10/08 09:55:43 lux
-% Column numbers now start at 1. If the column number is less than 1 it
-% will not be shown.
-%
-% Revision 1.1 2000/07/23 11:03:37 lux
-% Positions now implemented in a separate module.
-%
-%
-\nwfilename{Position.lhs}
-\section{Positions}
-A source file position consists of a filename, a line number, and a
-column number. A tab stop is assumed at every eighth column.
-\begin{verbatim}
-
-> module Position where
-> import Data.Generics
-
-> newtype SrcRef = SrcRef [Int] deriving (Typeable,Data) -- a pointer to the origin
-
--- the instances for standard classes or such that SrcRefs are invisible
-
-> instance Show SrcRef where show _ = ""
-> instance Read SrcRef where readsPrec _ s = [(noRef,s)]
-> instance Eq SrcRef where _ == _ = True
-> instance Ord SrcRef where compare _ _ = EQ
-
-> noRef :: SrcRef
-> noRef = SrcRef []
->
-> incSrcRef :: SrcRef -> Int -> SrcRef
-> incSrcRef (SrcRef [i]) j = SrcRef [i+j]
-> incSrcRef is _ = error $ "internal error; increment source ref: " ++ show is
-
-> data Position
-> = Position{ file :: FilePath, line :: Int, column :: Int, ast :: SrcRef }
-> | AST { ast :: SrcRef }
-> deriving (Eq, Ord,Data,Typeable)
->
-> incPosition :: Position -> Int -> Position
-> incPosition p j = p{ast=incSrcRef (ast p) j}
-
-> instance Read Position where
-> readsPrec p s =
-> [ (Position{file="",line=i,column=j,ast=noRef},s') | ((i,j),s') <- readsPrec p s]
-
-> instance Show Position where
-> showsPrec _ Position{file=fn,line=l,column=c} =
-> (if null fn then id else shows fn . showString ", ") .
-> showString "line " . shows l .
-> (if c > 0 then showChar '.' . shows c else id)
-> showsPrec _ AST{} = id
-
-> tabWidth :: Int
-> tabWidth = 8
-
-> first :: FilePath -> Position
-> first fn = Position fn 1 1 noRef
-
-> incr :: Position -> Int -> Position
-> incr p@Position{column=c} n = p{column=c + n}
-
-> next :: Position -> Position
-> next = flip incr 1
-
-> tab :: Position -> Position
-> tab p@Position{column=c} = p{column=c + tabWidth - (c - 1) `mod` tabWidth}
-
-> nl :: Position -> Position
-> nl p@Position{line=l} = p{line=l + 1, column=1}
-
-> noPos, noPos' :: Position
-> noPos = Position{ file = "", line = 0, column = 0, ast = noRef }
-> noPos' = AST noRef
-
-> showLine :: Position -> String
-> showLine x@Position{line=l,column=c}
-> | x == noPos = ""
-> | otherwise = "(line " ++ show l ++ "." ++ show c ++ ") "
-
-\end{verbatim}
-
-> class SrcRefOf a where
-> srcRefsOf :: a -> [SrcRef]
-> srcRefsOf = (:[]) . srcRefOf
-> srcRefOf :: a -> SrcRef
-> srcRefOf = head . srcRefsOf
-
-> instance SrcRefOf Position where srcRefOf = ast
diff --git a/src/PrecCheck.lhs b/src/PrecCheck.lhs
--- a/src/PrecCheck.lhs
+++ b/src/PrecCheck.lhs
@@ -16,10 +16,15 @@
of the operators involved.
\begin{verbatim}
-> module PrecCheck(precCheck,precCheckGoal) where
+> module PrecCheck(precCheck) where
> import Data.List
+> import Curry.Base.Position
+> import Curry.Base.Ident
+> import Curry.Syntax
+> import Curry.Syntax.Utils
+
> import Base
\end{verbatim}
@@ -34,13 +39,13 @@
> bindPrecs m ds pEnv =
> case linear ops of
> Linear ->
-> case [PIdent p op | PIdent p op <- ops, op `notElem` bvs] of
+> case [ op | op <- ops, op `notElem` bvs] of
> [] -> foldr bindPrec pEnv fixDs
-> PIdent p op : _ -> errorAt' (undefinedOperator op)
-> NonLinear (PIdent p op) -> errorAt' (duplicatePrecedence op)
+> op : _ -> errorAt' (undefinedOperator op)
+> NonLinear op -> errorAt' (duplicatePrecedence op)
> where (fixDs,nonFixDs) = partition isInfixDecl ds
> bvs = concatMap boundValues nonFixDs
-> ops = [PIdent p op | InfixDecl p _ _ ops <- fixDs, op <- ops]
+> ops = [ op | InfixDecl p _ _ ops <- fixDs, op <- ops]
> bindPrec (InfixDecl _ fix pr ops) pEnv
> | p == defaultP = pEnv
> | otherwise = foldr (flip (bindP m) p) pEnv ops
@@ -72,11 +77,6 @@
> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
> precCheck = checkDecls
-> precCheckGoal :: PEnv -> Goal -> Goal
-> precCheckGoal pEnv (Goal p e ds) = Goal p (checkExpr m pEnv' e) ds'
-> where (pEnv',ds') = checkDecls m pEnv ds
-> m = emptyMIdent
-
> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
> checkDecls m pEnv ds = pEnv' `seq` (pEnv',ds')
> where pEnv' = bindPrecs m ds pEnv
@@ -247,8 +247,7 @@
> InfixApply (fixUPrec pEnv uop e1 op1 e2) op2 e3
> | pr2 > 6 = UnaryMinus uop (fixRPrec pEnv e1 op1 (InfixApply e2 op2 e3))
> | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op2)
-> where OpPrec fix1 pr1 = opPrec op1 pEnv
-> OpPrec fix2 pr2 = opPrec op2 pEnv
+> where OpPrec fix2 pr2 = opPrec op2 pEnv
> fixUPrec _ uop e1 op e2 = UnaryMinus uop (InfixApply e1 op e2)
> fixRPrec :: PEnv -> Expression -> InfixOp -> Expression
diff --git a/src/Pretty.lhs b/src/Pretty.lhs
deleted file mode 100644
--- a/src/Pretty.lhs
+++ /dev/null
@@ -1,905 +0,0 @@
-Hand converted to standard Haskell -- jcp
-
-*********************************************************************************
-* *
-* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *
-* *
-* based on "The Design of a Pretty-printing Library" *
-* in Advanced Functional Programming, *
-* Johan Jeuring and Erik Meijer (eds), LNCS 925 *
-* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *
-* *
-* Heavily modified by Simon Peyton Jones, Dec 96 *
-* *
-*********************************************************************************
-
-Version 3.0 28 May 1997
- * Cured massive performance bug. If you write
-
- foldl <> empty (map (text.show) [1..10000])
-
- you get quadratic behaviour with V2.0. Why? For just the same reason as you get
- quadratic behaviour with left-associated (++) chains.
-
- This is really bad news. One thing a pretty-printer abstraction should
- certainly guarantee is insensivity to associativity. It matters: suddenly
- GHC's compilation times went up by a factor of 100 when I switched to the
- new pretty printer.
-
- I fixed it with a bit of a hack (because I wanted to get GHC back on the
- road). I added two new constructors to the Doc type, Above and Beside:
-
- <> = Beside
- $$ = Above
-
- Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
- the Doc to squeeze out these suspended calls to Beside and Above; but in so
- doing I re-associate. It's quite simple, but I'm not satisfied that I've done
- the best possible job. I'll send you the code if you are interested.
-
- * Added new exports:
- punctuate, hang
- int, integer, float, double, rational,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
-
- * fullRender's type signature has changed. Rather than producing a string it
- now takes an extra couple of arguments that tells it how to glue fragments
- of output together:
-
- fullRender :: Mode
- -> Int -- Line length
- -> Float -- Ribbons per line
- -> (TextDetails -> a -> a) -- What to do with text
- -> a -- What to do at the end
- -> Doc
- -> a -- Result
-
- The "fragments" are encapsulated in the TextDetails data type:
- data TextDetails = Chr Char
- | Str String
- | PStr FAST_STRING
-
- The Chr and Str constructors are obvious enough. The PStr constructor has a packed
- string (FAST_STRING) inside it. It's generated by using the new "ptext" export.
-
- An advantage of this new setup is that you can get the renderer to do output
- directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
- rather than producing a string that you then print.
-
-
-Version 2.0 24 April 1997
- * Made empty into a left unit for <> as well as a right unit;
- it is also now true that
- nest k empty = empty
- which wasn't true before.
-
- * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
-
- * Added $+$
-
- * Corrected and tidied up the laws and invariants
-
-======================================================================
-Relative to John's original paper, there are the following new features:
-
-1. There's an empty document, "empty". It's a left and right unit for
- both <> and $$, and anywhere in the argument list for
- sep, hcat, hsep, vcat, fcat etc.
-
- It is Really Useful in practice.
-
-2. There is a paragraph-fill combinator, fsep, that's much like sep,
- only it keeps fitting things on one line until itc can't fit any more.
-
-3. Some random useful extra combinators are provided.
- <+> puts its arguments beside each other with a space between them,
- unless either argument is empty in which case it returns the other
-
-
- hcat is a list version of <>
- hsep is a list version of <+>
- vcat is a list version of $$
-
- sep (separate) is either like hsep or like vcat, depending on what fits
-
- cat is behaves like sep, but it uses <> for horizontal conposition
- fcat is behaves like fsep, but it uses <> for horizontal conposition
-
- These new ones do the obvious things:
- char, semi, comma, colon, space,
- parens, brackets, braces,
- quotes, doubleQuotes
-
-4. The "above" combinator, $$, now overlaps its two arguments if the
- last line of the top argument stops before the first line of the second begins.
- For example: text "hi" $$ nest 5 "there"
- lays out as
- hi there
- rather than
- hi
- there
-
- There are two places this is really useful
-
- a) When making labelled blocks, like this:
- Left -> code for left
- Right -> code for right
- LongLongLongLabel ->
- code for longlonglonglabel
- The block is on the same line as the label if the label is
- short, but on the next line otherwise.
-
- b) When laying out lists like this:
- [ first
- , second
- , third
- ]
- which some people like. But if the list fits on one line
- you want [first, second, third]. You can't do this with
- John's original combinators, but it's quite easy with the
- new $$.
-
- The combinator $+$ gives the original "never-overlap" behaviour.
-
-5. Several different renderers are provided:
- * a standard one
- * one that uses cut-marks to avoid deeply-nested documents
- simply piling up in the right-hand margin
- * one that ignores indentation (fewer chars output; good for machines)
- * one that ignores indentation and newlines (ditto, only more so)
-
-6. Numerous implementation tidy-ups
- Use of unboxed data types to speed up the implementation
-
-
-
-\begin{code}
-module Pretty (
- Doc, -- Abstract
- Mode(..), TextDetails(..),
- Style,
-
- empty, nest,
-
- text, char, ptext,
- int, integer, float, double, rational,
- parens, brackets, braces, quotes, doubleQuotes,
- semi, comma, colon, space, equals,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
-
- (<>), (<+>), hcat, hsep,
- ($$), ($+$), vcat,
- sep, cat,
- fsep, fcat,
-
- hang, punctuate,
-
- renderStyle,
- render, fullRender
- ) where
-
--- Don't import Util( assertPanic ) because it makes a loop in the module structure
-
-import Data.Ratio
-infixl 6 <>
-infixl 6 <+>
-infixl 5 $$, $+$
-\end{code}
-
-
-
-*********************************************************
-* *
-\subsection{CPP magic so that we can compile with both GHC and Hugs}
-* *
-*********************************************************
-
-The library uses unboxed types to get a bit more speed, but these CPP macros
-allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
- __GLASGOW_HASKELL__
-
-
-*********************************************************
-* *
-\subsection{The interface}
-* *
-*********************************************************
-
-The primitive @Doc@ values
-
-\begin{code}
-empty :: Doc
-text :: String -> Doc
-char :: Char -> Doc
-
-semi, comma, colon, space, equals :: Doc
-lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
-
-parens, brackets, braces :: Doc -> Doc
-quotes, doubleQuotes :: Doc -> Doc
-
-int :: Int -> Doc
-integer :: Integer -> Doc
-float :: Float -> Doc
-double :: Double -> Doc
-rational :: Rational -> Doc
-\end{code}
-
-
-Combining @Doc@ values
-
-\begin{code}
-(<>) :: Doc -> Doc -> Doc -- Beside
-hcat :: [Doc] -> Doc -- List version of <>
-(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
-hsep :: [Doc] -> Doc -- List version of <+>
-
-($$) :: Doc -> Doc -> Doc -- Above; if there is no
- -- overlap it "dovetails" the two
-vcat :: [Doc] -> Doc -- List version of $$
-
-cat :: [Doc] -> Doc -- Either hcat or vcat
-sep :: [Doc] -> Doc -- Either hsep or vcat
-fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
-fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
-
-nest :: Int -> Doc -> Doc -- Nested
-\end{code}
-
-GHC-specific ones.
-
-\begin{code}
-hang :: Doc -> Int -> Doc -> Doc
-punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
-\end{code}
-
-Displaying @Doc@ values.
-
-\begin{code}
-instance Show Doc where
- showsPrec prec doc cont = showDoc doc cont
-
-render :: Doc -> String -- Uses default style
-fullRender :: Mode
- -> Int -- Line length
- -> Float -- Ribbons per line
- -> (TextDetails -> a -> a) -- What to do with text
- -> a -- What to do at the end
- -> Doc
- -> a -- Result
-
-renderStyle :: Style -> Doc -> String
-data Style = Style { lineLength :: Int, -- In chars
- ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
- mode :: Mode
- }
-style :: Style -- The default style
-style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
-
-data Mode = PageMode -- Normal
- | ZigZagMode -- With zig-zag cuts
- | LeftMode -- No indentation, infinitely long lines
- | OneLineMode -- All on one line
-
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{The @Doc@ calculus}
-* *
-*********************************************************
-
-The @Doc@ combinators satisfy the following laws:
-\begin{verbatim}
-Laws for $$
-~~~~~~~~~~~
- (x $$ y) $$ z = x $$ (y $$ z)
- empty $$ x = x
- x $$ empty = x
-
- ...ditto $+$...
-
-Laws for <>
-~~~~~~~~~~~
- (x <> y) <> z = x <> (y <> z)
- empty <> x = empty
- x <> empty = x
-
- ...ditto <+>...
-
-Laws for text
-~~~~~~~~~~~~~
- text s <> text t = text (s++t)
- text "" <> x = x, if x non-empty
-
-Laws for nest
-~~~~~~~~~~~~~
- nest 0 x = x
- nest k (nest k' x) = nest (k+k') x
- nest k (x <> y) = nest k z <> nest k y
- nest k (x $$ y) = nest k x $$ nest k y
- nest k empty = empty
- x <> nest k y = x <> y, if x non-empty
-
-** Note the side condition on ! It is this that
-** makes it OK for empty to be a left unit for <>.
-
-Miscellaneous
-~~~~~~~~~~~~~
- (text s <> x) $$ y = text s <> ((text "" <> x)) $$
- nest (-length s) y)
-
- (x $$ y) <> z = x $$ (y <> z)
- if y non-empty
-
-
-Laws for list versions
-~~~~~~~~~~~~~~~~~~~~~~
- sep (ps++[empty]++qs) = sep (ps ++ qs)
- ...ditto hsep, hcat, vcat, fill...
-
- nest k (sep ps) = sep (map (nest k) ps)
- ...ditto hsep, hcat, vcat, fill...
-
-Laws for oneLiner
-~~~~~~~~~~~~~~~~~
- oneLiner (nest k p) = nest k (oneLiner p)
- oneLiner (x <> y) = oneLiner x <> oneLiner y
-\end{verbatim}
-
-
-You might think that the following verion of would
-be neater:
-\begin{verbatim}
-<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
- nest (-length s) y)
-\end{verbatim}
-But it doesn't work, for if x=empty, we would have
-\begin{verbatim}
- text s $$ y = text s <> (empty $$ nest (-length s) y)
- = text s <> nest (-length s) y
-\end{verbatim}
-
-
-
-*********************************************************
-* *
-\subsection{Simple derived definitions}
-* *
-*********************************************************
-
-\begin{code}
-semi = char ';'
-colon = char ':'
-comma = char ','
-space = char ' '
-equals = char '='
-lparen = char '('
-rparen = char ')'
-lbrack = char '['
-rbrack = char ']'
-lbrace = char '{'
-rbrace = char '}'
-
-int n = text (show n)
-integer n = text (show n)
-float n = text (show n)
-double n = text (show n)
-rational n = text (show n)
--- SIGBJORN wrote instead:
--- rational n = text (show (fromRationalX n))
-
-quotes p = char '`' <> p <> char '\''
-doubleQuotes p = char '"' <> p <> char '"'
-parens p = char '(' <> p <> char ')'
-brackets p = char '[' <> p <> char ']'
-braces p = char '{' <> p <> char '}'
-
-
-hcat = foldr (<>) empty
-hsep = foldr (<+>) empty
-vcat = foldr ($$) empty
-
-hang d1 n d2 = d1 $$ (nest n d2)
-
-punctuate p [] = []
-punctuate p (d:ds) = go d ds
- where
- go d [] = [d]
- go d (e:es) = (d <> p) : go e es
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{The @Doc@ data type}
-* *
-*********************************************************
-
-A @Doc@ represents a {\em set} of layouts. A @Doc@ with
-no occurrences of @Union@ or @NoDoc@ represents just one layout.
-\begin{code}
-data Doc
- = Empty -- empty
- | NilAbove Doc -- text "" $$ x
- | TextBeside TextDetails Int Doc -- text s <> x
- | Nest Int Doc -- nest k x
- | Union Doc Doc -- ul `union` ur
- | NoDoc -- The empty set of documents
- | Beside Doc Bool Doc -- True <=> space between
- | Above Doc Bool Doc -- True <=> never overlap
-
-type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
-
-
-reduceDoc :: Doc -> RDoc
-reduceDoc (Beside p g q) = beside p g (reduceDoc q)
-reduceDoc (Above p g q) = above p g (reduceDoc q)
-reduceDoc p = p
-
-
-data TextDetails = Chr Char
- | Str String
- | PStr String
-space_text = Chr ' '
-nl_text = Chr '\n'
-\end{code}
-
-Here are the invariants:
-\begin{itemize}
-\item
-The argument of @NilAbove@ is never @Empty@. Therefore
-a @NilAbove@ occupies at least two lines.
-
-\item
-The arugment of @TextBeside@ is never @Nest@.
-
-\item
-The layouts of the two arguments of @Union@ both flatten to the same string.
-
-\item
-The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
-
-\item
-The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
-If the left argument of a union is equivalent to the empty set (@NoDoc@),
-then the @NoDoc@ appears in the first line.
-
-\item
-An empty document is always represented by @Empty@.
-It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
-
-\item
-The first line of every layout in the left argument of @Union@
-is longer than the first line of any layout in the right argument.
-(1) ensures that the left argument has a first line. In view of (3),
-this invariant means that the right argument must have at least two
-lines.
-\end{itemize}
-
-\begin{code}
- -- Arg of a NilAbove is always an RDoc
-nilAbove_ p = NilAbove p
-
- -- Arg of a TextBeside is always an RDoc
-textBeside_ s sl p = TextBeside s sl p
-
- -- Arg of Nest is always an RDoc
-nest_ k p = Nest k p
-
- -- Args of union are always RDocs
-union_ p q = Union p q
-
-\end{code}
-
-
-Notice the difference between
- * NoDoc (no documents)
- * Empty (one empty document; no height and no width)
- * text "" (a document containing the empty string;
- one line high, but has no width)
-
-
-
-*********************************************************
-* *
-\subsection{@empty@, @text@, @nest@, @union@}
-* *
-*********************************************************
-
-\begin{code}
-empty = Empty
-
-char c = textBeside_ (Chr c) 1 Empty
-text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
-ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
-
-nest k p = mkNest k (reduceDoc p) -- Externally callable version
-
--- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
-mkNest k (Nest k1 p) = mkNest (k + k1) p
-mkNest k NoDoc = NoDoc
-mkNest k Empty = Empty
-mkNest 0 p = p -- Worth a try!
-mkNest k p = nest_ k p
-
--- mkUnion checks for an empty document
-mkUnion Empty q = Empty
-mkUnion p q = p `union_` q
-\end{code}
-
-*********************************************************
-* *
-\subsection{Vertical composition @$$@}
-* *
-*********************************************************
-
-
-\begin{code}
-p $$ q = Above p False q
-p $+$ q = Above p True q
-
-above :: Doc -> Bool -> RDoc -> RDoc
-above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
-above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
-above p g q = aboveNest p g 0 (reduceDoc q)
-
-aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
--- Specfication: aboveNest p g k q = p $g$ (nest k q)
-
-aboveNest NoDoc g k q = NoDoc
-aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
- aboveNest p2 g k q
-
-aboveNest Empty g k q = mkNest k q
-aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
- -- p can't be Empty, so no need for mkNest
-
-aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
-aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
- where
- k1 = k - sl
- rest = case p of
- Empty -> nilAboveNest g k1 q
- other -> aboveNest p g k1 q
-\end{code}
-
-\begin{code}
-nilAboveNest :: Bool -> Int -> RDoc -> RDoc
--- Specification: text s <> nilaboveNest g k q
--- = text s <> (text "" $g$ nest k q)
-
-nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
-
-nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap
- = textBeside_ (Str (spaces k)) k q
- | otherwise -- Put them really above
- = nilAbove_ (mkNest k q)
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Horizontal composition @<>@}
-* *
-*********************************************************
-
-\begin{code}
-p <> q = Beside p False q
-p <+> q = Beside p True q
-
-beside :: Doc -> Bool -> RDoc -> RDoc
--- Specification: beside g p q = p q
-
-beside NoDoc g q = NoDoc
-beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
-beside Empty g q = q
-beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
-beside p@(Beside p1 g1 q1) g2 q2
- {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
- [ && (op1 == <> || op1 == <+>) ] -}
- | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
- | otherwise = beside (reduceDoc p) g2 q2
-beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
-beside (NilAbove p) g q = nilAbove_ (beside p g q)
-beside (TextBeside s sl p) g q = textBeside_ s sl rest
- where
- rest = case p of
- Empty -> nilBeside g q
- other -> beside p g q
-\end{code}
-
-\begin{code}
-nilBeside :: Bool -> RDoc -> RDoc
--- Specification: text "" <> nilBeside g p
--- = text "" p
-
-nilBeside g Empty = Empty -- Hence the text "" in the spec
-nilBeside g (Nest _ p) = nilBeside g p
-nilBeside g p | g = textBeside_ space_text 1 p
- | otherwise = p
-\end{code}
-
-*********************************************************
-* *
-\subsection{Separate, @sep@, Hughes version}
-* *
-*********************************************************
-
-\begin{code}
--- Specification: sep ps = oneLiner (hsep ps)
--- `union`
--- vcat ps
-
-sep = sepX True -- Separate with spaces
-cat = sepX False -- Don't
-
-sepX x [] = empty
-sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
-
-
--- Specification: sep1 g k ys = sep (x : map (nest k) ys)
--- = oneLiner (x nest k (hsep ys))
--- `union` x $$ nest k (vcat ys)
-
-sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
-sep1 g NoDoc k ys = NoDoc
-sep1 g (p `Union` q) k ys = sep1 g p k ys
- `union_`
- (aboveNest q False k (reduceDoc (vcat ys)))
-
-sep1 g Empty k ys = mkNest k (sepX g ys)
-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
-
-sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
-
--- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
--- Called when we have already found some text in the first item
--- We have to eat up nests
-
-sepNB g (Nest _ p) k ys = sepNB g p k ys
-
-sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
- `mkUnion`
- nilAboveNest False k (reduceDoc (vcat ys))
- where
- rest | g = hsep ys
- | otherwise = hcat ys
-
-sepNB g p k ys = sep1 g p k ys
-\end{code}
-
-*********************************************************
-* *
-\subsection{@fill@}
-* *
-*********************************************************
-
-\begin{code}
-fsep = fill True
-fcat = fill False
-
--- Specification:
--- fill [] = empty
--- fill [p] = p
--- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
--- (fill (oneLiner p2 : ps))
--- `union`
--- p1 $$ fill ps
-
-fill g [] = empty
-fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
-
-
-fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
-fill1 g NoDoc k ys = NoDoc
-fill1 g (p `Union` q) k ys = fill1 g p k ys
- `union_`
- (aboveNest q False k (fill g ys))
-
-fill1 g Empty k ys = mkNest k (fill g ys)
-fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
-
-fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
-
-fillNB g (Nest _ p) k ys = fillNB g p k ys
-fillNB g Empty k [] = Empty
-fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
- `mkUnion`
- nilAboveNest False k (fill g (y:ys))
- where
- k1 | g = k - 1
- | otherwise = k
-
-fillNB g p k ys = fill1 g p k ys
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Selecting the best layout}
-* *
-*********************************************************
-
-\begin{code}
-best :: Mode
- -> Int -- Line length
- -> Int -- Ribbon length
- -> RDoc
- -> RDoc -- No unions in here!
-
-best OneLineMode w r p
- = get p
- where
- get Empty = Empty
- get NoDoc = NoDoc
- get (NilAbove p) = nilAbove_ (get p)
- get (TextBeside s sl p) = textBeside_ s sl (get p)
- get (Nest k p) = get p -- Elide nest
- get (p `Union` q) = first (get p) (get q)
-
-best mode w r p
- = get w p
- where
- get :: Int -- (Remaining) width of line
- -> Doc -> Doc
- get w Empty = Empty
- get w NoDoc = NoDoc
- get w (NilAbove p) = nilAbove_ (get w p)
- get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
- get w (Nest k p) = nest_ k (get (w - k) p)
- get w (p `Union` q) = nicest w r (get w p) (get w q)
-
- get1 :: Int -- (Remaining) width of line
- -> Int -- Amount of first line already eaten up
- -> Doc -- This is an argument to TextBeside => eat Nests
- -> Doc -- No unions in here!
-
- get1 w sl Empty = Empty
- get1 w sl NoDoc = NoDoc
- get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
- get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
- get1 w sl (Nest k p) = get1 w sl p
- get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
- (get1 w sl q)
-
-nicest w r p q = nicest1 w r 0 p q
-nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
- | otherwise = q
-
-fits :: Int -- Space available
- -> Doc
- -> Bool -- True if *first line* of Doc fits in space available
-
-fits n p | n < 0 = False
-fits n NoDoc = False
-fits n Empty = True
-fits n (NilAbove _) = True
-fits n (TextBeside _ sl p) = fits (n - sl) p
-
-minn x y | x < y = x
- | otherwise = y
-\end{code}
-
-@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
-@first@ returns its first argument if it is non-empty, otherwise its second.
-
-\begin{code}
-first p q | nonEmptySet p = p
- | otherwise = q
-
-nonEmptySet NoDoc = False
-nonEmptySet (p `Union` q) = True
-nonEmptySet Empty = True
-nonEmptySet (NilAbove p) = True -- NoDoc always in first line
-nonEmptySet (TextBeside _ _ p) = nonEmptySet p
-nonEmptySet (Nest _ p) = nonEmptySet p
-\end{code}
-
-@oneLiner@ returns the one-line members of the given set of @Doc@s.
-
-\begin{code}
-oneLiner :: Doc -> Doc
-oneLiner NoDoc = NoDoc
-oneLiner Empty = Empty
-oneLiner (NilAbove p) = NoDoc
-oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
-oneLiner (Nest k p) = nest_ k (oneLiner p)
-oneLiner (p `Union` q) = oneLiner p
-\end{code}
-
-
-
-*********************************************************
-* *
-\subsection{Displaying the best layout}
-* *
-*********************************************************
-
-
-\begin{code}
-renderStyle Style{mode=mode, lineLength=lineLength, ribbonsPerLine=ribbonsPerLine} doc
- = fullRender mode lineLength ribbonsPerLine string_txt "" doc
-
-render doc = showDoc doc ""
-showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
-
-string_txt (Chr c) s = c:s
-string_txt (Str s1) s2 = s1 ++ s2
-string_txt (PStr s1) s2 = s1 ++ s2
-\end{code}
-
-\begin{code}
-
-fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
-
-fullRender mode line_length ribbons_per_line txt end doc
- = display mode line_length ribbon_length txt end best_doc
- where
- best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
-
- hacked_line_length, ribbon_length :: Int
- ribbon_length = round (fromIntegral line_length / ribbons_per_line)
- hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
-
-display mode page_width ribbon_width txt end doc
- = case page_width - ribbon_width of { gap_width ->
- case gap_width `quot` 2 of { shift ->
- let
- lay k (Nest k1 p) = lay (k + k1) p
- lay k Empty = end
-
- lay k (NilAbove p) = nl_text `txt` lay k p
-
- lay k (TextBeside s sl p)
- = case mode of
- ZigZagMode | k >= gap_width
- -> nl_text `txt` (
- Str (multi_ch shift '/') `txt` (
- nl_text `txt` (
- lay1 (k - shift) s sl p)))
-
- | k < 0
- -> nl_text `txt` (
- Str (multi_ch shift '\\') `txt` (
- nl_text `txt` (
- lay1 (k + shift) s sl p )))
-
- other -> lay1 k s sl p
-
- lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
-
- lay2 k (NilAbove p) = nl_text `txt` lay k p
- lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
- lay2 k (Nest _ p) = lay2 k p
- lay2 k Empty = end
- in
- lay 0 doc
- }}
-
-cant_fail = error "easy_display: NoDoc"
-easy_display nl_text txt end doc
- = lay doc cant_fail
- where
- lay NoDoc no_doc = no_doc
- lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
- lay (Nest k p) no_doc = lay p no_doc
- lay Empty no_doc = end
- lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
- lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
-
-indent n | n >= 8 = '\t' : indent (n - 8)
- | otherwise = spaces n
-
-multi_ch 0 ch = ""
-multi_ch n ch = ch : multi_ch (n - 1) ch
-
-spaces 0 = ""
-spaces n = ' ' : spaces (n - 1)
-\end{code}
-
diff --git a/src/PrettyCombinators.lhs b/src/PrettyCombinators.lhs
new file mode 100644
--- /dev/null
+++ b/src/PrettyCombinators.lhs
@@ -0,0 +1,905 @@
+Hand converted to standard Haskell -- jcp
+
+*********************************************************************************
+* *
+* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *
+* *
+* based on "The Design of a Pretty-printing Library" *
+* in Advanced Functional Programming, *
+* Johan Jeuring and Erik Meijer (eds), LNCS 925 *
+* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *
+* *
+* Heavily modified by Simon Peyton Jones, Dec 96 *
+* *
+*********************************************************************************
+
+Version 3.0 28 May 1997
+ * Cured massive performance bug. If you write
+
+ foldl <> empty (map (text.show) [1..10000])
+
+ you get quadratic behaviour with V2.0. Why? For just the same reason as you get
+ quadratic behaviour with left-associated (++) chains.
+
+ This is really bad news. One thing a pretty-printer abstraction should
+ certainly guarantee is insensivity to associativity. It matters: suddenly
+ GHC's compilation times went up by a factor of 100 when I switched to the
+ new pretty printer.
+
+ I fixed it with a bit of a hack (because I wanted to get GHC back on the
+ road). I added two new constructors to the Doc type, Above and Beside:
+
+ <> = Beside
+ $$ = Above
+
+ Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
+ the Doc to squeeze out these suspended calls to Beside and Above; but in so
+ doing I re-associate. It's quite simple, but I'm not satisfied that I've done
+ the best possible job. I'll send you the code if you are interested.
+
+ * Added new exports:
+ punctuate, hang
+ int, integer, float, double, rational,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+ * fullRender's type signature has changed. Rather than producing a string it
+ now takes an extra couple of arguments that tells it how to glue fragments
+ of output together:
+
+ fullRender :: Mode
+ -> Int -- Line length
+ -> Float -- Ribbons per line
+ -> (TextDetails -> a -> a) -- What to do with text
+ -> a -- What to do at the end
+ -> Doc
+ -> a -- Result
+
+ The "fragments" are encapsulated in the TextDetails data type:
+ data TextDetails = Chr Char
+ | Str String
+ | PStr FAST_STRING
+
+ The Chr and Str constructors are obvious enough. The PStr constructor has a packed
+ string (FAST_STRING) inside it. It's generated by using the new "ptext" export.
+
+ An advantage of this new setup is that you can get the renderer to do output
+ directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
+ rather than producing a string that you then print.
+
+
+Version 2.0 24 April 1997
+ * Made empty into a left unit for <> as well as a right unit;
+ it is also now true that
+ nest k empty = empty
+ which wasn't true before.
+
+ * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
+
+ * Added $+$
+
+ * Corrected and tidied up the laws and invariants
+
+======================================================================
+Relative to John's original paper, there are the following new features:
+
+1. There's an empty document, "empty". It's a left and right unit for
+ both <> and $$, and anywhere in the argument list for
+ sep, hcat, hsep, vcat, fcat etc.
+
+ It is Really Useful in practice.
+
+2. There is a paragraph-fill combinator, fsep, that's much like sep,
+ only it keeps fitting things on one line until itc can't fit any more.
+
+3. Some random useful extra combinators are provided.
+ <+> puts its arguments beside each other with a space between them,
+ unless either argument is empty in which case it returns the other
+
+
+ hcat is a list version of <>
+ hsep is a list version of <+>
+ vcat is a list version of $$
+
+ sep (separate) is either like hsep or like vcat, depending on what fits
+
+ cat is behaves like sep, but it uses <> for horizontal conposition
+ fcat is behaves like fsep, but it uses <> for horizontal conposition
+
+ These new ones do the obvious things:
+ char, semi, comma, colon, space,
+ parens, brackets, braces,
+ quotes, doubleQuotes
+
+4. The "above" combinator, $$, now overlaps its two arguments if the
+ last line of the top argument stops before the first line of the second begins.
+ For example: text "hi" $$ nest 5 "there"
+ lays out as
+ hi there
+ rather than
+ hi
+ there
+
+ There are two places this is really useful
+
+ a) When making labelled blocks, like this:
+ Left -> code for left
+ Right -> code for right
+ LongLongLongLabel ->
+ code for longlonglonglabel
+ The block is on the same line as the label if the label is
+ short, but on the next line otherwise.
+
+ b) When laying out lists like this:
+ [ first
+ , second
+ , third
+ ]
+ which some people like. But if the list fits on one line
+ you want [first, second, third]. You can't do this with
+ John's original combinators, but it's quite easy with the
+ new $$.
+
+ The combinator $+$ gives the original "never-overlap" behaviour.
+
+5. Several different renderers are provided:
+ * a standard one
+ * one that uses cut-marks to avoid deeply-nested documents
+ simply piling up in the right-hand margin
+ * one that ignores indentation (fewer chars output; good for machines)
+ * one that ignores indentation and newlines (ditto, only more so)
+
+6. Numerous implementation tidy-ups
+ Use of unboxed data types to speed up the implementation
+
+
+
+\begin{code}
+module PrettyCombinators (
+ Doc, -- Abstract
+ Mode(..), TextDetails(..),
+ Style,
+
+ empty, nest,
+
+ text, char, ptext,
+ int, integer, float, double, rational,
+ parens, brackets, braces, quotes, doubleQuotes,
+ semi, comma, colon, space, equals,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+ (<>), (<+>), hcat, hsep,
+ ($$), ($+$), vcat,
+ sep, cat,
+ fsep, fcat,
+
+ hang, punctuate,
+
+ renderStyle,
+ render, fullRender
+ ) where
+
+-- Don't import Util( assertPanic ) because it makes a loop in the module structure
+
+import Data.Ratio
+infixl 6 <>
+infixl 6 <+>
+infixl 5 $$, $+$
+\end{code}
+
+
+
+*********************************************************
+* *
+\subsection{CPP magic so that we can compile with both GHC and Hugs}
+* *
+*********************************************************
+
+The library uses unboxed types to get a bit more speed, but these CPP macros
+allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
+ __GLASGOW_HASKELL__
+
+
+*********************************************************
+* *
+\subsection{The interface}
+* *
+*********************************************************
+
+The primitive @Doc@ values
+
+\begin{code}
+empty :: Doc
+text :: String -> Doc
+char :: Char -> Doc
+
+semi, comma, colon, space, equals :: Doc
+lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
+
+parens, brackets, braces :: Doc -> Doc
+quotes, doubleQuotes :: Doc -> Doc
+
+int :: Int -> Doc
+integer :: Integer -> Doc
+float :: Float -> Doc
+double :: Double -> Doc
+rational :: Rational -> Doc
+\end{code}
+
+
+Combining @Doc@ values
+
+\begin{code}
+(<>) :: Doc -> Doc -> Doc -- Beside
+hcat :: [Doc] -> Doc -- List version of <>
+(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
+hsep :: [Doc] -> Doc -- List version of <+>
+
+($$) :: Doc -> Doc -> Doc -- Above; if there is no
+ -- overlap it "dovetails" the two
+vcat :: [Doc] -> Doc -- List version of $$
+
+cat :: [Doc] -> Doc -- Either hcat or vcat
+sep :: [Doc] -> Doc -- Either hsep or vcat
+fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
+fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
+
+nest :: Int -> Doc -> Doc -- Nested
+\end{code}
+
+GHC-specific ones.
+
+\begin{code}
+hang :: Doc -> Int -> Doc -> Doc
+punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
+\end{code}
+
+Displaying @Doc@ values.
+
+\begin{code}
+instance Show Doc where
+ showsPrec prec doc cont = showDoc doc cont
+
+render :: Doc -> String -- Uses default style
+fullRender :: Mode
+ -> Int -- Line length
+ -> Float -- Ribbons per line
+ -> (TextDetails -> a -> a) -- What to do with text
+ -> a -- What to do at the end
+ -> Doc
+ -> a -- Result
+
+renderStyle :: Style -> Doc -> String
+data Style = Style { lineLength :: Int, -- In chars
+ ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
+ mode :: Mode
+ }
+style :: Style -- The default style
+style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
+
+data Mode = PageMode -- Normal
+ | ZigZagMode -- With zig-zag cuts
+ | LeftMode -- No indentation, infinitely long lines
+ | OneLineMode -- All on one line
+
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{The @Doc@ calculus}
+* *
+*********************************************************
+
+The @Doc@ combinators satisfy the following laws:
+\begin{verbatim}
+Laws for $$
+~~~~~~~~~~~
+ (x $$ y) $$ z = x $$ (y $$ z)
+ empty $$ x = x
+ x $$ empty = x
+
+ ...ditto $+$...
+
+Laws for <>
+~~~~~~~~~~~
+ (x <> y) <> z = x <> (y <> z)
+ empty <> x = empty
+ x <> empty = x
+
+ ...ditto <+>...
+
+Laws for text
+~~~~~~~~~~~~~
+ text s <> text t = text (s++t)
+ text "" <> x = x, if x non-empty
+
+Laws for nest
+~~~~~~~~~~~~~
+ nest 0 x = x
+ nest k (nest k' x) = nest (k+k') x
+ nest k (x <> y) = nest k z <> nest k y
+ nest k (x $$ y) = nest k x $$ nest k y
+ nest k empty = empty
+ x <> nest k y = x <> y, if x non-empty
+
+** Note the side condition on ! It is this that
+** makes it OK for empty to be a left unit for <>.
+
+Miscellaneous
+~~~~~~~~~~~~~
+ (text s <> x) $$ y = text s <> ((text "" <> x)) $$
+ nest (-length s) y)
+
+ (x $$ y) <> z = x $$ (y <> z)
+ if y non-empty
+
+
+Laws for list versions
+~~~~~~~~~~~~~~~~~~~~~~
+ sep (ps++[empty]++qs) = sep (ps ++ qs)
+ ...ditto hsep, hcat, vcat, fill...
+
+ nest k (sep ps) = sep (map (nest k) ps)
+ ...ditto hsep, hcat, vcat, fill...
+
+Laws for oneLiner
+~~~~~~~~~~~~~~~~~
+ oneLiner (nest k p) = nest k (oneLiner p)
+ oneLiner (x <> y) = oneLiner x <> oneLiner y
+\end{verbatim}
+
+
+You might think that the following verion of would
+be neater:
+\begin{verbatim}
+<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
+ nest (-length s) y)
+\end{verbatim}
+But it doesn't work, for if x=empty, we would have
+\begin{verbatim}
+ text s $$ y = text s <> (empty $$ nest (-length s) y)
+ = text s <> nest (-length s) y
+\end{verbatim}
+
+
+
+*********************************************************
+* *
+\subsection{Simple derived definitions}
+* *
+*********************************************************
+
+\begin{code}
+semi = char ';'
+colon = char ':'
+comma = char ','
+space = char ' '
+equals = char '='
+lparen = char '('
+rparen = char ')'
+lbrack = char '['
+rbrack = char ']'
+lbrace = char '{'
+rbrace = char '}'
+
+int n = text (show n)
+integer n = text (show n)
+float n = text (show n)
+double n = text (show n)
+rational n = text (show n)
+-- SIGBJORN wrote instead:
+-- rational n = text (show (fromRationalX n))
+
+quotes p = char '`' <> p <> char '\''
+doubleQuotes p = char '"' <> p <> char '"'
+parens p = char '(' <> p <> char ')'
+brackets p = char '[' <> p <> char ']'
+braces p = char '{' <> p <> char '}'
+
+
+hcat = foldr (<>) empty
+hsep = foldr (<+>) empty
+vcat = foldr ($$) empty
+
+hang d1 n d2 = d1 $$ (nest n d2)
+
+punctuate p [] = []
+punctuate p (d:ds) = go d ds
+ where
+ go d [] = [d]
+ go d (e:es) = (d <> p) : go e es
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{The @Doc@ data type}
+* *
+*********************************************************
+
+A @Doc@ represents a {\em set} of layouts. A @Doc@ with
+no occurrences of @Union@ or @NoDoc@ represents just one layout.
+\begin{code}
+data Doc
+ = Empty -- empty
+ | NilAbove Doc -- text "" $$ x
+ | TextBeside TextDetails Int Doc -- text s <> x
+ | Nest Int Doc -- nest k x
+ | Union Doc Doc -- ul `union` ur
+ | NoDoc -- The empty set of documents
+ | Beside Doc Bool Doc -- True <=> space between
+ | Above Doc Bool Doc -- True <=> never overlap
+
+type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
+
+
+reduceDoc :: Doc -> RDoc
+reduceDoc (Beside p g q) = beside p g (reduceDoc q)
+reduceDoc (Above p g q) = above p g (reduceDoc q)
+reduceDoc p = p
+
+
+data TextDetails = Chr Char
+ | Str String
+ | PStr String
+space_text = Chr ' '
+nl_text = Chr '\n'
+\end{code}
+
+Here are the invariants:
+\begin{itemize}
+\item
+The argument of @NilAbove@ is never @Empty@. Therefore
+a @NilAbove@ occupies at least two lines.
+
+\item
+The arugment of @TextBeside@ is never @Nest@.
+
+\item
+The layouts of the two arguments of @Union@ both flatten to the same string.
+
+\item
+The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
+
+\item
+The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
+If the left argument of a union is equivalent to the empty set (@NoDoc@),
+then the @NoDoc@ appears in the first line.
+
+\item
+An empty document is always represented by @Empty@.
+It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
+
+\item
+The first line of every layout in the left argument of @Union@
+is longer than the first line of any layout in the right argument.
+(1) ensures that the left argument has a first line. In view of (3),
+this invariant means that the right argument must have at least two
+lines.
+\end{itemize}
+
+\begin{code}
+ -- Arg of a NilAbove is always an RDoc
+nilAbove_ p = NilAbove p
+
+ -- Arg of a TextBeside is always an RDoc
+textBeside_ s sl p = TextBeside s sl p
+
+ -- Arg of Nest is always an RDoc
+nest_ k p = Nest k p
+
+ -- Args of union are always RDocs
+union_ p q = Union p q
+
+\end{code}
+
+
+Notice the difference between
+ * NoDoc (no documents)
+ * Empty (one empty document; no height and no width)
+ * text "" (a document containing the empty string;
+ one line high, but has no width)
+
+
+
+*********************************************************
+* *
+\subsection{@empty@, @text@, @nest@, @union@}
+* *
+*********************************************************
+
+\begin{code}
+empty = Empty
+
+char c = textBeside_ (Chr c) 1 Empty
+text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
+ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
+
+nest k p = mkNest k (reduceDoc p) -- Externally callable version
+
+-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
+mkNest k (Nest k1 p) = mkNest (k + k1) p
+mkNest k NoDoc = NoDoc
+mkNest k Empty = Empty
+mkNest 0 p = p -- Worth a try!
+mkNest k p = nest_ k p
+
+-- mkUnion checks for an empty document
+mkUnion Empty q = Empty
+mkUnion p q = p `union_` q
+\end{code}
+
+*********************************************************
+* *
+\subsection{Vertical composition @$$@}
+* *
+*********************************************************
+
+
+\begin{code}
+p $$ q = Above p False q
+p $+$ q = Above p True q
+
+above :: Doc -> Bool -> RDoc -> RDoc
+above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
+above p g q = aboveNest p g 0 (reduceDoc q)
+
+aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
+-- Specfication: aboveNest p g k q = p $g$ (nest k q)
+
+aboveNest NoDoc g k q = NoDoc
+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
+ aboveNest p2 g k q
+
+aboveNest Empty g k q = mkNest k q
+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
+ -- p can't be Empty, so no need for mkNest
+
+aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
+aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
+ where
+ k1 = k - sl
+ rest = case p of
+ Empty -> nilAboveNest g k1 q
+ other -> aboveNest p g k1 q
+\end{code}
+
+\begin{code}
+nilAboveNest :: Bool -> Int -> RDoc -> RDoc
+-- Specification: text s <> nilaboveNest g k q
+-- = text s <> (text "" $g$ nest k q)
+
+nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
+
+nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap
+ = textBeside_ (Str (spaces k)) k q
+ | otherwise -- Put them really above
+ = nilAbove_ (mkNest k q)
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{Horizontal composition @<>@}
+* *
+*********************************************************
+
+\begin{code}
+p <> q = Beside p False q
+p <+> q = Beside p True q
+
+beside :: Doc -> Bool -> RDoc -> RDoc
+-- Specification: beside g p q = p q
+
+beside NoDoc g q = NoDoc
+beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
+beside Empty g q = q
+beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty
+beside p@(Beside p1 g1 q1) g2 q2
+ {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
+ [ && (op1 == <> || op1 == <+>) ] -}
+ | g1 == g2 = beside p1 g1 (beside q1 g2 q2)
+ | otherwise = beside (reduceDoc p) g2 q2
+beside p@(Above _ _ _) g q = beside (reduceDoc p) g q
+beside (NilAbove p) g q = nilAbove_ (beside p g q)
+beside (TextBeside s sl p) g q = textBeside_ s sl rest
+ where
+ rest = case p of
+ Empty -> nilBeside g q
+ other -> beside p g q
+\end{code}
+
+\begin{code}
+nilBeside :: Bool -> RDoc -> RDoc
+-- Specification: text "" <> nilBeside g p
+-- = text "" p
+
+nilBeside g Empty = Empty -- Hence the text "" in the spec
+nilBeside g (Nest _ p) = nilBeside g p
+nilBeside g p | g = textBeside_ space_text 1 p
+ | otherwise = p
+\end{code}
+
+*********************************************************
+* *
+\subsection{Separate, @sep@, Hughes version}
+* *
+*********************************************************
+
+\begin{code}
+-- Specification: sep ps = oneLiner (hsep ps)
+-- `union`
+-- vcat ps
+
+sep = sepX True -- Separate with spaces
+cat = sepX False -- Don't
+
+sepX x [] = empty
+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
+
+
+-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
+-- = oneLiner (x nest k (hsep ys))
+-- `union` x $$ nest k (vcat ys)
+
+sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
+sep1 g NoDoc k ys = NoDoc
+sep1 g (p `Union` q) k ys = sep1 g p k ys
+ `union_`
+ (aboveNest q False k (reduceDoc (vcat ys)))
+
+sep1 g Empty k ys = mkNest k (sepX g ys)
+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
+
+sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
+
+-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
+-- Called when we have already found some text in the first item
+-- We have to eat up nests
+
+sepNB g (Nest _ p) k ys = sepNB g p k ys
+
+sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
+ `mkUnion`
+ nilAboveNest False k (reduceDoc (vcat ys))
+ where
+ rest | g = hsep ys
+ | otherwise = hcat ys
+
+sepNB g p k ys = sep1 g p k ys
+\end{code}
+
+*********************************************************
+* *
+\subsection{@fill@}
+* *
+*********************************************************
+
+\begin{code}
+fsep = fill True
+fcat = fill False
+
+-- Specification:
+-- fill [] = empty
+-- fill [p] = p
+-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
+-- (fill (oneLiner p2 : ps))
+-- `union`
+-- p1 $$ fill ps
+
+fill g [] = empty
+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
+
+
+fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
+fill1 g NoDoc k ys = NoDoc
+fill1 g (p `Union` q) k ys = fill1 g p k ys
+ `union_`
+ (aboveNest q False k (fill g ys))
+
+fill1 g Empty k ys = mkNest k (fill g ys)
+fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
+
+fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
+
+fillNB g (Nest _ p) k ys = fillNB g p k ys
+fillNB g Empty k [] = Empty
+fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
+ `mkUnion`
+ nilAboveNest False k (fill g (y:ys))
+ where
+ k1 | g = k - 1
+ | otherwise = k
+
+fillNB g p k ys = fill1 g p k ys
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{Selecting the best layout}
+* *
+*********************************************************
+
+\begin{code}
+best :: Mode
+ -> Int -- Line length
+ -> Int -- Ribbon length
+ -> RDoc
+ -> RDoc -- No unions in here!
+
+best OneLineMode w r p
+ = get p
+ where
+ get Empty = Empty
+ get NoDoc = NoDoc
+ get (NilAbove p) = nilAbove_ (get p)
+ get (TextBeside s sl p) = textBeside_ s sl (get p)
+ get (Nest k p) = get p -- Elide nest
+ get (p `Union` q) = first (get p) (get q)
+
+best mode w r p
+ = get w p
+ where
+ get :: Int -- (Remaining) width of line
+ -> Doc -> Doc
+ get w Empty = Empty
+ get w NoDoc = NoDoc
+ get w (NilAbove p) = nilAbove_ (get w p)
+ get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
+ get w (Nest k p) = nest_ k (get (w - k) p)
+ get w (p `Union` q) = nicest w r (get w p) (get w q)
+
+ get1 :: Int -- (Remaining) width of line
+ -> Int -- Amount of first line already eaten up
+ -> Doc -- This is an argument to TextBeside => eat Nests
+ -> Doc -- No unions in here!
+
+ get1 w sl Empty = Empty
+ get1 w sl NoDoc = NoDoc
+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
+ get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
+ get1 w sl (Nest k p) = get1 w sl p
+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
+ (get1 w sl q)
+
+nicest w r p q = nicest1 w r 0 p q
+nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
+ | otherwise = q
+
+fits :: Int -- Space available
+ -> Doc
+ -> Bool -- True if *first line* of Doc fits in space available
+
+fits n p | n < 0 = False
+fits n NoDoc = False
+fits n Empty = True
+fits n (NilAbove _) = True
+fits n (TextBeside _ sl p) = fits (n - sl) p
+
+minn x y | x < y = x
+ | otherwise = y
+\end{code}
+
+@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
+@first@ returns its first argument if it is non-empty, otherwise its second.
+
+\begin{code}
+first p q | nonEmptySet p = p
+ | otherwise = q
+
+nonEmptySet NoDoc = False
+nonEmptySet (p `Union` q) = True
+nonEmptySet Empty = True
+nonEmptySet (NilAbove p) = True -- NoDoc always in first line
+nonEmptySet (TextBeside _ _ p) = nonEmptySet p
+nonEmptySet (Nest _ p) = nonEmptySet p
+\end{code}
+
+@oneLiner@ returns the one-line members of the given set of @Doc@s.
+
+\begin{code}
+oneLiner :: Doc -> Doc
+oneLiner NoDoc = NoDoc
+oneLiner Empty = Empty
+oneLiner (NilAbove p) = NoDoc
+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
+oneLiner (Nest k p) = nest_ k (oneLiner p)
+oneLiner (p `Union` q) = oneLiner p
+\end{code}
+
+
+
+*********************************************************
+* *
+\subsection{Displaying the best layout}
+* *
+*********************************************************
+
+
+\begin{code}
+renderStyle Style{mode=mode, lineLength=lineLength, ribbonsPerLine=ribbonsPerLine} doc
+ = fullRender mode lineLength ribbonsPerLine string_txt "" doc
+
+render doc = showDoc doc ""
+showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
+
+string_txt (Chr c) s = c:s
+string_txt (Str s1) s2 = s1 ++ s2
+string_txt (PStr s1) s2 = s1 ++ s2
+\end{code}
+
+\begin{code}
+
+fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
+fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
+
+fullRender mode line_length ribbons_per_line txt end doc
+ = display mode line_length ribbon_length txt end best_doc
+ where
+ best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
+
+ hacked_line_length, ribbon_length :: Int
+ ribbon_length = round (fromIntegral line_length / ribbons_per_line)
+ hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
+
+display mode page_width ribbon_width txt end doc
+ = case page_width - ribbon_width of { gap_width ->
+ case gap_width `quot` 2 of { shift ->
+ let
+ lay k (Nest k1 p) = lay (k + k1) p
+ lay k Empty = end
+
+ lay k (NilAbove p) = nl_text `txt` lay k p
+
+ lay k (TextBeside s sl p)
+ = case mode of
+ ZigZagMode | k >= gap_width
+ -> nl_text `txt` (
+ Str (multi_ch shift '/') `txt` (
+ nl_text `txt` (
+ lay1 (k - shift) s sl p)))
+
+ | k < 0
+ -> nl_text `txt` (
+ Str (multi_ch shift '\\') `txt` (
+ nl_text `txt` (
+ lay1 (k + shift) s sl p )))
+
+ other -> lay1 k s sl p
+
+ lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
+
+ lay2 k (NilAbove p) = nl_text `txt` lay k p
+ lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
+ lay2 k (Nest _ p) = lay2 k p
+ lay2 k Empty = end
+ in
+ lay 0 doc
+ }}
+
+cant_fail = error "easy_display: NoDoc"
+easy_display nl_text txt end doc
+ = lay doc cant_fail
+ where
+ lay NoDoc no_doc = no_doc
+ lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
+ lay (Nest k p) no_doc = lay p no_doc
+ lay Empty no_doc = end
+ lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
+ lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
+
+indent n | n >= 8 = '\t' : indent (n - 8)
+ | otherwise = spaces n
+
+multi_ch 0 ch = ""
+multi_ch n ch = ch : multi_ch (n - 1) ch
+
+spaces 0 = ""
+spaces n = ' ' : spaces (n - 1)
+\end{code}
+
diff --git a/src/Qual.lhs b/src/Qual.lhs
--- a/src/Qual.lhs
+++ b/src/Qual.lhs
@@ -19,17 +19,16 @@
\em{Note:} The modified version also qualifies type constructors
\begin{verbatim}
-> module Qual(qual,qualGoal) where
+> module Qual(qual) where
+
+> import Curry.Base.Ident
+> import Curry.Syntax
+
> import Base
> import TopEnv
> qual :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl]
> qual m tyEnv ds = map (qualDecl m tyEnv) ds
-
-> qualGoal :: ValueEnv -> Goal -> Goal
-> qualGoal tyEnv (Goal p e ds) =
-> Goal p (qualExpr (mkMIdent []) tyEnv e)
-> (map (qualDecl (mkMIdent []) tyEnv) ds)
> qualDecl :: ModuleIdent -> ValueEnv -> Decl -> Decl
> qualDecl m tyEnv (FunctionDecl p f eqs) =
diff --git a/src/ScopeEnv.hs b/src/ScopeEnv.hs
--- a/src/ScopeEnv.hs
+++ b/src/ScopeEnv.hs
@@ -15,7 +15,7 @@
level, exists, beginScope, endScope, endScopeUp,
toList, toLevelList, currentLevel) where
-import Env
+import qualified Data.Map as Map
import Prelude hiding (lookup)
-------------------------------------------------------------------------------
@@ -23,14 +23,14 @@
-- Returns an empty scope environment
new :: Ord a => ScopeEnv a b
-new = ScopeEnv 0 emptyEnv []
+new = ScopeEnv 0 Map.empty []
-- Inserts a value under a key into the environment of the current scope
insert :: Ord a => a -> b -> ScopeEnv a b -> ScopeEnv a b
insert key val env = modifySE insertLev env
where
- insertLev lev local = bindEnv key (val,lev) local
+ insertLev lev local = Map.insert key (val,lev) local
-- Updates the value stored under an existing key in the environment of
@@ -39,8 +39,8 @@
update key val env = modifySE updateLev env
where
updateLev lev local = maybe local
- (\ (_,lev') -> bindEnv key (val,lev') local)
- (lookupEnv key local)
+ (\ (_,lev') -> Map.insert key (val,lev') local)
+ (Map.lookup key local)
-- Modifies the value of an existing key by applying the function 'fun'
-- in the environment of the current scope
@@ -49,8 +49,8 @@
where
modifyLev lev local
= maybe local
- (\ (val',lev') -> bindEnv key (fun val', lev') local)
- (lookupEnv key local)
+ (\ (val',lev') -> Map.insert key (fun val', lev') local)
+ (Map.lookup key local)
-- Looks up the value which is stored under a key from the environment of
@@ -58,7 +58,7 @@
lookup :: Ord a => a -> ScopeEnv a b -> Maybe b
lookup key env = selectSE lookupLev env
where
- lookupLev lev local = maybe Nothing (Just . fst) (lookupEnv key local)
+ lookupLev lev local = maybe Nothing (Just . fst) (Map.lookup key local)
-- Similar to 'lookup', but returns an alternative value, if the key
@@ -71,14 +71,14 @@
level :: Ord a => a -> ScopeEnv a b -> Int
level key env = selectSE levelLev env
where
- levelLev lev local = maybe (-1) snd (lookupEnv key local)
+ levelLev lev local = maybe (-1) snd (Map.lookup key local)
-- Checks, whether a key exists in the environment of the current scope
exists :: Ord a => a -> ScopeEnv a b -> Bool
exists key env = selectSE existsLev env
where
- existsLev lev local = maybe False (const True) (lookupEnv key local)
+ existsLev lev local = maybe False (const True) (Map.lookup key local)
-- Switches to the next scope (i.e. pushes the environment of the current
@@ -106,18 +106,18 @@
endScopeUp (ScopeEnv _ top [])
= ScopeEnv 0 top []
endScopeUp (ScopeEnv lev top (local:[]))
- = ScopeEnv 0 (foldr (updateSE local) top (envToList top)) []
+ = ScopeEnv 0 (foldr (updateSE local) top (Map.toList top)) []
endScopeUp (ScopeEnv lev top (local:local':locals))
= ScopeEnv (lev - 1)
top
- ((foldr (updateSE local) local' (envToList local')):locals)
+ ((foldr (updateSE local) local' (Map.toList local')):locals)
-- Returns the environment of current scope as a (key,value) list
toList :: Ord a => ScopeEnv a b -> [(a,b)]
toList env = selectSE toListLev env
where
- toListLev lev local = map (\ (key,(val,_)) -> (key,val)) (envToList local)
+ toListLev lev local = map (\ (key,(val,_)) -> (key,val)) (Map.toList local)
-- Returns all (key,value) pairs from the environment of the current scope
@@ -127,7 +127,7 @@
where
toLevelListLev lev local
= map (\ (key,(val,_)) -> (key,val))
- (filter (\ (_,(_,lev')) -> lev' == lev) (envToList local))
+ (filter (\ (_,(_,lev')) -> lev' == lev) (Map.toList local))
-- Returns the current level
@@ -140,7 +140,7 @@
-- Privates...
--
-modifySE :: (Int -> Env a (b,Int) -> Env a (b,Int)) -> ScopeEnv a b
+modifySE :: (Int -> Map.Map a (b,Int) -> Map.Map a (b,Int)) -> ScopeEnv a b
-> ScopeEnv a b
modifySE f (ScopeEnv _ top [])
= ScopeEnv 0 (f 0 top) []
@@ -148,19 +148,19 @@
= ScopeEnv lev top ((f lev local):locals)
--
-selectSE :: (Int -> Env a (b,Int) -> c) -> ScopeEnv a b -> c
+selectSE :: (Int -> Map.Map a (b,Int) -> c) -> ScopeEnv a b -> c
selectSE f (ScopeEnv _ top []) = f 0 top
selectSE f (ScopeEnv lev _ (local:_)) = f lev local
--
-updateSE :: Ord a => Env a (b,Int) -> (a,(b,Int)) -> Env a (b,Int)
- -> Env a (b,Int)
+updateSE :: Ord a => Map.Map a (b,Int) -> (a,(b,Int)) -> Map.Map a (b,Int)
+ -> Map.Map a (b,Int)
updateSE local (key,(_,lev)) local'
= maybe local'
(\ (val',lev')
- -> if lev == lev' then bindEnv key (val',lev) local'
+ -> if lev == lev' then Map.insert key (val',lev) local'
else local')
- (lookupEnv key local)
+ (Map.lookup key local)
@@ -168,7 +168,7 @@
-------------------------------------------------------------------------------
-- Data type for representing information in nested scopes.
-data ScopeEnv a b = ScopeEnv Int (Env a (b,Int)) [Env a (b,Int)]
+data ScopeEnv a b = ScopeEnv Int (Map.Map a (b,Int)) [Map.Map a (b,Int)]
deriving Show
diff --git a/src/ShowCurrySyntax.hs b/src/ShowCurrySyntax.hs
deleted file mode 100644
--- a/src/ShowCurrySyntax.hs
+++ /dev/null
@@ -1,493 +0,0 @@
---- Transform a CurrySyntax module into a string representation without any
---- pretty printing.
---- Behaves like a derived Show instance even on parts with a specific one.
----
---- @author Sebastian Fischer (sebf@informatik.uni-kiel.de)
---- @version December 2008
---- bug fixed by bbr
-
-
-module ShowCurrySyntax ( showModule ) where
-
-import Ident
-import Position
-import CurrySyntax
-
-showModule :: Module -> String
-showModule m = showsModule m "\n"
-
-showsModule :: Module -> ShowS
-showsModule (Module mident espec decls)
- = showsString "Module "
- . showsModuleIdent mident . newline
- . showsMaybe showsExportSpec espec . newline
- . showsList (\d -> showsDecl d . newline) decls
-
-showsPosition :: Position -> ShowS
-showsPosition Position{line=row,column=col} = showsPair shows shows (row,col)
--- showsPosition (Position file row col)
--- = showsString "(Position "
--- . shows file . space
--- . shows row . space
--- . shows col
--- . showsString ")"
-
-showsExportSpec :: ExportSpec -> ShowS
-showsExportSpec (Exporting pos exports)
- = showsString "(Exporting "
- . showsPosition pos . space
- . showsList showsExport exports
- . showsString ")"
-
-showsExport :: Export -> ShowS
-showsExport (Export qident)
- = showsString "(Export " . showsQualIdent qident . showsString ")"
-showsExport (ExportTypeWith qident ids)
- = showsString "(ExportTypeWith "
- . showsQualIdent qident . space
- . showsList showsIdent ids
- . showsString ")"
-showsExport (ExportTypeAll qident)
- = showsString "(ExportTypeAll " . showsQualIdent qident . showsString ")"
-showsExport (ExportModule m)
- = showsString "(ExportModule " . showsModuleIdent m . showChar ')'
-
-showsImportSpec :: ImportSpec -> ShowS
-showsImportSpec (Importing pos imports)
- = showsString "(Importing "
- . showsPosition pos . space
- . showsList showsImport imports
- . showsString ")"
-showsImportSpec (Hiding pos imports)
- = showsString "(Hiding "
- . showsPosition pos . space
- . showsList showsImport imports
- . showsString ")"
-
-showsImport :: Import -> ShowS
-showsImport (Import ident)
- = showsString "(Import " . showsIdent ident . showsString ")"
-showsImport (ImportTypeWith ident idents)
- = showsString "(ImportTypeWith "
- . showsIdent ident . space
- . showsList showsIdent idents
- . showsString ")"
-showsImport (ImportTypeAll ident)
- = showsString "(ImportTypeAll " . showsIdent ident . showsString ")"
-
-showsDecl :: Decl -> ShowS
-showsDecl (ImportDecl pos mident quali mmident mimpspec)
- = showsString "(ImportDecl "
- . showsPosition pos . space
- . showsModuleIdent mident . space
- . shows quali . space
- . showsMaybe showsModuleIdent mmident . space
- . showsMaybe showsImportSpec mimpspec
- . showsString ")"
-showsDecl (InfixDecl pos infx prec idents)
- = showsString "(InfixDecl "
- . showsPosition pos . space
- . shows infx . space
- . shows prec . space
- . showsList showsIdent idents
- . showsString ")"
-showsDecl (DataDecl pos ident idents consdecls)
- = showsString "(DataDecl "
- . showsPosition pos . space
- . showsIdent ident . space
- . showsList showsIdent idents . space
- . showsList showsConsDecl consdecls
- . showsString ")"
-showsDecl (NewtypeDecl pos ident idents newconsdecl)
- = showsString "(NewtypeDecl "
- . showsPosition pos . space
- . showsIdent ident . space
- . showsList showsIdent idents . space
- . showsNewConsDecl newconsdecl
- . showsString ")"
-showsDecl (TypeDecl pos ident idents typ)
- = showsString "(TypeDecl "
- . showsPosition pos . space
- . showsIdent ident . space
- . showsList showsIdent idents . space
- . showsTypeExpr typ
- . showsString ")"
-showsDecl (TypeSig pos idents typ)
- = showsString "(TypeSig "
- . showsPosition pos . space
- . showsList showsIdent idents . space
- . showsTypeExpr typ
- . showsString ")"
-showsDecl (EvalAnnot pos idents annot)
- = showsString "(EvalAnnot "
- . showsPosition pos . space
- . showsList showsIdent idents . space
- . shows annot
- . showsString ")"
-showsDecl (FunctionDecl pos ident eqs)
- = showsString "(FunctionDecl "
- . showsPosition pos . space
- . showsIdent ident . space
- . showsList showsEquation eqs
- . showsString ")"
-showsDecl (ExternalDecl pos cconv mstr ident typ)
- = showsString "(ExternalDecl "
- . showsPosition pos . space
- . shows cconv . space
- . shows mstr . space
- . showsIdent ident . space
- . showsTypeExpr typ
- . showsString ")"
-showsDecl (FlatExternalDecl pos idents)
- = showsString "(FlatExternalDecl "
- . showsPosition pos . space
- . showsList showsIdent idents
- . showsString ")"
-showsDecl (PatternDecl pos cons rhs)
- = showsString "(PatternDecl "
- . showsPosition pos . space
- . showsConsTerm cons . space
- . showsRhs rhs
- . showsString ")"
-showsDecl (ExtraVariables pos idents)
- = showsString "(ExtraVariables "
- . showsPosition pos . space
- . showsList showsIdent idents
- . showsString ")"
-
-showsConsDecl :: ConstrDecl -> ShowS
-showsConsDecl (ConstrDecl pos idents ident types)
- = showsString "(ConstrDecl "
- . showsPosition pos . space
- . showsList showsIdent idents . space
- . showsIdent ident . space
- . showsList showsTypeExpr types
- . showsString ")"
-showsConstrDecl (ConOpDecl pos idents rtyp ident ltyp)
- = showsString "(ConOpDecl "
- . showsPosition pos . space
- . showsList showsIdent idents . space
- . showsTypeExpr rtyp . space
- . showsIdent ident . space
- . showsTypeExpr ltyp
- . showsString ")"
-
-showsNewConsDecl :: NewConstrDecl -> ShowS
-showsNewConsDecl (NewConstrDecl pos idents ident typ)
- = showsString "(NewConstrDecl "
- . showsPosition pos . space
- . showsList showsIdent idents . space
- . showsIdent ident . space
- . showsTypeExpr typ
- . showsString ")"
-
-showsTypeExpr :: TypeExpr -> ShowS
-showsTypeExpr (ConstructorType qident types)
- = showsString "(ConstructorType "
- . showsQualIdent qident . space
- . showsList showsTypeExpr types
- . showsString ")"
-showsTypeExpr (VariableType ident)
- = showsString "(VariableType " . showsIdent ident . showsString ")"
-showsTypeExpr (TupleType types)
- = showsString "(TupleType " . showsList showsTypeExpr types . showsString ")"
-showsTypeExpr (ListType typ)
- = showsString "(ListType " . showsTypeExpr typ . showsString ")"
-showsTypeExpr (ArrowType dom ran)
- = showsString "(ArrowType "
- . showsTypeExpr dom . space
- . showsTypeExpr ran
- . showsString ")"
-showsTypeExpr (RecordType fieldts mtyp)
- = showsString "(RecordType "
- . showsList (showsPair (showsList showsIdent) showsTypeExpr) fieldts . space
- . showsMaybe showsTypeExpr mtyp
- . showsString ")"
-
-showsEquation :: Equation -> ShowS
-showsEquation (Equation pos lhs rhs)
- = showsString "(Equation "
- . showsPosition pos . space
- . showsLhs lhs . space
- . showsRhs rhs
- . showsString ")"
-
-showsLhs :: Lhs -> ShowS
-showsLhs (FunLhs ident conss)
- = showsString "(FunLhs "
- . showsIdent ident . space
- . showsList showsConsTerm conss
- . showsString ")"
-showsLhs (OpLhs cons1 ident cons2)
- = showsString "(OpLhs "
- . showsConsTerm cons1 . space
- . showsIdent ident . space
- . showsConsTerm cons2
- . showsString ")"
-showsLhs (ApLhs lhs conss)
- = showsString "(ApLhs "
- . showsLhs lhs . space
- . showsList showsConsTerm conss
- . showsString ")"
-
-showsRhs :: Rhs -> ShowS
-showsRhs (SimpleRhs pos exp decls)
- = showsString "(SimpleRhs "
- . showsPosition pos . space
- . showsExpression exp . space
- . showsList showsDecl decls
- . showsString ")"
-showsRhs (GuardedRhs cexps decls)
- = showsString "(GuardedRhs "
- . showsList showsCondExpr cexps . space
- . showsList showsDecl decls
- . showsString ")"
-
-showsCondExpr :: CondExpr -> ShowS
-showsCondExpr (CondExpr pos exp1 exp2)
- = showsString "(CondExpr "
- . showsPosition pos . space
- . showsExpression exp1 . space
- . showsExpression exp2
- . showsString ")"
-
-showsLiteral :: Literal -> ShowS
-showsLiteral (Char _ c) = showsString "(Char " . shows c . showsString ")"
-showsLiteral (Int ident n)
- = showsString "(Int "
- . showsIdent ident . space
- . shows n
- . showsString ")"
-showsLiteral (Float _ x) = showsString "(Float " . shows x . showsString ")"
-showsLiteral (String _ s) = showsString "(String " . shows s . showsString ")"
-
-showsConsTerm :: ConstrTerm -> ShowS
-showsConsTerm (LiteralPattern lit)
- = showsString "(LiteralPattern "
- . showsLiteral lit
- . showsString ")"
-showsConsTerm (NegativePattern ident lit)
- = showsString "(NegativePattern "
- . showsIdent ident . space
- . showsLiteral lit
- . showsString ")"
-showsConsTerm (VariablePattern ident)
- = showsString "(VariablePattern "
- . showsIdent ident
- . showsString ")"
-showsConsTerm (ConstructorPattern qident conss)
- = showsString "(ConstructorPattern "
- . showsQualIdent qident . space
- . showsList showsConsTerm conss
- . showsString ")"
-showsConsTerm (InfixPattern cons1 qident cons2)
- = showsString "(InfixPattern "
- . showsConsTerm cons1 . space
- . showsQualIdent qident . space
- . showsConsTerm cons2
- . showsString ")"
-showsConsTerm (ParenPattern cons)
- = showsString "(ParenPattern "
- . showsConsTerm cons
- . showsString ")"
-showsConsTerm (TuplePattern _ conss)
- = showsString "(TuplePattern "
- . showsList showsConsTerm conss
- . showsString ")"
-showsConsTerm (ListPattern _ conss)
- = showsString "(ListPattern "
- . showsList showsConsTerm conss
- . showsString ")"
-showsConsTerm (AsPattern ident cons)
- = showsString "(AsPattern "
- . showsIdent ident . space
- . showsConsTerm cons
- . showsString ")"
-showsConsTerm (LazyPattern _ cons)
- = showsString "(LazyPattern "
- . showsConsTerm cons
- . showsString ")"
-showsConsTerm (FunctionPattern qident conss)
- = showsString "(FunctionPattern "
- . showsQualIdent qident . space
- . showsList showsConsTerm conss
- . showsString ")"
-showsConsTerm (InfixFuncPattern cons1 qident cons2)
- = showsString "(InfixFuncPattern "
- . showsConsTerm cons1 . space
- . showsQualIdent qident . space
- . showsConsTerm cons2
- . showsString ")"
-showsConsTerm (RecordPattern cfields mcons)
- = shows "(RecordPattern "
- . showsList (showsField showsConsTerm) cfields . space
- . showsMaybe showsConsTerm mcons
- . showsString ")"
-
-showsExpression :: Expression -> ShowS
-showsExpression (Literal lit)
- = showsString "(Literal " . showsLiteral lit . showsString ")"
-showsExpression (Variable qident)
- = showsString "(Variable " . showsQualIdent qident . showsString ")"
-showsExpression (Constructor qident)
- = showsString "(Constructor " . showsQualIdent qident . showsString ")"
-showsExpression (Paren exp)
- = showsString "(Paren " . showsExpression exp . showsString ")"
-showsExpression (Typed exp typ)
- = showsString "(Typed "
- . showsExpression exp . space
- . showsTypeExpr typ
- . showsString ")"
-showsExpression (Tuple _ exps)
- = showsString "(Tuple " . showsList showsExpression exps . showsString ")"
-showsExpression (List _ exps)
- = showsString "(List " . showsList showsExpression exps . showsString ")"
-showsExpression (ListCompr _ exp stmts)
- = showsString "(ListCompr "
- . showsExpression exp . space
- . showsList showsStatement stmts
- . showsString ")"
-showsExpression (EnumFrom exp)
- = showsString "(EnumFrom " . showsExpression exp . showsString ")"
-showsExpression (EnumFromThen exp1 exp2)
- = showsString "(EnumFromThen "
- . showsExpression exp1 . space
- . showsExpression exp2
- . showsString ")"
-showsExpression (EnumFromTo exp1 exp2)
- = showsString "(EnumFromTo "
- . showsExpression exp1 . space
- . showsExpression exp2
- . showsString ")"
-showsExpression (EnumFromThenTo exp1 exp2 exp3)
- = showsString "(EnumFromThenTo "
- . showsExpression exp1 . space
- . showsExpression exp2 . space
- . showsExpression exp3
- . showsString ")"
-showsExpression (UnaryMinus ident exp)
- = showsString "(UnaryMinus "
- . showsIdent ident . space
- . showsExpression exp
- . showsString ")"
-showsExpression (Apply exp1 exp2)
- = showsString "(Apply "
- . showsExpression exp1 . space
- . showsExpression exp2
- . showsString ")"
-showsExpression (InfixApply exp1 op exp2)
- = showsString "(InfixApply "
- . showsExpression exp1 . space
- . showsInfixOp op . space
- . showsExpression exp2
- . showsString ")"
-showsExpression (LeftSection exp op)
- = showsString "(LeftSection "
- . showsExpression exp . space
- . showsInfixOp op
- . showsString ")"
-showsExpression (RightSection op exp)
- = showsString "(RightSection "
- . showsInfixOp op . space
- . showsExpression exp
- . showsString ")"
-showsExpression (Lambda _ conss exp)
- = showsString "(Lambda "
- . showsList showsConsTerm conss . space
- . showsExpression exp
- . showsString ")"
-showsExpression (Let decls exp)
- = showsString "(Let "
- . showsList showsDecl decls . space
- . showsExpression exp
- . showsString ")"
-showsExpression (Do stmts exp)
- = showsString "(Do "
- . showsList showsStatement stmts . space
- . showsExpression exp
- . showsString ")"
-showsExpression (IfThenElse _ exp1 exp2 exp3)
- = showsString "(IfThenElse "
- . showsExpression exp1 . space
- . showsExpression exp2 . space
- . showsExpression exp3
- . showsString ")"
-showsExpression (Case _ exp alts)
- = showsString "(Case "
- . showsExpression exp . space
- . showsList showsAlt alts
- . showsString ")"
-showsExpression (RecordConstr efields)
- = showsString "(RecordConstr "
- . showsList (showsField showsExpression) efields
- . showsString ")"
-showsExpression (RecordSelection exp ident)
- = showsString "(RecordSelection "
- . showsExpression exp . space
- . showsIdent ident
- . showsString ")"
-showsExpression (RecordUpdate efields exp)
- = showsString "(RecordUpdate "
- . showsList (showsField showsExpression) efields . space
- . showsExpression exp
- . showsString ")"
-
-showsInfixOp :: InfixOp -> ShowS
-showsInfixOp (InfixOp qident)
- = showsString "(InfixOp " . showsQualIdent qident . showsString ")"
-showsInfixOp (InfixConstr qident)
- = showsString "(InfixConstr " . showsQualIdent qident . showsString ")"
-
-showsStatement :: Statement -> ShowS
-showsStatement (StmtExpr _ exp)
- = showsString "(StmtExpr " . showsExpression exp . showsString ")"
-showsStatement (StmtDecl decls)
- = showsString "(StmtDecl " . showsList showsDecl decls . showsString ")"
-showsStatement (StmtBind _ cons exp)
- = showsString "(StmtBind "
- . showsConsTerm cons . space
- . showsExpression exp
- . showsString ")"
-
-showsAlt :: Alt -> ShowS
-showsAlt (Alt pos cons rhs)
- = showsString "(Alt "
- . showsPosition pos . space
- . showsConsTerm cons . space
- . showsRhs rhs
- . showsString ")"
-
-showsField :: (a -> ShowS) -> Field a -> ShowS
-showsField sa (Field pos ident a)
- = showsString "(Field "
- . showsPosition pos . space
- . showsIdent ident . space
- . sa a
- . showsString ")"
-
-showsString :: String -> ShowS
-showsString = (++)
-
-space :: ShowS
-space = showsString " "
-
-newline :: ShowS
-newline = showsString "\n"
-
-showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS
-showsMaybe shs
- = maybe (showsString "Nothing")
- (\x -> showsString "(Just " . shs x . showsString ")")
-
-showsList :: (a -> ShowS) -> [a] -> ShowS
-showsList _ [] = showsString "[]"
-showsList shs (x:xs)
- = showsString "["
- . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs
- . showsString "]"
-
-showsPair :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS
-showsPair sa sb (a,b)
- = showsString "(" . sa a . showsString "," . sb b . showsString ")"
-
-
diff --git a/src/Simplify.lhs b/src/Simplify.lhs
--- a/src/Simplify.lhs
+++ b/src/Simplify.lhs
@@ -24,17 +24,23 @@
> module Simplify(simplify) where
-> import Control.Monad
+> import Control.Monad.Reader as R
+> import Control.Monad.State as S
+> import qualified Data.Map as Map
+> import Curry.Base.Position
+> import Curry.Base.Ident
+> import Curry.Syntax
+> import Curry.Syntax.Utils
+
+> import Types
> import Base
-> import Combined
-> import Env
> import SCC
> import Typing
-> type SimplifyState a = StateT ValueEnv (ReaderT EvalEnv (St Int)) a
-> type InlineEnv = Env Ident Expression
+> type SimplifyState a = S.StateT ValueEnv (ReaderT EvalEnv (S.State Int)) a
+> type InlineEnv = Map.Map Ident Expression
> type SimplifyFlags = Bool
> flatFlag :: SimplifyFlags -> Bool
@@ -42,13 +48,13 @@
> simplify :: SimplifyFlags -> ValueEnv -> EvalEnv -> Module -> (Module,ValueEnv)
> simplify flags tyEnv evEnv m
-> = runSt (callRt (callSt (simplifyModule flags m) tyEnv) evEnv) 1
+> = S.evalState (R.runReaderT (S.evalStateT (simplifyModule flags m) tyEnv) evEnv) 1
> simplifyModule :: SimplifyFlags -> Module -> SimplifyState (Module,ValueEnv)
> simplifyModule flat (Module m es ds) =
> do
-> ds' <- mapM (simplifyDecl flat m emptyEnv) ds
-> tyEnv <- fetchSt
+> ds' <- mapM (simplifyDecl flat m Map.empty) ds
+> tyEnv <- S.get
> return (Module m es ds',tyEnv)
> simplifyDecl :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Decl -> SimplifyState Decl
@@ -135,22 +141,23 @@
> simplifyEquation flat m env (Equation p lhs rhs) =
> do
> rhs' <- simplifyRhs flat m env rhs
-> tyEnv <- fetchSt
-> evEnv <- liftSt envRt
+> tyEnv <- S.get
+> evEnv <- S.lift R.ask
> return (inlineFun flat m tyEnv evEnv p lhs rhs')
> inlineFun :: SimplifyFlags -> ModuleIdent -> ValueEnv -> EvalEnv -> Position -> Lhs -> Rhs
> -> [Equation]
> inlineFun flags m tyEnv evEnv p (FunLhs f ts)
> (SimpleRhs _ (Let [FunctionDecl _ f' eqs'] e) _)
-> | f' `notElem` qfv m eqs' && e' == Variable (qualify f') &&
+> | True -- False -- inlining of functions is deactivated (hsi)
+> && f' `notElem` qfv m eqs' && e' == Variable (qualify f') &&
> n == arrowArity (funType m tyEnv (qualify f')) &&
> (evMode evEnv f == evMode evEnv f' ||
> and [all isVarPattern ts | Equation _ (FunLhs _ ts) _ <- eqs']) =
-> map (merge p f ts' vs') eqs'
+> map (mergeEqns p f ts' vs') eqs'
> where n :: Int -- type signature necessary for nhc
> (n,vs',ts',e') = etaReduce 0 [] (reverse ts) e
-> merge p f ts vs (Equation _ (FunLhs _ ts') rhs) =
+> mergeEqns p f ts vs (Equation _ (FunLhs _ ts') rhs) =
> Equation p (FunLhs f (ts ++ zipWith AsPattern vs ts')) rhs
> etaReduce n vs (VariablePattern v : ts) (Apply e (Variable v'))
> | qualify v == v' = etaReduce (n+1) (v:vs) ts e
@@ -188,7 +195,7 @@
> simplifyExpr flat m env (Variable v)
> | isQualified v = return (Variable v)
> | otherwise = maybe (return (Variable v)) (simplifyExpr flat m env)
-> (lookupEnv (unqualify v) env)
+> (Map.lookup (unqualify v) env)
> simplifyExpr _ _ _ (Constructor c) = return (Constructor c)
> simplifyExpr flags m env (Apply (Let ds e1) e2)
> = simplifyExpr flags m env (Let ds (Apply e1 e2))
@@ -203,7 +210,7 @@
> return (Apply e1' e2')
> simplifyExpr flags m env (Let ds e) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> dss' <- mapM (sharePatternRhs m tyEnv) ds
> simplifyLet flags m env
> (scc bv (qfv m) (foldr (hoistDecls flags) [] (concat dss'))) e
@@ -251,7 +258,7 @@
> simplifyLet flags m env (ds:dss) e =
> do
> ds' <- mapM (simplifyDecl flags m env) ds
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> e' <- simplifyLet flags m (inlineVars flags m tyEnv ds' env) dss e
> dss'' <-
> mapM (expandPatternBindings flags m tyEnv (qfv m ds' ++ qfv m e')) ds'
@@ -260,13 +267,15 @@
> inlineVars :: SimplifyFlags -> ModuleIdent -> ValueEnv -> [Decl] -> InlineEnv -> InlineEnv
> inlineVars flags m tyEnv [PatternDecl _ (VariablePattern v) (SimpleRhs _ e _)] env
-> | canInline e = bindEnv v e env
-> where canInline (Literal _) = True
-> canInline (Constructor _) = True
-> canInline (Variable v')
-> | isQualified v' = arrowArity (funType m tyEnv v') > 0
-> | otherwise = v /= unqualify v'
-> canInline _ = False
+> | canInline e = Map.insert v e env
+> where
+> canInline (Literal _) = True
+> canInline (Constructor _) = True
+> canInline _ = False -- inlining of variables is deactivated (hsi)
+> canInline (Variable v')
+> | isQualified v' = arrowArity (funType m tyEnv v') > 0
+> | otherwise = v /= unqualify v'
+> canInline _ = False
> inlineVars _ _ _ _ env = env
> mkLet :: SimplifyFlags -> ModuleIdent -> [Decl] -> Expression -> Expression
@@ -431,14 +440,14 @@
> _ -> internalError ("funType " ++ show f)
> evMode :: EvalEnv -> Ident -> Maybe EvalAnnotation
-> evMode evEnv f = lookupEnv f evEnv
+> evMode evEnv f = Map.lookup f evEnv
> freshIdent :: ModuleIdent -> (Int -> Ident) -> TypeScheme
> -> SimplifyState Ident
> freshIdent m f ty =
> do
-> x <- liftM f (liftSt (liftRt (updateSt (1 +))))
-> updateSt_ (bindFun m x ty)
+> x <- liftM f (S.lift (R.lift ( S.modify succ >> S.get)))
+> S.modify (bindFun m x ty)
> return x
> shuffle :: [a] -> [[a]]
diff --git a/src/SyntaxCheck.lhs b/src/SyntaxCheck.lhs
--- a/src/SyntaxCheck.lhs
+++ b/src/SyntaxCheck.lhs
@@ -24,12 +24,16 @@
> import Data.Maybe
> import Data.List
-> import Control.Monad
+> import qualified Data.Map as Map
+> import Control.Monad.State as S
+> import Curry.Syntax
+> import Curry.Syntax.Utils
+> import Types
+> import Curry.Base.Position
+> import Curry.Base.Ident
> import Base
-> import Env
> import NestEnv
-> import Combined
> import Utils
\end{verbatim}
@@ -44,8 +48,7 @@
addition, this process will also rename the local variables.
\begin{verbatim}
-> syntaxCheck :: Bool -> ModuleIdent -> ImportEnv -> ArityEnv -> ValueEnv
-> -> TCEnv -> [Decl] -> [Decl]
+> syntaxCheck :: Bool -> ModuleIdent -> ImportEnv -> ArityEnv -> ValueEnv -> TCEnv -> [Decl] -> [Decl]
> syntaxCheck withExt m iEnv aEnv tyEnv tcEnv ds =
> case linear (concatMap constrs tds) of
> --Linear -> tds ++ run (checkModule withExt m env vds)
@@ -59,22 +62,18 @@
> tds'
> env2 = foldr (bindTypes m) env1 rs
-> --syntaxCheckGoal :: Bool -> ValueEnv -> Goal -> Goal
-> --syntaxCheckGoal withExt tyEnv g =
-> -- run (checkGoal withExt (mkMIdent []) (globalEnv (fmap renameInfo tyEnv)) g)
-
\end{verbatim}
A global state transformer is used for generating fresh integer keys
by which the variables get renamed.
\begin{verbatim}
-> type RenameState a = St Int a
+> type RenameState a = S.State Int a
> run :: RenameState a -> a
-> run m = runSt m (globalKey + 1)
+> run m = S.evalState m (globalKey + 1)
> newId :: RenameState Int
-> newId = updateSt (1 +)
+> newId = S.modify succ >> S.get
\end{verbatim}
\ToDo{Probably the state transformer should use an \texttt{Integer}
@@ -113,7 +112,7 @@
> renameInfo tcEnv iEnv aEnv (NewtypeConstructor _ _)
> = Constr 1
> renameInfo tcEnv iEnv aEnv (Value qid _)
-> = let (mmid, id) = splitQualIdent qid
+> = let (mmid, id) = (qualidMod qid, qualidId qid)
> qid' = maybe qid
> (\mid -> maybe qid
> (\mid' -> qualifyWith mid' id)
@@ -234,7 +233,7 @@
> | (isJust mmid) && ((fromJust mmid) == preludeMIdent) && (ident == consId)
> = qualLookupNestEnv (qualify ident) env
> | otherwise = []
-> where (mmid, ident) = splitQualIdent v
+> where (mmid, ident) = (qualidMod v, qualidId v)
> lookupTupleConstr :: Ident -> [RenameInfo]
> lookupTupleConstr v
@@ -256,13 +255,6 @@
> checkTopDecls withExt m env ds =
> checkDeclGroup (bindFuncDecl m) withExt m globalKey env ds
-> --checkGoal :: Bool -> ModuleIdent -> RenameEnv -> Goal -> RenameState Goal
-> --checkGoal withExt m env (Goal p e ds) =
-> -- do
-> -- (env',ds') <- checkLocalDecls withExt m env ds
-> -- e' <- checkExpr withExt p m env' e
-> -- return (Goal p e' ds')
-
> checkTypeDecl :: Bool -> ModuleIdent -> Decl -> Decl
> checkTypeDecl withExt m d@(TypeDecl p r tvs (RecordType fs rty))
> | not withExt = errorAt (positionOfIdent r) noRecordExt
@@ -370,7 +362,7 @@
> | isJust m || isDataConstr op' env =
> checkOpLhs k env (f . InfixPattern t1 op) t2
> | otherwise = Left (op'',OpLhs (f t1) op'' t2)
-> where (m,op') = splitQualIdent op
+> where (m,op') = (qualidMod op, qualidId op)
> op'' = renameIdent op' k
> checkOpLhs _ _ f t = Right (f t)
@@ -591,8 +583,7 @@
> checkConstrTerm withExt k p m env (RecordPattern fs t)
> | not withExt = errorAt p noRecordExt
> | not (null fs) =
-> let (Field _ label patt) = head fs
-> p' = positionOfIdent label
+> let (Field _ label _) = head fs
> in case (lookupVar label env) of
> [] -> errorAt' (undefinedLabel label)
> [RecordLabel r ls]
@@ -741,7 +732,7 @@
> checkExpr withExt p m env (RecordConstr fs)
> | not withExt = errorAt p noRecordExt
> | not (null fs) =
-> let (Field _ label expr) = head fs
+> let (Field _ label _) = head fs
> in case (lookupVar label env) of
> [] -> errorAt' (undefinedLabel label)
> [RecordLabel r ls]
@@ -772,7 +763,7 @@
> checkExpr withExt p m env (RecordUpdate fs e)
> | not withExt = errorAt p noRecordExt
> | not (null fs) =
-> let (Field _ label expr) = head fs
+> let (Field _ label _) = head fs
> in case (lookupVar label env) of
> [] -> errorAt' (undefinedLabel label)
> [RecordLabel r ls]
@@ -868,16 +859,16 @@
it is necessary to sort the list of declarations.
> sortFuncDecls :: [Decl] -> [Decl]
-> sortFuncDecls decls = sortFD emptyEnv [] decls
+> sortFuncDecls decls = sortFD Map.empty [] decls
> where
> sortFD env res [] = reverse res
> sortFD env res (decl:decls)
> = case decl of
> FunctionDecl _ ident _
-> | isJust (lookupEnv ident env)
+> | isJust (Map.lookup ident env)
> -> sortFD env (insertBy cmpFuncDecl decl res) decls
> | otherwise
-> -> sortFD (bindEnv ident () env) (decl:res) decls
+> -> sortFD (Map.insert ident () env) (decl:res) decls
> _ -> sortFD env (decl:res) decls
> cmpFuncDecl :: Decl -> Decl -> Ordering
@@ -886,26 +877,13 @@
> | otherwise = GT
> cmpFuncDecl decl1 decl2 = GT
-> cmpPos :: Position -> Position -> Ordering
-> cmpPos p1 p2 | lp1 < lp2 = LT
-> | lp1 == lp2 = EQ
-> | otherwise = GT
-> where lp1 = line p1
-> lp2 = line p2
+cmpPos :: Position -> Position -> Ordering
+cmpPos p1 p2 | lp1 < lp2 = LT
+ | lp1 == lp2 = EQ
+ | otherwise = GT
+ where lp1 = line p1
+ lp2 = line p2
-> getDeclPos :: Decl -> Position
-> getDeclPos (ImportDecl pos _ _ _ _) = pos
-> getDeclPos (InfixDecl pos _ _ _) = pos
-> getDeclPos (DataDecl pos _ _ _) = pos
-> getDeclPos (NewtypeDecl pos _ _ _) = pos
-> getDeclPos (TypeDecl pos _ _ _) = pos
-> getDeclPos (TypeSig pos _ _) = pos
-> getDeclPos (EvalAnnot pos _ _) = pos
-> getDeclPos (FunctionDecl pos _ _) = pos
-> getDeclPos (ExternalDecl pos _ _ _ _) = pos
-> getDeclPos (FlatExternalDecl pos _) = pos
-> getDeclPos (PatternDecl pos _ _) = pos
-> getDeclPos (ExtraVariables pos _) = pos
\end{verbatim}
Due to the lack of a capitalization convention in Curry, it is
@@ -1106,18 +1084,6 @@
> where arguments 0 = "no arguments"
> arguments 1 = "1 argument"
> arguments n = show n ++ " arguments"
-
-> --partialFuncPatt :: QualIdent -> Int -> Int -> String
-> --partialFuncPatt f arity argc =
-> -- "Function pattern " ++ qualName f ++ " expects at least "
-> -- ++ arguments arity ++ " but is applied to " ++ show argc
-> -- where arguments 0 = "no arguments"
-> -- arguments 1 = "1 argument"
-> -- arguments n = show n ++ " arguments"
-
-> noExpressionStatement :: String
-> noExpressionStatement =
-> "Last statement in a do expression must be an expression"
> illegalRecordPatt :: String
> illegalRecordPatt = "Expexting `_` after `|` in the record pattern"
diff --git a/src/SyntaxColoring.hs b/src/SyntaxColoring.hs
--- a/src/SyntaxColoring.hs
+++ b/src/SyntaxColoring.hs
@@ -1,24 +1,24 @@
module SyntaxColoring (Program,Code(..),TypeKind(..),ConstructorKind(..),
- IdentifierKind(..),FunctionKind(..),filename2program,
+ IdentifierKind(..),FunctionKind(..), genProgram,
code2string,getQualIdent, position2code,
area2codes) where
import Debug.Trace
+import Data.Function(on)
import Data.Maybe
+import Data.Either
import Data.List
-
-import CurryLexer
-import Position
-import Frontend
-import Ident
-import CurrySyntax
import Data.Char hiding(Space)
-import Message
-import Control.Exception
-import PathUtils (readModule)
+import Curry.Base.Position
+import Curry.Base.Ident
+import Curry.Base.MessageMonad
+import Curry.Syntax
+import Curry.Syntax.Lexer
+
+
debug = False -- mergen von Token und Codes
trace' s x = if debug then trace s x else x
@@ -28,10 +28,6 @@
trace'' s x = if debug' then trace s x else x
-debug'' = False -- parseResults und codes
-
-trace''' s x = if debug'' then trace s x else x
-
type Program = [(Int,Int,Code)]
data Code = Keyword String
@@ -47,9 +43,9 @@
| CharCode String
| Symbol String
| Identifier IdentifierKind QualIdent
- | CodeWarning [Message] Code
- | CodeError [Message] Code
- | NotParsed String deriving Show
+ | CodeWarning [WarnMsg] Code
+ | NotParsed String
+ deriving Show
data TypeKind = TypeDecla
| TypeUse
@@ -71,50 +67,21 @@
| OtherFunctionKind deriving Show
-
---- @param importpaths
---- @param filename
---- @return program
-filename2program :: [String] -> String -> IO Program
-filename2program paths filename=
- readModule filename >>= \ cont ->
- (catchError show (typingParse paths filename cont)) >>= \ typingParseResult ->
- (catchError show (fullParse paths filename cont)) >>= \ fullParseResult ->
- (catchError show (return (parse filename cont))) >>= \ parseResult ->
- (catchError show (return (Frontend.lex filename cont))) >>= \ lexResult ->
- return (genProgram cont (typingParseResult : fullParseResult : [parseResult]) lexResult)
-
-
--- @param plaintext
--- @param list with parse-Results with descending quality e.g. [typingParse,fullParse,parse]
--- @param lex-Result
--- @return program
-genProgram :: String -> [Result Module] -> Result [(Position,Token)] -> Program
-genProgram _ parseResults (Result mess posNtokList) =
- let messages = (prepareMessages
- (concatMap getMessages parseResults ++
- mess))
- mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages)
- posNtokList)
- (nameList,codes) = catIdentifiers parseResults in
- trace''' ("parseResults : " ++ show parseResults ++ "\n\nCodes: " ++ show codes ++ "\n\nToken: " ++ show mergedMessages)
- (tokenNcodes2codes
- nameList
- 1
- 1
- mergedMessages
- codes)
-
-
-genProgram plainText parseResults (Failure messages) =
- trace' (unlines (map (\(Message _ _ str) -> str) allMessages))
- (buildMessagesIntoPlainText allMessages plainText)
- where
- allMessages = prepareMessages (concatMap getMessages parseResults ++
- messages)
-
+genProgram :: String -> [MsgMonad Module] -> MsgMonad [(Position,Token)] -> Program
+genProgram plainText parseResults m
+ = case runMsg m of
+ (Left e, msgs) -> buildMessagesIntoPlainText (e : msgs) plainText
+ (Right posNtokList, mess)
+ -> let messages = (prepareMessages (concatMap getMessages parseResults ++ mess))
+ mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages) posNtokList)
+ (nameList,codes) = catIdentifiers parseResults
+ in tokenNcodes2codes nameList 1 1 mergedMessages codes
--- @param Program
@@ -138,25 +105,9 @@
| otherwise = area2codes xs p1 p2
where
posBegin = Position file l c noRef
- posEnd = Position file l (c + (length (code2string code))) noRef
-
-
---- this function intercepts errors and converts it to Messages
---- @param a show-function for (Result a)
---- @param a function that generates a (Result a)
---- @return (Result a) without runtimeerrors
-catchError :: (Result a -> String) -> IO (Result a) -> IO (Result a)
-catchError toString toDo = Control.Exception.catch (toDo >>= returnComplete toString) handler
- where
- handler (ErrorCall str) = return (Failure [setMessagePosition (Message Error Nothing str)])
- handler e = return (Failure [Message Error Nothing (show e)])
-
- returnComplete :: (a -> String) -> a -> IO a
- returnComplete toString a = f (toString a) (return a)
- where
- f [] r = r
- f (_:xs) r = f xs r
+ posEnd = Position file l (c + length (code2string code)) noRef
+
--- @param code
--- @return qualIdent if available
getQualIdent :: Code -> Maybe QualIdent
@@ -167,18 +118,12 @@
getQualIdent _ = Nothing
--- privates-----------------------------------------------------------------------------------
-
-
-codeWithoutPos :: (Int,Int,Code) -> Code
-codeWithoutPos (_,_,c) = c
-
-- DEBUGGING----------- wird bald nicht mehr gebraucht
-setMessagePosition :: Message -> Message
-setMessagePosition m@(Message _ (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
-setMessagePosition (Message typ _ m) =
- let mes@(Message _ pos _) = (Message typ (getPositionFromString m) m) in
+setMessagePosition :: WarnMsg -> WarnMsg
+setMessagePosition m@(WarnMsg (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
+setMessagePosition (WarnMsg _ m) =
+ let mes@(WarnMsg pos _) = (WarnMsg (getPositionFromString m) m) in
trace'' ("pos:" ++ show pos ++ ":" ++ show mes) mes
getPositionFromString :: String -> Maybe Position
@@ -208,7 +153,6 @@
flatCode :: Code -> Code
flatCode (CodeWarning _ code) = code
-flatCode (CodeError _ code) = code
flatCode code = code
@@ -216,31 +160,28 @@
-- ----------Message---------------------------------------
-getMessages :: Result a -> [Message]
-getMessages (Result mess _) = mess
-getMessages (Failure mess) = mess
+getMessages :: MsgMonad a -> [WarnMsg]
+getMessages = snd . runMsg --(Result mess _) = mess
+-- getMessages (Failure mess) = mess
-lessMessage :: Message -> Message -> Bool
-lessMessage (Message _ mPos1 _) (Message _ mPos2 _) = mPos1 < mPos2
+lessMessage :: WarnMsg -> WarnMsg -> Bool
+lessMessage (WarnMsg mPos1 _) (WarnMsg mPos2 _) = mPos1 < mPos2
-nubMessages :: [Message] -> [Message]
+nubMessages :: [WarnMsg] -> [WarnMsg]
nubMessages = nubBy eqMessage
-eqMessage :: Message -> Message -> Bool
-eqMessage (Message f1 p1 s1) (Message f2 p2 s2) = (f1 == f2) && (p1 == p2) && (s1 == s2)
+eqMessage :: WarnMsg -> WarnMsg -> Bool
+eqMessage (WarnMsg p1 s1) (WarnMsg p2 s2) = (p1 == p2) && (s1 == s2)
-prepareMessages :: [Message] -> [Message]
+prepareMessages :: [WarnMsg] -> [WarnMsg]
prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages
-hasError [] = False
-hasError ((Message Error _ _):ms) = True
-hasError (_:ms) = hasError ms
-buildMessagesIntoPlainText :: [Message] -> String -> Program
+buildMessagesIntoPlainText :: [WarnMsg] -> String -> Program
buildMessagesIntoPlainText messages text =
buildMessagesIntoPlainText' messages (lines text) [] 1
where
- buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program
+ buildMessagesIntoPlainText' :: [WarnMsg] -> [String] -> [String] -> Int -> Program
buildMessagesIntoPlainText' _ [] [] _ =
[]
buildMessagesIntoPlainText' _ [] postStrs line =
@@ -253,11 +194,11 @@
if null pre
then buildMessagesIntoPlainText' post preStrs (postStrs ++ [str]) (ln + 1)
else (ln,1,NotParsed (unlines postStrs)) :
- (if hasError pre then (ln,1,CodeError pre (NotParsed str)) : [(ln,1,NewLine)]
- else (ln,1,CodeWarning pre (NotParsed str)) : [(ln,1,NewLine)]) ++
- (buildMessagesIntoPlainText' post preStrs [] (ln + 1))
+ (ln,1,CodeWarning pre (NotParsed str)) :
+ (ln,1,NewLine) :
+ buildMessagesIntoPlainText' post preStrs [] (ln + 1)
where
- isLeq (Message _ (Just p) _) = line p <= ln
+ isLeq (WarnMsg (Just p) _) = line p <= ln
isLeq _ = True
@@ -265,19 +206,19 @@
--- @param parse-Modules [typingParse,fullParse,parse]
-catIdentifiers :: [Result Module] -> ([(ModuleIdent,ModuleIdent)],[Code])
-catIdentifiers [] = ([],[])
-catIdentifiers [(Failure _)] = ([],[])
-catIdentifiers [(Result _ m@(Module moduleIdent maybeExportSpec decls))] =
- catIdentifiers' m Nothing
-catIdentifiers ((Failure _):y:ys) =
- catIdentifiers (y:ys)
-catIdentifiers rs@((Result _ m@(Module _ _ _)):y:ys) =
- catIdentifiers' (getLastModule (reverse rs)) (Just m)
- where
- getLastModule ((Failure _):xs) = getLastModule xs
- getLastModule ((Result _ m@(Module _ _ _)):_) = m
+catIdentifiers :: [MsgMonad Module] -> ([(ModuleIdent,ModuleIdent)],[Code])
+catIdentifiers = catIds . rights . map (fst . runMsg)
+ where
+ catIds [] = ([],[])
+ catIds [m] =
+ catIdentifiers' m Nothing
+ catIds rs@(m:y:ys) =
+ catIdentifiers' (last rs) (Just m)
+-- not in base befoer base4
+
+rights xs = [ x | Right x <- xs]
+
--- @param parse-Module
--- @param Maybe betterParse-Module
catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])
@@ -285,19 +226,18 @@
Nothing =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in
(concatMap renamedImports decls,
- ([ModuleName moduleIdent] ++
- (maybe [] exportSpec2codes maybeExportSpec) ++
- codes))
+ ModuleName moduleIdent :
+ maybe [] exportSpec2codes maybeExportSpec ++ codes)
catIdentifiers' (Module moduleIdent maybeExportSpec1 _)
(Just (Module _ maybeExportSpec2 decls)) =
let codes = (concatMap decl2codes (qsort lessDecl decls)) in
(concatMap renamedImports decls,
replaceFunctionCalls $
- map (addModuleIdent moduleIdent) $
+ map (addModuleIdent moduleIdent)
([ModuleName moduleIdent] ++
- (mergeExports2codes
+ mergeExports2codes
(maybe [] (\(Exporting _ i) -> i) maybeExportSpec1)
- (maybe [] (\(Exporting _ i) -> i) maybeExportSpec2)) ++
+ (maybe [] (\(Exporting _ i) -> i) maybeExportSpec2) ++
codes))
@@ -325,55 +265,46 @@
idOccur2functionCall :: [QualIdent] -> Code -> Code
idOccur2functionCall qualIdents ide@(Identifier IdOccur qualIdent)
- | isQualified qualIdent = (Function FunctionCall qualIdent)
- | elem qualIdent qualIdents = (Function FunctionCall qualIdent)
+ | isQualified qualIdent = Function FunctionCall qualIdent
+ | elem qualIdent qualIdents = Function FunctionCall qualIdent
| otherwise = ide
idOccur2functionCall qualIdents (CodeWarning mess code) =
- (CodeWarning mess (idOccur2functionCall qualIdents code))
-idOccur2functionCall qualIdents (CodeError mess code) =
- (CodeError mess (idOccur2functionCall qualIdents code))
+ CodeWarning mess (idOccur2functionCall qualIdents code)
idOccur2functionCall _ code = code
addModuleIdent :: ModuleIdent -> Code -> Code
-addModuleIdent moduleIdent (Function x qualIdent)
+addModuleIdent moduleIdent c@(Function x qualIdent)
| uniqueId (unqualify qualIdent) == 0 =
- (Function x (qualQualify moduleIdent qualIdent))
- | otherwise = (Function x qualIdent)
+ Function x (qualQualify moduleIdent qualIdent)
+ | otherwise = c
addModuleIdent moduleIdent cn@(ConstructorName x qualIdent)
| not $ isQualified qualIdent =
- (ConstructorName x (qualQualify moduleIdent qualIdent))
+ ConstructorName x (qualQualify moduleIdent qualIdent)
| otherwise = cn
addModuleIdent moduleIdent tc@(TypeConstructor TypeDecla qualIdent)
| not $ isQualified qualIdent =
- (TypeConstructor TypeDecla (qualQualify moduleIdent qualIdent))
+ TypeConstructor TypeDecla (qualQualify moduleIdent qualIdent)
| otherwise = tc
addModuleIdent moduleIdent (CodeWarning mess code) =
- (CodeWarning mess (addModuleIdent moduleIdent code))
-addModuleIdent moduleIdent (CodeError mess code) =
- (CodeError mess (addModuleIdent moduleIdent code))
+ CodeWarning mess (addModuleIdent moduleIdent code)
addModuleIdent _ c = c
-- ----------------------------------------
-mergeMessages :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
-mergeMessages mess pos = mergeMessages' (prepareMessages mess) pos
-
-
-
-mergeMessages' :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
+mergeMessages' :: [WarnMsg] -> [(Position,Token)] -> [([WarnMsg],Position,Token)]
mergeMessages' _ [] = []
mergeMessages' [] ((p,t):ps) = ([],p,t) : mergeMessages' [] ps
-mergeMessages' mss@(m@(Message _ mPos x):ms) ((p,t):ps)
- | mPos <= Just p = (trace' (show mPos ++ " <= " ++ show (Just p) ++ " Message: " ++ x) ([m],p,t)) : mergeMessages' ms ps
+mergeMessages' mss@(m@(WarnMsg mPos x):ms) ((p,t):ps)
+ | mPos <= Just p = trace' (show mPos ++ " <= " ++ show (Just p) ++ " Message: " ++ x) ([m],p,t) : mergeMessages' ms ps
| otherwise = ([],p,t) : mergeMessages' mss ps
-tokenNcodes2codes :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([Message],Position,Token)] -> [Code] -> [(Int,Int,Code)]
+tokenNcodes2codes :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([WarnMsg],Position,Token)] -> [Code] -> [(Int,Int,Code)]
tokenNcodes2codes _ _ _ [] _ = []
tokenNcodes2codes nameList currLine currCol toks@((messages,pos@Position{line=line,column=col},token):ts) codes
| currLine < line =
- trace' (" NewLine: ")
+ trace' " NewLine: "
((currLine,currCol,NewLine) :
tokenNcodes2codes nameList (currLine + 1) 1 toks codes)
| currCol < col =
@@ -419,14 +350,11 @@
newLine = (currLine + length (lines tokenStr)) - 1
newCol = currCol + length tokenStr
- rename mid = Just $ maybe mid id (lookup mid nameList)
+ rename mid = Just $ fromMaybe mid (lookup mid nameList)
addMessage [] = []
addMessage ((l,c,code):cs)
- | null messages = ((l,c,code):cs)
- | hasError messages =
- trace' ("Error bei code: " ++ show codes ++ ":" ++ show messages)
- ((l,c,CodeError messages code): addMessage cs)
+ | null messages = (l,c,code):cs
| otherwise = trace' ("Warning bei code: " ++ show codes ++ ":" ++ show messages)
((l,c,CodeWarning messages code): addMessage cs)
@@ -434,12 +362,12 @@
renameModuleIdents :: [(ModuleIdent,ModuleIdent)] -> Code -> Code
renameModuleIdents nameList c =
case c of
- Function x qualIdent -> Function x (rename qualIdent (splitQualIdent qualIdent))
- Identifier x qualIdent -> Identifier x (rename qualIdent (splitQualIdent qualIdent))
+ Function x qualIdent -> Function x (rename qualIdent (qualidMod qualIdent))
+ Identifier x qualIdent -> Identifier x (rename qualIdent (qualidMod qualIdent))
_ -> c
where
- rename x (Nothing,_) = x
- rename x (Just m,i) = maybe x (\ m' -> qualifyWith m' i) (lookup m nameList)
+ rename x (Nothing) = x
+ rename x (Just m) = maybe x (\ m' -> qualifyWith m' (qualidId x)) (lookup m nameList)
{-
codeWithoutUniqueID :: Code -> String
@@ -454,11 +382,11 @@
codeQualifiers = maybe [] moduleQualifiers . getModuleIdent
getModuleIdent :: Code -> Maybe ModuleIdent
-getModuleIdent (ConstructorName _ qualIdent) = fst $ splitQualIdent qualIdent
-getModuleIdent (Function _ qualIdent) = fst $ splitQualIdent qualIdent
+getModuleIdent (ConstructorName _ qualIdent) = qualidMod qualIdent
+getModuleIdent (Function _ qualIdent) = qualidMod qualIdent
getModuleIdent (ModuleName moduleIdent) = Just moduleIdent
-getModuleIdent (Identifier _ qualIdent) = fst $ splitQualIdent qualIdent
-getModuleIdent (TypeConstructor _ qualIdent) = fst $ splitQualIdent qualIdent
+getModuleIdent (Identifier _ qualIdent) = qualidMod qualIdent
+getModuleIdent (TypeConstructor _ qualIdent) = qualidMod qualIdent
getModuleIdent _ = Nothing
@@ -551,7 +479,7 @@
lessDecl :: Decl -> Decl -> Bool
-lessDecl decl1 decl2 = getPosition decl1 < getPosition decl2
+lessDecl = (<) `on` getPosition
qsort _ [] = []
qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y | y <- xs, not $ less y x]
@@ -598,7 +526,7 @@
export2codes _ (ExportTypeWith qualIdent idents) =
- [TypeConstructor TypeExport qualIdent] ++ map (Function OtherFunctionKind . qualify) idents
+ TypeConstructor TypeExport qualIdent : map (Function OtherFunctionKind . qualify) idents
export2codes _ (ExportTypeAll qualIdent) =
[TypeConstructor TypeExport qualIdent]
export2codes _ (ExportModule moduleIdent) =
@@ -610,9 +538,9 @@
maybe [] ((:[]) . ModuleName) mModuleIdent ++
maybe [] (importSpec2codes moduleIdent) importSpec
decl2codes (InfixDecl _ _ _ idents) =
- (map (Function InfixFunction . qualify) idents)
+ map (Function InfixFunction . qualify) idents
decl2codes (DataDecl _ ident idents constrDecls) =
- [TypeConstructor TypeDecla (qualify ident)] ++
+ TypeConstructor TypeDecla (qualify ident) :
map (Identifier UnknownId . qualify) idents ++
concatMap constrDecl2codes constrDecls
decl2codes (NewtypeDecl xPosition xIdent yIdents xNewConstrDecl) =
@@ -642,7 +570,7 @@
lhs2codes :: Lhs -> [Code]
lhs2codes (FunLhs ident constrTerms) =
- (Function FunDecl $ qualify ident) : concatMap constrTerm2codes constrTerms
+ Function FunDecl (qualify ident) : concatMap constrTerm2codes constrTerms
lhs2codes (OpLhs constrTerm1 ident constrTerm2) =
constrTerm2codes constrTerm1 ++ [Function FunDecl $ qualify ident] ++ constrTerm2codes constrTerm2
lhs2codes (ApLhs lhs constrTerms) =
@@ -663,17 +591,17 @@
constrTerm2codes (NegativePattern ident literal) = []
constrTerm2codes (VariablePattern ident) = [Identifier IdDecl (qualify ident)]
constrTerm2codes (ConstructorPattern qualIdent constrTerms) =
- (ConstructorName ConstrPattern qualIdent) : concatMap constrTerm2codes constrTerms
+ ConstructorName ConstrPattern qualIdent : concatMap constrTerm2codes constrTerms
constrTerm2codes (InfixPattern constrTerm1 qualIdent constrTerm2) =
constrTerm2codes constrTerm1 ++ [ConstructorName ConstrPattern qualIdent] ++ constrTerm2codes constrTerm2
constrTerm2codes (ParenPattern constrTerm) = constrTerm2codes constrTerm
constrTerm2codes (TuplePattern _ constrTerms) = concatMap constrTerm2codes constrTerms
constrTerm2codes (ListPattern _ constrTerms) = concatMap constrTerm2codes constrTerms
constrTerm2codes (AsPattern ident constrTerm) =
- (Function OtherFunctionKind $ qualify ident) : constrTerm2codes constrTerm
+ Function OtherFunctionKind (qualify ident) : constrTerm2codes constrTerm
constrTerm2codes (LazyPattern _ constrTerm) = constrTerm2codes constrTerm
constrTerm2codes (FunctionPattern qualIdent constrTerms) =
- (Function OtherFunctionKind qualIdent) : concatMap constrTerm2codes constrTerms
+ Function OtherFunctionKind qualIdent : concatMap constrTerm2codes constrTerms
constrTerm2codes (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =
constrTerm2codes constrTerm1 ++ [Function InfixFunction qualIdent] ++ constrTerm2codes constrTerm2
@@ -704,7 +632,7 @@
expression2codes expression2 ++
expression2codes expression3
expression2codes (UnaryMinus ident expression) =
- [Symbol (name ident)] ++ expression2codes expression
+ Symbol (name ident) : expression2codes expression
expression2codes (Apply expression1 expression2) =
expression2codes expression1 ++ expression2codes expression2
expression2codes (InfixApply expression1 infixOp expression2) =
@@ -744,7 +672,7 @@
constrDecl2codes :: ConstrDecl -> [Code]
constrDecl2codes (ConstrDecl _ idents ident typeExprs) =
- (ConstructorName ConstrDecla $ qualify ident) : concatMap typeExpr2codes typeExprs
+ ConstructorName ConstrDecla (qualify ident) : concatMap typeExpr2codes typeExprs
constrDecl2codes (ConOpDecl _ idents typeExpr1 ident typeExpr2) =
typeExpr2codes typeExpr1 ++ [ConstructorName ConstrDecla $ qualify ident] ++ typeExpr2codes typeExpr2
@@ -757,14 +685,14 @@
import2codes moduleIdent (Import ident) =
[Function OtherFunctionKind $ qualifyWith moduleIdent ident]
import2codes moduleIdent (ImportTypeWith ident idents) =
- [ConstructorName OtherConstrKind $ qualifyWith moduleIdent ident] ++
+ ConstructorName OtherConstrKind (qualifyWith moduleIdent ident) :
map (Function OtherFunctionKind . qualifyWith moduleIdent) idents
import2codes moduleIdent (ImportTypeAll ident) =
[ConstructorName OtherConstrKind $ qualifyWith moduleIdent ident]
typeExpr2codes :: TypeExpr -> [Code]
typeExpr2codes (ConstructorType qualIdent typeExprs) =
- (TypeConstructor TypeUse qualIdent) : concatMap typeExpr2codes typeExprs
+ TypeConstructor TypeUse qualIdent : concatMap typeExpr2codes typeExprs
typeExpr2codes (VariableType ident) =
[Identifier IdOccur (qualify ident)]
typeExpr2codes (TupleType typeExprs) =
@@ -851,14 +779,13 @@
attributes2string (StringAttributes sval _) = showSt sval
attributes2string (IdentAttributes mIdent ident) =concat (intersperse "." (mIdent ++ [ident]))
-basename = reverse . takeWhile (/='/') . reverse
showCh c
| c == '\\' = "'\\\\'"
| elem c ('\127' : ['\001' .. '\031']) = show c
| otherwise = toString c
where
- toString c = "'" ++ c : "'"
+ toString c = '\'' : c : "'"
showSt = addQuotes . concatMap toGoodChar
where
@@ -870,4 +797,4 @@
| c == '"' = "\\\""
| otherwise = c : ""
where
- justShow = reverse . tail . reverse . tail . show
+ justShow = init . tail . show
diff --git a/src/TopEnv.lhs b/src/TopEnv.lhs
--- a/src/TopEnv.lhs
+++ b/src/TopEnv.lhs
@@ -41,10 +41,10 @@
> allImports,moduleImports,localBindings) where
> import Data.Maybe
+> import qualified Data.Map as Map
+> import Control.Arrow(second)
+> import Curry.Base.Ident
-> import Env
-> import Ident
-> import Utils
> data Source = Local | Import [ModuleIdent] deriving (Eq,Show)
@@ -55,32 +55,32 @@
> | origName x == origName y = Just x
> | otherwise = Nothing
-> newtype TopEnv a = TopEnv (Env QualIdent [(Source,a)]) deriving Show
+> newtype TopEnv a = TopEnv (Map.Map QualIdent [(Source,a)]) deriving Show
> instance Functor TopEnv where
-> fmap f (TopEnv env) = TopEnv (fmap (map (apSnd f)) env)
+> fmap f (TopEnv env) = TopEnv (fmap (map (second f)) env)
-> entities :: QualIdent -> Env QualIdent [(Source,a)] -> [(Source,a)]
-> entities x env = fromMaybe [] (lookupEnv x env)
+> entities :: QualIdent -> Map.Map QualIdent [(Source,a)] -> [(Source,a)]
+> entities x env = fromMaybe [] (Map.lookup x env)
> emptyTopEnv :: TopEnv a
-> emptyTopEnv = TopEnv emptyEnv
+> emptyTopEnv = TopEnv Map.empty
> predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
> predefTopEnv x y (TopEnv env) =
-> case lookupEnv x env of
+> case Map.lookup x env of
> Just _ -> error "internal error: predefTopEnv"
-> Nothing -> TopEnv (bindEnv x [(Import [],y)] env)
+> Nothing -> TopEnv (Map.insert x [(Import [],y)] env)
> importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
> importTopEnv m x y (TopEnv env) =
-> TopEnv (bindEnv x' (mergeImport m y (entities x' env)) env)
+> TopEnv (Map.insert x' (mergeImport m y (entities x' env)) env)
> where x' = qualify x
> qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
> -> TopEnv a
> qualImportTopEnv m x y (TopEnv env) =
-> TopEnv (bindEnv x' (mergeImport m y (entities x' env)) env)
+> TopEnv (Map.insert x' (mergeImport m y (entities x' env)) env)
> where x' = qualifyWith m x
> mergeImport :: Entity a => ModuleIdent -> a -> [(Source,a)] -> [(Source,a)]
@@ -96,7 +96,7 @@
> qualBindTopEnv :: String -> QualIdent -> a -> TopEnv a -> TopEnv a
> qualBindTopEnv fun x y (TopEnv env) =
-> TopEnv (bindEnv x (bindLocal y (entities x env)) env)
+> TopEnv (Map.insert x (bindLocal y (entities x env)) env)
> where bindLocal y ys
> | null [y' | (Local,y') <- ys] = (Local,y) : ys
> | otherwise = error ("internal error: \"qualBindTopEnv "
@@ -108,14 +108,14 @@
> qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
> qualRebindTopEnv x y (TopEnv env) =
-> TopEnv (bindEnv x (rebindLocal (entities x env)) env)
+> TopEnv (Map.insert x (rebindLocal (entities x env)) env)
> where rebindLocal [] = error "internal error: qualRebindTopEnv"
> rebindLocal ((Local,_) : ys) = (Local,y) : ys
> rebindLocal ((Import ms,y) : ys) = (Import ms,y) : rebindLocal ys
> unbindTopEnv :: Ident -> TopEnv a -> TopEnv a
> unbindTopEnv x (TopEnv env) =
-> TopEnv (bindEnv x' (unbindLocal (entities x' env)) env)
+> TopEnv (Map.insert x' (unbindLocal (entities x' env)) env)
> where x' = qualify x
> unbindLocal [] = error "internal error: unbindTopEnv"
> unbindLocal ((Local,_) : ys) = ys
@@ -129,11 +129,11 @@
> allImports :: TopEnv a -> [(QualIdent,a)]
> allImports (TopEnv env) =
-> [(x,y) | (x,ys) <- envToList env, (Import _,y) <- ys]
+> [(x,y) | (x,ys) <- Map.toList env, (Import _,y) <- ys]
> unqualBindings :: TopEnv a -> [(Ident,(Source,a))]
> unqualBindings (TopEnv env) =
-> [(x',y) | (x,ys) <- takeWhile (not . isQualified . fst) (envToList env),
+> [(x',y) | (x,ys) <- takeWhile (not . isQualified . fst) (Map.toList env),
> let x' = unqualify x, y <- ys]
> moduleImports :: ModuleIdent -> TopEnv a -> [(Ident,a)]
diff --git a/src/TypeCheck.lhs b/src/TypeCheck.lhs
--- a/src/TypeCheck.lhs
+++ b/src/TypeCheck.lhs
@@ -21,21 +21,25 @@
type annotation is present.
\begin{verbatim}
-> module TypeCheck(typeCheck,typeCheckGoal) where
+> module TypeCheck(typeCheck) where
-> import Control.Monad
+> import Control.Monad.State as S
> import Data.List
> import Data.Maybe
+> import qualified Data.Map as Map
> import qualified Data.Set as Set
+> import Curry.Base.Position
+> import Curry.Base.Ident
+> import Curry.Syntax
+> import Curry.Syntax.Pretty
+> import Curry.Syntax.Utils
+
+
> import Base
-> import Pretty
-> import Ident
-> import CurryPP
-> import Env
+> import Types
+> import PrettyCombinators
> import TopEnv
-
-> import Combined
> import SCC
> import TypeSubst
> import Utils
@@ -57,36 +61,24 @@
> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv,ValueEnv)
> typeCheck m tcEnv tyEnv ds =
-> run (tcDecls m tcEnv' emptyEnv vds >>
-> liftSt fetchSt >>= \theta -> fetchSt >>= \tyEnv' ->
+> run (tcDecls m tcEnv' Map.empty vds >>
+> S.lift S.get >>= \theta -> S.get >>= \tyEnv' ->
> return (tcEnv',subst theta tyEnv'))
> (bindLabels m tcEnv' (bindConstrs m tcEnv' tyEnv))
> where (tds,vds) = partition isTypeDecl ds
> tcEnv' = bindTypes m tds tcEnv
\end{verbatim}
-Type checking of a goal expression is simpler because the type
-constructor environment is fixed already and there are no
-type declarations in a goal.
-\begin{verbatim}
-> typeCheckGoal :: TCEnv -> ValueEnv -> Goal -> ValueEnv
-> typeCheckGoal tcEnv tyEnv (Goal p e ds) =
-> run (tcRhs m0 tcEnv tyEnv emptyEnv (SimpleRhs p e ds) >>
-> liftSt fetchSt >>= \theta -> fetchSt >>= \tyEnv' ->
-> return (subst theta tyEnv')) tyEnv
-> where m0 = mkMIdent []
-
-\end{verbatim}
The type checker makes use of nested state monads in order to
maintain the type environment, the current substitution, and a counter
which is used for generating fresh type variables.
\begin{verbatim}
-> type TcState a = StateT ValueEnv (StateT TypeSubst (St Int)) a
+> type TcState a = S.StateT ValueEnv (S.StateT TypeSubst (S.State Int)) a
> run :: TcState a -> ValueEnv -> a
-> run m tyEnv = runSt (callSt (callSt m tyEnv) idSubst) 0
+> run m tyEnv = S.evalState (S.evalStateT (S.evalStateT m tyEnv) idSubst) 0
\end{verbatim}
\paragraph{Defining Types}
@@ -218,10 +210,10 @@
inferred type is less general than the signature.
\begin{verbatim}
-> type SigEnv = Env Ident TypeExpr
+> type SigEnv = Map.Map Ident TypeExpr
> bindTypeSig :: Ident -> TypeExpr -> SigEnv -> SigEnv
-> bindTypeSig = bindEnv
+> bindTypeSig = Map.insert
> bindTypeSigs :: Decl -> SigEnv -> SigEnv
> bindTypeSigs (TypeSig _ vs ty) env =
@@ -229,7 +221,7 @@
> bindTypeSigs _ env = env
> lookupTypeSig :: Ident -> SigEnv -> Maybe TypeExpr
-> lookupTypeSig = lookupEnv
+> lookupTypeSig = Map.lookup
> qualLookupTypeSig :: ModuleIdent -> QualIdent -> SigEnv -> Maybe TypeExpr
> qualLookupTypeSig m f sigs = localIdent m f >>= flip lookupTypeSig sigs
@@ -259,8 +251,8 @@
> nameType (RecordType fs rty) tvs =
> (RecordType (zip ls tys') (listToMaybe rty'), tvs)
> where (ls, tys) = unzip fs
-> (tys', tvs') = nameTypes tys tvs
-> (rty', tvs'') = nameTypes (maybeToList rty) tvs
+> (tys', _) = nameTypes tys tvs
+> (rty', _) = nameTypes (maybeToList rty) tvs
\end{verbatim}
\paragraph{Type Inference}
@@ -302,17 +294,17 @@
> mapM_ (tcExtraVar m tcEnv sigs ) vs
> tcDeclGroup m tcEnv sigs ds =
> do
-> tyEnv0 <- fetchSt
+> tyEnv0 <- S.get
> tysLhs <- mapM (tcDeclLhs m tcEnv sigs) ds
> tysRhs <- mapM (tcDeclRhs m tcEnv tyEnv0 sigs) ds
> sequence_ (zipWith3 (unifyDecl m) ds tysLhs tysRhs)
-> theta <- liftSt fetchSt
+> theta <- S.lift S.get
> mapM_ (genDecl m tcEnv sigs (fvEnv (subst theta tyEnv0)) theta) ds
> --tcForeignFunct :: ModuleIdent -> TCEnv -> Position -> CallConv -> Ident
> -- -> TypeExpr -> TcState ()
> --tcForeignFunct m tcEnv p cc f ty =
-> -- updateSt_ (bindFun m f (checkForeignType cc (expandPolyType tcEnv ty)))
+> -- S.modify (bindFun m f (checkForeignType cc (expandPolyType tcEnv ty)))
> -- where checkForeignType CallConvPrimitive ty = ty
> -- checkForeignType CallConvCCall (ForAll n ty) =
> -- ForAll n (checkCCallType ty)
@@ -332,11 +324,11 @@
> tcExternalFunct :: ModuleIdent -> TCEnv -> Ident -> TypeExpr -> TcState ()
> tcExternalFunct m tcEnv f ty =
-> updateSt_ (bindFun m f (expandPolyType m tcEnv ty))
+> S.modify (bindFun m f (expandPolyType m tcEnv ty))
> tcFlatExternalFunct :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TcState ()
> tcFlatExternalFunct m tcEnv sigs f =
-> typeOf f tcEnv sigs >>= updateSt_ . bindFun m f
+> typeOf f tcEnv sigs >>= S.modify . bindFun m f
> where typeOf f tcEnv sigs =
> case lookupTypeSig f sigs of
> Just ty -> return (expandPolyType m tcEnv ty)
@@ -345,7 +337,7 @@
> tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident
> -> TcState ()
> tcExtraVar m tcEnv sigs v =
-> typeOf v tcEnv sigs >>= updateSt_ . bindFun m v . monoType
+> typeOf v tcEnv sigs >>= S.modify . bindFun m v . monoType
> where typeOf v tcEnv sigs =
> case lookupTypeSig v sigs of
> Just ty
@@ -404,9 +396,9 @@
> genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst -> Decl
> -> TcState ()
> genDecl m tcEnv sigs lvs theta (FunctionDecl _ f _) =
-> updateSt_ (genVar True m tcEnv sigs lvs theta f)
+> S.modify (genVar True m tcEnv sigs lvs theta f)
> genDecl m tcEnv sigs lvs theta (PatternDecl p t _) =
-> mapM_ (updateSt_ . genVar False m tcEnv sigs lvs theta ) (bv t)
+> mapM_ (S.modify . genVar False m tcEnv sigs lvs theta ) (bv t)
> genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst
> -> Ident -> ValueEnv -> ValueEnv
@@ -442,7 +434,7 @@
> tcLiteral m (Int v _) = --return intType
> do
> ty <- freshConstrained [intType,floatType]
-> updateSt_ (bindFun m v (monoType ty))
+> S.modify (bindFun m v (monoType ty))
> return ty
> tcLiteral _ (Float _ _) = return floatType
> tcLiteral _ (String _ _) = return stringType
@@ -456,12 +448,12 @@
> ty <- case lookupTypeSig v sigs of
> Just t -> inst (expandPolyType m tcEnv t)
> Nothing -> freshTypeVar
-> updateSt_ (bindFun m v (monoType ty))
+> S.modify (bindFun m v (monoType ty))
> return ty
>
> tcConstrTerm m tcEnv sigs p t@(ConstructorPattern c ts) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> ty <- skol (constrType m c tyEnv)
> unifyArgs (ppConstrTerm 0 t) ts ty
> where unifyArgs _ [] ty = return ty
@@ -473,7 +465,7 @@
> unifyArgs _ _ _ = internalError "tcConstrTerm"
> tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> ty <- skol (constrType m op tyEnv)
> unifyArgs (ppConstrTerm 0 t) [t1,t2] ty
> where unifyArgs _ [] ty = return ty
@@ -504,7 +496,7 @@
> tcConstrTerm m tcEnv sigs p (LazyPattern _ t) = tcConstrTerm m tcEnv sigs p t
> tcConstrTerm m tcEnv sigs p t@(FunctionPattern f ts) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv)
> unifyArgs (ppConstrTerm 0 t) ts ty
> where unifyArgs _ [] ty = return ty
@@ -553,14 +545,14 @@
> ty <- maybe freshTypeVar
> (inst . expandPolyType m tcEnv)
> (lookupTypeSig v sigs)
-> tyEnv <- fetchSt
-> ty' <- maybe (updateSt_ (bindFun m v (monoType ty)) >> return ty)
+> tyEnv <- S.get
+> ty' <- maybe (S.modify (bindFun m v (monoType ty)) >> return ty)
> (\ (ForAll _ t) -> return t)
> (sureVarType v tyEnv)
> return ty'
> tcConstrTermFP m tcEnv sigs p t@(ConstructorPattern c ts) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> ty <- skol (constrType m c tyEnv)
> unifyArgs (ppConstrTerm 0 t) ts ty
> where unifyArgs _ [] ty = return ty
@@ -572,7 +564,7 @@
> unifyArgs _ _ _ = internalError "tcConstrTermFP"
> tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> ty <- skol (constrType m op tyEnv)
> unifyArgs (ppConstrTerm 0 t) [t1,t2] ty
> where unifyArgs _ [] ty = return ty
@@ -603,7 +595,7 @@
> tcConstrTermFP m tcEnv sigs p (LazyPattern _ t) = tcConstrTermFP m tcEnv sigs p t
> tcConstrTermFP m tcEnv sigs p t@(FunctionPattern f ts) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv)
> unifyArgs (ppConstrTerm 0 t) ts ty
> where unifyArgs _ [] ty = return ty
@@ -640,11 +632,11 @@
> -> Field ConstrTerm -> TcState (Ident,Type)
> tcFieldPatt tcPatt m f@(Field _ l t) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> let p = positionOfIdent l
> lty <- maybe (freshTypeVar
> >>= (\lty' ->
-> updateSt_
+> S.modify
> (bindLabel l (qualifyWith m (mkIdent "#Rec"))
> (polyType lty'))
> >> return lty'))
@@ -689,15 +681,15 @@
> tcExpr m tcEnv sigs p (Variable v) =
> case qualLookupTypeSig m v sigs of
> Just ty -> inst (expandPolyType m tcEnv ty)
-> Nothing -> fetchSt >>= inst . funType m v
-> tcExpr m tcEnv sigs p (Constructor c) = fetchSt >>= instExist . constrType m c
+> Nothing -> S.get >>= inst . funType m v
+> tcExpr m tcEnv sigs p (Constructor c) = S.get >>= instExist . constrType m c
> tcExpr m tcEnv sigs p (Typed e sig) =
> do
-> tyEnv0 <- fetchSt
+> tyEnv0 <- S.get
> ty <- tcExpr m tcEnv sigs p e
> inst sigma' >>=
> flip (unify p "explicitly typed expression" (ppExpr 0 e) m) ty
-> theta <- liftSt fetchSt
+> theta <- S.lift S.get
> let sigma = gen (fvEnv (subst theta tyEnv0)) (subst theta ty)
> unless (sigma == sigma')
> (errorAt p (typeSigTooGeneral m (text "Expression:" <+> ppExpr 0 e)
@@ -718,7 +710,7 @@
> tcElems doc es ty
> tcExpr m tcEnv sigs p (ListCompr _ e qs) =
> do
-> tyEnv0 <- fetchSt
+> tyEnv0 <- S.get
> mapM_ (tcQual m tcEnv sigs p) qs
> ty <- tcExpr m tcEnv sigs p e
> checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 (listType ty)
@@ -814,21 +806,21 @@
> return (TypeArrow alpha gamma)
> tcExpr m tcEnv sigs p exp@(Lambda r ts e) =
> do
-> tyEnv0 <- fetchSt
+> tyEnv0 <- S.get
> tys <- mapM (tcConstrTerm m tcEnv sigs p) ts
> ty <- tcExpr m tcEnv sigs p e
> checkSkolems p m (text "Expression:" <+> ppExpr 0 exp) tyEnv0
> (foldr TypeArrow ty tys)
> tcExpr m tcEnv sigs p (Let ds e) =
> do
-> tyEnv0 <- fetchSt
-> theta <- liftSt fetchSt
+> tyEnv0 <- S.get
+> theta <- S.lift S.get
> tcDecls m tcEnv sigs ds
> ty <- tcExpr m tcEnv sigs p e
> checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty
> tcExpr m tcEnv sigs p (Do sts e) =
> do
-> tyEnv0 <- fetchSt
+> tyEnv0 <- S.get
> mapM_ (tcStmt m tcEnv sigs p) sts
> alpha <- freshTypeVar
> ty <- tcExpr m tcEnv sigs p e
@@ -846,7 +838,7 @@
> return ty3
> tcExpr m tcEnv sigs p (Case _ e alts) =
> do
-> tyEnv0 <- fetchSt
+> tyEnv0 <- S.get
> ty <- tcExpr m tcEnv sigs p e
> alpha <- freshTypeVar
> tcAlts tyEnv0 ty alpha alts
@@ -868,10 +860,10 @@
> tcExpr m tcEnv sigs p r@(RecordSelection e l) =
> do
> ty <- tcExpr m tcEnv sigs p e
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> lty <- maybe (freshTypeVar
> >>= (\lty' ->
-> updateSt_
+> S.modify
> (bindLabel l (qualifyWith m (mkIdent "#Rec"))
> (monoType lty'))
> >> return lty'))
@@ -923,11 +915,11 @@
> -> TcState (Ident,Type)
> tcFieldExpr m tcEnv sigs comb f@(Field _ l e) =
> do
-> tyEnv <- fetchSt
+> tyEnv <- S.get
> let p = positionOfIdent l
> lty <- maybe (freshTypeVar
> >>= (\lty' ->
-> updateSt_
+> S.modify
> (bindLabel l (qualifyWith m (mkIdent "#Rec"))
> (monoType lty'))
> >> return lty'))
@@ -950,14 +942,14 @@
> -> TcState (Type,Type)
> tcArrow p what doc m ty =
> do
-> theta <- liftSt fetchSt
+> theta <- S.lift S.get
> unaryArrow (subst theta ty)
> where unaryArrow (TypeArrow ty1 ty2) = return (ty1,ty2)
> unaryArrow (TypeVariable tv) =
> do
> alpha <- freshTypeVar
> beta <- freshTypeVar
-> liftSt (updateSt_ (bindVar tv (TypeArrow alpha beta)))
+> S.lift (S.modify (bindVar tv (TypeArrow alpha beta)))
> return (alpha,beta)
> unaryArrow ty = errorAt p (nonFunctionType what doc m ty)
@@ -969,7 +961,7 @@
> do
> beta <- freshTypeVar
> gamma <- freshTypeVar
-> liftSt (updateSt_ (bindVar tv (TypeArrow beta gamma)))
+> S.lift (S.modify (bindVar tv (TypeArrow beta gamma)))
> return (ty1,beta,gamma)
> binaryArrow ty1 ty2 =
> errorAt p (nonBinaryOp what doc m (TypeArrow ty1 ty2))
@@ -983,13 +975,13 @@
> unify :: Position -> String -> Doc -> ModuleIdent -> Type -> Type
> -> TcState ()
> unify p what doc m ty1 ty2 =
-> liftSt $ {-$-}
+> S.lift $ {-$-}
> do
-> theta <- fetchSt
+> theta <- S.get
> let ty1' = subst theta ty1
> let ty2' = subst theta ty2
> either (errorAt p . typeMismatch what doc m ty1' ty2')
-> (updateSt_ . compose)
+> (S.modify . compose)
> (unifyTypes m ty1' ty2')
> unifyTypes :: ModuleIdent -> Type -> Type -> Either Doc TypeSubst
@@ -1086,7 +1078,7 @@
> -> TcState Type
> checkSkolems p m what tyEnv ty =
> do
-> theta <- liftSt fetchSt
+> theta <- S.lift S.get
> let ty' = subst theta ty
> fs = fsEnv (subst theta tyEnv)
> unless (all (`Set.member` fs) (typeSkolems ty'))
@@ -1100,7 +1092,7 @@
\begin{verbatim}
> fresh :: (Int -> a) -> TcState a
-> fresh f = liftM f (liftSt (liftSt (updateSt (1 +))))
+> fresh f = liftM f (S.lift (S.lift (S.modify succ >> S.get)))
> freshVar :: (Int -> a) -> TcState a
> freshVar f = fresh (\n -> f (- n - 1))
@@ -1184,20 +1176,6 @@
> [Value _ sigma] -> sigma
> _ -> internalError ("funType " ++ show f)
-> sureFunType :: ModuleIdent -> QualIdent -> ValueEnv -> Maybe TypeScheme
-> sureFunType m f tyEnv =
-> case (qualLookupValue f tyEnv) of
-> [Value _ sigma] -> Just sigma
-> vs -> case (qualLookupValue (qualQualify m f) tyEnv) of
-> [Value _ sigma] -> Just sigma
-> _ -> Nothing
-
-> labelType :: Ident -> ValueEnv -> TypeScheme
-> labelType l tyEnv =
-> case lookupValue l tyEnv of
-> Label _ _ sigma : _ -> sigma
-> _ -> internalError ("labelType " ++ show l)
-
> sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme
> sureLabelType l tyEnv =
> case lookupValue l tyEnv of
@@ -1319,11 +1297,6 @@
> vcat [text "Existential type escapes out of its scope", what,
> text "Type:" <+> ppType m ty]
-> invalidCType :: String -> ModuleIdent -> Type -> String
-> invalidCType what m ty = show $
-> vcat [text ("Invalid " ++ what ++ " type in foreign declaration"),
-> ppType m ty]
-
> recursiveType :: ModuleIdent -> Int -> Type -> Doc
> recursiveType m tv ty = incompatibleTypes m (TypeVariable tv) ty
@@ -1345,3 +1318,14 @@
> text "are incompatible"]
\end{verbatim}
+
+
+\end{verbatim}
+The following functions implement pretty-printing for types.
+\begin{verbatim}
+
+> ppType :: ModuleIdent -> Type -> Doc
+> ppType m = ppTypeExpr 0 . fromQualType m
+
+> ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc
+> ppTypeScheme m (ForAll _ ty) = ppType m ty
diff --git a/src/TypeSubst.lhs b/src/TypeSubst.lhs
--- a/src/TypeSubst.lhs
+++ b/src/TypeSubst.lhs
@@ -15,6 +15,8 @@
> import Data.Maybe
> import Data.List
+> import Types
+
> import Subst
> import Base
> import TopEnv
diff --git a/src/Types.lhs b/src/Types.lhs
--- a/src/Types.lhs
+++ b/src/Types.lhs
@@ -16,7 +16,7 @@
> import Data.List
> import Data.Maybe
-> import Ident
+> import Curry.Base.Ident
\end{verbatim}
A type is either a type variable, an application of a type constructor
@@ -47,7 +47,7 @@
> | TypeArrow Type Type
> | TypeSkolem Int
> | TypeRecord [(Ident,Type)] (Maybe Int)
-> deriving (Eq,Show)
+> deriving (Show, Eq)
\end{verbatim}
The function \texttt{isArrowType} checks whether a type is a function
@@ -172,8 +172,8 @@
quantified variables.
\begin{verbatim}
-> data TypeScheme = ForAll Int Type deriving (Eq,Show)
-> data ExistTypeScheme = ForAllExist Int Int Type deriving (Eq,Show)
+> data TypeScheme = ForAll Int Type deriving (Show, Eq)
+> data ExistTypeScheme = ForAllExist Int Int Type deriving (Show, Eq)
\end{verbatim}
The functions \texttt{monoType} and \texttt{polyType} translate a type
@@ -215,3 +215,37 @@
> typeVar = TypeVariable
\end{verbatim}
+
+
+
+> qualifyType :: ModuleIdent -> Type -> Type
+> qualifyType m (TypeConstructor tc tys)
+> | isTupleId tc' = tupleType tys'
+> | tc' == unitId && n == 0 = unitType
+> | tc' == listId && n == 1 = listType (head tys')
+> | otherwise = TypeConstructor (qualQualify m tc) tys'
+> where n = length tys'
+> tc' = unqualify tc
+> tys' = map (qualifyType m) tys
+> qualifyType _ (TypeVariable tv) = TypeVariable tv
+> qualifyType m (TypeConstrained tys tv) =
+> TypeConstrained (map (qualifyType m) tys) tv
+> qualifyType m (TypeArrow ty1 ty2) =
+> TypeArrow (qualifyType m ty1) (qualifyType m ty2)
+> qualifyType _ (TypeSkolem k) = TypeSkolem k
+> qualifyType m (TypeRecord fs rty) =
+> TypeRecord (map (\ (l,ty) -> (l, qualifyType m ty)) fs) rty
+
+
+> unqualifyType :: ModuleIdent -> Type -> Type
+> unqualifyType m (TypeConstructor tc tys) =
+> TypeConstructor (qualUnqualify m tc) (map (unqualifyType m) tys)
+> unqualifyType _ (TypeVariable tv) = TypeVariable tv
+> unqualifyType m (TypeConstrained tys tv) =
+> TypeConstrained (map (unqualifyType m) tys) tv
+> unqualifyType m (TypeArrow ty1 ty2) =
+> TypeArrow (unqualifyType m ty1) (unqualifyType m ty2)
+> unqualifyType m (TypeSkolem k) = TypeSkolem k
+> unqualifyType m (TypeRecord fs rty) =
+> TypeRecord (map (\ (l,ty) -> (l, unqualifyType m ty)) fs) rty
+
diff --git a/src/Typing.lhs b/src/Typing.lhs
--- a/src/Typing.lhs
+++ b/src/Typing.lhs
@@ -12,10 +12,14 @@
> import Data.Maybe
> import Control.Monad
+> import Control.Monad.State as S
+> import Curry.Base.Ident
+> import Curry.Syntax
+
+> import Types
> import Base
> import TypeSubst
-> import Combined
> import TopEnv
> import Utils
@@ -84,10 +88,10 @@
environment.}
\begin{verbatim}
-> type TyState a = StateT TypeSubst (St Int) a
+> type TyState a = S.StateT TypeSubst (S.State Int) a
> run :: TyState a -> ValueEnv -> a
-> run m tyEnv = runSt (callSt m idSubst) 0
+> run m tyEnv = S.evalState (S.evalStateT m idSubst) 0
> class Typeable a where
> typeOf :: ValueEnv -> a -> Type
@@ -108,7 +112,7 @@
> where doComputeType =
> do
> ty <- f tyEnv x
-> theta <- fetchSt
+> theta <- S.get
> return (fixTypeVars tyEnv (subst theta ty))
> fixTypeVars :: ValueEnv -> Type -> Type
@@ -281,7 +285,7 @@
\begin{verbatim}
> freshTypeVar :: TyState Type
-> freshTypeVar = liftM TypeVariable $ liftSt $ updateSt (1 +)
+> freshTypeVar = liftM TypeVariable $ S.lift (S.modify succ >> S.get)
> instType :: Int -> Type -> TyState Type
> instType n ty =
@@ -304,7 +308,7 @@
> unify :: Type -> Type -> TyState ()
> unify ty1 ty2 =
-> updateSt_ (\theta -> unifyTypes (subst theta ty1) (subst theta ty2) theta)
+> S.modify (\theta -> unifyTypes (subst theta ty1) (subst theta ty2) theta)
> unifyList :: [Type] -> [Type] -> TyState ()
> unifyList tys1 tys2 = sequence_ (zipWith unify tys1 tys2)
@@ -312,14 +316,14 @@
> unifyArrow :: Type -> TyState (Type,Type)
> unifyArrow ty =
> do
-> theta <- fetchSt
+> theta <- S.get
> case subst theta ty of
> TypeVariable tv
> | tv >= 0 ->
> do
> ty1 <- freshTypeVar
> ty2 <- freshTypeVar
-> updateSt_ (bindVar tv (TypeArrow ty1 ty2))
+> S.modify (bindVar tv (TypeArrow ty1 ty2))
> return (ty1,ty2)
> TypeArrow ty1 ty2 -> return (ty1,ty2)
> ty' -> internalError ("unifyArrow (" ++ show ty' ++ ")")
diff --git a/src/Unlit.lhs b/src/Unlit.lhs
deleted file mode 100644
--- a/src/Unlit.lhs
+++ /dev/null
@@ -1,110 +0,0 @@
-% -*- LaTeX -*-
-% $Id: Unlit.lhs,v 1.2 2002/10/01 06:55:50 lux Exp $
-%
-% $Log: Unlit.lhs,v $
-% Revision 1.2 2002/10/01 06:55:50 lux
-% unlit returns an error message to the caller instead of calling error.
-%
-% Revision 1.1 2000/02/07 14:05:55 lux
-% The compiler now supports literate source files. Literate source files
-% must end with the suffix ".lcurry".
-%
-%
-\nwfilename{Unlit.lhs}
-\section{Literate comments}
-Since version 0.7 of the language report, Curry accepts literate
-source programs. In a literate source all program lines must begin
-with a greater sign in the first column. All other lines are assumed
-to be documentation. In order to avoid some common errors with
-literate programs, Curry requires at least one program line to be
-present in the file. In addition, every block of program code must be
-preceded by a blank line and followed by a blank line.
-
-The module \texttt{Unlit} acts as a preprocessor which converts
-literate source programs into the ``un-literate'' format accepted by
-the lexer. The implementation, together with the comments below, was
-derived from appendix D in the Haskell 1.2 report.
-\begin{verbatim}
-
-> module Unlit(unlit) where
-> import Data.Char
-> import Position
-
-\end{verbatim}
-Each of the lines in a literate script is a program line, a blank
-line, or a comment line. In the first case the text is kept with the
-line.
-\begin{verbatim}
-
-> data Classified = Program String | Blank | Comment
-
-\end{verbatim}
-In a literate program, program lines begin with a \verb|>| character,
-blank lines contain only whitespace, and all other lines are comment
-lines.
-\begin{verbatim}
-
-> classify :: String -> Classified
-> classify "" = Blank
-> classify (c:cs)
-> | c == '>' = Program cs
-> | all isSpace (c:cs) = Blank
-> | otherwise = Comment
-
-\end{verbatim}
-In the corresponding program, program lines have the leading \verb|>|
-replaced by a leading space, to preserve tab alignments.
-\begin{verbatim}
-
-> unclassify :: Classified -> String
-> unclassify (Program cs) = ' ' : cs
-> unclassify Blank = ""
-> unclassify Comment = ""
-
-\end{verbatim}
-Process a literate program into error messages (if any) and the
-corresponding non-literate program.
-\begin{verbatim}
-
-> unlit :: FilePath -> String -> (String,String)
-> unlit fn lcy = (es,cy)
-> where cs = map classify (lines lcy)
-> es = unlines (errors fn cs)
-> cy = unlines (map unclassify cs)
-
-\end{verbatim}
-Check that each program line is not adjacent to a comment line and
-there is at least one program line.
-\begin{verbatim}
-
-> errors :: FilePath -> [Classified] -> [String]
-> errors fn cs =
-> concat (zipWith3 adjacent (iterate nl (first fn)) cs (tail cs)) ++
-> empty fn (filter isProgram cs)
-
-\end{verbatim}
-Given a line number and a pair of adjacent lines, generate a list of
-error messages, which will contain either one entry or none.
-\begin{verbatim}
-
-> adjacent :: Position -> Classified -> Classified -> [String]
-> adjacent p (Program _) Comment = [message (nl p) "after"]
-> adjacent p Comment (Program _) = [message p "before"]
-> adjacent p _ _ = []
-
-> message p w = show p ++ ": comment line " ++ w ++ " program line."
-
-\end{verbatim}
-Given the list of program lines generate an error if this list is
-empty.
-\begin{verbatim}
-
-> empty :: FilePath -> [Classified] -> [String]
-> empty fn [] = [show (first fn) ++ ": no code in literate script"]
-> empty fn _ = []
-
-> isProgram :: Classified -> Bool
-> isProgram (Program _) = True
-> isProgram _ = False
-
-\end{verbatim}
diff --git a/src/Utils.lhs b/src/Utils.lhs
--- a/src/Utils.lhs
+++ b/src/Utils.lhs
@@ -12,16 +12,10 @@
\begin{verbatim}
> module Utils where
-> infixr 5 ++!
-\end{verbatim}
-\paragraph{Pairs}
-The functions \texttt{apFst} and \texttt{apSnd} apply a function to
-the first and second components of a pair, resp.
-\begin{verbatim}
+> import Data.List(foldl')
-> apFst f (x,y) = (f x,y)
-> apSnd f (x,y) = (x,f y)
+> infixr 5 ++!
\end{verbatim}
\paragraph{Triples}
@@ -62,9 +56,9 @@
case of the recursion.
\begin{verbatim}
-> foldl_strict :: (a -> b -> a) -> a -> [b] -> a
-> foldl_strict f z [] = z
-> foldl_strict f z (x:xs) = let z' = f z x in z' `seq` foldl_strict f z' xs
+foldl_strict :: (a -> b -> a) -> a -> [b] -> a
+foldl_strict = foldl'
+
\end{verbatim}
\paragraph{Folding with two lists}
diff --git a/src/WarnCheck.hs b/src/WarnCheck.hs
--- a/src/WarnCheck.hs
+++ b/src/WarnCheck.hs
@@ -8,22 +8,47 @@
--
module WarnCheck (warnCheck) where
-import Control.Monad
+import Control.Monad.State
+import qualified Data.Map as Map
import Data.List
-import CurrySyntax
-import Ident
-import Position
-import Base (ValueEnv, ValueInfo(..), qualLookupValue, lookupValue)
+import Curry.Base.Ident
+import Curry.Base.Position
+import Curry.Base.MessageMonad
+import Curry.Syntax
+
+import Base (ValueEnv, ValueInfo(..), qualLookupValue)
import TopEnv
import qualified ScopeEnv
import ScopeEnv (ScopeEnv)
-import Message
-import Env
+-------------------------------------------------------------------------------
+-- Data type for representing the current state of generating warnings.
+-- The monadic representation of the state allows the usage of monadic
+-- syntax (do expression) for dealing easier and safer with its
+-- contents.
+type CheckState = State CState
+
+data CState = CState {messages :: [WarnMsg],
+ scope :: ScopeEnv QualIdent IdInfo,
+ values :: ValueEnv,
+ moduleId :: ModuleIdent }
+
+-- Runs a 'CheckState' action and returns the list of messages
+run :: CheckState a -> [WarnMsg]
+run f
+ = reverse (messages (execState f emptyState))
+
+emptyState :: CState
+emptyState = CState {messages = [],
+ scope = ScopeEnv.new,
+ values = emptyTopEnv,
+ moduleId = mkMIdent []
+ }
+
-------------------------------------------------------------------------------
-- Find potentially incorrect code in a Curry program and generate
@@ -33,7 +58,7 @@
-- - idle case alternatives
-- - overlapping case alternatives
-- - function rules which are not together
-warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [Message]
+warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [WarnMsg]
warnCheck mid vals imports decls
= run (do addImportedValues vals
addModuleId mid
@@ -164,6 +189,7 @@
(foldM' genWarning' (map unrefVar idents'))
endScope
+
--
checkCondExpr :: ModuleIdent -> CondExpr -> CheckState ()
checkCondExpr mid (CondExpr _ cond expr)
@@ -325,6 +351,7 @@
checkOverlappingAlts mid alts
--
+-- FIXME this looks buggy: is alts' required to be non-null or not? (hsi)
checkIdleAlts :: ModuleIdent -> [Alt] -> CheckState ()
checkIdleAlts mid alts
= do alts' <- dropUnless' isVarAlt alts
@@ -382,16 +409,16 @@
-- Find function rules which are not together
checkDeclOccurrences :: [Decl] -> CheckState ()
-checkDeclOccurrences decls = checkDO (mkIdent "") emptyEnv decls
+checkDeclOccurrences decls = checkDO (mkIdent "") Map.empty decls
where
checkDO prevId env [] = return ()
checkDO prevId env ((FunctionDecl pos ident _):decls)
= do c <- isConsId ident
if not (c || prevId == ident)
- then (maybe (checkDO ident (bindEnv ident pos env) decls)
+ then (maybe (checkDO ident (Map.insert ident pos env) decls)
(\pos' -> genWarning' (rulesNotTogether ident pos')
>> checkDO ident env decls)
- (lookupEnv ident env))
+ (Map.lookup ident env))
else checkDO ident env decls
checkDO _ env (_:decls)
= checkDO (mkIdent "") env decls
@@ -399,15 +426,15 @@
-- check import declarations for multiply imported modules
checkImports :: [Decl] -> CheckState ()
-checkImports imps = checkImps emptyEnv imps
+checkImports imps = checkImps Map.empty imps
where
checkImps env [] = return ()
checkImps env ((ImportDecl pos mid _ _ spec):imps)
| mid /= preludeMIdent
- = maybe (checkImps (bindEnv mid (fromImpSpec spec) env) imps)
+ = maybe (checkImps (Map.insert mid (fromImpSpec spec) env) imps)
(\ishs -> checkImpSpec env pos mid ishs spec
>>= (\env' -> checkImps env' imps))
- (lookupEnv mid env)
+ (Map.lookup mid env)
| otherwise
= checkImps env imps
checkImps env (_:imps) = checkImps env imps
@@ -417,21 +444,21 @@
checkImpSpec env pos mid (is,hs) (Just (Importing _ is'))
| null is && any (\i' -> notElem i' hs) is'
= do genWarning' (multiplyImportedModule mid)
- return (bindEnv mid (is',hs) env)
+ return (Map.insert mid (is',hs) env)
| null iis
- = return (bindEnv mid (is' ++ is,hs) env)
+ = return (Map.insert mid (is' ++ is,hs) env)
| otherwise
= do foldM' genWarning'
(map ((multiplyImportedSymbol mid) . impName) iis)
- return (bindEnv mid (unionBy cmpImport is' is,hs) env)
+ return (Map.insert mid (unionBy cmpImport is' is,hs) env)
where iis = intersectBy cmpImport is' is
checkImpSpec env pos mid (is,hs) (Just (Hiding _ hs'))
| null ihs
- = return (bindEnv mid (is,hs' ++ hs) env)
+ = return (Map.insert mid (is,hs' ++ hs) env)
| otherwise
= do foldM' genWarning'
(map ((multiplyHiddenSymbol mid) . impName) ihs)
- return (bindEnv mid (is,unionBy cmpImport hs' hs) env)
+ return (Map.insert mid (is,unionBy cmpImport hs' hs) env)
where ihs = intersectBy cmpImport hs' hs
cmpImport (ImportTypeWith id1 cs1) (ImportTypeWith id2 cs2)
@@ -572,68 +599,29 @@
_ -> info
--- Data type for representing the current state of generating warnings.
--- The monadic representation of the state allows the usage of monadic
--- syntax (do expression) for dealing easier and safer with its
--- contents.
-data CheckState a = CheckState (CState () -> CState a)
-
-data CState a = CState {messages :: [Message],
- scope :: ScopeEnv QualIdent IdInfo,
- values :: ValueEnv,
- moduleId :: ModuleIdent,
- result :: a
- }
-
--
-emptyState :: CState ()
-emptyState = CState {messages = [],
- scope = ScopeEnv.new,
- values = emptyTopEnv,
- moduleId = mkMIdent [],
- result = ()
- }
-
---
modifyScope :: (ScopeEnv QualIdent IdInfo -> ScopeEnv QualIdent IdInfo)
- -> CState a -> CState a
+ -> CState -> CState
modifyScope f state = state{ scope = f (scope state) }
--- 'CheckState' is declared as an instance of 'Monad' to use its actions
--- in 'do' expressions
-instance Monad CheckState where
-
- -- (>>=) :: CheckState a -> (a -> CheckState b) -> CheckState b
- (CheckState f) >>= g
- = CheckState (\state -> let state' = f state
- CheckState h = g (result state')
- in h (state'{ result = () }))
-
- -- (>>) :: CheckState a -> CheckState b -> CheckState b
- a >> b = a >>= (\_ -> b)
-
- -- return :: a -> CheckState a
- return val = CheckState (\state -> state{ result = val })
-
-
--
-genWarning :: Position -> (WarningType,String) -> CheckState ()
-genWarning pos (warnType,msg)
- = CheckState (\state -> state{ messages = warnMsg:(messages state) })
- where warnMsg = message (Warning warnType) pos msg
+genWarning :: Position -> String -> CheckState ()
+genWarning pos msg
+ = modify (\state -> state{ messages = warnMsg:(messages state) })
+ where warnMsg = WarnMsg (Just pos) msg
-genWarning' :: (Position,WarningType,String) -> CheckState ()
-genWarning' (pos,warnType,msg)
- = CheckState (\state -> state{ messages = warnMsg:(messages state) })
- where warnMsg = message (Warning warnType) pos msg
+genWarning' :: (Position, String) -> CheckState ()
+genWarning' (pos, msg)
+ = modify (\state -> state{ messages = warnMsg:(messages state) })
+ where warnMsg = WarnMsg (Just pos) msg
--
insertVar :: Ident -> CheckState ()
insertVar id
| isAnnonId id = return ()
| otherwise
- = CheckState
+ = modify
(\state -> modifyScope
(ScopeEnv.insert (commonId id) (VarInfo False)) state)
@@ -642,101 +630,90 @@
insertTypeVar id
| isAnnonId id = return ()
| otherwise
- = CheckState
+ = modify
(\state -> modifyScope
(ScopeEnv.insert (typeId id) (VarInfo False)) state)
--
insertConsId :: Ident -> CheckState ()
insertConsId id
- = CheckState
+ = modify
(\state -> modifyScope (ScopeEnv.insert (commonId id) ConsInfo) state)
--
insertTypeConsId :: Ident -> CheckState ()
insertTypeConsId id
- = CheckState
+ = modify
(\state -> modifyScope (ScopeEnv.insert (typeId id) ConsInfo) state)
--
isVarId :: Ident -> CheckState Bool
isVarId id
- = CheckState (\state -> state{ result = isVar state (commonId id) })
+ = gets (\state -> isVar state (commonId id))
--
isConsId :: Ident -> CheckState Bool
isConsId id
- = CheckState (\state -> state{ result = isCons state (qualify id) })
+ = gets (\state -> isCons state (qualify id))
--
isQualConsId :: QualIdent -> CheckState Bool
isQualConsId qid
- = CheckState (\state -> state{ result = isCons state qid })
+ = gets (\state -> isCons state qid)
--
isShadowingVar :: Ident -> CheckState Bool
isShadowingVar id
- = CheckState
- (\state -> state{ result = isShadowing state (commonId id) })
-
---
-isShadowingTypeVar :: Ident -> CheckState Bool
-isShadowingTypeVar id
- = CheckState
- (\state -> state{ result = isShadowing state (typeId id) })
+ = gets (\state -> isShadowing state (commonId id))
--
visitId :: Ident -> CheckState ()
visitId id
- = CheckState
+ = modify
(\state -> modifyScope
(ScopeEnv.modify visitVariable (commonId id)) state)
--
visitTypeId :: Ident -> CheckState ()
visitTypeId id
- = CheckState
+ = modify
(\state -> modifyScope
(ScopeEnv.modify visitVariable (typeId id)) state)
--
-isUnrefVar :: Ident -> CheckState Bool
-isUnrefVar id
- = CheckState (\state -> state{ result = isUnref state (commonId id) })
-
---
isUnrefTypeVar :: Ident -> CheckState Bool
isUnrefTypeVar id
- = CheckState (\state -> state{ result = isUnref state (typeId id) })
+ = gets (\state -> isUnref state (typeId id))
--
returnUnrefVars :: CheckState [Ident]
returnUnrefVars
- = CheckState (\state ->
+ = gets (\state ->
let ids = map fst (ScopeEnv.toLevelList (scope state))
unrefs = filter (isUnref state) ids
- in state{ result = map unqualify unrefs })
+ in map unqualify unrefs )
--
addModuleId :: ModuleIdent -> CheckState ()
-addModuleId mid = CheckState (\state -> state{ moduleId = mid })
+addModuleId mid = modify (\state -> state{ moduleId = mid })
--
-returnModuleId :: CheckState ModuleIdent
-returnModuleId = CheckState (\state -> state{ result = moduleId state })
+withScope :: CheckState a -> CheckState ()
+withScope m = beginScope >> m >> endScope
+
--
beginScope :: CheckState ()
-beginScope = CheckState (\state -> modifyScope ScopeEnv.beginScope state)
+beginScope = modify (\state -> modifyScope ScopeEnv.beginScope state)
--
endScope :: CheckState ()
-endScope = CheckState (\state -> modifyScope ScopeEnv.endScopeUp state)
+endScope = modify (\state -> modifyScope ScopeEnv.endScopeUp state)
-- Adds the content of a value environment to the state
addImportedValues :: ValueEnv -> CheckState ()
-addImportedValues vals = CheckState (\state -> state{ values = vals })
+addImportedValues vals = modify (\state -> state{ values = vals })
--
foldM' :: (a -> CheckState ()) -> [a] -> CheckState ()
@@ -768,36 +745,31 @@
if p then all' mpred xs else return False
--- Runs a 'CheckState' action and returns the list of messages
-run :: CheckState a -> [Message]
-run (CheckState f)
- = reverse (messages (f emptyState))
-
-------------------------------------------------------------------------------
--
-isShadowing :: CState a -> QualIdent -> Bool
+isShadowing :: CState -> QualIdent -> Bool
isShadowing state qid
= let sc = scope state
in maybe False isVariable (ScopeEnv.lookup qid sc)
&& ScopeEnv.level qid sc < ScopeEnv.currentLevel sc
--
-isUnref :: CState a -> QualIdent -> Bool
+isUnref :: CState -> QualIdent -> Bool
isUnref state qid
= let sc = scope state
in maybe False (not . variableVisited) (ScopeEnv.lookup qid sc)
&& ScopeEnv.level qid sc == ScopeEnv.currentLevel sc
--
-isVar :: CState a -> QualIdent -> Bool
+isVar :: CState -> QualIdent -> Bool
isVar state qid = maybe (isAnnonId (unqualify qid))
isVariable
(ScopeEnv.lookup qid (scope state))
--
-isCons :: CState a -> QualIdent -> Bool
+isCons :: CState -> QualIdent -> Bool
isCons state qid = maybe (isImportedCons state qid)
isConstructor
(ScopeEnv.lookup qid (scope state))
@@ -831,56 +803,49 @@
-------------------------------------------------------------------------------
-- Warnings...
-unrefTypeVar :: Ident -> (Position,WarningType,String)
+unrefTypeVar :: Ident -> (Position, String)
unrefTypeVar id =
(positionOfIdent id,
- UnrefTypeVar,
"unreferenced type variable \"" ++ show id ++ "\"")
-unrefVar :: Ident -> (Position,WarningType,String)
+unrefVar :: Ident -> (Position, String)
unrefVar id =
(positionOfIdent id,
- UnrefVar,
- "unreferenced variable \"" ++ show id ++ "\"")
+ "unused declaration of variable \"" ++ show id ++ "\"")
-shadowingVar :: Ident -> (Position,WarningType,String)
+shadowingVar :: Ident -> (Position, String)
shadowingVar id =
(positionOfIdent id,
- ShadowingVar,
"shadowing symbol \"" ++ show id ++ "\"")
-idleCaseAlts :: (WarningType,String)
-idleCaseAlts = (IdleCaseAlt,"idle case alternative(s)")
+idleCaseAlts :: String
+idleCaseAlts = "idle case alternative(s)"
-overlappingCaseAlt :: (WarningType,String)
-overlappingCaseAlt = (OverlapCase,"redundant overlapping case alternative")
+overlappingCaseAlt :: String
+overlappingCaseAlt = "redundant overlapping case alternative"
-rulesNotTogether :: Ident -> Position -> (Position,WarningType,String)
+rulesNotTogether :: Ident -> Position -> (Position, String)
rulesNotTogether id pos
= (positionOfIdent id,
- RulesNotTogether,
"rules for function \"" ++ show id ++ "\" "
++ "are not together "
++ "(first occurrence at "
++ show (line pos) ++ "." ++ show (column pos) ++ ")")
-multiplyImportedModule :: ModuleIdent -> (Position,WarningType,String)
+multiplyImportedModule :: ModuleIdent -> (Position, String)
multiplyImportedModule mid
= (positionOfModuleIdent mid,
- MultipleImportModule,
"module \"" ++ show mid ++ "\" was imported more than once")
-multiplyImportedSymbol :: ModuleIdent -> Ident -> (Position,WarningType,String)
+multiplyImportedSymbol :: ModuleIdent -> Ident -> (Position, String)
multiplyImportedSymbol mid ident
= (positionOfIdent ident,
- MultipleImportSymbol,
"symbol \"" ++ show ident ++ "\" was imported from module \""
++ show mid ++ "\" more than once")
-multiplyHiddenSymbol :: ModuleIdent -> Ident -> (Position,WarningType,String)
+multiplyHiddenSymbol :: ModuleIdent -> Ident -> (Position, String)
multiplyHiddenSymbol mid ident
= (positionOfIdent ident,
- MultipleHiding,
"symbol \"" ++ show ident ++ "\" from module \"" ++ show mid
++ "\" was hidden more than once")
@@ -893,9 +858,6 @@
tail_ alt [] = alt
tail_ _ (_:xs) = xs
-head_ :: a -> [a] -> a
-head_ alt [] = alt
-head_ _ (x:_) = x
--
cmpListM :: Monad m => (a -> a -> m Bool) -> [a] -> [a] -> m Bool
diff --git a/src/cymake.hs b/src/cymake.hs
--- a/src/cymake.hs
+++ b/src/cymake.hs
@@ -16,13 +16,13 @@
import Data.List
import Data.Maybe
import System.IO
-import System.Environment
-import System.Exit
+import System.Environment(getArgs, getProgName)
+import System.Exit(ExitCode(..), exitWith)
import Control.Monad (unless)
import Data.Char (isDigit)
import GetOpt
-import CurryBuilder
+import CurryBuilder(buildCurry)
import CurryCompilerOpts
import CurryHtml
@@ -45,7 +45,7 @@
| null errs' && not (elem Html opts) = do
unless (noVerb options')
(putStrLn $ "This is cymake, version 0.1."
- ++ filter isDigit "$Revision: 3624 $")
+ ++ filter isDigit "$Revision: 3630 $")
mapM_ (buildCurry options') files
| null errs' = do
let importFiles = nub $ importPaths opts'