Split off top-level declarations in syntax

Ignore-this: 8bcfee98b2396a4f7e42ca719a1ccbf

darcs-hash:20111109152752-e29d1-9d649146338747e38329c16eb1234d2354215656.gz

src/Language/Inch/Check.lhs

@@ -67,9 +67,12 @@ Set this to True in order to verify the context regularly:
 > goodTy :: Context -> Type k -> Bool
 > goodTy = goodFV
 
+> goodTopDecl :: Context -> TopDeclaration () -> Bool
+> goodTopDecl g (DataDecl _ _ cs _)  = all (\ (_ ::: t) -> goodTy g t) cs
+> goodTopDecl g (Decl d)             = goodDecl g d
+
 > goodDecl :: Context -> Declaration () -> Bool
 > goodDecl g (SigDecl _ t)        = goodTy g t
-> goodDecl g (DataDecl _ _ cs _)  = all (\ (_ ::: t) -> goodTy g t) cs
 > goodDecl _ (FunDecl _ _)        = True
 
 

src/Language/Inch/Erase.lhs

@@ -159,16 +159,19 @@
 >     (ps',  g) <- erasePatList ps
 >     return (p' :! ps', f . g)
 
-> eraseDecl :: Declaration () -> Contextual (Declaration ())
-> eraseDecl (DataDecl s k cs ds) =
+> eraseTopDecl :: TopDeclaration () -> Contextual (TopDeclaration ())
+> eraseTopDecl (DataDecl s k cs ds) =
 >     case eraseKind k of
 >         Just (Ex k') -> do
 >             cs' <- traverse eraseCon cs
 >             return $ DataDecl s k' cs' ds
->         Nothing -> error $ "eraseType: failed to erase kind " ++ show k
+>         Nothing -> error $ "eraseTopDecl: failed to erase kind " ++ show k
+> eraseTopDecl (Decl d) = Decl <$> eraseDecl d
+
+> eraseDecl :: Declaration () -> Contextual (Declaration ())
 > eraseDecl (FunDecl x ps) =
 >     FunDecl x <$> traverse eraseAlt ps
 > eraseDecl (SigDecl x ty) = SigDecl x <$> eraseToSet ty
 
 > eraseModule :: Module () -> Contextual (Module ())
-> eraseModule (Mod mh is ds) = Mod mh is <$> traverse eraseDecl ds
+> eraseModule (Mod mh is ds) = Mod mh is <$> traverse eraseTopDecl ds

src/Language/Inch/File.lhs

@@ -41,18 +41,18 @@
 > getInterface :: Module () -> String
 > getInterface = renderMe . map fog . filter dataOrSigDecl . modDecls
 >   where
->     dataOrSigDecl (SigDecl _ _)       = True
->     dataOrSigDecl (DataDecl _ _ _ _)  = True
->     dataOrSigDecl (FunDecl _ _)       = False
+>     dataOrSigDecl (DataDecl _ _ _ _)    = True
+>     dataOrSigDecl (Decl (SigDecl _ _))  = True
+>     dataOrSigDecl (Decl (FunDecl _ _))  = False
 
 
-> readImport :: FilePath -> Import -> IO [SDeclaration ()]
+> readImport :: FilePath -> Import -> IO [STopDeclaration ()]
 > readImport dir im = do
 >     s <- catch (readFile (combine dir inchFile)) $ \ (_ :: IOException) ->
 >              catch (readFile =<< getDataFileName inchFile) $ \ (_ :: IOException) ->
 >                  hPutStrLn stderr ("Could not load " ++ inchFile) >> return ""
 >     case parseInterface inchFile s of
->         Right ds  -> return $ filter (included . declName) ds
+>         Right ds  -> return $ filter (included . topDeclName) ds
 >         Left err  -> putStrLn ("interface parse error:\n" ++ show err) >> exitFailure
 >   where
 >     inchFile = importName im ++ ".inch"
@@ -61,7 +61,7 @@
 >         Imp ys        -> x `elem` ys
 >         ImpHiding ys  -> x `notElem` ys
 
-> readImports :: FilePath -> [Import] -> IO [SDeclaration ()]
+> readImports :: FilePath -> [Import] -> IO [STopDeclaration ()]
 > readImports dir is = fmap join (mapM (readImport dir) is')
 >   where
 >     is' = if any (("Prelude" ==) . importName) is then is

src/Language/Inch/Parser.lhs

@@ -284,7 +284,7 @@ Terms
 
 Interface files
 
-> interface = many (dataDecl <|> sigDecl)
+> interface = many (dataDecl <|> Decl <$> sigDecl)
 
 
 Modules
@@ -316,23 +316,41 @@ Modules
 > moduleName = join . intersperse "." <$> identLike False "module name" `sepBy` dot
 
 
-> topdecls  = associate <$> many (dataDecl <|> sigDecl <|> funDecl)
-> decls     = associate <$> many (sigDecl <|> funDecl)
+> topdecls  = associateTop <$> many (dataDecl
+>                                    <|> (Decl <$> (sigDecl <|> funDecl)))
+>  where
+>     associateTop :: [STopDeclaration ()] -> [STopDeclaration ()]
+>     associateTop = map joinFun . groupBy sameFun
+>
+>     sameFun (Decl (FunDecl x _)) (Decl (FunDecl y _))  = x == y
+>     sameFun _             _                            = False
+> 
+>     joinFun :: [STopDeclaration ()] -> STopDeclaration ()
+>     joinFun [d] = d
+>     joinFun fs@(Decl (FunDecl x _) : _) = Decl (FunDecl x (join (map altsOf fs)))
+>     joinFun _ = error "joinFun: impossible"
+>
+>     altsOf (Decl (FunDecl _ as)) = as
+>     altsOf _ = error "altsOf: impossible"
 
-> associate :: [SDeclaration ()] -> [SDeclaration ()]
-> associate = map joinFun . groupBy sameFun
+> decls     = associate <$> many (sigDecl <|> funDecl)
 >   where
+>     associate :: [SDeclaration ()] -> [SDeclaration ()]
+>     associate = map joinFun . groupBy sameFun
+>
 >     sameFun (FunDecl x _) (FunDecl y _)  = x == y
 >     sameFun _             _              = False
 > 
 >     joinFun :: [SDeclaration ()] -> SDeclaration ()
 >     joinFun [d] = d
 >     joinFun fs@(FunDecl x _ : _) = FunDecl x (join (map altsOf fs))
 >     joinFun _ = error "joinFun: impossible"
-
+>
 >     altsOf (FunDecl _ as) = as
 >     altsOf _ = error "altsOf: impossible"
 
+
+
 > dataDecl = I.lineFold $ do
 >     try (reserved "data")
 >     s <- tyConName

src/Language/Inch/PrettyPrinter.lhs

@@ -54,7 +54,7 @@
 > instance Pretty String where
 >     pretty s _ = text s
 
-> instance Pretty [SDeclaration ()] where
+> instance Pretty [STopDeclaration ()] where
 >     pretty ds _ = vcat (map prettyHigh ds)
 
 > instance Pretty SKind where
@@ -192,7 +192,7 @@
 >     pretty (ImpHiding xs)  _ = text "hiding" <+> parens (hsep (punctuate (text ",") (map text xs)))
 
 
-> instance Pretty (SDeclaration a) where
+> instance Pretty (STopDeclaration a) where
 >     pretty (DataDecl n k cs ds) _ = hang (text "data" <+> text n
 >         <+> (if k /= SKSet then text "::" <+> prettyHigh k else empty)
 >         <+> text "where") 2 $
@@ -201,6 +201,9 @@
 >         derivingClause []  = empty
 >         derivingClause xs  = text "deriving" <+>
 >                                parens (hsep (punctuate  (text ",") (map text xs)))
+>     pretty (Decl d) s = pretty d s
+
+> instance Pretty (SDeclaration a) where
 >     pretty (FunDecl n ps) _ = vcat (map ((text n <+>) . prettyHigh) ps)
 >     pretty (SigDecl n ty) _ = text n <+> text "::" <+> prettyHigh ty
 

src/Language/Inch/ProgramCheck.lhs

@@ -29,35 +29,39 @@
 >         B0  -> return ()
 >         _   -> traceContext "assertContextEmpty" >> erk "context is not empty"
 
-> checkModule :: SModule () -> [SDeclaration ()] -> Contextual (Module ())
+> checkModule :: SModule () -> [STopDeclaration ()] -> Contextual (Module ())
 > checkModule (Mod mh is ds) xs = do
 >     mapM_ makeTyCon xs
->     mapM_ (makeBinding True) xs
->     mapM_ checkDecl xs
+>     mapM_ (makeTopBinding True) xs
+>     mapM_ checkTopDecl xs
 >     mapM_ makeTyCon ds
->     mapM_ (makeBinding False) ds
->     ds' <- concat <$> traverse checkDecl ds
+>     mapM_ (makeTopBinding False) ds
+>     ds' <- concat <$> traverse checkTopDecl ds
 >     return $ Mod mh is ds'
 >   where
->     makeTyCon :: SDeclaration () -> Contextual ()
+>     makeTyCon :: STopDeclaration () -> Contextual ()
 >     makeTyCon (DataDecl t k _ _) = inLocation (text $ "in data type " ++ t) $
 >         case kindKind k of
 >           Ex k' -> do
 >             unless (targetsSet k') $ errKindTarget k
 >             insertTyCon t (Ex k')
->     makeTyCon _ = return ()
+>     makeTyCon (Decl _) = return ()
 
-> checkDecl :: SDeclaration () -> Contextual [Declaration ()]
-> checkDecl (DataDecl t k cs ds) = inLocation (text $ "in data type " ++ t) $ 
+> makeTopBinding :: Bool -> STopDeclaration () -> Contextual ()
+> makeTopBinding _ (DataDecl _ _ _ _)  = return ()
+> makeTopBinding b (Decl d) = makeBinding b d
+
+> checkTopDecl :: STopDeclaration () -> Contextual [TopDeclaration ()]
+> checkTopDecl (DataDecl t k cs ds) = inLocation (text $ "in data type " ++ t) $ 
 >   unEx (kindKind k) $ \ k' -> do
 >     cs'    <- traverse (checkConstructor t) cs
 >     return [DataDecl t k' cs' ds]
 > checkDecl d = do
 >   assertContextEmpty 
->   ds <- checkInferFunDecl d
+>   ds <- checkInferDecl d
 >   assertContextEmpty
->   unless (all (goodDecl B0) ds) $ erk $ unlines ("checkDecl: bad declaration" : map (renderMe . fog) ds)
->   return ds
+>   unless (all (goodDecl B0) ds) $ erk $ unlines ("checkTopDecl: bad declaration" : map (renderMe . fog) ds)
+>   return $ map Decl ds
 
 > checkConstructor :: TyConName -> SConstructor -> Contextual Constructor
 > checkConstructor t (c ::: ty) = inLocation (text $ "in constructor " ++ c) $ do

src/Language/Inch/Syntax.lhs

@@ -53,24 +53,26 @@
 
 > type Con s        = TmConName ::: ATy s () KSet
 
-> type Term             = Tm OK
 > type Module           = Mod OK
+> type Term             = Tm OK
 > type Constructor      = Con OK
 > type Alternative      = Alt OK
 > type CaseAlternative  = CaseAlt OK
 > type PatternList      = PatList OK
 > type Pattern          = Pat OK
+> type TopDeclaration   = TopDecl OK
 > type Declaration      = Decl OK
 > type Guard            = Grd OK
 > type GuardTerms       = GrdTms OK
 
-> type STerm             = Tm RAW
 > type SModule           = Mod RAW
+> type STerm             = Tm RAW
 > type SConstructor      = Con RAW
 > type SAlternative      = Alt RAW
 > type SCaseAlternative  = CaseAlt RAW
 > type SPatternList      = PatList RAW
 > type SPattern          = Pat RAW
+> type STopDeclaration   = TopDecl RAW
 > type SDeclaration      = Decl RAW
 > type SGuard            = Grd RAW
 > type SGuardTerms       = GrdTms RAW
@@ -150,7 +152,7 @@
 
 > data Mod s a = Mod { modName :: Maybe (String, [String])
 >                    , modImports :: [Import]
->                    , modDecls :: [Decl s a]
+>                    , modDecls :: [TopDecl s a]
 >                    }
 
 > deriving instance Show (Mod RAW a)
@@ -172,6 +174,7 @@
 >   deriving (Eq, Show)
 
 
+
 > data Tm s a where
 >     TmVar    :: TmName                    -> Tm s a
 >     TmCon    :: TmConName                 -> Tm s a
@@ -251,9 +254,47 @@
 > tmBinOp t m n = TmBinOp t `TmApp` m `TmApp` n
 
 
-> data Decl s a where
+
+
+> data TopDecl s a where
 >     DataDecl  :: TyConName -> AKind s k -> [TmConName ::: ATy s a KSet] ->
->                      [String] -> Decl s a
+>                      [String] -> TopDecl s a
+>     Decl      :: Decl s a -> TopDecl s a
+
+> deriving instance Show (TopDecl RAW a)
+> deriving instance Show (TopDecl OK a)
+
+> instance Eq (TopDecl RAW a) where
+>     DataDecl x k cs ds == DataDecl x' k' cs' ds' = x == x' && k == k' && cs == cs' && ds == ds'
+>     Decl d == Decl d' = d == d'
+>     _ == _ = False
+
+> instance TravTypes TopDecl where
+
+>     travTypes g (DataDecl x k cs ds) =
+>         DataDecl x k <$> traverse (\ (y ::: t) -> (y :::) <$> g t) cs <*> pure ds
+>     travTypes g (Decl d) = Decl <$> travTypes g d
+
+>     fogTypes g (DataDecl x k cs ds) = DataDecl x (fogKind k)
+>         (map (\ (y ::: t) -> y ::: fogTy' g [] t) cs)
+>         ds
+>     fogTypes g (Decl d)  = Decl (fogTypes g d)
+
+>     renameTypes g (DataDecl x k cs ds) = DataDecl x k
+>         (map (\ (y ::: t) -> y ::: renameTy g t) cs)
+>         ds
+>     renameTypes g (Decl d)  = Decl (renameTypes g d)
+
+> instance a ~ b => FV (TopDecl OK a) b where
+>     fvFoldMap f (DataDecl _ _ cs _)  = fvFoldMap f (map (\ (_ ::: t) -> t) cs)
+>     fvFoldMap f (Decl d)             = fvFoldMap f d
+
+> topDeclName :: TopDecl s a -> String
+> topDeclName (DataDecl x _ _ _)  = x
+> topDeclName (Decl d)            = declName d
+
+
+> data Decl s a where
 >     FunDecl   :: TmName -> [Alt s a] -> Decl s a
 >     SigDecl   :: TmName -> ATy s a KSet -> Decl s a
 
@@ -262,32 +303,21 @@
 > deriving instance Eq (Decl RAW a)
 
 > instance TravTypes Decl where
-
->     travTypes g (DataDecl x k cs ds) =
->         DataDecl x k <$> traverse (\ (y ::: t) -> (y :::) <$> g t) cs <*> pure ds
 >     travTypes g (FunDecl x ps) =
 >         FunDecl x <$> traverse (travTypes g) ps
 >     travTypes g (SigDecl x ty) = SigDecl x <$> g ty
 
->     fogTypes g (DataDecl x k cs ds) = DataDecl x (fogKind k)
->         (map (\ (y ::: t) -> y ::: fogTy' g [] t) cs)
->         ds
 >     fogTypes g (FunDecl x ps)  = FunDecl x (map (fogTypes g) ps)
 >     fogTypes g (SigDecl x ty)  = SigDecl x (fogTy' g [] ty)
 
->     renameTypes g (DataDecl x k cs ds) = DataDecl x k
->         (map (\ (y ::: t) -> y ::: renameTy g t) cs)
->         ds
 >     renameTypes g (FunDecl x ps)  = FunDecl x (map (renameTypes g) ps)
 >     renameTypes g (SigDecl x ty)  = SigDecl x (renameTy g ty) 
 
 > instance a ~ b => FV (Decl OK a) b where
->     fvFoldMap f (DataDecl _ _ cs _)  = fvFoldMap f (map (\ (_ ::: t) -> t) cs)
 >     fvFoldMap f (FunDecl _ as)       = fvFoldMap f as
 >     fvFoldMap f (SigDecl _ t)        = fvFoldMap f t
 
 > declName :: Decl s a -> String
-> declName (DataDecl x _ _ _)  = x
 > declName (FunDecl x _)       = x
 > declName (SigDecl x _)       = x
 

src/Language/Inch/TypeCheck.lhs

@@ -380,7 +380,7 @@ status.
 > checkLocalDecls ds =
 >     withLayerExtract False False (LetBindings Map.empty) letBindings $ do
 >         mapM_ (makeBinding False) ds
->         Data.List.concat <$> traverse checkInferFunDecl ds  
+>         Data.List.concat <$> traverse checkInferDecl ds  
 
 > makeBinding :: Bool -> SDeclaration () -> Contextual ()
 > makeBinding defd (SigDecl x ty) = inLocation (text $ "in binding " ++ x) $ do
@@ -390,12 +390,11 @@ status.
 >         KSet  -> insertBinding x (Just ty', defd)
 >         _     -> errKindNotSet (fogKind k)
 > makeBinding _ (FunDecl _ _)       = return ()
-> makeBinding _ (DataDecl _ _ _ _)  = return ()
 
-> checkInferFunDecl :: SDeclaration () -> Contextual [Declaration ()]
-> checkInferFunDecl (FunDecl s []) =
+> checkInferDecl :: SDeclaration () -> Contextual [Declaration ()]
+> checkInferDecl (FunDecl s []) =
 >   inLocation (text $ "in declaration of " ++ s) $ erk $ "No alternative"
-> checkInferFunDecl (FunDecl s (p:ps)) = do
+> checkInferDecl (FunDecl s (p:ps)) = do
 >     when (not (null ps) && isVarAlt p) $ errDuplicateTmVar s
 >     mty <- optional $ lookupBinding s
 >     case mty of
@@ -405,10 +404,9 @@ status.
 >             (fd, ty) <- inferFunDecl s (p:ps)
 >             updateBinding s (Just ty, True)
 >             return [SigDecl s ty, fd]
-> checkInferFunDecl (SigDecl x _) = do
+> checkInferDecl (SigDecl x _) = do
 >     _ ::: ty <- fst <$> lookupBinding x
 >     return [SigDecl x ty]
-> checkInferFunDecl (DataDecl _ _ _ _) = error "checkInferFunDecl: that's a data declaration"
 
 > inferFunDecl :: String -> [SAlternative ()] -> Contextual (Declaration (), Type KSet)
 > inferFunDecl s pats =

tests/Main.lhs

@@ -77,7 +77,7 @@
 >                                    ++ s' ++ "\n" ++ show err
 >     Left err -> Left $ "Initial parse:\n" ++ s ++ "\n" ++ show err
 
-> parseCheck :: [SDeclaration ()] -> (String, Bool) -> Either String String
+> parseCheck :: [STopDeclaration ()] -> (String, Bool) -> Either String String
 > parseCheck ds (s, b) = case parseModule "parseCheck" s of
 >     Right md   -> case evalStateT (checkModule md ds) initialState of
 >         Right md'
@@ -92,7 +92,7 @@
 >                             ++ renderMe md ++ "\n" ++ renderMe err ++ "\n"
 >     Left err  -> Left $ "Parse error:\n" ++ s ++ "\n" ++ show err ++ "\n"
 
-> eraseCheck :: [SDeclaration ()] -> String -> Either String String
+> eraseCheck :: [STopDeclaration ()] -> String -> Either String String
 > eraseCheck ds s = case parseModule "eraseCheck" s of
 >     Right md   -> case runStateT (checkModule md ds) initialState of
 >         Right (md', st) -> case evalStateT (eraseModule md') st of