Commit 538d5bc4 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Small refactorings

parent 7ba3efd7
......@@ -44,9 +44,9 @@ In this section a lexer for Curry is implemented.
> isEOF (Token cat _) = cat == EOF
> -- |Category of curry tokens
> data Category =
> data Category
> -- literals
> CharTok | IntTok | FloatTok | IntegerTok | StringTok
> = CharTok | IntTok | FloatTok | IntegerTok | StringTok
> -- identifiers
> | Id | QId | Sym | QSym
> -- punctuation symbols
......@@ -71,6 +71,8 @@ In this section a lexer for Curry is implemented.
> | Sym_Dot | Sym_Minus | Sym_MinusDot
> -- end-of-file token
> | EOF
> -- compiler pragma (bjp)
> | Pragma
> -- comments (only for full lexer) inserted by men & bbr
> | LineComment | NestedComment
> deriving (Eq,Ord)
......@@ -87,22 +89,22 @@ attribute values, we make use of records.
> -- |Attributes associated to a token
> data Attributes
> = NoAttributes
> | CharAttributes { cval :: Char, original :: String}
> | IntAttributes { ival :: Int , original :: String}
> | FloatAttributes { fval :: Double, original :: String}
> | IntegerAttributes { intval :: Integer, original :: String}
> | StringAttributes { sval :: String, original :: String}
> | IdentAttributes { modul :: [String], sval :: String}
> | CharAttributes { cval :: Char , original :: String}
> | IntAttributes { ival :: Int , original :: String}
> | FloatAttributes { fval :: Double , original :: String}
> | IntegerAttributes { intval :: Integer , original :: String}
> | StringAttributes { sval :: String , original :: String}
> | IdentAttributes { modul :: [String], sval :: String}
> instance Show Attributes where
> showsPrec _ NoAttributes = showChar '_'
> showsPrec _ (CharAttributes cv _) = shows cv
> showsPrec _ (IntAttributes iv _) = shows iv
> showsPrec _ (FloatAttributes fv _) = shows fv
> showsPrec _ NoAttributes = showChar '_'
> showsPrec _ (CharAttributes cv _) = shows cv
> showsPrec _ (IntAttributes iv _) = shows iv
> showsPrec _ (FloatAttributes fv _) = shows fv
> showsPrec _ (IntegerAttributes iv _) = shows iv
> showsPrec _ (StringAttributes sv _) = shows sv
> showsPrec _ (StringAttributes sv _) = shows sv
> showsPrec _ (IdentAttributes mIdent ident) =
> showString ("`" ++ concat (intersperse "." (mIdent ++ [ident])) ++ "'")
> showString ("`" ++ intercalate "." (mIdent ++ [ident]) ++ "'")
\end{verbatim}
The following functions can be used to construct tokens with
......@@ -155,6 +157,10 @@ specific attributes.
> nestedCommentTok s = Token NestedComment
> StringAttributes { sval = s, original = s }
> -- |Construct a 'Token' for a compiler pragma
> pragmaTok :: String -> Token
> pragmaTok s = Token Pragma StringAttributes { sval = s, original = s }
\end{verbatim}
The \texttt{Show} instance of \texttt{Token} is designed to display
all tokens in their source representation.
......@@ -232,9 +238,10 @@ all tokens in their source representation.
> showsPrec _ (Token EOF _) = showString "<end-of-file>"
> showsPrec _ (Token LineComment a) = shows a
> showsPrec _ (Token NestedComment a) = shows a
> showsPrec _ (Token Pragma a) = showString "pragma " . shows a
\end{verbatim}
Tables for reserved operators and identifiers
Maps for reserved operators and identifiers
\begin{verbatim}
> -- |Map of reserved operators
......@@ -326,8 +333,8 @@ Lexing functions
> 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):)
> | c == EOF = returnP [(p, t)]
> | otherwise = lexFile `thenP` returnP . ((p, t) :)
> lexer :: SuccessP a -> FailP a -> P a
> lexer success fail = skipBlanks
......@@ -335,8 +342,8 @@ Lexing functions
> 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 = skipBlanks (nl p) (tail' (dropWhile (/= '\n') s)) True
> skipBlanks p ('{':'-':'#':s) bol = lexPragma id p success fail (incr p 3) s bol
> skipBlanks p ('{':'-':s) bol =
> nestedComment p skipBlanks fail (incr p 2) s bol
> skipBlanks p (c:s) bol
......@@ -353,8 +360,8 @@ Lexing functions
> 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 ('{':'-':'#':s) bol = lexPragma id p success fail (incr p 3) 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 =
......@@ -364,6 +371,18 @@ Lexing functions
> lexLineComment success p s = case break (=='\n') s of
> (comment,rest) -> success p (lineCommentTok comment) (incr p (length comment)) rest
> lexPragma :: (String -> String) -> Position -> SuccessP a -> FailP a -> P a
> lexPragma prag p0 success _ p ('#':'-':'}':s)
> = success p (pragmaTok (prag "")) (incr p 3) s
> lexPragma prag p0 success fail p (c@'\t':s)
> = lexPragma (prag . (c:)) p0 success fail (tab p) s
> lexPragma prag p0 success fail p (c@'\n':s)
> = lexPragma (prag . (c:)) p0 success fail (nl p) s
> lexPragma prag p0 success fail p (c:s)
> = lexPragma (prag . (c:)) p0 success fail (next p) s
> lexPragma prag p0 success fail p ""
> = fail p0 "Unterminated pragma" p []
> lexNestedComment :: Int -> (String -> String) ->
> Position -> SuccessP a -> FailP a -> P a
> lexNestedComment 1 comment p0 success _ p ('-':'}':s) =
......
......@@ -43,9 +43,11 @@ an unlimited range of integer constants in Curry programs.
\paragraph{Modules}
\begin{verbatim}
> data Module = Module ModuleIdent (Maybe ExportSpec) [Decl]
> data Module = Module [Pragma] ModuleIdent (Maybe ExportSpec) [Decl]
> deriving (Eq,Show,Read,Typeable,Data)
> data Pragma = Pragma String String
> data ExportSpec = Exporting Position [Export]
> deriving (Eq,Show,Read,Typeable,Data)
> data Export
......
......@@ -6,15 +6,15 @@ module Html.SyntaxColoring
import Data.Char hiding (Space)
import Data.Function (on)
import Data.Maybe
import Data.List
import Debug.Trace
import Data.Maybe ()
import Data.List ()
import Debug.Trace ()
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.MessageMonad
import Curry.Syntax hiding (infixOp)
import Curry.Syntax.Lexer
import Curry.Syntax.Lexer ()
debug :: Bool
debug = False -- mergen von Token und Codes
......
......@@ -92,15 +92,21 @@ code are obsolete and commented out.
> compileModule :: Options -> FilePath -> IO (Maybe FilePath)
> compileModule opts fn = do
> modul <- liftM (importPrelude fn . ok . parseModule likeFlat fn) (readModule fn)
> -- read, parse and eventually add Prelude import
> modul <- liftM (importPrelude opts fn . ok . parseModule likeFlat fn) (readModule fn)
> -- generate module identifier from file name if missing
> let m = patchModuleId fn modul
> -- check whether module identifier and file name fit together
> checkModuleId fn m
> -- load the imported interfaces into a 'ModuleEnv'
> mEnv <- loadInterfaces (importPaths opts) m
> if uacy || src
> then do
> (tyEnv, tcEnv, _, m', _, _) <- simpleCheckModule opts mEnv m
> if uacy
> -- generate untyped AbstractCurry
> then genAbstract opts fn tyEnv tcEnv m'
> -- just output the parsed source
> else do
> let outputFile = fromMaybe (sourceRepName fn) (output opts)
> outputMod = showModule m'
......@@ -109,7 +115,7 @@ code are obsolete and commented out.
> else do
> -- checkModule checks types, and then transModule introduces new
> -- functions (by lambda lifting in 'desugar'). Consequence: The
> -- type of the newly introduced functions are not inferred (hsi)
> -- types of the newly introduced functions are not inferred (hsi)
> (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m
> let (il,aEnv',dumps) = transModule fcy False False
> mEnv tyEnv tcEnv aEnv m'
......@@ -127,22 +133,56 @@ code are obsolete and commented out.
> | acy = genAbstract opts' fn' tyEnv tcEnv m'
> | otherwise = return Nothing
> loadInterfaces :: [FilePath] -> Module -> IO ModuleEnv
> loadInterfaces paths (Module m _ ds) =
> foldM (loadInterface paths [m]) Map.empty
> [(p,m') | ImportDecl p m' _ _ _ <- ds]
\end{verbatim}
A module which doesn't contain a \texttt{module ... where} declaration
obtains its filename as module identifier (unlike the definition in
Haskell and original MCC where a module obtains \texttt{main}).
\begin{verbatim}
> patchModuleId :: FilePath -> Module -> Module
> patchModuleId fn m@(Module mid mexports decls)
> | moduleName mid == "main"
> = Module (mkMIdent [takeBaseName fn]) mexports decls
> | otherwise
> = m
> checkModuleId :: Monad m => FilePath -> Module -> m ()
> checkModuleId fn (Module mid _ _)
> | last (moduleQualifiers mid) == takeBaseName fn
> = return ()
> | otherwise
> = error ("module \"" ++ moduleName mid
> ++ "\" must be in a file \"" ++ moduleName mid
> ++ ".curry\"")
> | last (moduleQualifiers mid) == takeBaseName fn
> = return ()
> | otherwise
> = error $ "module \"" ++ moduleName mid
> ++ "\" must be in a file \"" ++ moduleName mid
> ++ ".curry\""
\end{verbatim}
An implicit import of the prelude is added to the declarations of
every module, except for the prelude itself, or when the import is disabled
by a compiler option. If no explicit import for the prelude is present,
the prelude is imported unqualified, otherwise
only a qualified import is added.
\begin{verbatim}
> importPrelude :: Options -> FilePath -> Module -> Module
> importPrelude opts fn (Module m es ds)
> | m == preludeMIdent = Module m es ds
> | xNoImplicitPrelude = Module m es ds
> | otherwise = Module m es ds'
> where ids = [decl | decl@(ImportDecl _ _ _ _ _) <- ds]
> ds' = ImportDecl (first fn) preludeMIdent
> (preludeMIdent `elem` map importedModule ids)
> Nothing Nothing : ds
> importedModule (ImportDecl _ m' _ asM _) = fromMaybe m' asM
> importedModule _ = error "Modules.importPrelude.importedModule: no pattern match"
> -- |Load the interface files into the 'ModuleEnv'
> loadInterfaces :: [FilePath] -> Module -> IO ModuleEnv
> loadInterfaces paths (Module m _ ds) =
> foldM (loadInterface paths [m]) Map.empty
> [(p, m') | ImportDecl p m' _ _ _ <- ds]
> simpleCheckModule :: Options -> ModuleEnv -> Module
> -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[WarnMsg])
> -> 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)
......@@ -238,40 +278,6 @@ code are obsolete and commented out.
> | uniqueId x == 0 = bindQual (x,y)
> | otherwise = bindTopEnv "Modules.qualifyEnv" x y
> writeXML :: Bool -> Maybe FilePath -> FilePath -> CurryEnv -> IL.Module -> IO ()
> writeXML sub tfn sfn cEnv il = writeModule sub ofn (showln code)
> where ofn = fromMaybe (xmlName sfn) tfn
> code = (IL.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 (flatName sfn) tfn)
> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog
> writeFlatFile opts@Options{extendedFlat=ext,writeToSubdir=sub} (res,msgs) fname = do
> unless (noWarn opts) (printMessages msgs)
> if ext then writeExtendedFlat sub fname res
> else writeFlatCurry sub fname res
> return res
> writeTypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module
> -> IO ()
> writeTypedAbs sub tfn sfn tyEnv tcEnv modul
> = AC.writeCurry sub fname (genTypedAbstract tyEnv tcEnv modul)
> where fname = fromMaybe (acyName sfn) tfn
> writeUntypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv
> -> Module -> IO ()
> writeUntypedAbs sub tfn sfn tyEnv tcEnv modul
> = AC.writeCurry sub fname (genUntypedAbstract tyEnv tcEnv modul)
> where fname = fromMaybe (uacyName sfn) tfn
> showln :: Show a => a -> String
> showln x = shows x "\n"
\end{verbatim}
The function \texttt{importModules} brings the declarations of all
......@@ -386,23 +392,6 @@ type check.
> TypeRecord (map (\ (l,ty) -> (l,expandRecords tcEnv ty)) fs) rv
> expandRecords _ ty = ty
\end{verbatim}
An implicit import of the prelude is added to the declarations of
every module, except for the prelude itself. If no explicit import for
the prelude is present, the prelude is imported unqualified, otherwise
only a qualified import is added.
\begin{verbatim}
> importPrelude :: FilePath -> Module -> Module
> importPrelude fn (Module m es ds) =
> Module m es (if m == preludeMIdent then ds else ds')
> where ids = [decl | decl@(ImportDecl _ _ _ _ _) <- ds]
> ds' = ImportDecl (first fn) preludeMIdent
> (preludeMIdent `elem` map importedModule ids)
> Nothing Nothing : ds
> importedModule (ImportDecl _ m' _ asM _) = fromMaybe m' asM
> importedModule _ = error "Modules.importPrelude.importedModule: no pattern match"
\end{verbatim}
If an import declaration for a module is found, the compiler first
checks whether an import for the module is already pending. In this
......@@ -414,7 +403,7 @@ and compiled.
\begin{verbatim}
> loadInterface :: [FilePath] -> [ModuleIdent] -> ModuleEnv ->
> (Position,ModuleIdent) -> IO ModuleEnv
> (Position, ModuleIdent) -> IO ModuleEnv
> loadInterface paths ctxt mEnv (p,m)
> | m `elem` ctxt = errorAt p (cyclicImport m (takeWhile (/= m) ctxt))
> | isLoaded m mEnv = return mEnv
......@@ -461,13 +450,49 @@ generated FlatCurry terms (type \texttt{Prog}).
Interface files are updated by the Curry builder when necessary.
(see module \texttt{CurryBuilder}).
-- ---------------------------------------------------------------------------
-- File Output
-- ---------------------------------------------------------------------------
> writeXML :: Bool -> Maybe FilePath -> FilePath -> CurryEnv -> IL.Module -> IO ()
> writeXML sub tfn sfn cEnv il = writeModule sub ofn (showln code)
> where ofn = fromMaybe (xmlName sfn) tfn
> code = (IL.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 (flatName sfn) tfn)
> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog
> writeFlatFile opts (res, msgs) fname = do
> unless (noWarn opts) (printMessages msgs)
> if extendedFlat opts then writeExtendedFlat sub fname res
> else writeFlatCurry sub fname res
> return res
> where sub = writeToSubdir opts
> writeTypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module -> IO ()
> writeTypedAbs sub tfn sfn tyEnv tcEnv modul
> = AC.writeCurry sub fname (genTypedAbstract tyEnv tcEnv modul)
> where fname = fromMaybe (acyName sfn) tfn
> writeUntypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module -> IO ()
> writeUntypedAbs sub tfn sfn tyEnv tcEnv modul
> = AC.writeCurry sub fname (genUntypedAbstract tyEnv tcEnv modul)
> where fname = fromMaybe (uacyName sfn) tfn
> showln :: Show a => a -> String
> showln x = shows x "\n"
\end{verbatim}
The \texttt{doDump} function writes the selected information to the
standard output.
\begin{verbatim}
> doDump :: Options -> (Dump,Doc) -> IO ()
> doDump opts (d,x) =
> doDump opts (d, x) =
> when (d `elem` dump opts)
> (print (text hd $$ text (replicate (length hd) '=') $$ x))
> where hd = dumpHeader d
......@@ -520,21 +545,20 @@ be dependent on it any longer.
> cEnv = curryEnv mEnv tcEnv intf modul
> emptyIntf = Prog "" [] [] [] []
> writeInterface intf' msgs = do
> unless (noWarn opts) (printMessages msgs)
> writeFlatCurry (writeToSubdir opts) fintName intf'
> unless (noWarn opts) (printMessages msgs)
> writeFlatCurry (writeToSubdir opts) fintName intf'
> genAbstract :: Options -> FilePath -> ValueEnv -> TCEnv -> Module
> -> IO (Maybe FilePath)
> genAbstract :: Options -> FilePath -> ValueEnv -> TCEnv -> Module -> IO (Maybe FilePath)
> genAbstract opts@Options{writeToSubdir=sub} fname tyEnv tcEnv modul
> | abstract opts
> = do writeTypedAbs sub Nothing fname tyEnv tcEnv modul
> return Nothing
> | untypedAbstract opts
> = do writeUntypedAbs sub Nothing fname tyEnv tcEnv modul
> return Nothing
> | otherwise
> = internalError "@Modules.genAbstract: illegal option"
> | abstract opts
> = do writeTypedAbs sub Nothing fname tyEnv tcEnv modul
> return Nothing
> | untypedAbstract opts
> = do writeUntypedAbs sub Nothing fname tyEnv tcEnv modul
> return Nothing
> | otherwise
> = internalError "@Modules.genAbstract: illegal option"
> printMessages :: [WarnMsg] -> IO ()
> printMessages [] = return ()
......@@ -556,21 +580,6 @@ from the type environment.
> isValue (Value _ _) = True
> isValue (Label _ _ _) = False
\end{verbatim}
A module which doesn't contain a \texttt{module ... where} declaration
obtains its filename as module identifier (unlike the definition in
Haskell and original MCC where a module obtains \texttt{main}).
\begin{verbatim}
> patchModuleId :: FilePath -> Module -> Module
> patchModuleId fn (Module mid mexports decls)
> | (moduleName mid) == "main"
> = Module (mkMIdent [takeBaseName fn]) mexports decls
> | otherwise
> = Module mid mexports decls
\end{verbatim}
Error functions.
\begin{verbatim}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment