make conversion functions for input ports optional
This commit is contained in:
parent
828c2c7372
commit
9dda928ac4
12 changed files with 38 additions and 19 deletions
|
@ -197,8 +197,10 @@ expression (L span expr) =
|
||||||
md = pad ++ MD.toHtml doc ++ pad
|
md = pad ++ MD.toHtml doc ++ pad
|
||||||
|
|
||||||
PortIn name _ _ handler ->
|
PortIn name _ _ handler ->
|
||||||
do handler' <- expression handler
|
do handler' <- case handler of
|
||||||
return $ obj "Native.Ports.portIn" `call` [ string name, handler' ]
|
Nothing -> return []
|
||||||
|
Just h -> (:[]) `fmap` expression h
|
||||||
|
return $ obj "Native.Ports.portIn" `call` ([ string name ] ++ handler')
|
||||||
|
|
||||||
PortOut name _ signal ->
|
PortOut name _ signal ->
|
||||||
do signal' <- expression signal
|
do signal' <- expression signal
|
||||||
|
|
|
@ -29,7 +29,7 @@ data ParsePort
|
||||||
|
|
||||||
data Port
|
data Port
|
||||||
= Out String Expr.LExpr T.Type
|
= Out String Expr.LExpr T.Type
|
||||||
| In String Expr.LExpr T.Type
|
| In String (Maybe Expr.LExpr) T.Type
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
|
type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
|
||||||
|
@ -108,7 +108,10 @@ instance Pretty Port where
|
||||||
pretty port =
|
pretty port =
|
||||||
case port of
|
case port of
|
||||||
Out name expr tipe -> mkPort "<-" name expr tipe
|
Out name expr tipe -> mkPort "<-" name expr tipe
|
||||||
In name expr tipe -> mkPort "->" name expr tipe
|
In name mexpr tipe ->
|
||||||
|
case mexpr of
|
||||||
|
Nothing -> prettyPort name ":" tipe
|
||||||
|
Just expr -> mkPort "->" name expr tipe
|
||||||
where
|
where
|
||||||
mkPort arrow name expr tipe =
|
mkPort arrow name expr tipe =
|
||||||
P.vcat [ prettyPort name ":" tipe
|
P.vcat [ prettyPort name ":" tipe
|
||||||
|
|
|
@ -40,7 +40,7 @@ data Expr' def
|
||||||
| Record [(String, LExpr' def)]
|
| Record [(String, LExpr' def)]
|
||||||
| Markdown String String [LExpr' def]
|
| Markdown String String [LExpr' def]
|
||||||
-- for type checking and code gen only
|
-- for type checking and code gen only
|
||||||
| PortIn String SrcType.Type Type.Variable (LExpr' def)
|
| PortIn String SrcType.Type Type.Variable (Maybe (LExpr' def))
|
||||||
| PortOut String SrcType.Type (LExpr' def)
|
| PortOut String SrcType.Type (LExpr' def)
|
||||||
|
|
||||||
type ParseExpr = Expr' ParseDef
|
type ParseExpr = Expr' ParseDef
|
||||||
|
@ -129,7 +129,7 @@ instance Pretty def => Pretty (Expr' def) where
|
||||||
|
|
||||||
Markdown _ _ _ -> P.text "[markdown| ... |]"
|
Markdown _ _ _ -> P.text "[markdown| ... |]"
|
||||||
|
|
||||||
PortIn _ _ _ handler -> pretty handler
|
PortIn _ _ _ _ -> P.text "<port in>"
|
||||||
|
|
||||||
PortOut _ _ signal -> pretty signal
|
PortOut _ _ signal -> pretty signal
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,7 @@ module Transform.Canonicalize (interface, metadataModule) where
|
||||||
import Control.Arrow ((***))
|
import Control.Arrow ((***))
|
||||||
import Control.Applicative (Applicative,(<$>),(<*>))
|
import Control.Applicative (Applicative,(<$>),(<*>))
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
|
import Data.Traversable (traverse)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
|
@ -169,7 +170,7 @@ rename env (L s expr) =
|
||||||
|
|
||||||
PortIn name st tt handler ->
|
PortIn name st tt handler ->
|
||||||
do st' <- renameType' env st
|
do st' <- renameType' env st
|
||||||
handler' <- rnm handler
|
handler' <- traverse rnm handler
|
||||||
return $ PortIn name st' tt handler'
|
return $ PortIn name st' tt handler'
|
||||||
|
|
||||||
PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
|
PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
{-# OPTIONS_GHC -Wall #-}
|
{-# OPTIONS_GHC -Wall #-}
|
||||||
module Transform.Check (mistakes) where
|
module Transform.Check (mistakes) where
|
||||||
|
|
||||||
|
import qualified Control.Arrow as Arrow
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
import qualified Data.Maybe as Maybe
|
import qualified Data.Maybe as Maybe
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
@ -44,10 +45,11 @@ duplicates decls =
|
||||||
unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
|
unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
|
||||||
|
|
||||||
(portNames, portExprs) =
|
(portNames, portExprs) =
|
||||||
unzip $ flip map [ port | D.Port port <- decls ] $ \port ->
|
Arrow.second Maybe.catMaybes $ unzip $
|
||||||
|
flip map [ port | D.Port port <- decls ] $ \port ->
|
||||||
case port of
|
case port of
|
||||||
D.Out name expr _ -> (name,expr)
|
D.Out name expr _ -> (name, Just expr)
|
||||||
D.In name expr _ -> (name,expr)
|
D.In name expr _ -> (name, expr)
|
||||||
|
|
||||||
getNames = Set.toList . Pattern.boundVars
|
getNames = Set.toList . Pattern.boundVars
|
||||||
|
|
||||||
|
|
|
@ -62,6 +62,7 @@ combineAnnotations = go
|
||||||
|
|
||||||
Port (PPIn name' expr) : rest | name == name' ->
|
Port (PPIn name' expr) : rest | name == name' ->
|
||||||
do expr' <- exprCombineAnnotations expr
|
do expr' <- exprCombineAnnotations expr
|
||||||
(:) (Port (In name expr' tipe)) <$> go rest
|
(:) (Port (In name (Just expr') tipe)) <$> go rest
|
||||||
|
|
||||||
|
_ -> (:) (Port (In name Nothing tipe)) <$> go portRest
|
||||||
|
|
||||||
_ -> Left (msg name)
|
|
||||||
|
|
|
@ -2,6 +2,7 @@
|
||||||
module Transform.Expression (crawlLet, checkPorts) where
|
module Transform.Expression (crawlLet, checkPorts) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
|
import Data.Traversable (traverse)
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
import SourceSyntax.Location
|
import SourceSyntax.Location
|
||||||
import qualified SourceSyntax.Type as ST
|
import qualified SourceSyntax.Type as ST
|
||||||
|
@ -50,7 +51,7 @@ crawl portInCheck portOutCheck defsTransform = go
|
||||||
Let defs body -> Let <$> defsTransform defs <*> go body
|
Let defs body -> Let <$> defsTransform defs <*> go body
|
||||||
PortIn name st tt handler ->
|
PortIn name st tt handler ->
|
||||||
do portInCheck name st tt
|
do portInCheck name st tt
|
||||||
PortIn name st tt <$> go handler
|
PortIn name st tt <$> traverse go handler
|
||||||
PortOut name st signal ->
|
PortOut name st signal ->
|
||||||
do portOutCheck name st
|
do portOutCheck name st
|
||||||
PortOut name st <$> go signal
|
PortOut name st <$> go signal
|
||||||
|
|
|
@ -49,7 +49,7 @@ expression (L loc expr) =
|
||||||
Modify r fs -> Modify (f r) (map (var *** f) fs)
|
Modify r fs -> Modify (f r) (map (var *** f) fs)
|
||||||
Record fs -> Record (map (var *** f) fs)
|
Record fs -> Record (map (var *** f) fs)
|
||||||
Markdown uid md es -> Markdown uid md (map f es)
|
Markdown uid md es -> Markdown uid md (map f es)
|
||||||
PortIn name st tt handler -> PortIn name st tt (f handler)
|
PortIn name st tt handler -> PortIn name st tt (fmap f handler)
|
||||||
PortOut name st signal -> PortOut name st (f signal)
|
PortOut name st signal -> PortOut name st (f signal)
|
||||||
|
|
||||||
definition :: Def -> Def
|
definition :: Def -> Def
|
||||||
|
|
|
@ -3,6 +3,7 @@ module Transform.SortDefinitions (sortDefs) where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
|
import Data.Traversable (traverse)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
import SourceSyntax.Location
|
import SourceSyntax.Location
|
||||||
|
@ -85,7 +86,8 @@ reorder (L s expr) =
|
||||||
|
|
||||||
PortOut name st signal -> PortOut name st <$> reorder signal
|
PortOut name st signal -> PortOut name st <$> reorder signal
|
||||||
|
|
||||||
PortIn name st tt handler -> PortIn name st tt <$> reorder handler
|
PortIn name st tt handler ->
|
||||||
|
PortIn name st tt <$> traverse reorder handler
|
||||||
|
|
||||||
-- Actually do some reordering
|
-- Actually do some reordering
|
||||||
Let defs body ->
|
Let defs body ->
|
||||||
|
|
|
@ -38,5 +38,5 @@ subst old new expr =
|
||||||
Record fs -> Record (map (second f) fs)
|
Record fs -> Record (map (second f) fs)
|
||||||
Literal _ -> expr
|
Literal _ -> expr
|
||||||
Markdown uid md es -> Markdown uid md (map f es)
|
Markdown uid md es -> Markdown uid md (map f es)
|
||||||
PortIn name st tt handler -> PortIn name st tt (f handler)
|
PortIn name st tt handler -> PortIn name st tt (fmap f handler)
|
||||||
PortOut name st signal -> PortOut name st (f signal)
|
PortOut name st signal -> PortOut name st (f signal)
|
|
@ -49,10 +49,14 @@ toDefs decl =
|
||||||
case port of
|
case port of
|
||||||
Out name expr@(L.L s _) tipe ->
|
Out name expr@(L.L s _) tipe ->
|
||||||
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
|
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
|
||||||
In name expr@(L.L s _) tipe ->
|
In name mexpr tipe ->
|
||||||
unsafePerformIO $ do
|
unsafePerformIO $ do
|
||||||
tvar <- Type.var Type.Flexible
|
tvar <- Type.var Type.Flexible
|
||||||
return $ [ definition name (L.L s $ E.PortIn name tipe tvar expr) tipe ]
|
return $ [ definition name (loc $ E.PortIn name tipe tvar mexpr) tipe ]
|
||||||
|
where
|
||||||
|
loc = case mexpr of
|
||||||
|
Just (L.L s _) -> L.L s
|
||||||
|
Nothing -> L.none
|
||||||
|
|
||||||
-- no constraints are needed for fixity declarations
|
-- no constraints are needed for fixity declarations
|
||||||
Fixity _ _ _ -> []
|
Fixity _ _ _ -> []
|
||||||
|
|
|
@ -3,6 +3,7 @@ module Type.Constrain.Expression where
|
||||||
|
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Maybe as Maybe
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import qualified Control.Monad as Monad
|
import qualified Control.Monad as Monad
|
||||||
|
@ -147,7 +148,9 @@ constrain env (L span expr) tipe =
|
||||||
(c1 /\ c))
|
(c1 /\ c))
|
||||||
|
|
||||||
PortIn _ _ tt handler ->
|
PortIn _ _ tt handler ->
|
||||||
constrain env handler (VarN tt)
|
constrain env (Maybe.fromMaybe identity handler) (VarN tt)
|
||||||
|
where
|
||||||
|
identity = Loc.none $ Lambda (PVar "x") (Loc.none $ Var "x")
|
||||||
|
|
||||||
PortOut _ _ signal ->
|
PortOut _ _ signal ->
|
||||||
constrain env signal tipe
|
constrain env signal tipe
|
||||||
|
|
Loading…
Reference in a new issue