Parse and ignore import statements

Ignore-this: ea8da63c6e20f7865d58138fc1f19b3

darcs-hash:20111024121605-e29d1-0a3fbc351b16b25e464065590df9fe5379ff4cff.gz

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]

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

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"

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

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)

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) $

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

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 ()" :
 >   []