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
|
||||
|
||||
PortIn name _ _ handler ->
|
||||
do handler' <- expression handler
|
||||
return $ obj "Native.Ports.portIn" `call` [ string name, handler' ]
|
||||
do handler' <- case handler of
|
||||
Nothing -> return []
|
||||
Just h -> (:[]) `fmap` expression h
|
||||
return $ obj "Native.Ports.portIn" `call` ([ string name ] ++ handler')
|
||||
|
||||
PortOut name _ signal ->
|
||||
do signal' <- expression signal
|
||||
|
|
|
@ -29,7 +29,7 @@ data ParsePort
|
|||
|
||||
data Port
|
||||
= Out String Expr.LExpr T.Type
|
||||
| In String Expr.LExpr T.Type
|
||||
| In String (Maybe Expr.LExpr) T.Type
|
||||
deriving (Show)
|
||||
|
||||
type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
|
||||
|
@ -108,7 +108,10 @@ instance Pretty Port where
|
|||
pretty port =
|
||||
case port of
|
||||
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
|
||||
mkPort arrow name expr tipe =
|
||||
P.vcat [ prettyPort name ":" tipe
|
||||
|
|
|
@ -40,7 +40,7 @@ data Expr' def
|
|||
| Record [(String, LExpr' def)]
|
||||
| Markdown String String [LExpr' def]
|
||||
-- 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)
|
||||
|
||||
type ParseExpr = Expr' ParseDef
|
||||
|
@ -129,7 +129,7 @@ instance Pretty def => Pretty (Expr' def) where
|
|||
|
||||
Markdown _ _ _ -> P.text "[markdown| ... |]"
|
||||
|
||||
PortIn _ _ _ handler -> pretty handler
|
||||
PortIn _ _ _ _ -> P.text "<port in>"
|
||||
|
||||
PortOut _ _ signal -> pretty signal
|
||||
|
||||
|
|
|
@ -4,6 +4,7 @@ module Transform.Canonicalize (interface, metadataModule) where
|
|||
import Control.Arrow ((***))
|
||||
import Control.Applicative (Applicative,(<$>),(<*>))
|
||||
import Control.Monad.Identity
|
||||
import Data.Traversable (traverse)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
|
@ -169,7 +170,7 @@ rename env (L s expr) =
|
|||
|
||||
PortIn name st tt handler ->
|
||||
do st' <- renameType' env st
|
||||
handler' <- rnm handler
|
||||
handler' <- traverse rnm handler
|
||||
return $ PortIn name st' tt handler'
|
||||
|
||||
PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
{-# OPTIONS_GHC -Wall #-}
|
||||
module Transform.Check (mistakes) where
|
||||
|
||||
import qualified Control.Arrow as Arrow
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Set as Set
|
||||
|
@ -44,10 +45,11 @@ duplicates decls =
|
|||
unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
|
||||
|
||||
(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
|
||||
D.Out name expr _ -> (name,expr)
|
||||
D.In name expr _ -> (name,expr)
|
||||
D.Out name expr _ -> (name, Just expr)
|
||||
D.In name expr _ -> (name, expr)
|
||||
|
||||
getNames = Set.toList . Pattern.boundVars
|
||||
|
||||
|
|
|
@ -62,6 +62,7 @@ combineAnnotations = go
|
|||
|
||||
Port (PPIn name' expr) : rest | name == name' ->
|
||||
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
|
||||
|
||||
import Control.Applicative ((<$>),(<*>))
|
||||
import Data.Traversable (traverse)
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Location
|
||||
import qualified SourceSyntax.Type as ST
|
||||
|
@ -50,7 +51,7 @@ crawl portInCheck portOutCheck defsTransform = go
|
|||
Let defs body -> Let <$> defsTransform defs <*> go body
|
||||
PortIn name st tt handler ->
|
||||
do portInCheck name st tt
|
||||
PortIn name st tt <$> go handler
|
||||
PortIn name st tt <$> traverse go handler
|
||||
PortOut name st signal ->
|
||||
do portOutCheck name st
|
||||
PortOut name st <$> go signal
|
||||
|
|
|
@ -49,7 +49,7 @@ expression (L loc expr) =
|
|||
Modify r fs -> Modify (f r) (map (var *** f) fs)
|
||||
Record fs -> Record (map (var *** f) fs)
|
||||
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)
|
||||
|
||||
definition :: Def -> Def
|
||||
|
|
|
@ -3,6 +3,7 @@ module Transform.SortDefinitions (sortDefs) where
|
|||
|
||||
import Control.Monad.State
|
||||
import Control.Applicative ((<$>),(<*>))
|
||||
import Data.Traversable (traverse)
|
||||
import qualified Data.Map as Map
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Location
|
||||
|
@ -85,7 +86,8 @@ reorder (L s expr) =
|
|||
|
||||
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
|
||||
Let defs body ->
|
||||
|
|
|
@ -38,5 +38,5 @@ subst old new expr =
|
|||
Record fs -> Record (map (second f) fs)
|
||||
Literal _ -> expr
|
||||
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)
|
|
@ -49,10 +49,14 @@ toDefs decl =
|
|||
case port of
|
||||
Out name expr@(L.L s _) 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
|
||||
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
|
||||
Fixity _ _ _ -> []
|
||||
|
|
|
@ -3,6 +3,7 @@ module Type.Constrain.Expression where
|
|||
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Set as Set
|
||||
import Control.Applicative ((<$>))
|
||||
import qualified Control.Monad as Monad
|
||||
|
@ -147,7 +148,9 @@ constrain env (L span expr) tipe =
|
|||
(c1 /\ c))
|
||||
|
||||
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 ->
|
||||
constrain env signal tipe
|
||||
|
|
Loading…
Reference in a new issue