shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Refactor import/export specs a little.

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -60,8 +60,8 @@

 data ExportItem

   = ExpModule IdentModule

-  | ExpTypeCon Ident

-  | ExpType Ident

+  | ExpTypeSome Ident [Ident]

+  | ExpTypeAll Ident

   | ExpValue Ident

 --DEBUG  deriving (Show)

@@ -84,8 +84,8 @@

 --DEBUG  deriving (Show)

 data ImportItem

-  = ImpTypeCon Ident

-  | ImpType Ident

+  = ImpTypeSome Ident [Ident]

+  | ImpTypeAll Ident

   | ImpValue Ident

 --DEBUG  deriving (Show)

@@ -564,9 +564,13 @@

 ppImportItem :: ImportItem -> Doc

 ppImportItem ae =

   case ae of

-    ImpTypeCon i -> ppIdent i <> text "(..)"

-    ImpType i -> ppIdent i

+    ImpTypeSome i [] -> ppIdent i

+    ImpTypeSome i is -> ppIdent i <> parens (ppCommaSep $ map ppIdent is)

+    ImpTypeAll i -> ppIdent i <> text "(..)"

     ImpValue i -> ppIdent i

+

+ppCommaSep :: [Doc] -> Doc

+ppCommaSep = hsep . punctuate (text ",")

 ppEDef :: EDef -> Doc

 ppEDef def =

--- a/src/MicroHs/Parse.hs

+++ b/src/MicroHs/Parse.hs

@@ -260,10 +260,12 @@

 pExportItem :: P ExportItem

 pExportItem =

-      ExpModule <$> (pKeyword "module" *> pUQIdent)

-  <|< ExpTypeCon <$> (pUQIdentSym <* pSpec '(' <* pConList <* pSpec ')')

-  <|< ExpType <$> pUQIdentSym

-  <|< ExpValue <$> pLQIdentSym

+      ExpModule   <$> (pKeyword "module" *> pUQIdent)

+  <|< expType     <$> pUQIdentSym <*> (pSpec '(' *> pConList <* pSpec ')')

+  <|< ExpTypeSome <$> pUQIdentSym <*> pure []

+  <|< ExpValue    <$> pLQIdentSym

+  where expType i Nothing   = ExpTypeAll  i

+        expType i (Just is) = ExpTypeSome i is

 pKeyword :: String -> P ()

 pKeyword kw = () <$ satisfy kw is

@@ -376,12 +378,16 @@

 pImportItem :: P ImportItem

 pImportItem =

-      ImpTypeCon <$> (pUQIdentSym <* pSpec '(' <* pConList <* pSpec ')')

-  <|< ImpType <$> pUQIdentSym

-  <|< ImpValue <$> pLQIdentSym

+      impType     <$> pUQIdentSym <*> (pSpec '(' *> pConList <* pSpec ')')

+  <|< ImpTypeSome <$> pUQIdentSym <*> pure []

+  <|< ImpValue    <$> pLQIdentSym

+  where impType i Nothing   = ImpTypeAll  i

+        impType i (Just is) = ImpTypeSome i is

-pConList :: P ()

-pConList = pSymbol ".." <|< (() <$ esepBy1 pQIdent (pSpec ','))   -- XXX treat list as ..

+pConList :: P (Maybe [Ident])

+pConList =

+      (Nothing <$ pSymbol "..")

+  <|< (Just <$> esepBy1 (pQIdent <|> pParens pSymOper) (pSpec ','))

 --------

 -- Types

--- a/src/MicroHs/TypeCheck.hs

+++ b/src/MicroHs/TypeCheck.hs

@@ -173,8 +173,8 @@

     keep x xs = elem x xs /= hide

     ivs = [ i | ImpValue i <- is ]

     vs' = filter (\ (ValueExport i _) -> keep i ivs) vs

-    cts = [ i | ImpTypeCon i <- is ]

-    its = [ i | ImpType i <- is ] ++ cts

+    cts = [ i | ImpTypeAll i <- is ] ++ [ i | ImpTypeSome i (_:_) <- is ]  -- XXX

+    its = [ i | ImpTypeSome i [] <- is ] ++ cts

     ts' = map (\ (TypeExport i e xvs) -> TypeExport i e $ filter (\ (ValueExport ii _) -> not hide || keep ii ivs) xvs) $

           map (\ te@(TypeExport i e _) -> if keep i cts then te else TypeExport i e []) $

           filter (\ (TypeExport i _ _) -> keep i its) ts

@@ -198,30 +198,28 @@

 -- Type and value exports

 getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ClassTable -> ExportItem ->

-           ([TypeExport], [ClsDef], [ValueExport])

+             ([TypeExport], [ClsDef], [ValueExport])

 getTVExps impMap _ _ _ _ (ExpModule m) =

   case M.lookup m impMap of

     Just (TModule _ _ te _ ce _ ve _) -> (te, ce, ve)

     _ -> errorMessage (getSLoc m) $ "undefined module: " ++ showIdent m

-getTVExps _ tys vals ast cls (ExpTypeCon i) =

+getTVExps _ tys vals ast cls (ExpTypeSome i is) = getTypeExp tys vals ast cls i (`elem` is)

+getTVExps _ tys vals ast cls (ExpTypeAll  i   ) = getTypeExp tys vals ast cls i (const True)

+getTVExps _ _ vals _ _ (ExpValue i) =

+    ([], [], [ValueExport i (expLookup i vals)])

+

+-- Export a type, filter exported values by p.

+getTypeExp :: TypeTable -> ValueTable -> AssocTable -> ClassTable -> Ident -> (Ident -> Bool) ->

+              ([TypeExport], [ClsDef], [ValueExport])

+getTypeExp tys vals ast cls ti p =

   let

-    e = expLookup i tys

+    e = expLookup ti tys

     qi = tyQIdent e

-    ves = getAssocs vals ast qi

+    ves = filter (\ (ValueExport i _) -> p i) $ getAssocs vals ast qi

     cl = case M.lookup qi cls of

            Just ci -> [(qi, ci)]

            Nothing -> []

-  in ([TypeExport i e ves], cl, [])

-getTVExps _ tys _ _ cls (ExpType i) =

-  let

-    e = expLookup i tys

-    qi = tyQIdent e

-    cl = case M.lookup qi cls of

-           Just ci -> [(qi, ci)]

-           Nothing -> []

-  in ([TypeExport i e []], cl, [])

-getTVExps _ _ vals _ _ (ExpValue i) =

-    ([], [], [ValueExport i (expLookup i vals)])

+  in ([TypeExport ti e ves], cl, [])

 expLookup :: Ident -> SymTab -> Entry

 expLookup i m = either (errorMessage (getSLoc i)) id $ stLookup "export" i m

-- 

⑨