b00a8cb · elk · git.iko.soy

compiler/Build/File.hs+27−6

compare with master

unifiedsplit

@@ -10,6 +10,7 @@ import System.FilePath

10import System.IO

11

12import qualified Data.Binary as Binary

13+import qualified Data.List as List

13import qualified Data.Maybe as Maybe

14import qualified Data.Maybe as Maybe

14import qualified Data.Map as Map

15import qualified Data.Map as Map

15import qualified Data.ByteString.Lazy as L

16import qualified Data.ByteString.Lazy as L

@@ -34,17 +35,37 @@ type Build a = BuildT IO a

34-- Interfaces, remembering if something was recompiled

35-- Interfaces, remembering if something was recompiled

35type BInterfaces = Map.Map String (Bool, M.ModuleInterface)

36type BInterfaces = Map.Map String (Bool, M.ModuleInterface)

36

37

37−evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)

38+evalBuild :: Flag.Flags -> M.Interfaces -> Build ()

39+ -> IO (Map.Map String M.ModuleInterface, Maybe String)

38−evalBuild flags interfaces b = do

40+evalBuild flags interfaces build =

39− (_, s) <- evalRWST b flags (fmap notUpdated interfaces)

41+ do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)

40− return . getLast $ s

42+ return (fmap snd ifaces, getLast moduleNames)

41 where

43 where

42− notUpdated i = (False, i)

44+ notUpdated iface = (False, iface)

43

45

44-- | Builds a list of files, returning the moduleName of the last one.

46-- | Builds a list of files, returning the moduleName of the last one.

45-- Returns \"\" if the list is empty

47-- Returns \"\" if the list is empty

46build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String

48build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String

49+build flags interfaces files =

47−build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll

50+ do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)

51+ let removeTopName = Maybe.maybe id Map.delete topName

52+ mapM_ (checkPorts topName) (Map.toList $ removeTopName ifaces)

53+ return $ Maybe.fromMaybe "" topName

54+ where

55+ checkPorts topName (name,iface)

56+ | null ports = return ()

57+ | otherwise = Print.failure msg

58+ where

59+ ports = M.iPorts iface

60+ msg = concat

61+ [ "Port Error: ports may only appear in the main module, but\n"

62+ , " sub-module ", name, " declares the following port"

63+ , if length ports == 1 then "" else "s", ": "

64+ , List.intercalate ", " ports

65+ , case topName of

66+ Nothing -> ""

67+ Just tname -> "\n All ports must appear in module " ++ tname

68+ ]

48

69

49buildAll :: [FilePath] -> Build ()

70buildAll :: [FilePath] -> Build ()

50buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)

71buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)

compiler/Build/Source.hs+1

@@ -51,6 +51,7 @@ build noPrelude interfaces source =

51 , datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ]

52 , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]

53 , aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ]

54+ , ports = [ portName port | Port port <- decls ]

54 }

55 }

55

56

56 types <- TI.infer interfaces metaModule

57 types <- TI.infer interfaces metaModule

compiler/SourceSyntax/Declaration.hs+6

@@ -28,6 +28,12 @@ data Port

28 | In String T.Type

29 deriving (Show)

30

31+portName :: Port -> String

32+portName port =

33+ case port of

34+ Out name _ _ -> name

35+ In name _ -> name

36+

31type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

37type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

32type Declaration = Declaration' Port Expr.Def

38type Declaration = Declaration' Port Expr.Def

33

39

compiler/SourceSyntax/Module.hs+14−9

@@ -47,20 +47,23 @@ data MetadataModule =

47 , fixities :: [(Assoc, Int, String)]

48 , aliases :: [Alias]

49 , datatypes :: [ADT]

50+ , ports :: [String]

50 } deriving Show

51 } deriving Show

51

52

52type Interfaces = Map.Map String ModuleInterface

53type Interfaces = Map.Map String ModuleInterface

53type ADT = (String, [String], [(String,[Type])])

54type ADT = (String, [String], [(String,[Type])])

54type Alias = (String, [String], Type)

55type Alias = (String, [String], Type)

55

56

56−data ModuleInterface = ModuleInterface {

57+data ModuleInterface =

58+ ModuleInterface

57− iVersion :: Version.Version,

59+ { iVersion :: Version.Version

58− iTypes :: Map.Map String Type,

60+ , iTypes :: Map.Map String Type

59− iImports :: [(String, ImportMethod)],

61+ , iImports :: [(String, ImportMethod)]

60− iAdts :: [ADT],

62+ , iAdts :: [ADT]

61− iAliases :: [Alias],

63+ , iAliases :: [Alias]

62− iFixities :: [(Assoc, Int, String)]

64+ , iFixities :: [(Assoc, Int, String)]

65+ , iPorts :: [String]

63−} deriving Show

66+ } deriving Show

64

67

65metaToInterface :: MetadataModule -> ModuleInterface

68metaToInterface :: MetadataModule -> ModuleInterface

66metaToInterface metaModule =

69metaToInterface metaModule =

@@ -71,10 +74,11 @@ metaToInterface metaModule =

71 , iAdts = datatypes metaModule

74 , iAdts = datatypes metaModule

72 , iAliases = aliases metaModule

75 , iAliases = aliases metaModule

73 , iFixities = fixities metaModule

76 , iFixities = fixities metaModule

77+ , iPorts = ports metaModule

74 }

78 }

75

79

76instance Binary ModuleInterface where

80instance Binary ModuleInterface where

77− get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get

81+ get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get <*> get

78 put modul = do

82 put modul = do

79 put (iVersion modul)

83 put (iVersion modul)

80 put (iTypes modul)

84 put (iTypes modul)

@@ -82,3 +86,4 @@ instance Binary ModuleInterface where

82 put (iAdts modul)

86 put (iAdts modul)

83 put (iAliases modul)

87 put (iAliases modul)

84 put (iFixities modul)

88 put (iFixities modul)

89+ put (iPorts modul)

compiler/Transform/Canonicalize.hs+1

@@ -25,6 +25,7 @@ interface moduleName iface =

25 , iAdts = map (both prefix renameCtors) (iAdts iface)

26 , iAliases = map (both prefix renameType') (iAliases iface)

27 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

28+ , iPorts = iPorts iface

28 }

29 }

29 where

30 where

30 both f g (a,b,c) = (f a, b, g c)

31 both f g (a,b,c) = (f a, b, g c)