mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-22 07:48:10 +03:00
minimizeOrdered function
This commit is contained in:
parent
ae34e0957c
commit
172e8e7337
@ -25,7 +25,6 @@ import Unison.Reference (Reference, pattern Builtin, pattern Derived)
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.ConstructorType as ConstructorType
|
||||
import Unison.Term
|
||||
import qualified Unison.Typechecker.Components as Components
|
||||
import Unison.UnisonFile (UnisonFile(..))
|
||||
import qualified Unison.UnisonFile as UF
|
||||
import Unison.Var (Var)
|
||||
@ -337,19 +336,6 @@ serializeFile uf@(UnisonFile dataDecls effectDecls _ _) tm = do
|
||||
serializeFoldable (uncurry serializeConstructorArities) effectDecls'
|
||||
-- NB: we rewrite the term to minimize away let rec cycles, as let rec
|
||||
-- blocks aren't allowed to have effects
|
||||
pos <- serializeTerm
|
||||
(ABT.rebuildUp'
|
||||
( either
|
||||
(\e ->
|
||||
error
|
||||
( "The Unison file is malformed. It has duplicate bindings "
|
||||
++ show (void <$> e)
|
||||
)
|
||||
)
|
||||
id
|
||||
. Components.minimize'
|
||||
)
|
||||
body
|
||||
)
|
||||
pos <- serializeTerm body
|
||||
putWord8 0
|
||||
putBackref pos
|
||||
|
@ -21,7 +21,7 @@ import qualified Data.Text as Text
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Term as Term
|
||||
import qualified Unison.Var as Var
|
||||
import Unison.Typechecker.Components (minimize')
|
||||
import Unison.Typechecker.Components (minimizeOrdered')
|
||||
-- import Debug.Trace
|
||||
-- import qualified Unison.TermPrinter as TP
|
||||
-- import qualified Unison.Util.Pretty as P
|
||||
@ -93,7 +93,7 @@ isLeaf (TypeLink' _) = True
|
||||
isLeaf _ = False
|
||||
|
||||
minimizeCyclesOrCrash :: Var v => AnnotatedTerm v a -> AnnotatedTerm v a
|
||||
minimizeCyclesOrCrash t = case minimize' t of
|
||||
minimizeCyclesOrCrash t = case minimizeOrdered' t of
|
||||
Right t -> t
|
||||
Left e -> error $ "tried to minimize let rec with duplicate definitions: "
|
||||
++ show (fst <$> toList e)
|
||||
|
@ -570,7 +570,7 @@ block' isTop s openBlock closeBlock = do
|
||||
= let
|
||||
startAnnotation = (fst . fst . head $ toBindings bs)
|
||||
endAnnotation = (fst . fst . last $ toBindings bs)
|
||||
finish tm = case Components.minimize' tm of
|
||||
finish tm = case Components.minimizeOrdered' tm of
|
||||
Left dups -> customFailure $ DuplicateTermNames (toList dups)
|
||||
Right tm -> pure tm
|
||||
in
|
||||
|
@ -1,4 +1,4 @@
|
||||
module Unison.Typechecker.Components (minimize, minimize') where
|
||||
module Unison.Typechecker.Components (minimize, minimize',minimizeOrdered,minimizeUnordered,minimizeOrdered',minimizeUnordered',ordered,unordered) where
|
||||
|
||||
import Unison.Prelude
|
||||
|
||||
@ -16,6 +16,24 @@ import Unison.Term (AnnotatedTerm')
|
||||
import qualified Unison.Term as Term
|
||||
import Unison.Var (Var)
|
||||
|
||||
type Components vt v a = [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
|
||||
|
||||
unordered :: Var v => [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
|
||||
unordered = ABT.components
|
||||
|
||||
ordered :: Var v => [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
|
||||
ordered = ABT.orderedComponents
|
||||
|
||||
minimizeOrdered, minimizeUnordered ::
|
||||
Var v => AnnotatedTerm' vt v a -> Either (NonEmpty (v, [a])) (Maybe (AnnotatedTerm' vt v a))
|
||||
minimizeOrdered = minimize ordered
|
||||
minimizeUnordered = minimize unordered
|
||||
|
||||
minimizeOrdered', minimizeUnordered' ::
|
||||
Var v => AnnotatedTerm' vt v a -> Either (NonEmpty (v, [a])) (AnnotatedTerm' vt v a)
|
||||
minimizeOrdered' = minimize' ordered
|
||||
minimizeUnordered' = minimize' unordered
|
||||
|
||||
-- | Algorithm for minimizing cycles of a `let rec`. This can
|
||||
-- improve generalization during typechecking and may also be more
|
||||
-- efficient for execution.
|
||||
@ -32,9 +50,10 @@ import Unison.Var (Var)
|
||||
-- Fails on the left if there are duplicate definitions.
|
||||
minimize
|
||||
:: Var v
|
||||
=> AnnotatedTerm' vt v a
|
||||
=> Components vt v a
|
||||
-> AnnotatedTerm' vt v a
|
||||
-> Either (NonEmpty (v, [a])) (Maybe (AnnotatedTerm' vt v a))
|
||||
minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
|
||||
minimize components (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
|
||||
let bindings = first snd <$> bs
|
||||
group = map (fst . head &&& map (ABT.annotation . snd)) . groupBy ((==) `on` fst) . sortBy
|
||||
(compare `on` fst)
|
||||
@ -43,7 +62,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
|
||||
in if not $ null dupes
|
||||
then Left $ Nel.fromList dupes
|
||||
else
|
||||
let cs0 = ABT.components bindings
|
||||
let cs0 = components bindings
|
||||
-- within a cycle, we put the lambdas first, so
|
||||
-- unguarded definitions can refer to these lambdas, example:
|
||||
--
|
||||
@ -75,8 +94,8 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
|
||||
-- sure to preserve it, whereas the annotations at intermediate Abs
|
||||
-- nodes aren't necessarily meaningful
|
||||
Right . Just . ABT.annotate ann . foldr mklet e $ cs
|
||||
minimize _ = Right Nothing
|
||||
minimize _ _ = Right Nothing
|
||||
|
||||
minimize'
|
||||
:: Var v => AnnotatedTerm' vt v a -> Either (NonEmpty (v,[a])) (AnnotatedTerm' vt v a)
|
||||
minimize' term = fromMaybe term <$> minimize term
|
||||
:: Var v => Components vt v a -> AnnotatedTerm' vt v a -> Either (NonEmpty (v,[a])) (AnnotatedTerm' vt v a)
|
||||
minimize' cs term = fromMaybe term <$> minimize cs term
|
||||
|
@ -79,7 +79,7 @@ import Unison.Referent ( Referent )
|
||||
import Unison.Term ( AnnotatedTerm' )
|
||||
import qualified Unison.Term as Term
|
||||
import qualified Unison.Type as Type
|
||||
import Unison.Typechecker.Components ( minimize' )
|
||||
import Unison.Typechecker.Components ( minimizeOrdered' )
|
||||
import qualified Unison.Typechecker.TypeLookup as TL
|
||||
import qualified Unison.TypeVar as TypeVar
|
||||
import Unison.Var ( Var )
|
||||
@ -803,7 +803,7 @@ noteTopLevelType e binding typ = case binding of
|
||||
synthesize :: forall v loc . (Var v, Ord loc) => Term v loc -> M v loc (Type v loc)
|
||||
synthesize e | debugEnabled && traceShow ("synthesize"::String, e) False = undefined
|
||||
synthesize e = scope (InSynthesize e) $
|
||||
case minimize' e of
|
||||
case minimizeOrdered' e of
|
||||
Left es -> failWith (DuplicateDefinitions es)
|
||||
Right e -> do
|
||||
Type.Effect'' es t <- go e
|
||||
@ -1291,7 +1291,7 @@ check e t | debugEnabled && traceShow ("check" :: String, e, t) False = undefine
|
||||
check e0 t0 = scope (InCheck e0 t0) $ do
|
||||
ctx <- getContext
|
||||
let Type.Effect'' es t = t0
|
||||
let e = minimize' e0
|
||||
let e = minimizeOrdered' e0
|
||||
case e of
|
||||
Left e -> failWith $ DuplicateDefinitions e
|
||||
Right e ->
|
||||
|
@ -36,6 +36,7 @@ import qualified Unison.Typechecker.TypeLookup as TL
|
||||
import Unison.Names3 (Names0)
|
||||
import qualified Unison.LabeledDependency as LD
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import qualified Unison.Typechecker.Components as Components
|
||||
|
||||
data UnisonFile v a = UnisonFile {
|
||||
dataDeclarations :: Map v (Reference, DataDeclaration' v a),
|
||||
|
@ -558,6 +558,24 @@ instance (Foldable f, Functor f, Ord1 f, Var v) => Ord (Term f v a) where
|
||||
components :: Var v => [(v, Term f v a)] -> [[(v, Term f v a)]]
|
||||
components = Components.components freeVars
|
||||
|
||||
-- Converts to strongly connected components, preserving order of the input.
|
||||
-- Satisfies `join (orderedComponents vs) == vs`. Algorithm works by
|
||||
-- repeatedly collecting smallest cycle of definitions from remainder of list.
|
||||
orderedComponents :: Var v => [(v, Term f v a)] -> [[(v, Term f v a)]]
|
||||
orderedComponents tms = go [] Set.empty tms
|
||||
where
|
||||
go [] _ [] = []
|
||||
go [] deps (hd:rem) = go [hd] (deps <> freeVars (snd hd)) rem
|
||||
go cur deps rem = case findIndex isDep rem of
|
||||
Nothing -> reverse cur : let (hd,tl) = splitAt 1 rem
|
||||
in go hd (depsFor hd) tl
|
||||
Just i -> go (reverse newMembers ++ cur) deps' (drop (i+1) rem)
|
||||
where deps' = deps <> depsFor newMembers
|
||||
newMembers = take (i+1) rem
|
||||
where
|
||||
depsFor = foldMap (freeVars . snd)
|
||||
isDep (v, _) = Set.member v deps
|
||||
|
||||
-- Hash a strongly connected component and sort its definitions into a canonical order.
|
||||
hashComponent ::
|
||||
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v, Ord h, Accumulate h)
|
||||
|
Loading…
Reference in New Issue
Block a user