diff --git a/src/Control/Monad/Dataflow/Infer/InferExpression.purs b/src/Control/Monad/Dataflow/Infer/InferExpression.purs index 692d061..92e8ff9 100644 --- a/src/Control/Monad/Dataflow/Infer/InferExpression.purs +++ b/src/Control/Monad/Dataflow/Infer/InferExpression.purs @@ -7,8 +7,8 @@ import Control.Monad.Error.Class (throwError) import Control.Monad.Reader (asks, local) import Control.Monad.State (gets, modify_) import Data.Array (find, foldr, zip) -import Data.List ((:)) import Data.Lens (over, view) +import Data.List ((:)) import Data.Map as Map import Data.Maybe (Maybe(..), isJust) import Data.Set as Set @@ -97,9 +97,9 @@ infer expression = tv <- fresh createConstraint funcType (inputType `TArrow` tv) pure tv - Let _ name value body -> do + Let _ shouldGeneralize name value body -> do t <- infer value - inner <- generalize t + inner <- if shouldGeneralize then generalize t else pure $ Forall [] t createClosure name inner (infer body) If _ condition onTrue onFalse -> do conditionType <- infer condition diff --git a/src/Control/Monad/Dataflow/Solve/SolveExpression.purs b/src/Control/Monad/Dataflow/Solve/SolveExpression.purs index b5c7c18..7f2ef88 100644 --- a/src/Control/Monad/Dataflow/Solve/SolveExpression.purs +++ b/src/Control/Monad/Dataflow/Solve/SolveExpression.purs @@ -39,6 +39,6 @@ solveExpression expression = do -- helper to print a typemap printTypeMap :: forall l. Show l => Ord l => Map.Map l Type -> String printTypeMap = - foldr (\(Tuple location type') result -> result <> "\n" <> show location <> " = " <> show (prettify type')) "" + foldr (\(Tuple location type') result -> result <> "\n" <> show location <> " = " <> show (type')) "" <<< Array.sortBy (\(Tuple _ a) (Tuple _ b) -> compare (show a) $ show b) <<< Map.toUnfoldable diff --git a/src/Data/Dataflow/Expression.purs b/src/Data/Dataflow/Expression.purs index 9c71c77..abc8a5d 100644 --- a/src/Data/Dataflow/Expression.purs +++ b/src/Data/Dataflow/Expression.purs @@ -64,7 +64,7 @@ data Expression l | FunctionCall l (Expression l) (Expression l) | Lambda l VarName (Expression l) | Literal l Literal - | Let l VarName (Expression l) (Expression l) + | Let l Boolean VarName (Expression l) (Expression l) | If l (Expression l) (Expression l) (Expression l) | FixPoint l (Expression l) | Chain l (List (Expression l)) @@ -81,7 +81,7 @@ getLocation = case _ of FunctionCall l _ _ -> l Lambda l _ _ -> l Literal l _ -> l - Let l _ _ _ -> l + Let l _ _ _ _ -> l If l _ _ _ -> l FixPoint l _ -> l Native l _ -> l @@ -94,7 +94,7 @@ toMap expression = <> case expression of FunctionCall _ calee input -> toMap calee <> toMap input Lambda _ _ body -> toMap body - Let _ _ value body -> toMap value <> toMap body + Let _ _ _ value body -> toMap value <> toMap body If _ condition then' else' -> toMap condition <> toMap then' <> toMap else' Chain _ expressions -> foldr (\expression' -> (<>) $ toMap expression') mempty expressions FixPoint _ body -> toMap body @@ -145,16 +145,16 @@ sumarizeExpression :: forall l. Show l => Eq l => Expression l -> String sumarizeExpression = printRawExpression $ const "..." printRawLet :: forall l. (Expression l -> String) -> Expression l -> String -printRawLet print (Let _ name value _) = indent 2 (unwrap name <> " = " <> print value) <> "\n" +printRawLet print (Let _ _ name value _) = indent 2 (unwrap name <> " = " <> print value) <> "\n" printRawLet _ _ = "" printLet :: forall l. Boolean -> (Expression l -> String) -> Expression l -> String -printLet true print expression@(Let _ _ _ _) = "let\n" <> printLet false print expression +printLet true print expression@(Let _ _ _ _ _) = "let\n" <> printLet false print expression -printLet false print expression@(Let _ _ _ next@(Let _ _ _ _)) = printRawLet print expression <> printLet false print next +printLet false print expression@(Let _ _ _ _ next@(Let _ _ _ _ _)) = printRawLet print expression <> printLet false print next -printLet false print expression@(Let _ _ _ next) = printRawLet print expression <> "in\n" <> indent 2 (print next) +printLet false print expression@(Let _ _ _ _ next) = printRawLet print expression <> "in\n" <> indent 2 (print next) printLet _ _ _ = "" @@ -168,7 +168,7 @@ printRawExpression print expression = case expression of FunctionCall _ f i -> print f <> " " <> print i Lambda _ arg value -> "\\" <> show arg <> " -> " <> print value Literal _ literal -> show literal - Let _ _ _ _ -> printLet true (printRawExpression print) expression + Let _ _ _ _ _ -> printLet true (printRawExpression print) expression FixPoint _ e -> "fixpoint( " <> print e <> " )" If _ cond then' else' -> "if\n" @@ -210,10 +210,10 @@ wrapWith Nil = identity -- Optimize an expression optimize :: forall l. Expression l -> Expression l -optimize expression@(Let location name value body) = case removeWrappers body of +optimize expression@(Let location generalize name value body) = case removeWrappers body of Variable location' name' | name == name' -> wrapWith (wrappers body) $ wrap location' $ optimize value - _ -> Let location name (optimize value) $ optimize body + _ -> Let location generalize name (optimize value) $ optimize body optimize (FunctionCall location calee argument) = FunctionCall location (optimize calee) $ optimize argument diff --git a/src/Data/Dataflow/Graph.purs b/src/Data/Dataflow/Graph.purs index 50b055b..5376bef 100644 --- a/src/Data/Dataflow/Graph.purs +++ b/src/Data/Dataflow/Graph.purs @@ -29,7 +29,7 @@ compileGraph toExpression graph main = in foldr ( \(Tuple key value) body -> - Let Nowhere (VarName $ show key) value body + Let Nowhere true (VarName $ show key) value body ) (Variable Nowhere $ VarName $ show main) $ catMaybes diff --git a/src/Data/Editor/ExtendedLocation.purs b/src/Data/Editor/ExtendedLocation.purs index 306290d..de9c2ef 100644 --- a/src/Data/Editor/ExtendedLocation.purs +++ b/src/Data/Editor/ExtendedLocation.purs @@ -1,6 +1,5 @@ module Lunarbox.Data.Editor.ExtendedLocation ( ExtendedLocation(..) - , letWithLocation , normalize , nothing , _ExtendedLocation @@ -13,7 +12,7 @@ import Data.Default (class Default, def) import Data.Lens (Prism', prism') import Data.Maybe (Maybe(..)) import Lunarbox.Data.Dataflow.Class.Expressible (nullExpr) -import Lunarbox.Data.Dataflow.Expression (Expression(..), VarName, wrap) +import Lunarbox.Data.Dataflow.Expression (Expression) -- This represents a location which may or may not have an extra or a missing layer data ExtendedLocation l l' @@ -50,20 +49,6 @@ _ExtendedLocation = DeepLocation l _ -> Just l Nowhere -> Nothing --- helpers -letWithLocation :: - forall l l'. - ExtendedLocation l l' -> - VarName -> - Expression (ExtendedLocation l l') -> - Expression (ExtendedLocation l l') -> - Expression (ExtendedLocation l l') -letWithLocation location name value body = - Let Nowhere - name - (wrap location value) - body - -- Normalize nested Locations normalize :: forall l l' l''. ExtendedLocation l (ExtendedLocation l' l'') -> ExtendedLocation l (ExtendedLocation l' l'') normalize = case _ of diff --git a/src/Data/Editor/Node.purs b/src/Data/Editor/Node.purs index 38ac8da..8c3671c 100644 --- a/src/Data/Editor/Node.purs +++ b/src/Data/Editor/Node.purs @@ -66,7 +66,7 @@ compileNode nodes id child = outputNode id case outputId of Just outputId' -> Variable Nowhere $ VarName $ show outputId' Nothing -> nothing - ComplexNode { inputs, function } -> Let Nowhere name value child + ComplexNode { inputs, function } -> Let Nowhere false name value child where name = VarName $ show id diff --git a/src/Data/Editor/NodeGroup.purs b/src/Data/Editor/NodeGroup.purs index 8ed09a0..0343f4c 100644 --- a/src/Data/Editor/NodeGroup.purs +++ b/src/Data/Editor/NodeGroup.purs @@ -10,7 +10,7 @@ module Lunarbox.Data.Editor.NodeGroup import Prelude import Data.Lens (Lens') import Data.Lens.Record (prop) -import Data.List (List, foldl, (\\), (:)) +import Data.List (List, foldl, (\\), (:), reverse) import Data.Newtype (class Newtype, unwrap) import Data.Symbol (SProxy(..)) import Lunarbox.Data.Dataflow.Expression (Expression, VarName(..), functionDeclaration) @@ -38,7 +38,7 @@ derive instance newtypeNodeGroup :: Newtype NodeGroup _ compileNodeGroup :: NodeGroup -> Expression NodeOrPinLocation compileNodeGroup group@(NodeGroup { nodes, output, inputs }) = let - ordered = orderNodes group + ordered = reverse $ orderNodes group bodyNodes = output : (ordered \\ (output : inputs)) diff --git a/src/Data/Editor/State.purs b/src/Data/Editor/State.purs index f4d8ed6..f2d57ae 100644 --- a/src/Data/Editor/State.purs +++ b/src/Data/Editor/State.purs @@ -219,7 +219,7 @@ tryConnecting state = <<< ix toIndex ) (Just from) - state + state' state''' = set _partialTo Nothing $ set _partialFrom Nothing state'' pure $ compile state''' diff --git a/src/Data/Graph.purs b/src/Data/Graph.purs index 12abc92..82dbdff 100644 --- a/src/Data/Graph.purs +++ b/src/Data/Graph.purs @@ -10,10 +10,12 @@ module Lunarbox.Data.Graph , toUnfoldable , insertEdge , topologicalSort + , edges , _Graph ) where import Prelude +import Data.Array as Array import Data.Bifunctor (lmap, rmap) import Data.Foldable (class Foldable, foldMap, foldlDefault, foldrDefault) import Data.Graph as CG @@ -104,6 +106,13 @@ toUnfoldable (Graph m) = Map.toUnfoldable $ fst <$> m insertEdge :: forall k v. Ord k => k -> k -> Graph k v -> Graph k v insertEdge from to (Graph g) = Graph $ Map.alter (map (rmap (Set.insert to))) from g +-- Get all the edges from a graph +edges :: forall k v u. Unfoldable u => Ord k => Graph k v -> u (Tuple k k) +edges (Graph map) = + Map.toUnfoldable map + >>= (\(Tuple from (Tuple _ to)) -> Tuple from <$> Set.toUnfoldable to) + # Array.toUnfoldable + -- no idea how to implement this so I'm using an implementation from another lib topologicalSort :: forall k v. Ord k => Graph k v -> List k topologicalSort = CG.topologicalSort <<< CG.fromMap <<< unwrap