From a7f6577cd6d7c39e11757dc511c28378116388a6 Mon Sep 17 00:00:00 2001 From: "adam.gundry" Date: Mon, 24 Oct 2011 13:16:05 +0100 Subject: [PATCH] Parse and ignore import statements Ignore-this: ea8da63c6e20f7865d58138fc1f19b3 darcs-hash:20111024121605-e29d1-0a3fbc351b16b25e464065590df9fe5379ff4cff.gz --- examples/InchPrelude.hs | 12 +++++++-- src/Language/Inch/Erase.lhs | 4 +-- src/Language/Inch/Main.lhs | 13 +++++----- src/Language/Inch/Parser.lhs | 29 ++++++++++++++++----- src/Language/Inch/PrettyPrinter.lhs | 34 +++++++++++++++++++----- src/Language/Inch/ProgramCheck.lhs | 10 +++----- src/Language/Inch/Syntax.lhs | 25 +++++++++++++++--- tests/Main.lhs | 40 +++++++++++++++-------------- 8 files changed, 116 insertions(+), 51 deletions(-) diff --git a/examples/InchPrelude.hs b/examples/InchPrelude.hs index 206f61b..7963e9f 100644 --- a/examples/InchPrelude.hs +++ b/examples/InchPrelude.hs @@ -3,6 +3,15 @@ module InchPrelude where +import Prelude hiding (subtract, const, flip, maybe, either, + curry, uncurry, until, asTypeOf, map, + filter, concat, concatMap, head, tail, + last, init, null, length, foldl, foldl1, + foldr, foldr1, iterate, repeat, replicate, + take, drop, splitAt, takeWhile, reverse, + and, or, any, all, sum, product, maximum, + minimum, zip, zipWith, zipWith3) + -- Numeric functions @@ -302,8 +311,7 @@ iterate f x = x : iterate f (f x) repeat :: a -> [a] -repeat x = let xs = x:xs - in xs +repeat x = xs where xs = x:xs replicate :: Integer -> a -> [a] diff --git a/src/Language/Inch/Erase.lhs b/src/Language/Inch/Erase.lhs index dab22e8..0a8c647 100644 --- a/src/Language/Inch/Erase.lhs +++ b/src/Language/Inch/Erase.lhs @@ -156,5 +156,5 @@ > FunDecl x <$> traverse eraseAlt ps > eraseDecl (SigDecl x ty) = SigDecl x <$> eraseToSet ty -> eraseProg :: Program -> Contextual Program -> eraseProg = traverse eraseDecl +> eraseModule :: Module () -> Contextual (Module ()) +> eraseModule (Mod mh is ds) = Mod mh is <$> traverse eraseDecl ds diff --git a/src/Language/Inch/Main.lhs b/src/Language/Inch/Main.lhs index d1a619e..3cfcc61 100644 --- a/src/Language/Inch/Main.lhs +++ b/src/Language/Inch/Main.lhs @@ -5,6 +5,7 @@ > import System.Exit > import System.FilePath +> import Language.Inch.Context > import Language.Inch.Syntax > import Language.Inch.Parser > import Language.Inch.PrettyPrinter @@ -32,16 +33,16 @@ > modHeader (Just m) = "module " ++ m ++ " where\n" > preprocess :: String -> String -> Either String (String, String) -> preprocess fn s = case parseProgram fn s of -> Right (p, mn) -> case runCheckProg p of -> Right (p', st) -> case runStateT (eraseProg p') st of -> Right (p'', st) -> Right (sigs p', erased) +> preprocess fn s = case parseModule fn s of +> Right mod -> case runStateT (checkModule mod) initialState of +> Right (mod', st) -> case evalStateT (eraseModule mod') st of +> Right mod'' -> Right (sigs p, renderMe (fog mod'')) > where -> sigs = show . prettyProgram . filter dataOrSigDecl +> Mod _ _ p = mod'' +> sigs = renderMe . map fog . filter dataOrSigDecl > dataOrSigDecl (SigDecl _ _) = True > dataOrSigDecl (DataDecl _ _ _ _) = True > dataOrSigDecl (FunDecl _ _) = False -> erased = modHeader mn ++ show (prettyProgram p'') > Left err -> Left $ "erase error:\n" ++ renderMe err ++ "\n" > Left err -> Left $ "type-checking failed:\n" diff --git a/src/Language/Inch/Parser.lhs b/src/Language/Inch/Parser.lhs index dc9a834..0fb27db 100644 --- a/src/Language/Inch/Parser.lhs +++ b/src/Language/Inch/Parser.lhs @@ -1,8 +1,9 @@ -> module Language.Inch.Parser (parseProgram) where +> module Language.Inch.Parser (parseModule) where > import Control.Applicative > import Control.Monad > import Data.Char +> import Data.Maybe > import Text.ParserCombinators.Parsec hiding (parse, optional, many, (<|>)) > import Text.ParserCombinators.Parsec.Expr @@ -17,7 +18,7 @@ > import Language.Inch.Kit > import Language.Inch.Kind hiding (kind) -> parseProgram = I.parse program +> parseModule = I.parse module_ > def = haskellDef @@ -51,6 +52,8 @@ > specialOp s = try $ > string s >> notFollowedBy (opLetter def) >> whiteSpace +> optionalList p = maybe [] id <$> optional p + > doubleColon = reservedOp "::" @@ -249,16 +252,28 @@ Terms > wrapLam (Right s : ss) t = NumLam s $ rawCoerce $ wrapLam ss t -Programs +Modules -> program = do +> module_ = do > whiteSpace > _ <- optional (reserved "#line" >> integer >> stringLiteral) -> mn <- optional (reserved "module" *> -> identLike False "module name" <* reserved "where") +> mh <- optional (reserved "module" *> +> ((,) <$> identLike False "module name" +> <*> optionalList (parens (commaSep identifier))) +> <* reserved "where") +> is <- many importStmt > ds <- many decl > eof -> return (ds, mn) +> return $ Mod mh is ds + +> importStmt = do +> reserved "import" +> q <- isJust <$> optional (reserved "qualified") +> n <- identLike False "module name" +> as <- optional (reserved "as" *> identLike False "module name") +> im <- optional (parens (commaSep identifier)) +> ex <- optionalList (reserved "hiding" *> parens (commaSep identifier)) +> return $ Import q n as im ex > decl = dataDecl > <|> sigDecl diff --git a/src/Language/Inch/PrettyPrinter.lhs b/src/Language/Inch/PrettyPrinter.lhs index 3abd459..5d6feb9 100644 --- a/src/Language/Inch/PrettyPrinter.lhs +++ b/src/Language/Inch/PrettyPrinter.lhs @@ -31,12 +31,6 @@ > | dSize > curSize = parens d > | otherwise = d -> prettyProgram :: Program -> Doc -> prettyProgram = prettySProgram . map fog - -> prettySProgram :: SProgram -> Doc -> prettySProgram = vcat . intersperse (text " ") . map prettyHigh - > prettyVar :: Var () k -> Doc > prettyVar = prettyHigh . fogVar @@ -59,6 +53,8 @@ > instance Pretty String where > pretty s _ = text s +> instance Pretty [SDeclaration ()] where +> pretty ds _ = vcat (map prettyHigh ds) > instance Pretty SKind where > pretty SKSet = const $ text "*" @@ -163,6 +159,32 @@ > prettyLam d t = wrapDoc LamSize $ > text "\\" <+> d <+> text "->" <+> pretty t AppSize + +> parenCommaList :: Doc -> [String] -> Doc +> parenCommaList d [] = empty +> parenCommaList d xs = d <+> parens (hsep (punctuate (text ",") (map text xs))) + + +> instance Pretty (SModule a) where +> pretty (Mod mh is ds) _ = maybe empty prettyModHeader mh +> $$ vcat (map prettyHigh is) +> $$ vcat (intersperse (text " ") (map prettyHigh ds)) +> where +> prettyModHeader (s, es) = text "module" <+> text s <+> parenCommaList empty es <+> text "where" + + +> instance Pretty Import where +> pretty (Import q n as imp hid) _ = text "import" +> <+> (if q then text "qualified" else empty) +> <+> text n +> <+> (maybe empty (\ s -> text "as" <+> text s) as) +> <+> prettyImp imp +> <+> parenCommaList (text "hiding") hid +> where +> prettyImp Nothing = empty +> prettyImp (Just xs) = parens (hsep (punctuate (text ",") (map text xs))) + + > instance Pretty (SDeclaration a) where > pretty (DataDecl n k cs ds) _ = hang (text "data" <+> text n > <+> (if k /= SKSet then text "::" <+> prettyHigh k else empty) diff --git a/src/Language/Inch/ProgramCheck.lhs b/src/Language/Inch/ProgramCheck.lhs index dac02e0..c3c3978 100644 --- a/src/Language/Inch/ProgramCheck.lhs +++ b/src/Language/Inch/ProgramCheck.lhs @@ -29,14 +29,12 @@ > B0 -> return () > _ -> traceContext "assertContextEmpty" >> erk "context is not empty" -> runCheckProg :: SProgram -> Either ErrorData (Program, ZipState) -> runCheckProg p = runStateT (checkProg p) initialState - -> checkProg :: SProgram -> Contextual Program -> checkProg ds = do +> checkModule :: SModule () -> Contextual (Module ()) +> checkModule (Mod mh is ds) = do > mapM_ makeTyCon ds > mapM_ makeBinding ds -> concat <$> traverse checkDecl ds +> ds' <- concat <$> traverse checkDecl ds +> return $ Mod mh is ds' > where > makeTyCon :: SDeclaration () -> Contextual () > makeTyCon (DataDecl t k _ ds) = inLocation (text $ "in data type " ++ t) $ diff --git a/src/Language/Inch/Syntax.lhs b/src/Language/Inch/Syntax.lhs index 5d53ce7..6bed305 100644 --- a/src/Language/Inch/Syntax.lhs +++ b/src/Language/Inch/Syntax.lhs @@ -48,28 +48,27 @@ -> type Prog s = [Decl s ()] > type Con s = TmConName ::: ATy s () KSet > type Term = Tm OK +> type Module = Mod OK > type Constructor = Con OK > type Alternative = Alt OK > type CaseAlternative = CaseAlt OK > type PatternList = PatList OK > type Pattern = Pat OK > type Declaration = Decl OK -> type Program = Prog OK > type Guard = Grd OK > type GuardTerms = GrdTms OK > type STerm = Tm RAW +> type SModule = Mod RAW > type SConstructor = Con RAW > type SAlternative = Alt RAW > type SCaseAlternative = CaseAlt RAW > type SPatternList = PatList RAW > type SPattern = Pat RAW > type SDeclaration = Decl RAW -> type SProgram = Prog RAW > type SGuard = Grd RAW > type SGuardTerms = GrdTms RAW @@ -149,6 +148,26 @@ +> data Mod s a where +> Mod :: Maybe (String, [String]) -> [Import] -> [Decl s a] -> Mod s a + +> deriving instance Eq (Mod RAW a) + +> instance TravTypes Mod where +> travTypes g (Mod mh is ds) = Mod mh is <$> traverse (travTypes g) ds +> fogTypes g (Mod mh is ds) = Mod mh is (map (fogTypes g) ds) +> renameTypes g (Mod mh is ds) = Mod mh is (map (renameTypes g) ds) + +> data Import = Import { qualified :: Bool +> , importName :: String +> , asName :: Maybe String +> , impSpec :: Maybe [String] +> , hidingSpec :: [String] +> } +> deriving (Eq, Show) + + + > data Tm s a where > TmVar :: TmName -> Tm s a > TmCon :: TmConName -> Tm s a diff --git a/tests/Main.lhs b/tests/Main.lhs index 3e7bf60..def5108 100644 --- a/tests/Main.lhs +++ b/tests/Main.lhs @@ -5,6 +5,7 @@ > import Data.List > import System.Directory +> import Language.Inch.Context > import Language.Inch.Syntax > import Language.Inch.Parser > import Language.Inch.PrettyPrinter @@ -33,41 +34,41 @@ > eraseCheckTest = runTest id eraseCheck (map fst . filter snd $ parseCheckTestData) 0 0 > roundTrip :: String -> Either String String -> roundTrip s = case parseProgram "roundTrip" s of -> Right (prog, _) -> -> let s' = show $ vcatPretty prog in -> case parseProgram "roundTrip2" s' of -> Right (prog', _) -> | prog == prog' -> Right $ show (vcatPretty prog') +> roundTrip s = case parseModule "roundTrip" s of +> Right mod -> +> let s' = renderMe mod in +> case parseModule "roundTrip2" s' of +> Right mod' +> | mod == mod' -> Right $ renderMe mod' > | otherwise -> Left $ "Round trip mismatch:" > ++ "\n" ++ s ++ "\n" ++ s' -> ++ "\n" ++ show (vcatPretty prog') +> ++ "\n" ++ renderMe mod' > -- ++ "\n" ++ show prog ++ "\n" ++ show prog' > Left err -> Left $ "Round trip re-parse:\n" > ++ s' ++ "\n" ++ show err > Left err -> Left $ "Initial parse:\n" ++ s ++ "\n" ++ show err > parseCheck :: (String, Bool) -> Either String String -> parseCheck (s, b) = case parseProgram "parseCheck" s of -> Right (p, _) -> case runCheckProg p of -> Right (p', _) +> parseCheck (s, b) = case parseModule "parseCheck" s of +> Right mod -> case evalStateT (checkModule mod) initialState of +> Right mod' > | b -> Right $ "Accepted good program:\n" -> ++ show (prettyProgram p') ++ "\n" +> ++ renderMe (fog mod') ++ "\n" > | otherwise -> Left $ "Accepted bad program:\n" -> ++ show (prettyProgram p') ++ "\n" +> ++ renderMe (fog mod') ++ "\n" > Left err > | b -> Left $ "Rejected good program:\n" -> ++ show (prettySProgram p) ++ "\n" ++ renderMe err ++ "\n" +> ++ renderMe mod ++ "\n" ++ renderMe err ++ "\n" > | otherwise -> Right $ "Rejected bad program:\n" -> ++ show (prettySProgram p) ++ "\n" ++ renderMe err ++ "\n" +> ++ renderMe mod ++ "\n" ++ renderMe err ++ "\n" > Left err -> Left $ "Parse error:\n" ++ s ++ "\n" ++ show err ++ "\n" > eraseCheck :: String -> Either String String -> eraseCheck s = case parseProgram "eraseCheck" s of -> Right (p, _) -> case runCheckProg p of -> Right (p', st) -> case runStateT (eraseProg p') st of -> Right (p'', _) -> case runCheckProg (map fog p'') of -> Right (p''', _) -> Right $ "Erased program:\n" ++ show (prettyProgram p''') +> eraseCheck s = case parseModule "eraseCheck" s of +> Right mod -> case runStateT (checkModule mod) initialState of +> Right (mod', st) -> case runStateT (eraseModule mod') st of +> Right (mod'', st') -> case evalStateT (checkModule (fog mod'')) st' of +> Right mod''' -> Right $ "Erased program:\n" ++ renderMe (fog mod''') > Left err -> Left $ "Erased program failed to type check: " ++ renderMe err > Left err -> Left $ "Erase error:\n" ++ s ++ "\n" ++ renderMe err ++ "\n" @@ -206,6 +207,7 @@ > "f (_:x) = x" : > "x = y where y = 3" : > "x = y\n where\n y = z\n z = x" : +> "import A\nimport qualified B\nimport C (x, y)\nimport D as E hiding (z)\nimport F ()" : > []