Przeglądaj źródła

gidl: interfaces import child types

Pat Hickey 10 lat temu
rodzic
commit
f0e5748a8e
3 zmienionych plików z 27 dodań i 13 usunięć
  1. 14 4
      src/Gidl/Backend/Haskell/Interface.hs
  2. 7 9
      src/Gidl/Interface.hs
  3. 6 0
      tests/Test.hs

+ 14 - 4
src/Gidl/Backend/Haskell/Interface.hs

@@ -8,24 +8,34 @@ import Data.Char (toUpper)
 
 import Gidl.Types
 import Gidl.Interface
+import Gidl.Backend.Haskell.Types
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
 interfaceModule :: [String] -> InterfaceRepr -> Artifact
-interfaceModule modulepath ir =
+interfaceModule modulepath ir@(InterfaceRepr iname i) =
   artifactPath (intercalate "/" modulepath) $
   artifactText ((ifModuleName ir) ++ ".hs") $
   prettyLazyText 80 $
   stack
     [ text "module"
-      <+> tm (ifModuleName ir)
+      <+> im (ifModuleName ir)
       <+> text "where"
     , empty
+    , stack [ text "import" <+> im (ifModuleName iir)
+            | iir <- interfaceParents i
+            ]
+    , stack $ map (importDecl tm)
+            $ nub
+            $ map importType
+            $ interfaceTypes ir
     ]
   where
-  tm mname = mconcat $ punctuate dot
+  im mname = mconcat $ punctuate dot
                      $ map text (modulepath ++ [mname])
-
+  tm mname = mconcat $ punctuate dot
+                     $ map text (typepath modulepath ++ ["Types", mname])
+    where typepath = reverse . drop 1 . reverse
 
 ifModuleName :: InterfaceRepr -> String
 ifModuleName (InterfaceRepr iname _) = aux iname

+ 7 - 9
src/Gidl/Interface.hs

@@ -29,18 +29,16 @@ insertInterface iname i e@(InterfaceEnv ie) = case lookupInterface iname e of
 interfaceParents :: Interface i t -> [i]
 interfaceParents (Interface parents _) = parents
 
-interfaceTypes :: InterfaceName -> InterfaceEnv -> TypeEnv -> [TypeName]
-interfaceTypes iname ie te = nub (concatMap aux ms)
+interfaceTypes :: InterfaceRepr -> [TypeRepr]
+interfaceTypes ir@(InterfaceRepr iname i) = nub (concatMap aux ms)
   where
-  (Interface _ ms) = fromJust (lookupInterface iname ie)
+  (Interface _ ms) = i
   aux = typeLeaves
-      . fromJust
-      . (\tn -> lookupTypeName tn te)
-      . methodTN
+      . methodT
       . snd
-  methodTN :: Method TypeName -> TypeName
-  methodTN (AttrMethod _ tn) = tn
-  methodTN (StreamMethod _ tn) = tn
+  methodT :: Method TypeRepr -> Type TypeRepr
+  methodT (AttrMethod _ (TypeRepr _ t)) = t
+  methodT (StreamMethod _ (TypeRepr _ t)) = t
 
 
 data InterfaceRepr = InterfaceRepr InterfaceName (Interface InterfaceRepr TypeRepr)

+ 6 - 0
tests/Test.hs

@@ -8,6 +8,7 @@ import Gidl.Parse
 import Gidl.Schema
 import Gidl.Backend.Cabal
 import Gidl.Backend.Haskell.Types
+import Gidl.Backend.Haskell.Interface
 import Gidl.Backend.Haskell
 
 main :: IO ()
@@ -25,9 +26,14 @@ test f = do
   case parseDecls c of
     Left e -> print e
     Right (te@(TypeEnv te'), ie@(InterfaceEnv ie')) -> do
+      {-
       forM_ te' $ \(tn, t) -> do
         putStrLn (tn ++ ":")
         print (typeLeaves t)
         let a = typeModule (words "Sample IDL Haskell Types")
                            (typeDescrToRepr tn te)
         printArtifact a
+      -}
+      forM_ ie' $ \(iname, _i) -> do
+        printArtifact $ interfaceModule (words "Sample IDL Haskell Interface")
+                                        (interfaceDescrToRepr iname ie te)