unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-11-14 16:28:34 +03:00
Code Issues Projects Releases Wiki Activity

rename AnnotatedTerm to Term

Browse Source
This commit is contained in:
Arya Irani 2020-03-03 18:43:51 +01:00
parent b5cae909fc
commit 7dd59bc78c
36 changed files with 314 additions and 322 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
parser-typechecker/src/Unison/Codebase.hs
View File

@ -34,6 +34,7 @@ import Unison.Var ( Var )
import qualified Unison.Runtime.IOSource as IOSource
import Unison.Symbol ( Symbol )
import Unison.DataDeclaration (Decl)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
@ -41,7 +42,6 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash)
type DataDeclaration v a = DD.DataDeclaration' v a
type EffectDeclaration v a = DD.EffectDeclaration' v a
type Term v a = Term.AnnotatedTerm v a
data Codebase m v a =
Codebase { getTerm :: Reference.Id -> m (Maybe (Term v a))

4
parser-typechecker/src/Unison/Codebase/CodeLookup.hs
View File

@ -7,7 +7,7 @@ import qualified Data.Map as Map
import Unison.UnisonFile ( UnisonFile )
import qualified Unison.UnisonFile as UF
import qualified Unison.Term as Term
import Unison.Term ( AnnotatedTerm )
import Unison.Term ( Term )
import Unison.Var ( Var )
import qualified Unison.Reference as Reference
import Unison.DataDeclaration (Decl)
@ -29,7 +29,7 @@ fromUnisonFile uf = CodeLookup tm ty where
data CodeLookup v m a
= CodeLookup {
getTerm :: Reference.Id -> m (Maybe (AnnotatedTerm v a)),
getTerm :: Reference.Id -> m (Maybe (Term v a)),
getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a))
}

3
parser-typechecker/src/Unison/Codebase/Editor/Command.hs
View File

@ -31,7 +31,7 @@ import Unison.DataDeclaration ( Decl )
import qualified Unison.Codebase.Runtime as Runtime
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.Reference as Reference
import qualified Unison.Term as Term
import Unison.Term ( Term )
import qualified Unison.UnisonFile as UF
import qualified Unison.Lexer as L
import qualified Unison.Parser as Parser
@ -46,7 +46,6 @@ type AmbientAbilities v = [Type v Ann]
type SourceName = Text
type Source = Text
type LexedSource = (Text, [L.Token L.Lexeme])
type Term v a = Term.AnnotatedTerm v a
data LoadSourceResult = InvalidSourceNameError
| LoadError

3
parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs
View File

@ -50,6 +50,7 @@ import Unison.FileParsers ( parseAndSynthesizeFile
)
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.ShortHash as SH
import Unison.Term (Term)
import Unison.Type (Type)
typecheck
@ -171,7 +172,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
AppendToReflog reason old new -> Codebase.appendReflog codebase reason old new
LoadReflog -> Codebase.getReflog codebase
eval1 :: PPE.PrettyPrintEnv -> Term.AnnotatedTerm v Ann -> _
eval1 :: PPE.PrettyPrintEnv -> Term v Ann -> _
eval1 ppe tm = do
let codeLookup = Codebase.toCodeLookup codebase
r <- Runtime.evaluateTerm codeLookup ppe rt tm

2
parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -115,6 +115,7 @@ import Unison.Codebase.Editor.SearchResult' (SearchResult')
import qualified Unison.Codebase.Editor.SearchResult' as SR'
import qualified Unison.LabeledDependency as LD
import Unison.LabeledDependency (LabeledDependency)
import Unison.Term (Term)
import Unison.Type (Type)
import qualified Unison.Builtin as Builtin
import Unison.Codebase.NameSegment (NameSegment(..))
@ -130,7 +131,6 @@ import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as Nel
type F m i v = Free (Command m i v)
type Term v a = Term.AnnotatedTerm v a
-- type (Action m i v) a
type Action m i v = MaybeT (StateT (LoopState m v) (F m i v))

3
parser-typechecker/src/Unison/Codebase/Editor/Output.hs
View File

@ -40,13 +40,13 @@ import qualified Unison.HashQualified' as HQ'
import qualified Unison.Parser as Parser
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.Reference as Reference
import qualified Unison.Term as Term
import qualified Unison.Typechecker.Context as Context
import qualified Unison.UnisonFile as UF
import qualified Unison.Util.Pretty as P
import Unison.Codebase.Editor.DisplayThing (DisplayThing)
import qualified Unison.Codebase.Editor.TodoOutput as TO
import Unison.Codebase.Editor.SearchResult' (SearchResult')
import Unison.Term (Term)
import Unison.Type (Type)
import qualified Unison.Names3 as Names
import qualified Data.Set as Set
@ -57,7 +57,6 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash)
import Unison.Codebase.Editor.RemoteRepo as RemoteRepo
import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput)
type Term v a = Term.AnnotatedTerm v a
type ListDetailed = Bool
type SourceName = Text
type NumberedArgs = [String]

2
parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs
View File

@ -28,6 +28,7 @@ import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import qualified Unison.Result as Result
import qualified Unison.Term as Term
import Unison.Term ( Term )
import Unison.Util.Free ( Free
, eval
)
@ -48,7 +49,6 @@ import Unison.ConstructorType ( ConstructorType )
import qualified Unison.Runtime.IOSource as IOSource
type F m i v = Free (Command m i v)
type Term v a = Term.AnnotatedTerm v a
data Edits v = Edits
{ termEdits :: Map Reference TermEdit

2
parser-typechecker/src/Unison/Codebase/Editor/SlurpComponent.hs
View File

@ -75,7 +75,7 @@ closeWithDependencies uf inputs = seenDefns where
resolveTypes :: Set Reference -> [v]
resolveTypes rs = [ v | r <- Set.toList rs, Just v <- [Map.lookup r typeNames]]
findTerm :: v -> Maybe (Term.AnnotatedTerm v a)
findTerm :: v -> Maybe (Term.Term v a)
findTerm v = Map.lookup v allTerms
allTerms = UF.allTerms uf

7
parser-typechecker/src/Unison/Codebase/FileCodebase.hs
View File

@ -86,6 +86,7 @@ import Unison.Reference ( Reference )
import qualified Unison.Reference as Reference
import Unison.Referent ( Referent(..) )
import qualified Unison.Referent as Referent
import Unison.Term ( Term )
import qualified Unison.Term as Term
import Unison.Type ( Type )
import qualified Unison.Type as Type
@ -493,7 +494,7 @@ putTerm
-> S.Put a
-> FilePath
-> Reference.Id
-> Term.AnnotatedTerm v a
-> Term v a
-> Type v a
-> m ()
putTerm putV putA path h e typ = liftIO $ do
@ -549,7 +550,7 @@ putWatch
-> FilePath
-> UF.WatchKind
-> Reference.Id
-> Codebase.Term v a
-> Term v a
-> m ()
putWatch putV putA path k id e = liftIO $ S.putWithParentDirs
(V1.putTerm putV putA)
@ -654,7 +655,7 @@ codebase1 fmtV@(S.Format getV putV) fmtA@(S.Format getA putA) path =
createDirectoryIfMissing True wp
ls <- listDirectory wp
pure $ ls >>= (toList . componentIdFromString . takeFileName)
getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Codebase.Term v a))
getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term v a))
getWatch k id =
liftIO $ do
let wp = watchesDir path (Text.pack k)

3
parser-typechecker/src/Unison/Codebase/MainTerm.hs
View File

@ -13,6 +13,7 @@ import Unison.Prelude
import Unison.Parser ( Ann )
import qualified Unison.Parser as Parser
import qualified Unison.Term as Term
import Unison.Term ( Term )
import Unison.Var ( Var )
import qualified Unison.DataDeclaration as DD
import qualified Unison.HashQualified as HQ
@ -28,7 +29,7 @@ data MainTerm v
= NotAFunctionName String
| NotFound String
| BadType String
| Success HQ.HashQualified (Term.AnnotatedTerm v Ann) (Type v Ann)
| Success HQ.HashQualified (Term v Ann) (Type v Ann)
getMainTerm
:: (Monad m, Var v)

12
parser-typechecker/src/Unison/Codebase/Runtime.hs
View File

@ -13,9 +13,6 @@ import qualified Unison.Codebase.CodeLookup as CL
import qualified Unison.Codebase as Codebase
import Unison.UnisonFile ( UnisonFile )
import qualified Unison.Term as Term
import Unison.Term ( Term
, AnnotatedTerm
)
import Unison.Var ( Var )
import qualified Unison.Var as Var
import Unison.Reference ( Reference )
@ -26,6 +23,7 @@ import qualified Unison.Util.Pretty as P
import qualified Unison.PrettyPrintEnv as PPE
type Error = P.Pretty P.ColorText
type Term v = Term.Term v ()
data Runtime v = Runtime
{ terminate :: IO ()
@ -65,7 +63,7 @@ evaluateWatches
-- IO (bindings :: [v,Term v], map :: ^^^)
evaluateWatches code ppe evaluationCache rt uf = do
-- 1. compute hashes for everything in the file
let m :: Map v (Reference, AnnotatedTerm v a)
let m :: Map v (Reference, Term.Term v a)
m = Term.hashComponents (Map.fromList (UF.terms uf <> UF.allWatches uf))
watches = Set.fromList (fst <$> UF.allWatches uf)
watchKinds :: Map v UF.WatchKind
@ -105,7 +103,7 @@ evaluateWatches code ppe evaluationCache rt uf = do
pure $ Right (bindings, watchMap)
Left e -> pure (Left e)
where
-- unref :: Map Reference v -> AnnotatedTerm v a -> AnnotatedTerm v a
-- unref :: Map Reference v -> Term.Term v a -> Term.Term v a
unref rv t = ABT.visitPure go t
where
go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
@ -118,8 +116,8 @@ evaluateTerm
=> CL.CodeLookup v IO a
-> PPE.PrettyPrintEnv
-> Runtime v
-> Term.AnnotatedTerm v a
-> IO (Either Error (ABT.Term (Term.F v () ()) v ()))
-> Term.Term v a
-> IO (Either Error (Term v))
evaluateTerm codeLookup ppe rt tm = do
let uf = UF.UnisonFile mempty mempty mempty
(Map.singleton UF.RegularWatch [(Var.nameds "result", tm)])

6
parser-typechecker/src/Unison/Codebase/Serialization/V1.hs
View File

@ -45,7 +45,7 @@ import Unison.Hash ( Hash )
import Unison.Kind ( Kind )
import Unison.Reference ( Reference )
import Unison.Symbol ( Symbol(..) )
import Unison.Term ( AnnotatedTerm )
import Unison.Term ( Term )
import qualified Data.ByteString as B
import qualified Data.Sequence as Sequence
import qualified Data.Set as Set
@ -478,7 +478,7 @@ getPattern getA = getWord8 >>= \tag -> case tag of
putTerm :: (MonadPut m, Ord v)
=> (v -> m ()) -> (a -> m ())
-> AnnotatedTerm v a
-> Term v a
-> m ()
putTerm putVar putA = putABT putVar putA go where
go putChild t = case t of
@ -534,7 +534,7 @@ putTerm putVar putA = putABT putVar putA go where
putPattern putA pat *> putMaybe guard putChild *> putChild body
getTerm :: (MonadGet m, Ord v)
=> m v -> m a -> m (Term.AnnotatedTerm v a)
=> m v -> m a -> m (Term v a)
getTerm getVar getA = getABT getVar getA go where
go getChild = getWord8 >>= \tag -> case tag of
0 -> Term.Int <$> getInt

6
parser-typechecker/src/Unison/Codecs.hs
View File

@ -35,7 +35,7 @@ import qualified Unison.PatternP as Pattern
type Pos = Word64
serializeTerm :: (MonadPut m, MonadState Pos m, Var v)
=> AnnotatedTerm v a
=> Term v a
-> m Pos
serializeTerm x = do
let putTag = do putWord8 111; putWord8 0
@ -260,7 +260,7 @@ serializeCase2 (MatchCase p guard body) = do
putBackref body
serializeCase1 :: (Var v, MonadPut m, MonadState Pos m)
=> MatchCase p (AnnotatedTerm v a) -> m (MatchCase p Pos)
=> MatchCase p (Term v a) -> m (MatchCase p Pos)
serializeCase1 (MatchCase p guard body) = do
posg <- traverse serializeTerm guard
posb <- serializeTerm body
@ -325,7 +325,7 @@ serializeConstructorArities r constructorArities = do
serializeFile
:: (MonadPut m, MonadState Pos m, Monoid a, Var v)
=> UnisonFile v a -> AnnotatedTerm v a -> m ()
=> UnisonFile v a -> Term v a -> m ()
serializeFile uf@(UnisonFile dataDecls effectDecls _ _) tm = do
let body = UF.uberTerm' uf tm
let dataDecls' = second DD.constructorArities <$> toList dataDecls

14
parser-typechecker/src/Unison/CommandLine/DisplayValues.hs
View File

@ -6,7 +6,7 @@ module Unison.CommandLine.DisplayValues where
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Term (AnnotatedTerm)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Var (Var)
import qualified Unison.DataDeclaration as DD
@ -25,11 +25,11 @@ type Pretty = P.Pretty P.ColorText
displayTerm :: (Var v, Monad m)
=> PPE.PrettyPrintEnvDecl
-> (Reference -> m (Maybe (AnnotatedTerm v a)))
-> (Reference -> m (Maybe (Term v a)))
-> (Referent -> m (Maybe (Type v a)))
-> (Reference -> m (Maybe (AnnotatedTerm v a)))
-> (Reference -> m (Maybe (Term v a)))
-> (Reference -> m (Maybe (DD.Decl v a)))
-> AnnotatedTerm v a
-> Term v a
-> m Pretty
displayTerm pped terms typeOf eval types tm = case tm of
-- todo: can dispatch on other things with special rendering
@ -40,11 +40,11 @@ displayTerm pped terms typeOf eval types tm = case tm of
displayDoc :: (Var v, Monad m)
=> PPE.PrettyPrintEnvDecl
-> (Reference -> m (Maybe (AnnotatedTerm v a)))
-> (Reference -> m (Maybe (Term v a)))
-> (Referent -> m (Maybe (Type v a)))
-> (Reference -> m (Maybe (AnnotatedTerm v a)))
-> (Reference -> m (Maybe (Term v a)))
-> (Reference -> m (Maybe (DD.Decl v a)))
-> AnnotatedTerm v a
-> Term v a
-> m Pretty
displayDoc pped terms typeOf evaluated types t = go t
where

10
parser-typechecker/src/Unison/CommandLine/OutputMessages.hs
View File

@ -87,7 +87,7 @@ import qualified Unison.Referent as Referent
import Unison.Referent ( Referent )
import qualified Unison.Result as Result
import qualified Unison.Term as Term
import Unison.Term (AnnotatedTerm)
import Unison.Term (Term)
import Unison.Type (Type)
import qualified Unison.TermPrinter as TermPrinter
import qualified Unison.TypePrinter as TypePrinter
@ -972,7 +972,7 @@ formatMissingStuff terms types =
displayDefinitions' :: Var v => Ord a1
=> PPE.PrettyPrintEnvDecl
-> Map Reference.Reference (DisplayThing (DD.Decl v a1))
-> Map Reference.Reference (DisplayThing (Unison.Term.AnnotatedTerm v a1))
-> Map Reference.Reference (DisplayThing (Term v a1))
-> Pretty
displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTypes <> prettyTerms)
where
@ -1030,7 +1030,7 @@ displayDefinitions :: Var v => Ord a1 =>
Maybe FilePath
-> PPE.PrettyPrintEnvDecl
-> Map Reference.Reference (DisplayThing (DD.Decl v a1))
-> Map Reference.Reference (DisplayThing (Unison.Term.AnnotatedTerm v a1))
-> Map Reference.Reference (DisplayThing (Term v a1))
-> IO Pretty
displayDefinitions outputLoc ppe types terms | Map.null types && Map.null terms =
pure $ P.callout "😶" "No results to display."
@ -1699,7 +1699,7 @@ watchPrinter
-> PPE.PrettyPrintEnv
-> Ann
-> UF.WatchKind
-> Codebase.Term v ()
-> Term v ()
-> Runtime.IsCacheHit
-> Pretty
watchPrinter src ppe ann kind term isHit =
@ -1825,7 +1825,7 @@ prettyDiff diff = let
else mempty
]
isTestOk :: Codebase.Term v Ann -> Bool
isTestOk :: Term v Ann -> Bool
isTestOk tm = case tm of
Term.Sequence' ts -> all isSuccess ts where
isSuccess (Term.App' (Term.Constructor' ref cid) _) =

4
parser-typechecker/src/Unison/FileParser.hs
View File

@ -19,7 +19,7 @@ import Unison.DataDeclaration (DataDeclaration', EffectDeclaration')
import qualified Unison.DataDeclaration as DD
import qualified Unison.Lexer as L
import Unison.Parser
import Unison.Term (AnnotatedTerm)
import Unison.Term (Term)
import qualified Unison.Term as Term
import qualified Unison.TermParser as TermParser
import Unison.Type (Type)
@ -107,7 +107,7 @@ getVars = \case
Binding ((_,v), _) -> [v]
Bindings bs -> [ v | ((_,v), _) <- bs ]
stanza :: Var v => P v (Stanza v (AnnotatedTerm v Ann))
stanza :: Var v => P v (Stanza v (Term v Ann))
stanza = watchExpression <|> unexpectedAction <|> binding <|> namespace
where
unexpectedAction = failureIf (TermParser.blockTerm $> getErr) binding

11
parser-typechecker/src/Unison/FileParsers.hs
View File

@ -28,9 +28,8 @@ import qualified Unison.Referent as Referent
import Unison.Reference (Reference)
import Unison.Result (Note (..), Result, pattern Result, ResultT, CompilerBug(..))
import qualified Unison.Result as Result
import Unison.Term (AnnotatedTerm)
import qualified Unison.Term as Term
import qualified Unison.Type
import qualified Unison.Type as Type
import qualified Unison.Typechecker as Typechecker
import qualified Unison.Typechecker.TypeLookup as TL
import qualified Unison.Typechecker.Context as Context
@ -41,8 +40,8 @@ import Unison.Var (Var)
import qualified Unison.Var as Var
import Unison.Names3 (Names0)
type Term v = AnnotatedTerm v Ann
type Type v = Unison.Type.Type v Ann
type Term v = Term.Term v Ann
type Type v = Type.Type v Ann
type UnisonFile v = UF.UnisonFile v Ann
type Result' v = Result (Seq (Note v Ann))
@ -84,7 +83,7 @@ resolveNames
-> ResultT
(Seq (Note v Ann))
m
(AnnotatedTerm v Ann, TDNRMap v, TL.TypeLookup v Ann)
(Term v, TDNRMap v, TL.TypeLookup v Ann)
resolveNames typeLookupf preexistingNames uf = do
let tm = UF.typecheckingTerm uf
deps = Term.dependencies tm
@ -124,7 +123,7 @@ synthesizeFile
-> TL.TypeLookup v Ann
-> TDNRMap v
-> UnisonFile v
-> AnnotatedTerm v Ann
-> Term v
-> Result (Seq (Note v Ann)) (UF.TypecheckedUnisonFile v Ann)
synthesizeFile ambient tl fqnsByShortName uf term = do
let -- substitute Blanks for any remaining free vars in UF body

6
parser-typechecker/src/Unison/Parsers.hs
View File

@ -13,7 +13,7 @@ import qualified Unison.Parser as Parser
import Unison.PrintError ( prettyParseError
, defaultWidth )
import Unison.Symbol ( Symbol )
import Unison.Term ( AnnotatedTerm )
import Unison.Term ( Term )
import qualified Unison.TermParser as TermParser
import Unison.Type ( Type )
import qualified Unison.TypeParser as TypeParser
@ -37,7 +37,7 @@ parseTerm
:: Var v
=> String
-> Parser.ParsingEnv
-> Either (Parser.Err v) (AnnotatedTerm v Ann)
-> Either (Parser.Err v) (Term v Ann)
parseTerm = parse TermParser.term
parseType
@ -65,7 +65,7 @@ readAndParseFile penv fileName = do
let src = Text.unpack txt
pure $ parseFile fileName src penv
unsafeParseTerm :: Var v => String -> Parser.ParsingEnv -> AnnotatedTerm v Ann
unsafeParseTerm :: Var v => String -> Parser.ParsingEnv -> Term v Ann
unsafeParseTerm s = fmap (unsafeGetRightFrom s) . parseTerm $ s
unsafeReadAndParseFile

4
parser-typechecker/src/Unison/Result.hs
View File

@ -19,7 +19,7 @@ import Control.Monad.Writer ( WriterT(..)
import Unison.Name ( Name )
import qualified Unison.Parser as Parser
import Unison.Paths ( Path )
import Unison.Term ( AnnotatedTerm )
import Unison.Term ( Term )
import qualified Unison.Typechecker.Context as Context
import Control.Error.Util ( note)
import qualified Unison.Names3 as Names
@ -28,8 +28,6 @@ type Result notes = ResultT notes Identity
type ResultT notes f = MaybeT (WriterT notes f)
type Term v loc = AnnotatedTerm v loc
data Note v loc
= Parsing (Parser.Err v)
| NameResolutionFailures [Names.ResolutionFailure v loc]

20
parser-typechecker/src/Unison/Runtime/ANF.hs
View File

@ -26,7 +26,7 @@ import Unison.Typechecker.Components (minimize')
-- import qualified Unison.TermPrinter as TP
-- import qualified Unison.Util.Pretty as P
newtype ANF v a = ANF_ { term :: Term.AnnotatedTerm v a }
newtype ANF v a = ANF_ { term :: Term v a }
-- Replace all lambdas with free variables with closed lambdas.
-- Works by adding a parameter for each free variable. These
@ -38,7 +38,7 @@ newtype ANF v a = ANF_ { term :: Term.AnnotatedTerm v a }
--
-- The transformation is shallow and doesn't transform the body of
-- lambdas it finds inside of `t`.
lambdaLift :: (Var v, Semigroup a) => (v -> v) -> AnnotatedTerm v a -> AnnotatedTerm v a
lambdaLift :: (Var v, Semigroup a) => (v -> v) -> Term v a -> Term v a
lambdaLift liftVar t = result where
result = ABT.visitPure go t
go t@(LamsNamed' vs body) = Just $ let
@ -51,7 +51,7 @@ lambdaLift liftVar t = result where
(snd <$> subs)
go _ = Nothing
optimize :: forall a v . (Semigroup a, Var v) => AnnotatedTerm v a -> AnnotatedTerm v a
optimize :: forall a v . (Semigroup a, Var v) => Term v a -> Term v a
optimize t = go t where
ann = ABT.annotation
go (Let1' b body) | canSubstLet b body = go (ABT.bind body b)
@ -92,24 +92,24 @@ isLeaf (TermLink' _) = True
isLeaf (TypeLink' _) = True
isLeaf _ = False
minimizeCyclesOrCrash :: Var v => AnnotatedTerm v a -> AnnotatedTerm v a
minimizeCyclesOrCrash :: Var v => Term v a -> Term v a
minimizeCyclesOrCrash t = case minimize' t of
Right t -> t
Left e -> error $ "tried to minimize let rec with duplicate definitions: "
++ show (fst <$> toList e)
fromTerm' :: (Monoid a, Var v) => (v -> v) -> AnnotatedTerm v a -> AnnotatedTerm v a
fromTerm' :: (Monoid a, Var v) => (v -> v) -> Term v a -> Term v a
fromTerm' liftVar t = term (fromTerm liftVar t)
fromTerm :: forall a v . (Monoid a, Var v) => (v -> v) -> AnnotatedTerm v a -> ANF v a
fromTerm :: forall a v . (Monoid a, Var v) => (v -> v) -> Term v a -> ANF v a
fromTerm liftVar t = ANF_ (go $ lambdaLift liftVar t) where
ann = ABT.annotation
isRef (Ref' _) = True
isRef _ = False
fixup :: Set v -- if we gotta create new vars, avoid using these
-> ([AnnotatedTerm v a] -> AnnotatedTerm v a) -- do this with ANF'd args
-> [AnnotatedTerm v a] -- the args (not all in ANF already)
-> AnnotatedTerm v a -- the ANF'd term
-> ([Term v a] -> Term v a) -- do this with ANF'd args
-> [Term v a] -- the args (not all in ANF already)
-> Term v a -- the ANF'd term
fixup used f args = let
args' = Map.fromList $ toVar =<< (args `zip` [0..])
toVar (b, i) | isLeaf b = []
@ -118,7 +118,7 @@ fromTerm liftVar t = ANF_ (go $ lambdaLift liftVar t) where
toANF (b,i) = maybe b (var (ann b)) $ Map.lookup i args'
addLet (b,i) body = maybe body (\v -> let1' False [(v,go b)] body) (Map.lookup i args')
in foldr addLet (f argsANF) (args `zip` [(0::Int)..])
go :: AnnotatedTerm v a -> AnnotatedTerm v a
go :: Term v a -> Term v a
go e@(Apps' f args)
| (isRef f || isLeaf f) && all isLeaf args = e
| not (isRef f || isLeaf f) =

3
parser-typechecker/src/Unison/Runtime/IR.hs
View File

@ -21,7 +21,6 @@ import Unison.Hash (Hash)
import Unison.NamePrinter (prettyHashQualified0)
import Unison.Referent (Referent)
import Unison.Symbol (Symbol)
import Unison.Term (AnnotatedTerm)
import Unison.Util.CyclicEq (CyclicEq, cyclicEq)
import Unison.Util.CyclicOrd (CyclicOrd, cyclicOrd)
import Unison.Util.Monoid (intercalateMap)
@ -47,7 +46,7 @@ import qualified Unison.Var as Var
type Pos = Int
type Arity = Int
type ConstructorId = Int
type Term v = AnnotatedTerm v ()
type Term v = Term.Term v ()
data CompilationEnv e cont
= CompilationEnv { toIR' :: Map R.Reference (IR e cont)

2
parser-typechecker/src/Unison/Runtime/Rt1.hs
View File

@ -224,7 +224,7 @@ arity _ = 0
-- types that are referenced by the given term, `t`.
compilationEnv :: Monad m
=> CL.CodeLookup Symbol m a
-> Term.AnnotatedTerm Symbol a
-> Term.Term Symbol a
-> m CompilationEnv
compilationEnv env t = do
let typeDeps = Term.typeDependencies t

42
parser-typechecker/src/Unison/TermParser.hs
View File

@ -20,7 +20,7 @@ import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Parser hiding (seq)
import Unison.PatternP (Pattern)
import Unison.Term (AnnotatedTerm, IsTop)
import Unison.Term (Term, IsTop)
import Unison.Type (Type)
import Unison.Util.List (intercalateMapWith)
import Unison.Var (Var)
@ -60,7 +60,7 @@ operator characters (like empty? or fold-left).
Sections / partial application of infix operators is not implemented.
-}
type TermP v = P v (AnnotatedTerm v Ann)
type TermP v = P v (Term v Ann)
term :: Var v => TermP v
term = term2
@ -134,7 +134,7 @@ match = do
_ <- closeBlock
pure $ Term.match (ann start <> ann (last cases)) scrutinee cases
matchCase :: Var v => P v (Term.MatchCase Ann (AnnotatedTerm v Ann))
matchCase :: Var v => P v (Term.MatchCase Ann (Term v Ann))
matchCase = do
(p, boundVars) <- parsePattern
guard <- optional $ reserved "|" *> infixAppOrBooleanOp
@ -400,7 +400,7 @@ data UnbreakCase =
--
-- This function has some tracing which you can enable by deleting some calls to
-- 'const id' below.
docNormalize :: (Ord v, Show v) => AnnotatedTerm v a -> AnnotatedTerm v a
docNormalize :: (Ord v, Show v) => Term v a -> Term v a
docNormalize tm = case tm of
-- This pattern is just `DD.DocJoin seqs`, but exploded in order to grab
-- the annotations. The aim is just to map `normalize` over it.
@ -424,8 +424,8 @@ docNormalize tm = case tm of
miniPreProcess seqs = zip (toList seqs) (previousLines seqs)
unIndent
:: Ord v
=> [(AnnotatedTerm v a, UnbreakCase)]
-> [(AnnotatedTerm v a, UnbreakCase)]
=> [(Term v a, UnbreakCase)]
-> [(Term v a, UnbreakCase)]
unIndent tms = map go tms where
go (b, previous) =
((mapBlob $ (reduceIndent includeFirst minIndent)) b, previous)
@ -476,8 +476,8 @@ docNormalize tm = case tm of
-- be removed.
unbreakParas
:: (Show v, Ord v)
=> [(AnnotatedTerm v a, UnbreakCase, Bool)]
-> [(AnnotatedTerm v a, UnbreakCase, Bool)]
=> [(Term v a, UnbreakCase, Bool)]
-> [(Term v a, UnbreakCase, Bool)]
unbreakParas = map go where
-- 'candidate' means 'candidate to be joined with an adjacent line as part of a
-- paragraph'.
@ -524,7 +524,7 @@ docNormalize tm = case tm of
-- several, which we can't do perfectly, and which varies depending on
-- whether the doc is viewed or displayed. This can cause some glitches
-- cutting out whitespace immediately following @[source] and @[evaluate].
lastLines :: Show v => Sequence.Seq (AnnotatedTerm v a) -> [Maybe UnbreakCase]
lastLines :: Show v => Sequence.Seq (Term v a) -> [Maybe UnbreakCase]
lastLines tms = (flip fmap) (toList tms) $ \case
DD.DocBlob txt -> unbreakCase txt
DD.DocLink _ -> Nothing
@ -551,7 +551,7 @@ docNormalize tm = case tm of
-- fighting to break free - overwriting elements that are 'shadowed' by
-- a preceding element for which the predicate is true, with a copy of
-- that element.
previousLines :: Show v => Sequence.Seq (AnnotatedTerm v a) -> [UnbreakCase]
previousLines :: Show v => Sequence.Seq (Term v a) -> [UnbreakCase]
previousLines tms = tr xs'' where
tr = const id $
trace $ "previousLines: xs = " ++ (show xs) ++ ", xss = "
@ -574,7 +574,7 @@ docNormalize tm = case tm of
map (Maybe.fromJust . Maybe.fromJust . (List.find isJust) . reverse) xss
xs'' = List.Extra.dropEnd 1 xs'
-- For each element, can it be a line-continuation of a preceding blob?
continuesLine :: Sequence.Seq (AnnotatedTerm v a) -> [Bool]
continuesLine :: Sequence.Seq (Term v a) -> [Bool]
continuesLine tms = (flip fmap) (toList tms) $ \case
DD.DocBlob _ -> False -- value doesn't matter - you don't get adjacent blobs
DD.DocLink _ -> True
@ -598,7 +598,7 @@ docNormalize tm = case tm of
Term.app aa (Term.constructor ac DD.docRef DD.docBlobId) (Term.text at txt)
join aa ac as segs =
Term.app aa (Term.constructor ac DD.docRef DD.docJoinId) (Term.seq' as segs)
mapBlob :: Ord v => (Text -> Text) -> AnnotatedTerm v a -> AnnotatedTerm v a
mapBlob :: Ord v => (Text -> Text) -> Term v a -> Term v a
-- this pattern is just `DD.DocBlob txt` but exploded to capture the annotations as well
mapBlob f (aa@(Term.App' ac@(Term.Constructor' DD.DocRef DD.DocBlobId) at@(Term.Text' txt)))
= blob (ABT.annotation aa) (ABT.annotation ac) (ABT.annotation at) (f txt)
@ -616,7 +616,7 @@ bang = P.label "bang" $ do
e <- termLeaf
pure $ DD.forceTerm (ann start <> ann e) (ann start) e
var :: Var v => L.Token v -> AnnotatedTerm v Ann
var :: Var v => L.Token v -> Term v Ann
var t = Term.var (ann t) (L.payload t)
seqOp :: Ord v => P v Pattern.SeqOp
@ -666,7 +666,7 @@ verifyRelativeName' name = do
when (Text.isPrefixOf "." txt && txt /= ".") $
failCommitted (DisallowedAbsoluteName name)
binding :: forall v. Var v => P v ((Ann, v), AnnotatedTerm v Ann)
binding :: forall v. Var v => P v ((Ann, v), Term v Ann)
binding = label "binding" $ do
typ <- optional typedecl
-- a ++ b = ... OR
@ -746,8 +746,8 @@ importp = do
-- op m = case m of Monoid
data BlockElement v
= Binding ((Ann, v), AnnotatedTerm v Ann)
| Action (AnnotatedTerm v Ann)
= Binding ((Ann, v), Term v Ann)
| Action (Term v Ann)
| Namespace String [BlockElement v]
namespaceBlock :: Var v => P v (BlockElement v)
@ -761,7 +761,7 @@ namespaceBlock = do
_ <- closeBlock
pure $ Namespace (Name.toString $ L.payload name) elems
toBindings :: forall v . Var v => [BlockElement v] -> [((Ann,v), AnnotatedTerm v Ann)]
toBindings :: forall v . Var v => [BlockElement v] -> [((Ann,v), Term v Ann)]
toBindings b = let
expand (Binding ((a, v), e)) = [((a, Just v), e)]
expand (Action e) = [((ann e, Nothing), e)]
@ -770,8 +770,8 @@ toBindings b = let
finishBindings bs =
[((a, v `orBlank` i), e) | (((a,v), e), i) <- bs `zip` [(1::Int)..]]
scope :: String -> [((Ann, Maybe v), AnnotatedTerm v Ann)]
-> [((Ann, Maybe v), AnnotatedTerm v Ann)]
scope :: String -> [((Ann, Maybe v), Term v Ann)]
-> [((Ann, Maybe v), Term v Ann)]
scope name bs = let
vs :: [Maybe v]
vs = snd . fst <$> bs
@ -797,7 +797,7 @@ imports = do
-- A key feature of imports is we want to be able to say:
-- `use foo.bar Baz qux` without having to specify whether `Baz` or `qux` are
-- terms or types.
substImports :: Var v => Names -> [(v,v)] -> AnnotatedTerm v Ann -> AnnotatedTerm v Ann
substImports :: Var v => Names -> [(v,v)] -> Term v Ann -> Term v Ann
substImports ns imports =
ABT.substsInheritAnnotation [ (suffix, Term.var () full)
| (suffix,full) <- imports ] . -- no guard here, as `full` could be bound
@ -823,7 +823,7 @@ block' isTop s openBlock closeBlock = do
where
statement = namespaceBlock <|>
asum [ Binding <$> binding, Action <$> blockTerm ]
go :: L.Token () -> [BlockElement v] -> P v (AnnotatedTerm v Ann)
go :: L.Token () -> [BlockElement v] -> P v (Term v Ann)
go open bs
= let
startAnnotation = (fst . fst . head $ toBindings bs)

44
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -47,10 +47,10 @@ import qualified Unison.DataDeclaration as DD
import Unison.DataDeclaration (pattern TuplePattern, pattern TupleTerm')
import qualified Unison.ConstructorType as CT
pretty :: Var v => PrettyPrintEnv -> AnnotatedTerm v a -> Pretty ColorText
pretty :: Var v => PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty env tm = PP.syntaxToColor $ pretty0 env (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate env tm)
pretty' :: Var v => Maybe Int -> PrettyPrintEnv -> AnnotatedTerm v a -> ColorText
pretty' :: Var v => Maybe Int -> PrettyPrintEnv -> Term v a -> ColorText
pretty' (Just width) n t = PP.render width $ PP.syntaxToColor $ pretty0 n (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate n t)
pretty' Nothing n t = PP.renderUnbroken $ PP.syntaxToColor $ pretty0 n (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate n t)
@ -147,7 +147,7 @@ pretty0
:: Var v
=> PrettyPrintEnv
-> AmbientContext
-> AnnotatedTerm3 v PrintAnnotation
-> Term3 v PrintAnnotation
-> Pretty SyntaxText
pretty0
n
@ -299,8 +299,8 @@ pretty0
printLet :: Var v
=> BlockContext
-> [(v, AnnotatedTerm3 v PrintAnnotation)]
-> AnnotatedTerm3 v PrintAnnotation
-> [(v, Term3 v PrintAnnotation)]
-> Term3 v PrintAnnotation
-> Imports
-> ([Pretty SyntaxText] -> Pretty SyntaxText)
-> Pretty SyntaxText
@ -321,13 +321,13 @@ pretty0
-- operators. At the moment the policy is just to render symbolic
-- operators as infix - not 'wordy' function names. So we produce
-- "x + y" and "foo x y" but not "x `foo` y".
binaryOpsPred :: Var v => AnnotatedTerm3 v PrintAnnotation -> Bool
binaryOpsPred :: Var v => Term3 v PrintAnnotation -> Bool
binaryOpsPred = \case
Ref' r | isSymbolic (PrettyPrintEnv.termName n (Referent.Ref r)) -> True
Var' v | isSymbolic (HQ.unsafeFromVar v) -> True
_ -> False
nonForcePred :: AnnotatedTerm3 v PrintAnnotation -> Bool
nonForcePred :: Term3 v PrintAnnotation -> Bool
nonForcePred = \case
Constructor' DD.UnitRef 0 -> False
Constructor' DD.DocRef _ -> False
@ -342,7 +342,7 @@ pretty0
-- produce any backticks. We build the result out from the right,
-- starting at `f2`.
binaryApps
:: Var v => [(AnnotatedTerm3 v PrintAnnotation, AnnotatedTerm3 v PrintAnnotation)]
:: Var v => [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> Pretty SyntaxText
-> Pretty SyntaxText
binaryApps xs last = unbroken `PP.orElse` broken
@ -440,7 +440,7 @@ printCase
=> PrettyPrintEnv
-> Imports
-> DocLiteralContext
-> [MatchCase () (AnnotatedTerm3 v PrintAnnotation)]
-> [MatchCase () (Term3 v PrintAnnotation)]
-> Pretty SyntaxText
printCase env im doc ms = PP.lines $ map each gridArrowsAligned where
each (lhs, arrow, body) = PP.group $ (lhs <> arrow) `PP.hang` body
@ -483,12 +483,12 @@ prettyBinding
:: Var v
=> PrettyPrintEnv
-> HQ.HashQualified
-> AnnotatedTerm2 v at ap v a
-> Term2 v at ap v a
-> Pretty SyntaxText
prettyBinding n = prettyBinding0 n $ ac (-1) Block Map.empty MaybeDoc
prettyBinding' ::
Var v => Int -> PrettyPrintEnv -> HQ.HashQualified -> AnnotatedTerm v a -> ColorText
Var v => Int -> PrettyPrintEnv -> HQ.HashQualified -> Term v a -> ColorText
prettyBinding' width n v t = PP.render width $ PP.syntaxToColor $ prettyBinding n v t
prettyBinding0
@ -496,7 +496,7 @@ prettyBinding0
=> PrettyPrintEnv
-> AmbientContext
-> HQ.HashQualified
-> AnnotatedTerm2 v at ap v a
-> Term2 v at ap v a
-> Pretty SyntaxText
prettyBinding0 env a@AmbientContext { imports = im, docContext = doc } v term = go
(symbolic && isBinary term)
@ -547,7 +547,7 @@ prettyBinding0 env a@AmbientContext { imports = im, docContext = doc } v term =
LamsNamedOrDelay' vs _ -> length vs == 2
_ -> False -- unhittable
isDocLiteral :: AnnotatedTerm3 v PrintAnnotation -> Bool
isDocLiteral :: Term3 v PrintAnnotation -> Bool
isDocLiteral term = case term of
DD.DocJoin segs -> all isDocLiteral segs
DD.DocBlob _ -> True
@ -561,7 +561,7 @@ isDocLiteral term = case term of
_ -> False
-- Similar to DisplayValues.displayDoc, but does not follow and expand references.
prettyDoc :: Var v => PrettyPrintEnv -> Imports -> AnnotatedTerm3 v a -> Pretty SyntaxText
prettyDoc :: Var v => PrettyPrintEnv -> Imports -> Term3 v a -> Pretty SyntaxText
prettyDoc n im term = mconcat [ fmt S.DocDelimiter $ l "[: "
, go term
, spaceUnlessBroken
@ -765,7 +765,7 @@ instance Semigroup PrintAnnotation where
instance Monoid PrintAnnotation where
mempty = PrintAnnotation { usages = Map.empty }
suffixCounterTerm :: Var v => PrettyPrintEnv -> AnnotatedTerm2 v at ap v a -> PrintAnnotation
suffixCounterTerm :: Var v => PrettyPrintEnv -> Term2 v at ap v a -> PrintAnnotation
suffixCounterTerm n = \case
Var' v -> countHQ $ HQ.unsafeFromVar v
Ref' r -> countHQ $ PrettyPrintEnv.termName n (Referent.Ref r)
@ -785,9 +785,9 @@ suffixCounterType n = \case
Type.Ref' r -> countHQ $ PrettyPrintEnv.typeName n r
_ -> mempty
printAnnotate :: (Var v, Ord v) => PrettyPrintEnv -> AnnotatedTerm2 v at ap v a -> AnnotatedTerm3 v PrintAnnotation
printAnnotate :: (Var v, Ord v) => PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate n tm = fmap snd (go (reannotateUp (suffixCounterTerm n) tm)) where
go :: Ord v => AnnotatedTerm2 v at ap v b -> AnnotatedTerm2 v () () v b
go :: Ord v => Term2 v at ap v b -> Term2 v () () v b
go = extraMap' id (const ()) (const ())
countTypeUsages :: (Var v, Ord v) => PrettyPrintEnv -> Type v a -> PrintAnnotation
@ -865,7 +865,7 @@ x |> f = f x
calcImports
:: (Var v, Ord v)
=> Imports
-> AnnotatedTerm3 v PrintAnnotation
-> Term3 v PrintAnnotation
-> (Imports, [Pretty SyntaxText] -> Pretty SyntaxText)
calcImports im tm = (im', render $ getUses result)
where
@ -950,7 +950,7 @@ calcImports im tm = (im', render $ getUses result)
-- looking for child terms that are block terms, and see if any of those contain
-- all the usages of the name.
-- Cut out the occurrences of "const id $" to get tracing.
allInSubBlock :: (Var v, Ord v) => AnnotatedTerm3 v PrintAnnotation -> Prefix -> Suffix -> Int -> Bool
allInSubBlock :: (Var v, Ord v) => Term3 v PrintAnnotation -> Prefix -> Suffix -> Int -> Bool
allInSubBlock tm p s i = let found = concat $ ABT.find finder tm
result = any (/= tm) $ found
tr = const id $ trace ("\nallInSubBlock(" ++ show p ++ ", " ++
@ -983,7 +983,7 @@ allInSubBlock tm p s i = let found = concat $ ABT.find finder tm
-- syntax that get a call to `calcImports` in `pretty0`. AST nodes that do a calcImports in
-- pretty0, in order to try and emit a `use` statement, need to be emitted also by this
-- function, otherwise the `use` statement may come out at an enclosing scope instead.
immediateChildBlockTerms :: (Var vt, Var v) => AnnotatedTerm2 vt at ap v a -> [AnnotatedTerm2 vt at ap v a]
immediateChildBlockTerms :: (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a]
immediateChildBlockTerms = \case
Handle' handler body -> [handler, body]
If' _ t f -> [t, f]
@ -1007,8 +1007,8 @@ pattern LetBlock bindings body <- (unLetBlock -> Just (bindings, body))
-- outer block.
unLetBlock
:: Ord v
=> AnnotatedTerm2 vt at ap v a
-> Maybe ([(v, AnnotatedTerm2 vt at ap v a)], AnnotatedTerm2 vt at ap v a)
=> Term2 vt at ap v a
-> Maybe ([(v, Term2 vt at ap v a)], Term2 vt at ap v a)
unLetBlock t = rec t where
dontIntersect v1s v2s =
all (`Set.notMember` v2set) (fst <$> v1s) where

4
parser-typechecker/src/Unison/Typechecker.hs
View File

@ -29,7 +29,7 @@ import Unison.Referent (Referent)
import Unison.Result (pattern Result, Result,
ResultT, runResultT)
import qualified Unison.Result as Result
import Unison.Term (AnnotatedTerm)
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)
import qualified Unison.Typechecker.Context as Context
@ -41,8 +41,6 @@ import Unison.Util.List ( uniqueBy )
type Name = Text
type Term v loc = AnnotatedTerm v loc
data Notes v loc = Notes {
bugs :: Seq (Context.CompilerBug v loc),
errors :: Seq (Context.ErrorNote v loc),

12
parser-typechecker/src/Unison/Typechecker/Components.hs
View File

@ -12,14 +12,14 @@ import qualified Data.Map as Map
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import Unison.Term (AnnotatedTerm')
import Unison.Term (Term')
import qualified Unison.Term as Term
import Unison.Var (Var)
unordered :: Var v => [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
unordered :: Var v => [(v,Term' vt v a)] -> [[(v,Term' vt v a)]]
unordered = ABT.components
ordered :: Var v => [(v,AnnotatedTerm' vt v a)] -> [[(v,AnnotatedTerm' vt v a)]]
ordered :: Var v => [(v,Term' vt v a)] -> [[(v,Term' vt v a)]]
ordered = ABT.orderedComponents
-- | Algorithm for minimizing cycles of a `let rec`. This can
@ -38,8 +38,8 @@ ordered = ABT.orderedComponents
-- Fails on the left if there are duplicate definitions.
minimize
:: Var v
=> AnnotatedTerm' vt v a
-> Either (NonEmpty (v, [a])) (Maybe (AnnotatedTerm' vt v a))
=> Term' vt v a
-> Either (NonEmpty (v, [a])) (Maybe (Term' vt v a))
minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
let bindings = first snd <$> bs
group = map (fst . head &&& map (ABT.annotation . snd)) . groupBy ((==) `on` fst) . sortBy
@ -84,5 +84,5 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop ann bs e) =
minimize _ = Right Nothing
minimize'
:: Var v => AnnotatedTerm' vt v a -> Either (NonEmpty (v,[a])) (AnnotatedTerm' vt v a)
:: Var v => Term' vt v a -> Either (NonEmpty (v,[a])) (Term' vt v a)
minimize' term = fromMaybe term <$> minimize term

5
parser-typechecker/src/Unison/Typechecker/Context.hs
View File

@ -76,7 +76,6 @@ import Unison.PatternP ( Pattern )
import qualified Unison.PatternP as Pattern
import Unison.Reference ( Reference )
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' )
@ -88,7 +87,7 @@ import qualified Unison.TypePrinter as TP
type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v
type Type v loc = Type.Type (TypeVar v loc) loc
type Term v loc = AnnotatedTerm' (TypeVar v loc) v loc
type Term v loc = Term.Term' (TypeVar v loc) v loc
type Monotype v loc = Type.Monotype (TypeVar v loc) loc
type RedundantTypeAnnotation = Bool
@ -270,7 +269,7 @@ data ErrorNote v loc = ErrorNote {
-- with the fully qualified name fqn.
data InfoNote v loc
= SolvedBlank (B.Recorded loc) v (Type v loc)
| Decision v loc (Term.AnnotatedTerm v loc)
| Decision v loc (Term.Term v loc)
| TopLevelComponent [(v, Type.Type v loc, RedundantTypeAnnotation)]
deriving (Show)

6
parser-typechecker/src/Unison/Typechecker/TypeVar.hs
View File

@ -6,7 +6,7 @@ module Unison.Typechecker.TypeVar where
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import qualified Unison.Term as Term
import Unison.Term (AnnotatedTerm, AnnotatedTerm')
import Unison.Term (Term, Term')
import Unison.Type (Type)
import Unison.Var (Var)
import qualified Unison.Var as Var
@ -47,8 +47,8 @@ liftType = ABT.vmap Universal
lowerType :: Ord v => Type (TypeVar b v) a -> Type v a
lowerType = ABT.vmap underlying
liftTerm :: Ord v => AnnotatedTerm v a -> AnnotatedTerm' (TypeVar b v) v a
liftTerm :: Ord v => Term v a -> Term' (TypeVar b v) v a
liftTerm = Term.vtmap Universal
lowerTerm :: Ord v => AnnotatedTerm' (TypeVar b v) v a -> AnnotatedTerm v a
lowerTerm :: Ord v => Term' (TypeVar b v) v a -> Term v a
lowerTerm = Term.vtmap underlying

32
parser-typechecker/src/Unison/UnisonFile.hs
View File

@ -23,7 +23,7 @@ import qualified Unison.Names3 as Names
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import Unison.Term (AnnotatedTerm)
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)
import qualified Unison.Type as Type
@ -41,18 +41,18 @@ import Unison.LabeledDependency (LabeledDependency)
data UnisonFile v a = UnisonFile {
dataDeclarations :: Map v (Reference, DataDeclaration' v a),
effectDeclarations :: Map v (Reference, EffectDeclaration' v a),
terms :: [(v, AnnotatedTerm v a)],
watches :: Map WatchKind [(v, AnnotatedTerm v a)]
terms :: [(v, Term v a)],
watches :: Map WatchKind [(v, Term v a)]
} deriving Show
watchesOfKind :: WatchKind -> UnisonFile v a -> [(v, AnnotatedTerm v a)]
watchesOfKind :: WatchKind -> UnisonFile v a -> [(v, Term v a)]
watchesOfKind kind uf = Map.findWithDefault [] kind (watches uf)
watchesOfOtherKinds :: WatchKind -> UnisonFile v a -> [(v, AnnotatedTerm v a)]
watchesOfOtherKinds :: WatchKind -> UnisonFile v a -> [(v, Term v a)]
watchesOfOtherKinds kind uf =
join [ ws | (k, ws) <- Map.toList (watches uf), k /= kind ]
allWatches :: UnisonFile v a -> [(v, AnnotatedTerm v a)]
allWatches :: UnisonFile v a -> [(v, Term v a)]
allWatches = join . Map.elems . watches
type WatchKind = Var.WatchKind
@ -61,7 +61,7 @@ pattern TestWatch = Var.TestWatch
-- Converts a file to a single let rec with a body of `()`, for
-- purposes of typechecking.
typecheckingTerm :: (Var v, Monoid a) => UnisonFile v a -> AnnotatedTerm v a
typecheckingTerm :: (Var v, Monoid a) => UnisonFile v a -> Term v a
typecheckingTerm uf =
Term.letRec' True (terms uf <> testWatches <> watchesOfOtherKinds TestWatch uf) $
DD.unitTerm mempty
@ -71,7 +71,7 @@ typecheckingTerm uf =
testWatches = map (second f) $ watchesOfKind TestWatch uf
-- Converts a file and a body to a single let rec with the given body.
uberTerm' :: (Var v, Monoid a) => UnisonFile v a -> AnnotatedTerm v a -> AnnotatedTerm v a
uberTerm' :: (Var v, Monoid a) => UnisonFile v a -> Term v a -> Term v a
uberTerm' uf body =
Term.letRec' True (terms uf <> allWatches uf) $ body
@ -81,16 +81,16 @@ data TypecheckedUnisonFile v a =
TypecheckedUnisonFile {
dataDeclarations' :: Map v (Reference, DataDeclaration' v a),
effectDeclarations' :: Map v (Reference, EffectDeclaration' v a),
topLevelComponents' :: [[(v, AnnotatedTerm v a, Type v a)]],
watchComponents :: [(WatchKind, [(v, AnnotatedTerm v a, Type v a)])],
hashTerms :: Map v (Reference, AnnotatedTerm v a, Type v a)
topLevelComponents' :: [[(v, Term v a, Type v a)]],
watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])],
hashTerms :: Map v (Reference, Term v a, Type v a)
} deriving Show
typecheckedUnisonFile :: Var v
=> Map v (Reference, DataDeclaration' v a)
-> Map v (Reference, EffectDeclaration' v a)
-> [[(v, AnnotatedTerm v a, Type v a)]]
-> [(WatchKind, [(v, AnnotatedTerm v a, Type v a)])]
-> [[(v, Term v a, Type v a)]]
-> [(WatchKind, [(v, Term v a, Type v a)])]
-> TypecheckedUnisonFile v a
typecheckedUnisonFile datas effects tlcs watches =
file0 { hashTerms = hashImpl file0 }
@ -112,12 +112,12 @@ lookupDecl v uf =
over _2 Right <$> (Map.lookup v (dataDeclarations' uf) ) <|>
over _2 Left <$> (Map.lookup v (effectDeclarations' uf))
allTerms :: Ord v => TypecheckedUnisonFile v a -> Map v (AnnotatedTerm v a)
allTerms :: Ord v => TypecheckedUnisonFile v a -> Map v (Term v a)
allTerms uf =
Map.fromList [ (v, t) | (v, t, _) <- join $ topLevelComponents' uf ]
topLevelComponents :: TypecheckedUnisonFile v a
-> [[(v, AnnotatedTerm v a, Type v a)]]
-> [[(v, Term v a, Type v a)]]
topLevelComponents file =
topLevelComponents' file ++ [ comp | (TestWatch, comp) <- watchComponents file ]
@ -148,7 +148,7 @@ termSignatureExternalLabeledDependencies TypecheckedUnisonFile{..} =
dependencies' ::
forall v a. Var v => TypecheckedUnisonFile v a -> Relation Reference Reference
dependencies' file = let
terms :: Map v (Reference, AnnotatedTerm v a, Type v a)
terms :: Map v (Reference, Term v a, Type v a)
terms = hashTerms file
decls :: Map v (Reference, DataDeclaration' v a)
decls = dataDeclarations' file <>

7
parser-typechecker/tests/Unison/Test/Common.hs
View File

@ -16,14 +16,13 @@ import Unison.Parser (Ann(..))
import Unison.PrintError ( prettyParseError )
import Unison.Result (Result, Note)
import Unison.Symbol (Symbol)
import Unison.Term (AnnotatedTerm)
import Unison.Var (Var)
import Unison.UnisonFile (TypecheckedUnisonFile)
import qualified Unison.ABT as ABT
import qualified Unison.Lexer as L
import qualified Unison.Parser as Parser
import qualified Unison.Term as Term
import qualified Unison.TermParser as TermParser
import qualified Unison.Type
import qualified Unison.Type as Type
import qualified Unison.TypeParser as TypeParser
import qualified Unison.Util.Pretty as Pr
@ -31,8 +30,8 @@ import qualified Text.Megaparsec.Error as MPE
import qualified Unison.Names3
type Term v = AnnotatedTerm v Ann
type Type v = Unison.Type.Type v Ann
type Term v = Term.Term v Ann
type Type v = Type.Type v Ann
hqLength :: Int
hqLength = 10

2
parser-typechecker/tests/Unison/Test/Term.hs
View File

@ -20,7 +20,7 @@ test = scope "term" $ tests
let v s = Var.nameds s :: Symbol
tv s = Type.var() (v s)
v1 s = Var.freshenId 1 (v s)
tm :: Term.Term Symbol
tm :: Term.Term Symbol ()
tm = Term.ann() (Term.ann()
(Term.nat() 42)
(Type.introOuter() (v "a") $

9
parser-typechecker/tests/Unison/Test/TermPrinter.hs
View File

@ -6,7 +6,8 @@ import EasyTest
import qualified Data.Text as Text
import Unison.ABT (annotation)
import qualified Unison.HashQualified as HQ
import Unison.Term
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.TermPrinter
import qualified Unison.Type as Type
import Unison.Symbol (Symbol, symbol)
@ -29,7 +30,7 @@ getNames = PPE.fromNames Common.hqLength Unison.Builtin.names
tcDiffRtt :: Bool -> String -> String -> Int -> Test ()
tcDiffRtt rtt s expected width
= let
inputTerm = tm s :: Unison.Term.AnnotatedTerm Symbol Ann
inputTerm = tm s :: Term Symbol Ann
prettied = CT.toPlain <$> pretty getNames inputTerm
actual = if width == 0
then PP.renderUnbroken prettied
@ -75,9 +76,9 @@ tcBinding :: Int -> String -> Maybe String -> String -> String -> Test ()
tcBinding width v mtp tm expected
= let
baseTerm =
Unison.Test.Common.tm tm :: Unison.Term.AnnotatedTerm Symbol Ann
Unison.Test.Common.tm tm :: Term Symbol Ann
inputType = fmap Unison.Test.Common.t mtp :: Maybe (Type.Type Symbol Ann)
inputTerm (Just tp) = ann (annotation tp) baseTerm tp
inputTerm (Just tp) = Term.ann (annotation tp) baseTerm tp
inputTerm Nothing = baseTerm
varV = symbol $ Text.pack v
prettied = fmap CT.toPlain $ PP.syntaxToColor $ prettyBinding

10
parser-typechecker/tests/Unison/Test/UnisonSources.hs
View File

@ -36,7 +36,7 @@ import qualified Unison.Result as Result
import qualified Unison.Runtime.Rt1IO as RT
import Unison.Symbol (Symbol)
import qualified Unison.Term as Term
import Unison.Term ( AnnotatedTerm, Term, amap )
import Unison.Term ( Term )
import Unison.Test.Common (parseAndSynthesizeAsFile, parsingEnv)
import Unison.Type ( Type )
import qualified Unison.UnisonFile as UF
@ -153,8 +153,8 @@ resultTest rt uf filepath = do
let [watchResult] = view _5 <$> Map.elems watches
tm' = Term.letRec' False bindings watchResult
-- note . show $ tm'
-- note . show $ amap (const ()) tm
expect $ tm' == amap (const ()) tm
-- note . show $ Term.amap (const ()) tm
expect $ tm' == Term.amap (const ()) tm
Left e -> crash $ show e
else pure ()
@ -183,9 +183,9 @@ serializationTest uf = scope "serialization" . tests . concat $
bytes = putBytes (V1.putEffectDeclaration V1.putSymbol putUnit) decl'
decl'' = getFromBytes (V1.getEffectDeclaration V1.getSymbol getUnit) bytes
in expectEqual decl'' (Just decl')
testTerm :: (Symbol, (Reference, AnnotatedTerm Symbol Ann, Type Symbol Ann)) -> Test ()
testTerm :: (Symbol, (Reference, Term Symbol Ann, Type Symbol Ann)) -> Test ()
testTerm (name, (_, tm, tp)) = scope (Var.nameStr name) $
let tm' :: Term Symbol
let tm' :: Term Symbol ()
tm' = Term.amap (const ()) tm
tp' :: Type Symbol ()
tp' = ABT.amap (const ()) tp

34
unison-core/src/Unison/DataDeclaration.hs
View File

@ -35,8 +35,8 @@ import qualified Unison.Reference.Util as Reference.Util
import Unison.Referent ( Referent )
import qualified Unison.Referent as Referent
import qualified Unison.Term as Term
import Unison.Term ( AnnotatedTerm
, AnnotatedTerm2
import Unison.Term ( Term
, Term2
)
import Unison.Type ( Type )
import qualified Unison.Type as Type
@ -91,7 +91,7 @@ generateRecordAccessors
=> [(v, a)]
-> v
-> Reference
-> [(v, AnnotatedTerm v a)]
-> [(v, Term v a)]
generateRecordAccessors fields typename typ =
join [ tm t i | (t, i) <- fields `zip` [(0::Int)..] ]
where
@ -145,10 +145,10 @@ generateRecordAccessors fields typename typ =
-- along with the terms for those references and their types.
constructorTerms
:: (Reference -> ConstructorId -> Reference)
-> (a -> Reference -> ConstructorId -> AnnotatedTerm v a)
-> (a -> Reference -> ConstructorId -> Term v a)
-> Reference.Id
-> DataDeclaration' v a
-> [(Reference.Id, AnnotatedTerm v a, Type v a)]
-> [(Reference.Id, Term v a, Type v a)]
constructorTerms hashCtor f rid dd =
(\((a, _, t), (i, re@(Reference.DerivedId r))) -> (r, f a re i, t)) <$> zip
(constructors' dd)
@ -158,14 +158,14 @@ dataConstructorTerms
:: Ord v
=> Reference.Id
-> DataDeclaration' v a
-> [(Reference.Id, AnnotatedTerm v a, Type v a)]
-> [(Reference.Id, Term v a, Type v a)]
dataConstructorTerms = constructorTerms Term.hashConstructor Term.constructor
effectConstructorTerms
:: Ord v
=> Reference.Id
-> EffectDeclaration' v a
-> [(Reference.Id, AnnotatedTerm v a, Type v a)]
-> [(Reference.Id, Term v a, Type v a)]
effectConstructorTerms rid ed =
constructorTerms Term.hashRequest Term.request rid $ toDataDecl ed
@ -443,7 +443,7 @@ okConstructorReferent, failConstructorReferent :: Referent.Referent
okConstructorReferent = Referent.Con testResultRef okConstructorId CT.Data
failConstructorReferent = Referent.Con testResultRef failConstructorId CT.Data
failResult :: (Ord v, Monoid a) => a -> Text -> AnnotatedTerm v a
failResult :: (Ord v, Monoid a) => a -> Text -> Term v a
failResult ann msg =
Term.app ann (Term.request ann testResultRef failConstructorId)
(Term.text ann msg)
@ -557,30 +557,30 @@ pairType a = Type.ref a pairRef
testResultType a = Type.app a (Type.vector a) (Type.ref a testResultRef)
optionalType a = Type.ref a optionalRef
unitTerm :: Var v => a -> AnnotatedTerm v a
unitTerm :: Var v => a -> Term v a
unitTerm ann = Term.constructor ann unitRef 0
tupleConsTerm :: (Ord v, Semigroup a)
=> AnnotatedTerm2 vt at ap v a
-> AnnotatedTerm2 vt at ap v a
-> AnnotatedTerm2 vt at ap v a
=> Term2 vt at ap v a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
tupleConsTerm hd tl =
Term.apps' (Term.constructor (ABT.annotation hd) pairRef 0) [hd, tl]
tupleTerm :: (Var v, Monoid a) => [AnnotatedTerm v a] -> AnnotatedTerm v a
tupleTerm :: (Var v, Monoid a) => [Term v a] -> Term v a
tupleTerm = foldr tupleConsTerm (unitTerm mempty)
-- delayed terms are just lambdas that take a single `()` arg
-- `force` calls the function
forceTerm :: Var v => a -> a -> AnnotatedTerm v a -> AnnotatedTerm v a
forceTerm :: Var v => a -> a -> Term v a -> Term v a
forceTerm a au e = Term.app a e (unitTerm au)
delayTerm :: Var v => a -> AnnotatedTerm v a -> AnnotatedTerm v a
delayTerm :: Var v => a -> Term v a -> Term v a
delayTerm a = Term.lam a $ Var.named "()"
unTupleTerm
:: Term.AnnotatedTerm2 vt at ap v a
-> Maybe [Term.AnnotatedTerm2 vt at ap v a]
:: Term.Term2 vt at ap v a
-> Maybe [Term.Term2 vt at ap v a]
unTupleTerm t = case t of
Term.Apps' (Term.Constructor' PairRef 0) [fst, snd] ->
(fst :) <$> unTupleTerm snd

2
unison-core/src/Unison/Paths.hs
View File

@ -7,7 +7,6 @@ import Unison.Prelude
import Data.List
import Unison.ABT (V)
import Unison.Term (Term)
import Unison.Var (Var)
import qualified Data.Sequence as Sequence
import qualified Unison.ABT as ABT
@ -15,6 +14,7 @@ import qualified Unison.Term as E
import qualified Unison.Type as T
type Type v = T.Type v ()
type Term v = E.Term v ()
data Target v
= Term (Term v)

298
unison-core/src/Unison/Term.hs
View File

@ -103,39 +103,39 @@ data F typeVar typeAnn patternAnn a
type IsTop = Bool
-- | Like `Term v`, but with an annotation of type `a` at every level in the tree
type AnnotatedTerm v a = AnnotatedTerm2 v a a v a
type Term v a = Term2 v a a v a
-- | Allow type variables and term variables to differ
type AnnotatedTerm' vt v a = AnnotatedTerm2 vt a a v a
type Term' vt v a = Term2 vt a a v a
-- | Allow type variables, term variables, type annotations and term annotations
-- to all differ
type AnnotatedTerm2 vt at ap v a = ABT.Term (F vt at ap) v a
-- | Like `AnnotatedTerm v a`, but with only () for type and pattern annotations.
type AnnotatedTerm3 v a = AnnotatedTerm2 v () () v a
type Term2 vt at ap v a = ABT.Term (F vt at ap) v a
-- | Like `Term v a`, but with only () for type and pattern annotations.
type Term3 v a = Term2 v () () v a
-- | Terms are represented as ABTs over the base functor F, with variables in `v`
type Term v = AnnotatedTerm v ()
type Term0 v = Term v ()
-- | Terms with type variables in `vt`, and term variables in `v`
type Term' vt v = AnnotatedTerm' vt v ()
type Term0' vt v = Term' vt v ()
-- bindExternals
-- :: forall v a b b2
-- . Var v
-- => [(v, AnnotatedTerm2 v b a v b2)]
-- => [(v, Term2 v b a v b2)]
-- -> [(v, Reference)]
-- -> AnnotatedTerm2 v b a v a
-- -> AnnotatedTerm2 v b a v a
-- -> Term2 v b a v a
-- -> Term2 v b a v a
-- bindBuiltins termBuiltins typeBuiltins = f . g
-- where
-- f :: AnnotatedTerm2 v b a v a -> AnnotatedTerm2 v b a v a
-- f :: Term2 v b a v a -> Term2 v b a v a
-- f = typeMap (Type.bindBuiltins typeBuiltins)
-- g :: AnnotatedTerm2 v b a v a -> AnnotatedTerm2 v b a v a
-- g :: Term2 v b a v a -> Term2 v b a v a
-- g = ABT.substsInheritAnnotation termBuiltins
bindNames
:: forall v a . Var v
=> Set v
-> Names0
-> AnnotatedTerm v a
-> Names.ResolutionResult v a (AnnotatedTerm v a)
-> Term v a
-> Names.ResolutionResult v a (Term v a)
-- bindNames keepFreeTerms _ _ | trace "Keep free terms:" False
-- || traceShow keepFreeTerms False = undefined
bindNames keepFreeTerms ns e = do
@ -146,7 +146,7 @@ bindNames keepFreeTerms ns e = do
, a <- as ]
-- !_ = trace "free type vars: " ()
-- !_ = traceShow $ fst <$> freeTyVars
okTm :: (v,a) -> Names.ResolutionResult v a (v, AnnotatedTerm v a)
okTm :: (v,a) -> Names.ResolutionResult v a (v, Term v a)
okTm (v,a) = case Rel.lookupDom (Name.fromVar v) (Names.terms0 ns) of
rs | Set.size rs == 1 ->
pure (v, fromReferent a $ Set.findMin rs)
@ -161,8 +161,8 @@ bindNames keepFreeTerms ns e = do
bindSomeNames
:: forall v a . Var v
=> Names0
-> AnnotatedTerm v a
-> Names.ResolutionResult v a (AnnotatedTerm v a)
-> Term v a
-> Names.ResolutionResult v a (Term v a)
-- bindSomeNames ns e | trace "Term.bindSome" False
-- || trace "Names =" False
-- || traceShow ns False
@ -182,10 +182,10 @@ prepareTDNR t = fmap fst . ABT.visitPure f $ ABT.annotateBound t
Just $ resolve (a, bound) a (Text.unpack $ Var.name v)
f _ = Nothing
amap :: Ord v => (a -> a2) -> AnnotatedTerm v a -> AnnotatedTerm v a2
amap :: Ord v => (a -> a2) -> Term v a -> Term v a2
amap f = fmap f . patternMap (fmap f) . typeMap (fmap f)
patternMap :: (Pattern ap -> Pattern ap2) -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap2 v a
patternMap :: (Pattern ap -> Pattern ap2) -> Term2 vt at ap v a -> Term2 vt at ap2 v a
patternMap f = go where
go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of
ABT.Abs v t -> ABT.Abs v (go t)
@ -196,17 +196,17 @@ patternMap f = go where
-- Safe since `Match` is only ctor that has embedded `Pattern ap` arg
ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts)
vmap :: Ord v2 => (v -> v2) -> AnnotatedTerm v a -> AnnotatedTerm v2 a
vmap :: Ord v2 => (v -> v2) -> Term v a -> Term v2 a
vmap f = ABT.vmap f . typeMap (ABT.vmap f)
vtmap :: Ord vt2 => (vt -> vt2) -> AnnotatedTerm' vt v a -> AnnotatedTerm' vt2 v a
vtmap :: Ord vt2 => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a
vtmap f = typeMap (ABT.vmap f)
typeMap
:: Ord vt2
=> (Type vt at -> Type vt2 at2)
-> AnnotatedTerm2 vt at ap v a
-> AnnotatedTerm2 vt2 at2 ap v a
-> Term2 vt at ap v a
-> Term2 vt2 at2 ap v a
typeMap f = go
where
go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of
@ -223,8 +223,8 @@ extraMap'
=> (vt -> vt')
-> (at -> at')
-> (ap -> ap')
-> AnnotatedTerm2 vt at ap v a
-> AnnotatedTerm2 vt' at' ap' v a
-> Term2 vt at ap v a
-> Term2 vt' at' ap' v a
extraMap' vtf atf apf = ABT.extraMap (extraMap vtf atf apf)
extraMap
@ -263,10 +263,10 @@ matchCaseExtraMap :: (loc -> loc') -> MatchCase loc a -> MatchCase loc' a
matchCaseExtraMap f (MatchCase p x y) = MatchCase (fmap f p) x y
unannotate
:: forall vt at ap v a . Ord v => AnnotatedTerm2 vt at ap v a -> Term' vt v
:: forall vt at ap v a . Ord v => Term2 vt at ap v a -> Term0' vt v
unannotate = go
where
go :: AnnotatedTerm2 vt at ap v a -> Term' vt v
go :: Term2 vt at ap v a -> Term0' vt v
go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body)
go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body)
go (ABT.Var' v ) = ABT.var v
@ -278,12 +278,12 @@ unannotate = go
f' -> ABT.tm (unsafeCoerce f')
go _ = error "unpossible"
wrapV :: Ord v => AnnotatedTerm v a -> AnnotatedTerm (ABT.V v) a
wrapV :: Ord v => Term v a -> Term (ABT.V v) a
wrapV = vmap ABT.Bound
-- | All variables mentioned in the given term.
-- Includes both term and type variables, both free and bound.
allVars :: Ord v => AnnotatedTerm v a -> Set v
allVars :: Ord v => Term v a -> Set v
allVars tm = Set.fromList $
ABT.allVars tm ++ [ v | tp <- allTypes tm, v <- ABT.allVars tp ]
where
@ -291,13 +291,13 @@ allVars tm = Set.fromList $
Ann' e tp -> tp : allTypes e
_ -> foldMap allTypes $ ABT.out tm
freeVars :: AnnotatedTerm' vt v a -> Set v
freeVars :: Term' vt v a -> Set v
freeVars = ABT.freeVars
freeTypeVars :: Ord vt => AnnotatedTerm' vt v a -> Set vt
freeTypeVars :: Ord vt => Term' vt v a -> Set vt
freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t
freeTypeVarAnnotations :: Ord vt => AnnotatedTerm' vt v a -> Map vt [a]
freeTypeVarAnnotations :: Ord vt => Term' vt v a -> Map vt [a]
freeTypeVarAnnotations e = multimap $ go Set.empty e where
go bound tm = case tm of
Var' _ -> mempty
@ -312,8 +312,8 @@ freeTypeVarAnnotations e = multimap $ go Set.empty e where
substTypeVars :: (Ord v, Var vt)
=> [(vt, Type vt b)]
-> AnnotatedTerm' vt v a
-> AnnotatedTerm' vt v a
-> Term' vt v a
-> Term' vt v a
substTypeVars subs e = foldl' go e subs where
go e (vt, t) = substTypeVar vt t e
@ -324,8 +324,8 @@ substTypeVar
:: (Ord v, ABT.Var vt)
=> vt
-> Type vt b
-> AnnotatedTerm' vt v a
-> AnnotatedTerm' vt v a
-> Term' vt v a
-> Term' vt v a
substTypeVar vt ty = go Set.empty where
go bound tm | Set.member vt bound = tm
go bound tm = let loc = ABT.annotation tm in case tm of
@ -351,7 +351,7 @@ substTypeVar vt ty = go Set.empty where
(ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body)
_ -> error "unpossible"
renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> AnnotatedTerm' vt v a -> AnnotatedTerm' vt v a
renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> Term' vt v a -> Term' vt v a
renameTypeVar old new = go Set.empty where
go bound tm | Set.member old bound = tm
go bound tm = let loc = ABT.annotation tm in case tm of
@ -389,7 +389,7 @@ renameTypeVar old new = go Set.empty where
-- variables in any of its type signatures, with outer references represented
-- with explicit `introOuter` binders. The resulting term may have uppercase
-- free variables that are still unbound.
generalizeTypeSignatures :: (Var vt, Var v) => AnnotatedTerm' vt v a -> AnnotatedTerm' vt v a
generalizeTypeSignatures :: (Var vt, Var v) => Term' vt v a -> Term' vt v a
generalizeTypeSignatures = go Set.empty where
go bound tm = let loc = ABT.annotation tm in case tm of
Var' _ -> tm
@ -456,144 +456,144 @@ pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, an
pattern LetRecNamedAnnotatedTop' top ann bs e <-
(unLetRecNamedAnnotated -> Just (top, ann, bs,e))
fresh :: Var v => Term v -> v -> v
fresh :: Var v => Term0 v -> v -> v
fresh = ABT.fresh
-- some smart constructors
var :: a -> v -> AnnotatedTerm2 vt at ap v a
var :: a -> v -> Term2 vt at ap v a
var = ABT.annotatedVar
var' :: Var v => Text -> Term' vt v
var' :: Var v => Text -> Term0' vt v
var' = var() . Var.named
ref :: Ord v => a -> Reference -> AnnotatedTerm2 vt at ap v a
ref :: Ord v => a -> Reference -> Term2 vt at ap v a
ref a r = ABT.tm' a (Ref r)
termLink :: Ord v => a -> Referent -> AnnotatedTerm2 vt at ap v a
termLink :: Ord v => a -> Referent -> Term2 vt at ap v a
termLink a r = ABT.tm' a (TermLink r)
typeLink :: Ord v => a -> Reference -> AnnotatedTerm2 vt at ap v a
typeLink :: Ord v => a -> Reference -> Term2 vt at ap v a
typeLink a r = ABT.tm' a (TypeLink r)
builtin :: Ord v => a -> Text -> AnnotatedTerm2 vt at ap v a
builtin :: Ord v => a -> Text -> Term2 vt at ap v a
builtin a n = ref a (Reference.Builtin n)
float :: Ord v => a -> Double -> AnnotatedTerm2 vt at ap v a
float :: Ord v => a -> Double -> Term2 vt at ap v a
float a d = ABT.tm' a (Float d)
boolean :: Ord v => a -> Bool -> AnnotatedTerm2 vt at ap v a
boolean :: Ord v => a -> Bool -> Term2 vt at ap v a
boolean a b = ABT.tm' a (Boolean b)
int :: Ord v => a -> Int64 -> AnnotatedTerm2 vt at ap v a
int :: Ord v => a -> Int64 -> Term2 vt at ap v a
int a d = ABT.tm' a (Int d)
nat :: Ord v => a -> Word64 -> AnnotatedTerm2 vt at ap v a
nat :: Ord v => a -> Word64 -> Term2 vt at ap v a
nat a d = ABT.tm' a (Nat d)
text :: Ord v => a -> Text -> AnnotatedTerm2 vt at ap v a
text :: Ord v => a -> Text -> Term2 vt at ap v a
text a = ABT.tm' a . Text
char :: Ord v => a -> Char -> AnnotatedTerm2 vt at ap v a
char :: Ord v => a -> Char -> Term2 vt at ap v a
char a = ABT.tm' a . Char
watch :: (Var v, Semigroup a) => a -> String -> AnnotatedTerm v a -> AnnotatedTerm v a
watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a
watch a note e =
apps' (builtin a "Debug.watch") [text a (Text.pack note), e]
watchMaybe :: (Var v, Semigroup a) => Maybe String -> AnnotatedTerm v a -> AnnotatedTerm v a
watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a
watchMaybe Nothing e = e
watchMaybe (Just note) e = watch (ABT.annotation e) note e
blank :: Ord v => a -> AnnotatedTerm2 vt at ap v a
blank :: Ord v => a -> Term2 vt at ap v a
blank a = ABT.tm' a (Blank B.Blank)
placeholder :: Ord v => a -> String -> AnnotatedTerm2 vt a ap v a
placeholder :: Ord v => a -> String -> Term2 vt a ap v a
placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s)
resolve :: Ord v => at -> ab -> String -> AnnotatedTerm2 vt ab ap v at
resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at
resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s)
constructor :: Ord v => a -> Reference -> Int -> AnnotatedTerm2 vt at ap v a
constructor :: Ord v => a -> Reference -> Int -> Term2 vt at ap v a
constructor a ref n = ABT.tm' a (Constructor ref n)
request :: Ord v => a -> Reference -> Int -> AnnotatedTerm2 vt at ap v a
request :: Ord v => a -> Reference -> Int -> Term2 vt at ap v a
request a ref n = ABT.tm' a (Request ref n)
-- todo: delete and rename app' to app
app_ :: Ord v => Term' vt v -> Term' vt v -> Term' vt v
app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v
app_ f arg = ABT.tm (App f arg)
app :: Ord v => a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
app :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
app a f arg = ABT.tm' a (App f arg)
match :: Ord v => a -> AnnotatedTerm2 vt at a v a -> [MatchCase a (AnnotatedTerm2 vt at a v a)] -> AnnotatedTerm2 vt at a v a
match :: Ord v => a -> Term2 vt at a v a -> [MatchCase a (Term2 vt at a v a)] -> Term2 vt at a v a
match a scrutinee branches = ABT.tm' a (Match scrutinee branches)
handle :: Ord v => a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
handle :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
handle a h block = ABT.tm' a (Handle h block)
and :: Ord v => a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
and :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
and a x y = ABT.tm' a (And x y)
or :: Ord v => a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
or a x y = ABT.tm' a (Or x y)
seq :: Ord v => a -> [AnnotatedTerm2 vt at ap v a] -> AnnotatedTerm2 vt at ap v a
seq :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
seq a es = seq' a (Sequence.fromList es)
seq' :: Ord v => a -> Seq (AnnotatedTerm2 vt at ap v a) -> AnnotatedTerm2 vt at ap v a
seq' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
seq' a es = ABT.tm' a (Sequence es)
apps
:: Ord v
=> AnnotatedTerm2 vt at ap v a
-> [(a, AnnotatedTerm2 vt at ap v a)]
-> AnnotatedTerm2 vt at ap v a
=> Term2 vt at ap v a
-> [(a, Term2 vt at ap v a)]
-> Term2 vt at ap v a
apps = foldl' (\f (a, t) -> app a f t)
apps'
:: (Ord v, Semigroup a)
=> AnnotatedTerm2 vt at ap v a
-> [AnnotatedTerm2 vt at ap v a]
-> AnnotatedTerm2 vt at ap v a
=> Term2 vt at ap v a
-> [Term2 vt at ap v a]
-> Term2 vt at ap v a
apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t)
iff :: Ord v => a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
iff :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
iff a cond t f = ABT.tm' a (If cond t f)
ann_ :: Ord v => Term' vt v -> Type vt () -> Term' vt v
ann_ :: Ord v => Term0' vt v -> Type vt () -> Term0' vt v
ann_ e t = ABT.tm (Ann e t)
ann :: Ord v
=> a
-> AnnotatedTerm2 vt at ap v a
-> Term2 vt at ap v a
-> Type vt at
-> AnnotatedTerm2 vt at ap v a
-> Term2 vt at ap v a
ann a e t = ABT.tm' a (Ann e t)
-- arya: are we sure we want the two annotations to be the same?
lam :: Ord v => a -> v -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
lam :: Ord v => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a
lam a v body = ABT.tm' a (Lam (ABT.abs' a v body))
lam' :: Ord v => a -> [v] -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
lam' :: Ord v => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lam' a vs body = foldr (lam a) body vs
lam'' :: Ord v => [(a,v)] -> AnnotatedTerm2 vt at ap v a -> AnnotatedTerm2 vt at ap v a
lam'' :: Ord v => [(a,v)] -> Term2 vt at ap v a -> Term2 vt at ap v a
lam'' vs body = foldr (uncurry lam) body vs
isLam :: AnnotatedTerm2 vt at ap v a -> Bool
isLam :: Term2 vt at ap v a -> Bool
isLam t = arity t > 0
arity :: AnnotatedTerm2 vt at ap v a -> Int
arity :: Term2 vt at ap v a -> Int
arity (LamNamed' _ body) = 1 + arity body
arity (Ann' e _) = arity e
arity _ = 0
unLetRecNamedAnnotated
:: AnnotatedTerm' vt v a
:: Term' vt v a
-> Maybe
(IsTop, a, [((a, v), AnnotatedTerm' vt v a)], AnnotatedTerm' vt v a)
(IsTop, a, [((a, v), Term' vt v a)], Term' vt v a)
unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) =
Just (isTop, ann, avs `zip` bs, e)
unLetRecNamedAnnotated _ = Nothing
@ -601,9 +601,9 @@ unLetRecNamedAnnotated _ = Nothing
letRec'
:: (Ord v, Monoid a)
=> Bool
-> [(v, AnnotatedTerm' vt v a)]
-> AnnotatedTerm' vt v a
-> AnnotatedTerm' vt v a
-> [(v, Term' vt v a)]
-> Term' vt v a
-> Term' vt v a
letRec' isTop bindings body =
letRec isTop
(foldMap (ABT.annotation . snd) bindings <> ABT.annotation body)
@ -614,9 +614,9 @@ letRec
:: Ord v
=> Bool
-> a
-> [((a, v), AnnotatedTerm' vt v a)]
-> AnnotatedTerm' vt v a
-> AnnotatedTerm' vt v a
-> [((a, v), Term' vt v a)]
-> Term' vt v a
-> Term' vt v a
letRec _ _ [] e = e
letRec isTop a bindings e = ABT.cycle'
a
@ -627,7 +627,7 @@ letRec isTop a bindings e = ABT.cycle'
-- | Smart constructor for let rec blocks. Each binding in the block may
-- reference any other binding in the block in its body (including itself),
-- and the output expression may also reference any binding in the block.
letRec_ :: Ord v => IsTop -> [(v, Term' vt v)] -> Term' vt v -> Term' vt v
letRec_ :: Ord v => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v
letRec_ _ [] e = e
letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings)
where
@ -637,7 +637,7 @@ letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings)
-- reference only previous bindings in the block, not including itself.
-- The output expression may reference any binding in the block.
-- todo: delete me
let1_ :: Ord v => IsTop -> [(v,Term' vt v)] -> Term' vt v -> Term' vt v
let1_ :: Ord v => IsTop -> [(v,Term0' vt v)] -> Term0' vt v -> Term0' vt v
let1_ isTop bindings e = foldr f e bindings
where
f (v,b) body = ABT.tm (Let isTop b (ABT.abs v body))
@ -646,38 +646,38 @@ let1_ isTop bindings e = foldr f e bindings
let1
:: Ord v
=> IsTop
-> [((a, v), AnnotatedTerm2 vt at ap v a)]
-> AnnotatedTerm2 vt at ap v a
-> AnnotatedTerm2 vt at ap v a
-> [((a, v), Term2 vt at ap v a)]
-> Term2 vt at ap v a
-> Term2 vt at ap v a
let1 isTop bindings e = foldr f e bindings
where f ((ann, v), b) body = ABT.tm' ann (Let isTop b (ABT.abs' ann v body))
let1'
:: (Semigroup a, Ord v)
=> IsTop
-> [(v, AnnotatedTerm2 vt at ap v a)]
-> AnnotatedTerm2 vt at ap v a
-> AnnotatedTerm2 vt at ap v a
-> [(v, Term2 vt at ap v a)]
-> Term2 vt at ap v a
-> Term2 vt at ap v a
let1' isTop bindings e = foldr f e bindings
where
ann = ABT.annotation
f (v, b) body = ABT.tm' a (Let isTop b (ABT.abs' a v body))
where a = ann b <> ann body
-- let1' :: Var v => [(Text, Term' vt v)] -> Term' vt v -> Term' vt v
-- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v
-- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e
unLet1
:: Var v
=> AnnotatedTerm' vt v a
-> Maybe (IsTop, AnnotatedTerm' vt v a, ABT.Subst (F vt a a) v a)
=> Term' vt v a
-> Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a)
unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst)
unLet1 _ = Nothing
-- | Satisfies `unLet (let' bs e) == Just (bs, e)`
unLet
:: AnnotatedTerm2 vt at ap v a
-> Maybe ([(IsTop, v, AnnotatedTerm2 vt at ap v a)], AnnotatedTerm2 vt at ap v a)
:: Term2 vt at ap v a
-> Maybe ([(IsTop, v, Term2 vt at ap v a)], Term2 vt at ap v a)
unLet t = fixup (go t)
where
go (ABT.Tm' (Let isTop b (ABT.out -> ABT.Abs v t))) = case go t of
@ -688,11 +688,11 @@ unLet t = fixup (go t)
-- | Satisfies `unLetRec (letRec bs e) == Just (bs, e)`
unLetRecNamed
:: AnnotatedTerm2 vt at ap v a
:: Term2 vt at ap v a
-> Maybe
( IsTop
, [(v, AnnotatedTerm2 vt at ap v a)]
, AnnotatedTerm2 vt at ap v a
, [(v, Term2 vt at ap v a)]
, Term2 vt at ap v a
)
unLetRecNamed (ABT.Cycle' vs (ABT.Tm' (LetRec isTop bs e)))
| length vs == length bs = Just (isTop, zip vs bs, e)
@ -700,13 +700,13 @@ unLetRecNamed _ = Nothing
unLetRec
:: (Monad m, Var v)
=> AnnotatedTerm2 vt at ap v a
=> Term2 vt at ap v a
-> Maybe
( IsTop
, (v -> m v)
-> m
( [(v, AnnotatedTerm2 vt at ap v a)]
, AnnotatedTerm2 vt at ap v a
( [(v, Term2 vt at ap v a)]
, Term2 vt at ap v a
)
)
unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just
@ -719,42 +719,42 @@ unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just
unLetRec _ = Nothing
unApps
:: AnnotatedTerm2 vt at ap v a
-> Maybe (AnnotatedTerm2 vt at ap v a, [AnnotatedTerm2 vt at ap v a])
:: Term2 vt at ap v a
-> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a])
unApps t = unAppsPred (t, const True)
-- Same as unApps but taking a predicate controlling whether we match on a given function argument.
unAppsPred :: (AnnotatedTerm2 vt at ap v a, AnnotatedTerm2 vt at ap v a -> Bool) ->
Maybe (AnnotatedTerm2 vt at ap v a, [AnnotatedTerm2 vt at ap v a])
unAppsPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) ->
Maybe (Term2 vt at ap v a, [Term2 vt at ap v a])
unAppsPred (t, pred) = case go t [] of [] -> Nothing; f:args -> Just (f,args)
where
go (App' i o) acc | pred o = go i (o:acc)
go _ [] = []
go fn args = fn:args
unBinaryApp :: AnnotatedTerm2 vt at ap v a
-> Maybe (AnnotatedTerm2 vt at ap v a,
AnnotatedTerm2 vt at ap v a,
AnnotatedTerm2 vt at ap v a)
unBinaryApp :: Term2 vt at ap v a
-> Maybe (Term2 vt at ap v a,
Term2 vt at ap v a,
Term2 vt at ap v a)
unBinaryApp t = case unApps t of
Just (f, [arg1, arg2]) -> Just (f, arg1, arg2)
_ -> Nothing
-- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)"
unBinaryApps
:: AnnotatedTerm2 vt at ap v a
:: Term2 vt at ap v a
-> Maybe
( [(AnnotatedTerm2 vt at ap v a, AnnotatedTerm2 vt at ap v a)]
, AnnotatedTerm2 vt at ap v a
( [(Term2 vt at ap v a, Term2 vt at ap v a)]
, Term2 vt at ap v a
)
unBinaryApps t = unBinaryAppsPred (t, const True)
-- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function.
unBinaryAppsPred :: (AnnotatedTerm2 vt at ap v a
,AnnotatedTerm2 vt at ap v a -> Bool)
-> Maybe ([(AnnotatedTerm2 vt at ap v a,
AnnotatedTerm2 vt at ap v a)],
AnnotatedTerm2 vt at ap v a)
unBinaryAppsPred :: (Term2 vt at ap v a
,Term2 vt at ap v a -> Bool)
-> Maybe ([(Term2 vt at ap v a,
Term2 vt at ap v a)],
Term2 vt at ap v a)
unBinaryAppsPred (t, pred) = case unBinaryApp t of
Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of
Just (as, xLast) -> Just ((xLast, f) : as, y)
@ -762,12 +762,12 @@ unBinaryAppsPred (t, pred) = case unBinaryApp t of
_ -> Nothing
unLams'
:: AnnotatedTerm2 vt at ap v a -> Maybe ([v], AnnotatedTerm2 vt at ap v a)
:: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a)
unLams' t = unLamsPred' (t, const True)
-- Same as unLams', but always matches. Returns an empty [v] if the term doesn't start with a
-- lambda extraction.
unLamsOpt' :: AnnotatedTerm2 vt at ap v a -> Maybe ([v], AnnotatedTerm2 vt at ap v a)
unLamsOpt' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a)
unLamsOpt' t = case unLams' t of
r@(Just _) -> r
Nothing -> Just ([], t)
@ -776,8 +776,8 @@ unLamsOpt' t = case unLams' t of
-- delay (`'`) annotation which we want to preserve.
unLamsUntilDelay'
:: Var v
=> AnnotatedTerm2 vt at ap v a
-> Maybe ([v], AnnotatedTerm2 vt at ap v a)
=> Term2 vt at ap v a
-> Maybe ([v], Term2 vt at ap v a)
unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of
r@(Just _) -> r
Nothing -> Just ([], t)
@ -786,8 +786,8 @@ unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of
-- expression, where the scrutinee is also the last argument of the lambda
unLamsMatch'
:: Var v
=> AnnotatedTerm2 vt at ap v a
-> Maybe ([v], [MatchCase ap (AnnotatedTerm2 vt at ap v a)])
=> Term2 vt at ap v a
-> Maybe ([v], [MatchCase ap (Term2 vt at ap v a)])
unLamsMatch' t = case unLamsUntilDelay' t of
Just (reverse -> (v1:vs), Match' (Var' v1') branches) |
(v1 == v1') && not (Set.member v1' (Set.unions $ freeVars <$> branches)) ->
@ -800,30 +800,30 @@ unLamsMatch' t = case unLamsUntilDelay' t of
in Set.union guardVars rhsVars
-- Same as unLams' but taking a predicate controlling whether we match on a given binary function.
unLamsPred' :: (AnnotatedTerm2 vt at ap v a, v -> Bool) ->
Maybe ([v], AnnotatedTerm2 vt at ap v a)
unLamsPred' :: (Term2 vt at ap v a, v -> Bool) ->
Maybe ([v], Term2 vt at ap v a)
unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of
Nothing -> Just ([v], body)
Just (vs, body) -> Just (v:vs, body)
unLamsPred' _ = Nothing
unReqOrCtor :: AnnotatedTerm2 vt at ap v a -> Maybe (Reference, Int)
unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, Int)
unReqOrCtor (Constructor' r cid) = Just (r, cid)
unReqOrCtor (Request' r cid) = Just (r, cid)
unReqOrCtor _ = Nothing
-- Dependencies including referenced data and effect decls
dependencies :: (Ord v, Ord vt) => AnnotatedTerm2 vt at ap v a -> Set Reference
dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t)
typeDependencies :: (Ord v, Ord vt) => AnnotatedTerm2 vt at ap v a -> Set Reference
typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
typeDependencies =
Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies
-- Gets the types to which this term contains references via patterns and
-- data constructors.
constructorDependencies
:: (Ord v, Ord vt) => AnnotatedTerm2 vt at ap v a -> Set Reference
:: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
constructorDependencies =
Set.unions
. generalizedDependencies (const mempty)
@ -843,7 +843,7 @@ generalizedDependencies
-> (Reference -> r)
-> (Reference -> ConstructorId -> r)
-> (Reference -> r)
-> AnnotatedTerm2 vt at ap v a
-> Term2 vt at ap v a
-> Set r
generalizedDependencies termRef typeRef literalType dataConstructor dataType effectConstructor effectType
= Set.fromList . Writer.execWriter . ABT.visit' f where
@ -873,7 +873,7 @@ generalizedDependencies termRef typeRef literalType dataConstructor dataType eff
pat
labeledDependencies :: (Ord v, Ord vt)
=> AnnotatedTerm2 vt at ap v a
=> Term2 vt at ap v a
-> Set LabeledDependency
labeledDependencies = generalizedDependencies LD.termRef LD.typeRef LD.typeRef LD.dataConstructor LD.typeRef LD.effectConstructor LD.typeRef
@ -881,8 +881,8 @@ updateDependencies
:: Ord v
=> Map Reference Reference
-> Map Reference Reference
-> AnnotatedTerm v a
-> AnnotatedTerm v a
-> Term v a
-> Term v a
updateDependencies termUpdates typeUpdates = ABT.rebuildUp go
where
-- todo: this function might need tweaking if we ever allow type replacements
@ -895,27 +895,27 @@ updateDependencies termUpdates typeUpdates = ABT.rebuildUp go
-- | If the outermost term is a function application,
-- perform substitution of the argument into the body
betaReduce :: Var v => Term v -> Term v
betaReduce :: Var v => Term0 v -> Term0 v
betaReduce (App' (Lam' f) arg) = ABT.bind f arg
betaReduce e = e
betaNormalForm :: Var v => Term v -> Term v
betaNormalForm :: Var v => Term0 v -> Term0 v
betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a))
betaNormalForm e = e
-- x -> f x => f
etaNormalForm :: Eq v => Term v -> Term v
etaNormalForm :: Eq v => Term0 v -> Term0 v
etaNormalForm (LamNamed' v (App' f (Var' v'))) | v == v' = etaNormalForm f
etaNormalForm t = t
-- This converts `Reference`s it finds that are in the input `Map`
-- back to free variables
unhashComponent :: forall v a. Var v
=> Map Reference (AnnotatedTerm v a)
-> Map Reference (v, AnnotatedTerm v a)
=> Map Reference (Term v a)
-> Map Reference (v, Term v a)
unhashComponent m = let
usedVars = foldMap (Set.fromList . ABT.allVars) m
m' :: Map Reference (v, AnnotatedTerm v a)
m' :: Map Reference (v, Term v a)
m' = evalState (Map.traverseWithKey assignVar m) usedVars where
assignVar r t = (,t) <$> ABT.freshenS (Var.refNamed r)
unhash1 = ABT.rebuildUp' go where
@ -926,12 +926,12 @@ unhashComponent m = let
in second unhash1 <$> m'
hashComponents
:: Var v => Map v (AnnotatedTerm v a) -> Map v (Reference, AnnotatedTerm v a)
:: Var v => Map v (Term v a) -> Map v (Reference, Term v a)
hashComponents = ReferenceUtil.hashComponents $ ref ()
-- The hash for a constructor
hashConstructor'
:: (Reference -> Int -> Term Symbol) -> Reference -> Int -> Reference
:: (Reference -> Int -> Term0 Symbol) -> Reference -> Int -> Reference
hashConstructor' f r cid =
let
-- this is a bit circuitous, but defining everything in terms of hashComponents
@ -950,7 +950,7 @@ hashRequest = hashConstructor' $ request ()
fromReferent :: Ord v
=> a
-> Referent
-> AnnotatedTerm2 vt at ap v a
-> Term2 vt at ap v a
fromReferent a = \case
Referent.Ref r -> ref a r
Referent.Con r i ct -> case ct of