X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=9d050435602a908b2a4e50aa0261c50e7fc18ef8;hb=ade131124b0b12d47b4bcafd3808bd9db31428cd;hp=b12663df05ec8eaee5e22337c2cacddaac08c9dc;hpb=b7821e23b33faefc7de2fad54513e0d4d70e9729;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Flatten.hs b/Flatten.hs
index b12663d..9d05043 100644
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -1,12 +1,17 @@
 module Flatten where
 import CoreSyn
+import Control.Monad
+import qualified Var
 import qualified Type
 import qualified Name
 import qualified TyCon
 import qualified Maybe
+import Data.Traversable
 import qualified DataCon
 import qualified CoreUtils
+import Control.Applicative
 import Outputable ( showSDoc, ppr )
+import qualified Data.Foldable as Foldable
 import qualified Control.Monad.State as State
 
 -- | A datatype that maps each of the single values in a haskell structure to
@@ -19,7 +24,26 @@ data HsValueMap mapto =
 
 instance Functor HsValueMap where
   fmap f (Single s) = Single (f s)
-  fmap f (Tuple maps) = Tuple (fmap (fmap f) maps)
+  fmap f (Tuple maps) = Tuple (map (fmap f) maps)
+
+instance Foldable.Foldable HsValueMap where
+  foldMap f (Single s) = f s
+  -- The first foldMap folds a list of HsValueMaps, the second foldMap folds
+  -- each of the HsValueMaps in that list
+  foldMap f (Tuple maps) = Foldable.foldMap (Foldable.foldMap f) maps
+
+instance Traversable HsValueMap where
+  traverse f (Single s) = Single <$> f s
+  traverse f (Tuple maps) = Tuple <$> (traverse (traverse f) maps)
+
+data PassState s x = PassState (s -> (s, x))
+
+instance Functor (PassState s) where
+  fmap f (PassState a) = PassState (\s -> let (s', a') = a s in (s', f a'))
+
+instance Applicative (PassState s) where
+  pure x = PassState (\s -> (s, x))
+  PassState f <*> PassState x = PassState (\s -> let (s', f') = f s; (s'', x') = x s' in (s'', f' x'))
 
 -- | Creates a HsValueMap with the same structure as the given type, using the
 --   given function for mapping the single types.
@@ -103,6 +127,27 @@ data HsValueUse =
 
 type HsUseMap = HsValueMap HsValueUse
 
+-- | Builds a HsUseMap with the same structure has the given HsValueMap in
+--   which all the Single elements are marked as State, with increasing state
+--   numbers.
+useAsState :: HsValueMap a -> HsUseMap
+useAsState map =
+  map'
+  where
+    -- Traverse the existing map, resulting in a function that maps an initial
+    -- state number to the final state number and the new map
+    PassState f = traverse asState map
+    -- Run this function to get the new map
+    (_, map')   = f 0
+    -- This function maps each element to a State with a unique number, by
+    -- incrementing the state count.
+    asState x   = PassState (\s -> (s+1, State s))
+
+-- | Builds a HsUseMap with the same structure has the given HsValueMap in
+--   which all the Single elements are marked as Port.
+useAsPort :: HsValueMap a -> HsUseMap
+useAsPort map = fmap (\x -> Port) map
+
 data HsFunction = HsFunction {
   hsFuncName :: String,
   hsFuncArgs :: [HsUseMap],
@@ -159,7 +204,7 @@ typeMapToUseMap (Single ty) = do
   return $ Single (SignalUse id)
 
 typeMapToUseMap (Tuple tymaps) = do
-  usemaps <- mapM typeMapToUseMap tymaps
+  usemaps <- State.mapM typeMapToUseMap tymaps
   return $ Tuple usemaps
 
 -- | Flatten a haskell function
@@ -215,10 +260,47 @@ flattenExpr binds app@(App _ _) = do
       flattenApplicationExpr binds (CoreUtils.exprType app) f args
   where
     flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
-    flattenApplicationExpr binds ty f args = error $ "Function application not supported: " ++ (showSDoc $ ppr app)
+    -- | Flatten a normal application expression
+    flattenApplicationExpr binds ty f args = do
+      -- Find the function to call
+      let func = appToHsFunction ty f args
+      -- Flatten each of our args
+      flat_args <- (State.mapM (flattenExpr binds) args)
+      -- Check and split each of the arguments
+      let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
+      -- Generate signals for our result
+      res <- genSignalUses ty
+      -- Create the function application
+      let app = FApp {
+        appFunc = func,
+        appArgs = arg_ress,
+        appRes  = useMapToDefMap res
+      }
+      addApp app
+      return ([], res)
+    -- | Check a flattened expression to see if it is valid to use as a
+    --   function argument. The first argument is the original expression for
+    --   use in the error message.
+    checkArg arg flat =
+      let (args, res) = flat in
+      if not (null args)
+        then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
+        else flat 
 
 flattenExpr _ _ = do
   return ([], Tuple [])
 
+appToHsFunction ::
+  Type.Type       -- ^ The return type
+  -> Var.Var      -- ^ The function to call
+  -> [CoreExpr]   -- ^ The function arguments
+  -> HsFunction   -- ^ The needed HsFunction
+
+appToHsFunction ty f args =
+  HsFunction hsname hsargs hsres
+  where
+    hsname = Name.getOccString f
+    hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
+    hsres  = useAsPort (mkHsValueMap ty)
 
 -- vim: set ts=8 sw=2 sts=2 expandtab: