module Hydra.Rewriting where
import Hydra.Core
import Hydra.Monads
import Hydra.Module
import Hydra.Lexical
import Hydra.Compute
import Hydra.Mantle
import Hydra.Sorting
import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y
expandLambdas :: Ord m => Term m -> GraphFlow m (Term m)
expandLambdas :: forall m. Ord m => Term m -> GraphFlow m (Term m)
expandLambdas = forall b a s.
Ord b =>
((Term a -> Flow s (Term b)) -> Term a -> Flow s (Term b))
-> (a -> Flow s b) -> Term a -> Flow s (Term b)
rewriteTermM (forall {m}.
Ord m =>
[Term m]
-> (Term m -> Flow (Context m) (Term m))
-> Term m
-> Flow (Context m) (Term m)
expand []) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a
id)
where
expand :: [Term m]
-> (Term m -> Flow (Context m) (Term m))
-> Term m
-> Flow (Context m) (Term m)
expand [Term m]
args Term m -> Flow (Context m) (Term m)
recurse Term m
term = case Term m
term of
TermAnnotated (Annotated Term m
term' m
ann) -> forall m. Annotated (Term m) m -> Term m
TermAnnotated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a m. a -> m -> Annotated a m
Annotated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term m]
-> (Term m -> Flow (Context m) (Term m))
-> Term m
-> Flow (Context m) (Term m)
expand [Term m]
args Term m -> Flow (Context m) (Term m)
recurse Term m
term' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure m
ann)
TermApplication (Application Term m
lhs Term m
rhs) -> do
Term m
rhs' <- forall m. Ord m => Term m -> GraphFlow m (Term m)
expandLambdas Term m
rhs
[Term m]
-> (Term m -> Flow (Context m) (Term m))
-> Term m
-> Flow (Context m) (Term m)
expand (Term m
rhs'forall a. a -> [a] -> [a]
:[Term m]
args) Term m -> Flow (Context m) (Term m)
recurse Term m
lhs
TermFunction Function m
f -> case Function m
f of
FunctionCompareTo Term m
_ -> forall {m}. [Term m] -> Int -> Term m -> Term m
pad [Term m]
args Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term m -> Flow (Context m) (Term m)
recurse Term m
term
FunctionElimination Elimination m
_ -> forall {m}. [Term m] -> Int -> Term m -> Term m
pad [Term m]
args Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term m -> Flow (Context m) (Term m)
recurse Term m
term
FunctionLambda Lambda m
_ -> Flow (Context m) (Term m)
passThrough
FunctionPrimitive Name
name -> do
PrimitiveFunction m
prim <- forall m. Name -> GraphFlow m (PrimitiveFunction m)
requirePrimitiveFunction Name
name
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {m}. [Term m] -> Int -> Term m -> Term m
pad [Term m]
args (forall m. PrimitiveFunction m -> Int
primitiveFunctionArity PrimitiveFunction m
prim) Term m
term
Term m
_ -> Flow (Context m) (Term m)
passThrough
where
passThrough :: Flow (Context m) (Term m)
passThrough = forall {m}. [Term m] -> Int -> Term m -> Term m
pad [Term m]
args Int
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term m -> Flow (Context m) (Term m)
recurse Term m
term
pad :: [Term m] -> Int -> Term m -> Term m
pad [Term m]
args Int
arity Term m
term = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl forall {m}. Term m -> Variable -> Term m
lam (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl forall {m}. Term m -> Term m -> Term m
app Term m
term [Term m]
args') forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
L.reverse [Variable]
variables
where
variables :: [Variable]
variables = forall a. Int -> [a] -> [a]
L.take (forall a. Ord a => a -> a -> a
max Int
0 (Int
arity forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Term m]
args)) ((\Integer
i -> String -> Variable
Variable forall a b. (a -> b) -> a -> b
$ String
"v" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Integer
1..])
args' :: [Term m]
args' = [Term m]
args forall a. [a] -> [a] -> [a]
++ (forall m. Variable -> Term m
TermVariable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Variable]
variables)
app :: Term m -> Term m -> Term m
app Term m
lhs Term m
rhs = forall m. Application m -> Term m
TermApplication forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Term m -> Application m
Application Term m
lhs Term m
rhs
lam :: Term m -> Variable -> Term m
lam Term m
body Variable
v = forall m. Function m -> Term m
TermFunction forall a b. (a -> b) -> a -> b
$ forall m. Lambda m -> Function m
FunctionLambda forall a b. (a -> b) -> a -> b
$ forall m. Variable -> Term m -> Lambda m
Lambda Variable
v Term m
body
foldOverTerm :: TraversalOrder -> (a -> Term m -> a) -> a -> Term m -> a
foldOverTerm :: forall a m.
TraversalOrder -> (a -> Term m -> a) -> a -> Term m -> a
foldOverTerm TraversalOrder
order a -> Term m -> a
fld a
b0 Term m
term = case TraversalOrder
order of
TraversalOrder
TraversalOrderPre -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (forall a m.
TraversalOrder -> (a -> Term m -> a) -> a -> Term m -> a
foldOverTerm TraversalOrder
order a -> Term m -> a
fld) (a -> Term m -> a
fld a
b0 Term m
term) [Term m]
children
TraversalOrder
TraversalOrderPost -> a -> Term m -> a
fld (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (forall a m.
TraversalOrder -> (a -> Term m -> a) -> a -> Term m -> a
foldOverTerm TraversalOrder
order a -> Term m -> a
fld) a
b0 [Term m]
children) Term m
term
where
children :: [Term m]
children = forall m. Term m -> [Term m]
subterms Term m
term
foldOverType :: TraversalOrder -> (a -> Type m -> a) -> a -> Type m -> a
foldOverType :: forall a m.
TraversalOrder -> (a -> Type m -> a) -> a -> Type m -> a
foldOverType TraversalOrder
order a -> Type m -> a
fld a
b0 Type m
typ = case TraversalOrder
order of
TraversalOrder
TraversalOrderPre -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (forall a m.
TraversalOrder -> (a -> Type m -> a) -> a -> Type m -> a
foldOverType TraversalOrder
order a -> Type m -> a
fld) (a -> Type m -> a
fld a
b0 Type m
typ) [Type m]
children
TraversalOrder
TraversalOrderPost -> a -> Type m -> a
fld (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (forall a m.
TraversalOrder -> (a -> Type m -> a) -> a -> Type m -> a
foldOverType TraversalOrder
order a -> Type m -> a
fld) a
b0 [Type m]
children) Type m
typ
where
children :: [Type m]
children = forall m. Type m -> [Type m]
subtypes Type m
typ
freeVariablesInScheme :: Show m => TypeScheme m -> S.Set VariableType
freeVariablesInScheme :: forall m. Show m => TypeScheme m -> Set VariableType
freeVariablesInScheme (TypeScheme [VariableType]
vars Type m
t) = forall a. Ord a => Set a -> Set a -> Set a
S.difference (forall m. Type m -> Set VariableType
freeVariablesInType Type m
t) (forall a. Ord a => [a] -> Set a
S.fromList [VariableType]
vars)
freeVariablesInTerm :: Term m -> S.Set Variable
freeVariablesInTerm :: forall m. Term m -> Set Variable
freeVariablesInTerm Term m
term = case Term m
term of
TermAnnotated (Annotated Term m
term1 m
_) -> forall m. Term m -> Set Variable
freeVariablesInTerm Term m
term1
TermFunction (FunctionLambda (Lambda Variable
var Term m
body)) -> forall a. Ord a => a -> Set a -> Set a
S.delete Variable
var forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Set Variable
freeVariablesInTerm Term m
body
TermVariable Variable
v -> forall a. Ord a => [a] -> Set a
S.fromList [Variable
v]
Term m
_ -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Set Variable
s Term m
t -> forall a. Ord a => Set a -> Set a -> Set a
S.union Set Variable
s forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Set Variable
freeVariablesInTerm Term m
t) forall a. Set a
S.empty forall a b. (a -> b) -> a -> b
$ forall m. Term m -> [Term m]
subterms Term m
term
freeVariablesInType :: Type m -> S.Set VariableType
freeVariablesInType :: forall m. Type m -> Set VariableType
freeVariablesInType = forall a m.
TraversalOrder -> (a -> Type m -> a) -> a -> Type m -> a
foldOverType TraversalOrder
TraversalOrderPost forall {m}. Set VariableType -> Type m -> Set VariableType
fld forall a. Set a
S.empty
where
fld :: Set VariableType -> Type m -> Set VariableType
fld Set VariableType
vars Type m
typ = case Type m
typ of
TypeVariable VariableType
v -> forall a. Ord a => a -> Set a -> Set a
S.insert VariableType
v Set VariableType
vars
Type m
_ -> Set VariableType
vars
moduleDependencyNamespaces :: Bool -> Bool -> Bool -> Module m -> S.Set Namespace
moduleDependencyNamespaces :: forall m. Bool -> Bool -> Bool -> Module m -> Set Namespace
moduleDependencyNamespaces Bool
withEls Bool
withPrims Bool
withNoms Module m
mod = forall a. Ord a => a -> Set a -> Set a
S.delete (forall m. Module m -> Namespace
moduleNamespace Module m
mod) Set Namespace
names
where
names :: Set Namespace
names = forall a. Ord a => [a] -> Set a
S.fromList (Name -> Namespace
namespaceOfEager forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toList Set Name
elNames)
elNames :: Set Name
elNames = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Set Name
s Term m
t -> forall a. Ord a => Set a -> Set a -> Set a
S.union Set Name
s forall a b. (a -> b) -> a -> b
$ forall m. Bool -> Bool -> Bool -> Term m -> Set Name
termDependencyNames Bool
withEls Bool
withPrims Bool
withNoms Term m
t) forall a. Set a
S.empty forall a b. (a -> b) -> a -> b
$
(forall m. Element m -> Term m
elementData forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. Module m -> [Element m]
moduleElements Module m
mod) forall a. [a] -> [a] -> [a]
++ (forall m. Element m -> Term m
elementSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. Module m -> [Element m]
moduleElements Module m
mod)
isFreeIn :: Variable -> Term m -> Bool
isFreeIn :: forall m. Variable -> Term m -> Bool
isFreeIn Variable
v Term m
term = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
S.member Variable
v forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Set Variable
freeVariablesInTerm Term m
term
removeTermAnnotations :: Ord m => Term m -> Term m
removeTermAnnotations :: forall m. Ord m => Term m -> Term m
removeTermAnnotations = forall b a.
Ord b =>
((Term a -> Term b) -> Term a -> Term b)
-> (a -> b) -> Term a -> Term b
rewriteTerm forall {m} {t}. (Term m -> t) -> Term m -> t
remove forall a. a -> a
id
where
remove :: (Term m -> t) -> Term m -> t
remove Term m -> t
recurse Term m
term = case Term m
term of
TermAnnotated (Annotated Term m
term' m
_) -> (Term m -> t) -> Term m -> t
remove Term m -> t
recurse Term m
term'
Term m
_ -> Term m -> t
recurse Term m
term
removeTypeAnnotations :: Ord m => Type m -> Type m
removeTypeAnnotations :: forall m. Ord m => Type m -> Type m
removeTypeAnnotations = forall a b.
((Type a -> Type b) -> Type a -> Type b)
-> (a -> b) -> Type a -> Type b
rewriteType forall {m}. (Type m -> Type m) -> Type m -> Type m
remove forall a. a -> a
id
where
remove :: (Type m -> Type m) -> Type m -> Type m
remove Type m -> Type m
recurse Type m
typ = case Type m -> Type m
recurse Type m
typ of
TypeAnnotated (Annotated Type m
typ' m
_) -> (Type m -> Type m) -> Type m -> Type m
remove Type m -> Type m
recurse Type m
typ'
Type m
_ -> Type m -> Type m
recurse Type m
typ
replaceFreeVariableType :: Ord m => VariableType -> Type m -> Type m -> Type m
replaceFreeVariableType :: forall m. Ord m => VariableType -> Type m -> Type m -> Type m
replaceFreeVariableType VariableType
v Type m
rep = forall a b.
((Type a -> Type b) -> Type a -> Type b)
-> (a -> b) -> Type a -> Type b
rewriteType (Type m -> Type m) -> Type m -> Type m
mapExpr forall a. a -> a
id
where
mapExpr :: (Type m -> Type m) -> Type m -> Type m
mapExpr Type m -> Type m
recurse Type m
t = case Type m
t of
TypeLambda (LambdaType VariableType
v' Type m
body) -> if VariableType
v forall a. Eq a => a -> a -> Bool
== VariableType
v'
then Type m
t
else forall m. LambdaType m -> Type m
TypeLambda forall a b. (a -> b) -> a -> b
$ forall m. VariableType -> Type m -> LambdaType m
LambdaType VariableType
v' forall a b. (a -> b) -> a -> b
$ Type m -> Type m
recurse Type m
body
TypeVariable VariableType
v' -> if VariableType
v forall a. Eq a => a -> a -> Bool
== VariableType
v' then Type m
rep else Type m
t
Type m
_ -> Type m -> Type m
recurse Type m
t
rewrite :: ((a -> b) -> a -> b) -> ((a -> b) -> a -> b) -> a -> b
rewrite :: forall a b. ((a -> b) -> a -> b) -> ((a -> b) -> a -> b) -> a -> b
rewrite (a -> b) -> a -> b
fsub (a -> b) -> a -> b
f = a -> b
recurse
where
recurse :: a -> b
recurse = (a -> b) -> a -> b
f ((a -> b) -> a -> b
fsub a -> b
recurse)
rewriteTerm :: Ord b => ((Term a -> Term b) -> Term a -> Term b) -> (a -> b) -> Term a -> Term b
rewriteTerm :: forall b a.
Ord b =>
((Term a -> Term b) -> Term a -> Term b)
-> (a -> b) -> Term a -> Term b
rewriteTerm (Term a -> Term b) -> Term a -> Term b
f a -> b
mf = forall a b. ((a -> b) -> a -> b) -> ((a -> b) -> a -> b) -> a -> b
rewrite (Term a -> Term b) -> Term a -> Term b
fsub (Term a -> Term b) -> Term a -> Term b
f
where
fsub :: (Term a -> Term b) -> Term a -> Term b
fsub Term a -> Term b
recurse Term a
term = case Term a
term of
TermAnnotated (Annotated Term a
ex a
ann) -> forall m. Annotated (Term m) m -> Term m
TermAnnotated forall a b. (a -> b) -> a -> b
$ forall a m. a -> m -> Annotated a m
Annotated (Term a -> Term b
recurse Term a
ex) (a -> b
mf a
ann)
TermApplication (Application Term a
lhs Term a
rhs) -> forall m. Application m -> Term m
TermApplication forall a b. (a -> b) -> a -> b
$ forall m. Term m -> Term m -> Application m
Application (Term a -> Term b
recurse Term a
lhs) (Term a -> Term b
recurse Term a
rhs)
TermElement Name
name -> forall m. Name -> Term m
TermElement Name
name
TermFunction Function a
fun -> forall m. Function m -> Term m
TermFunction forall a b. (a -> b) -> a -> b
$ case Function a
fun of
FunctionCompareTo Term a
other -> forall m. Term m -> Function m
FunctionCompareTo forall a b. (a -> b) -> a -> b
$ Term a -> Term b
recurse Term a
other
FunctionElimination Elimination a
e -> forall m. Elimination m -> Function m
FunctionElimination forall a b. (a -> b) -> a -> b
$ case Elimination a
e of
Elimination a
EliminationElement -> forall m. Elimination m
EliminationElement
EliminationNominal Name
name -> forall m. Name -> Elimination m
EliminationNominal Name
name
EliminationOptional (OptionalCases Term a
nothing Term a
just) -> forall m. OptionalCases m -> Elimination m
EliminationOptional
(forall m. Term m -> Term m -> OptionalCases m
OptionalCases (Term a -> Term b
recurse Term a
nothing) (Term a -> Term b
recurse Term a
just))
EliminationRecord Projection
p -> forall m. Projection -> Elimination m
EliminationRecord Projection
p
EliminationUnion (CaseStatement Name
n [Field a]
cases) -> forall m. CaseStatement m -> Elimination m
EliminationUnion forall a b. (a -> b) -> a -> b
$ forall m. Name -> [Field m] -> CaseStatement m
CaseStatement Name
n (Field a -> Field b
forField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field a]
cases)
FunctionLambda (Lambda Variable
v Term a
body) -> forall m. Lambda m -> Function m
FunctionLambda forall a b. (a -> b) -> a -> b
$ forall m. Variable -> Term m -> Lambda m
Lambda Variable
v forall a b. (a -> b) -> a -> b
$ Term a -> Term b
recurse Term a
body
FunctionPrimitive Name
name -> forall m. Name -> Function m
FunctionPrimitive Name
name
TermLet (Let Variable
v Term a
t1 Term a
t2) -> forall m. Let m -> Term m
TermLet forall a b. (a -> b) -> a -> b
$ forall m. Variable -> Term m -> Term m -> Let m
Let Variable
v (Term a -> Term b
recurse Term a
t1) (Term a -> Term b
recurse Term a
t2)
TermList [Term a]
els -> forall m. [Term m] -> Term m
TermList forall a b. (a -> b) -> a -> b
$ Term a -> Term b
recurse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term a]
els
TermLiteral Literal
v -> forall m. Literal -> Term m
TermLiteral Literal
v
TermMap Map (Term a) (Term a)
m -> forall m. Map (Term m) (Term m) -> Term m
TermMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ (\(Term a
k, Term a
v) -> (Term a -> Term b
recurse Term a
k, Term a -> Term b
recurse Term a
v)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map (Term a) (Term a)
m
TermNominal (Named Name
name Term a
t) -> forall m. Named m -> Term m
TermNominal (forall m. Name -> Term m -> Named m
Named Name
name forall a b. (a -> b) -> a -> b
$ Term a -> Term b
recurse Term a
t)
TermOptional Maybe (Term a)
m -> forall m. Maybe (Term m) -> Term m
TermOptional forall a b. (a -> b) -> a -> b
$ Term a -> Term b
recurse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Term a)
m
TermProduct [Term a]
tuple -> forall m. [Term m] -> Term m
TermProduct (Term a -> Term b
recurse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term a]
tuple)
TermRecord (Record Name
n [Field a]
fields) -> forall m. Record m -> Term m
TermRecord forall a b. (a -> b) -> a -> b
$ forall m. Name -> [Field m] -> Record m
Record Name
n forall a b. (a -> b) -> a -> b
$ Field a -> Field b
forField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field a]
fields
TermSet Set (Term a)
s -> forall m. Set (Term m) -> Term m
TermSet forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ Term a -> Term b
recurse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toList Set (Term a)
s
TermSum (Sum Int
i Int
s Term a
trm) -> forall m. Sum m -> Term m
TermSum forall a b. (a -> b) -> a -> b
$ forall m. Int -> Int -> Term m -> Sum m
Sum Int
i Int
s forall a b. (a -> b) -> a -> b
$ Term a -> Term b
recurse Term a
trm
TermUnion (Union Name
n Field a
field) -> forall m. Union m -> Term m
TermUnion forall a b. (a -> b) -> a -> b
$ forall m. Name -> Field m -> Union m
Union Name
n forall a b. (a -> b) -> a -> b
$ Field a -> Field b
forField Field a
field
TermVariable Variable
v -> forall m. Variable -> Term m
TermVariable Variable
v
where
forField :: Field a -> Field b
forField Field a
f = Field a
f {fieldTerm :: Term b
fieldTerm = Term a -> Term b
recurse (forall m. Field m -> Term m
fieldTerm Field a
f)}
rewriteTermM :: Ord b => ((Term a -> Flow s (Term b)) -> Term a -> (Flow s (Term b))) -> (a -> Flow s b) -> Term a -> Flow s (Term b)
rewriteTermM :: forall b a s.
Ord b =>
((Term a -> Flow s (Term b)) -> Term a -> Flow s (Term b))
-> (a -> Flow s b) -> Term a -> Flow s (Term b)
rewriteTermM (Term a -> Flow s (Term b)) -> Term a -> Flow s (Term b)
f a -> Flow s b
mf = forall a b. ((a -> b) -> a -> b) -> ((a -> b) -> a -> b) -> a -> b
rewrite (Term a -> Flow s (Term b)) -> Term a -> Flow s (Term b)
fsub (Term a -> Flow s (Term b)) -> Term a -> Flow s (Term b)
f
where
fsub :: (Term a -> Flow s (Term b)) -> Term a -> Flow s (Term b)
fsub Term a -> Flow s (Term b)
recurse Term a
term = case Term a
term of
TermAnnotated (Annotated Term a
ex a
ma) -> forall m. Annotated (Term m) m -> Term m
TermAnnotated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a m. a -> m -> Annotated a m
Annotated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
ex forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Flow s b
mf a
ma)
TermApplication (Application Term a
lhs Term a
rhs) -> forall m. Application m -> Term m
TermApplication forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Term m -> Term m -> Application m
Application forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
lhs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term a -> Flow s (Term b)
recurse Term a
rhs)
TermElement Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Name -> Term m
TermElement Name
name
TermFunction Function a
fun -> forall m. Function m -> Term m
TermFunction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Function a
fun of
FunctionCompareTo Term a
other -> forall m. Term m -> Function m
FunctionCompareTo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
other
FunctionElimination Elimination a
e -> forall m. Elimination m -> Function m
FunctionElimination forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Elimination a
e of
Elimination a
EliminationElement -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall m. Elimination m
EliminationElement
EliminationNominal Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Name -> Elimination m
EliminationNominal Name
name
EliminationOptional (OptionalCases Term a
nothing Term a
just) -> forall m. OptionalCases m -> Elimination m
EliminationOptional forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(forall m. Term m -> Term m -> OptionalCases m
OptionalCases forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
nothing forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term a -> Flow s (Term b)
recurse Term a
just)
EliminationRecord Projection
p -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Projection -> Elimination m
EliminationRecord Projection
p
EliminationUnion (CaseStatement Name
n [Field a]
cases) -> forall m. CaseStatement m -> Elimination m
EliminationUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Name -> [Field m] -> CaseStatement m
CaseStatement Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Field a -> Flow s (Field b)
forField [Field a]
cases))
FunctionLambda (Lambda Variable
v Term a
body) -> forall m. Lambda m -> Function m
FunctionLambda forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Variable -> Term m -> Lambda m
Lambda Variable
v forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
body)
FunctionPrimitive Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Name -> Function m
FunctionPrimitive Name
name
TermLet (Let Variable
v Term a
t1 Term a
t2) -> forall m. Let m -> Term m
TermLet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Variable -> Term m -> Term m -> Let m
Let Variable
v forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term a -> Flow s (Term b)
recurse Term a
t2)
TermList [Term a]
els -> forall m. [Term m] -> Term m
TermList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Term a -> Flow s (Term b)
recurse [Term a]
els)
TermLiteral Literal
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Literal -> Term m
TermLiteral Literal
v
TermMap Map (Term a) (Term a)
m -> forall m. Map (Term m) (Term m) -> Term m
TermMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (Term a, Term a) -> Flow s (Term b, Term b)
forPair (forall k a. Map k a -> [(k, a)]
M.toList Map (Term a) (Term a)
m))
where
forPair :: (Term a, Term a) -> Flow s (Term b, Term b)
forPair (Term a
k, Term a
v) = do
Term b
km <- Term a -> Flow s (Term b)
recurse Term a
k
Term b
vm <- Term a -> Flow s (Term b)
recurse Term a
v
forall (m :: * -> *) a. Monad m => a -> m a
return (Term b
km, Term b
vm)
TermNominal (Named Name
name Term a
t) -> forall m. Named m -> Term m
TermNominal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Name -> Term m -> Named m
Named Name
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
t)
TermOptional Maybe (Term a)
m -> forall m. Maybe (Term m) -> Term m
TermOptional forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Term a -> Flow s (Term b)
recurse Maybe (Term a)
m)
TermProduct [Term a]
tuple -> forall m. [Term m] -> Term m
TermProduct forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Term a -> Flow s (Term b)
recurse [Term a]
tuple)
TermRecord (Record Name
n [Field a]
fields) -> forall m. Record m -> Term m
TermRecord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Name -> [Field m] -> Record m
Record Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Field a -> Flow s (Field b)
forField [Field a]
fields))
TermSet Set (Term a)
s -> forall m. Set (Term m) -> Term m
TermSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM Term a -> Flow s (Term b)
recurse forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set (Term a)
s))
TermSum (Sum Int
i Int
s Term a
trm) -> forall m. Sum m -> Term m
TermSum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Int -> Int -> Term m -> Sum m
Sum Int
i Int
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term a -> Flow s (Term b)
recurse Term a
trm)
TermUnion (Union Name
n Field a
field) -> forall m. Union m -> Term m
TermUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall m. Name -> Field m -> Union m
Union Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field a -> Flow s (Field b)
forField Field a
field)
TermVariable Variable
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Variable -> Term m
TermVariable Variable
v
where
forField :: Field a -> Flow s (Field b)
forField Field a
f = do
Term b
t <- Term a -> Flow s (Term b)
recurse (forall m. Field m -> Term m
fieldTerm Field a
f)
forall (m :: * -> *) a. Monad m => a -> m a
return Field a
f {fieldTerm :: Term b
fieldTerm = Term b
t}
rewriteTermMeta :: Ord b => (a -> b) -> Term a -> Term b
rewriteTermMeta :: forall b a. Ord b => (a -> b) -> Term a -> Term b
rewriteTermMeta = forall b a.
Ord b =>
((Term a -> Term b) -> Term a -> Term b)
-> (a -> b) -> Term a -> Term b
rewriteTerm forall {t} {t}. (t -> t) -> t -> t
mapExpr
where
mapExpr :: (t -> t) -> t -> t
mapExpr t -> t
recurse t
term = t -> t
recurse t
term
rewriteType :: ((Type a -> Type b) -> Type a -> Type b) -> (a -> b) -> Type a -> Type b
rewriteType :: forall a b.
((Type a -> Type b) -> Type a -> Type b)
-> (a -> b) -> Type a -> Type b
rewriteType (Type a -> Type b) -> Type a -> Type b
f a -> b
mf = forall a b. ((a -> b) -> a -> b) -> ((a -> b) -> a -> b) -> a -> b
rewrite (Type a -> Type b) -> Type a -> Type b
fsub (Type a -> Type b) -> Type a -> Type b
f
where
fsub :: (Type a -> Type b) -> Type a -> Type b
fsub Type a -> Type b
recurse Type a
typ = case Type a
typ of
TypeAnnotated (Annotated Type a
t a
ann) -> forall m. Annotated (Type m) m -> Type m
TypeAnnotated forall a b. (a -> b) -> a -> b
$ forall a m. a -> m -> Annotated a m
Annotated (Type a -> Type b
recurse Type a
t) (a -> b
mf a
ann)
TypeApplication (ApplicationType Type a
lhs Type a
rhs) -> forall m. ApplicationType m -> Type m
TypeApplication forall a b. (a -> b) -> a -> b
$ forall m. Type m -> Type m -> ApplicationType m
ApplicationType (Type a -> Type b
recurse Type a
lhs) (Type a -> Type b
recurse Type a
rhs)
TypeElement Type a
t -> forall m. Type m -> Type m
TypeElement forall a b. (a -> b) -> a -> b
$ Type a -> Type b
recurse Type a
t
TypeFunction (FunctionType Type a
dom Type a
cod) -> forall m. FunctionType m -> Type m
TypeFunction (forall m. Type m -> Type m -> FunctionType m
FunctionType (Type a -> Type b
recurse Type a
dom) (Type a -> Type b
recurse Type a
cod))
TypeLambda (LambdaType VariableType
v Type a
b) -> forall m. LambdaType m -> Type m
TypeLambda (forall m. VariableType -> Type m -> LambdaType m
LambdaType VariableType
v forall a b. (a -> b) -> a -> b
$ Type a -> Type b
recurse Type a
b)
TypeList Type a
t -> forall m. Type m -> Type m
TypeList forall a b. (a -> b) -> a -> b
$ Type a -> Type b
recurse Type a
t
TypeLiteral LiteralType
lt -> forall m. LiteralType -> Type m
TypeLiteral LiteralType
lt
TypeMap (MapType Type a
kt Type a
vt) -> forall m. MapType m -> Type m
TypeMap (forall m. Type m -> Type m -> MapType m
MapType (Type a -> Type b
recurse Type a
kt) (Type a -> Type b
recurse Type a
vt))
TypeNominal Name
name -> forall m. Name -> Type m
TypeNominal Name
name
TypeOptional Type a
t -> forall m. Type m -> Type m
TypeOptional forall a b. (a -> b) -> a -> b
$ Type a -> Type b
recurse Type a
t
TypeProduct [Type a]
types -> forall m. [Type m] -> Type m
TypeProduct (Type a -> Type b
recurse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type a]
types)
TypeRecord (RowType Name
name Maybe Name
extends [FieldType a]
fields) -> forall m. RowType m -> Type m
TypeRecord forall a b. (a -> b) -> a -> b
$ forall m. Name -> Maybe Name -> [FieldType m] -> RowType m
RowType Name
name Maybe Name
extends (FieldType a -> FieldType b
forfield forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldType a]
fields)
TypeSet Type a
t -> forall m. Type m -> Type m
TypeSet forall a b. (a -> b) -> a -> b
$ Type a -> Type b
recurse Type a
t
TypeSum [Type a]
types -> forall m. [Type m] -> Type m
TypeSum (Type a -> Type b
recurse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type a]
types)
TypeUnion (RowType Name
name Maybe Name
extends [FieldType a]
fields) -> forall m. RowType m -> Type m
TypeUnion forall a b. (a -> b) -> a -> b
$ forall m. Name -> Maybe Name -> [FieldType m] -> RowType m
RowType Name
name Maybe Name
extends (FieldType a -> FieldType b
forfield forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldType a]
fields)
TypeVariable VariableType
v -> forall m. VariableType -> Type m
TypeVariable VariableType
v
where
forfield :: FieldType a -> FieldType b
forfield FieldType a
f = FieldType a
f {fieldTypeType :: Type b
fieldTypeType = Type a -> Type b
recurse (forall m. FieldType m -> Type m
fieldTypeType FieldType a
f)}
rewriteTypeMeta :: (a -> b) -> Type a -> Type b
rewriteTypeMeta :: forall a b. (a -> b) -> Type a -> Type b
rewriteTypeMeta = forall a b.
((Type a -> Type b) -> Type a -> Type b)
-> (a -> b) -> Type a -> Type b
rewriteType forall {t} {t}. (t -> t) -> t -> t
mapExpr
where
mapExpr :: (t -> t) -> t -> t
mapExpr t -> t
recurse t
term = t -> t
recurse t
term
simplifyTerm :: Ord m => Term m -> Term m
simplifyTerm :: forall m. Ord m => Term m -> Term m
simplifyTerm = forall b a.
Ord b =>
((Term a -> Term b) -> Term a -> Term b)
-> (a -> b) -> Term a -> Term b
rewriteTerm forall {m} {b}. Ord m => (Term m -> b) -> Term m -> b
simplify forall a. a -> a
id
where
simplify :: (Term m -> b) -> Term m -> b
simplify Term m -> b
recurse Term m
term = Term m -> b
recurse forall a b. (a -> b) -> a -> b
$ case forall m. Term m -> Term m
stripTerm Term m
term of
TermApplication (Application Term m
lhs Term m
rhs) -> case forall m. Term m -> Term m
stripTerm Term m
lhs of
TermFunction (FunctionLambda (Lambda Variable
var Term m
body)) ->
if forall a. Ord a => a -> Set a -> Bool
S.member Variable
var (forall m. Term m -> Set Variable
freeVariablesInTerm Term m
body)
then case forall m. Term m -> Term m
stripTerm Term m
rhs of
TermVariable Variable
v -> forall m. Ord m => Term m -> Term m
simplifyTerm forall a b. (a -> b) -> a -> b
$ forall m. Ord m => Variable -> Variable -> Term m -> Term m
substituteVariable Variable
var Variable
v Term m
body
Term m
_ -> Term m
term
else forall m. Ord m => Term m -> Term m
simplifyTerm Term m
body
Term m
_ -> Term m
term
Term m
_ -> Term m
term
substituteVariable :: Ord m => Variable -> Variable -> Term m -> Term m
substituteVariable :: forall m. Ord m => Variable -> Variable -> Term m -> Term m
substituteVariable Variable
from Variable
to = forall b a.
Ord b =>
((Term a -> Term b) -> Term a -> Term b)
-> (a -> b) -> Term a -> Term b
rewriteTerm forall {m}. (Term m -> Term m) -> Term m -> Term m
replace forall a. a -> a
id
where
replace :: (Term m -> Term m) -> Term m -> Term m
replace Term m -> Term m
recurse Term m
term = case Term m
term of
TermVariable Variable
x -> Term m -> Term m
recurse forall a b. (a -> b) -> a -> b
$ (forall m. Variable -> Term m
TermVariable forall a b. (a -> b) -> a -> b
$ if Variable
x forall a. Eq a => a -> a -> Bool
== Variable
from then Variable
to else Variable
x)
TermFunction (FunctionLambda (Lambda Variable
var Term m
_)) -> if Variable
var forall a. Eq a => a -> a -> Bool
== Variable
from
then Term m
term
else Term m -> Term m
recurse Term m
term
Term m
_ -> Term m -> Term m
recurse Term m
term
subterms :: Term m -> [Term m]
subterms :: forall m. Term m -> [Term m]
subterms Term m
term = case Term m
term of
TermAnnotated (Annotated Term m
t m
_) -> [Term m
t]
TermApplication (Application Term m
lhs Term m
rhs) -> [Term m
lhs, Term m
rhs]
TermFunction Function m
f -> case Function m
f of
FunctionCompareTo Term m
other -> [Term m
other]
FunctionElimination Elimination m
e -> case Elimination m
e of
EliminationOptional (OptionalCases Term m
nothing Term m
just) -> [Term m
nothing, Term m
just]
EliminationUnion (CaseStatement Name
_ [Field m]
cases) -> forall m. Field m -> Term m
fieldTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field m]
cases
Elimination m
_ -> []
FunctionLambda (Lambda Variable
_ Term m
body) -> [Term m
body]
Function m
_ -> []
TermLet (Let Variable
_ Term m
t1 Term m
t2) -> [Term m
t1, Term m
t2]
TermList [Term m]
els -> [Term m]
els
TermMap Map (Term m) (Term m)
m -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ((\(Term m
k, Term m
v) -> [Term m
k, Term m
v]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map (Term m) (Term m)
m)
TermNominal (Named Name
_ Term m
t) -> [Term m
t]
TermOptional Maybe (Term m)
m -> forall a. Maybe a -> [a]
Y.maybeToList Maybe (Term m)
m
TermProduct [Term m]
tuple -> [Term m]
tuple
TermRecord (Record Name
n [Field m]
fields) -> forall m. Field m -> Term m
fieldTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field m]
fields
TermSet Set (Term m)
s -> forall a. Set a -> [a]
S.toList Set (Term m)
s
TermSum (Sum Int
_ Int
_ Term m
trm) -> [Term m
trm]
TermUnion (Union Name
_ Field m
field) -> [forall m. Field m -> Term m
fieldTerm Field m
field]
Term m
_ -> []
subtypes :: Type m -> [Type m]
subtypes :: forall m. Type m -> [Type m]
subtypes Type m
typ = case Type m
typ of
TypeAnnotated (Annotated Type m
t m
_) -> [Type m
t]
TypeApplication (ApplicationType Type m
lhs Type m
rhs) -> [Type m
lhs, Type m
rhs]
TypeElement Type m
et -> [Type m
et]
TypeFunction (FunctionType Type m
dom Type m
cod) -> [Type m
dom, Type m
cod]
TypeLambda (LambdaType VariableType
v Type m
body) -> [Type m
body]
TypeList Type m
lt -> [Type m
lt]
TypeLiteral LiteralType
_ -> []
TypeMap (MapType Type m
kt Type m
vt) -> [Type m
kt, Type m
vt]
TypeNominal Name
_ -> []
TypeOptional Type m
ot -> [Type m
ot]
TypeProduct [Type m]
types -> [Type m]
types
TypeRecord RowType m
rt -> forall m. FieldType m -> Type m
fieldTypeType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
TypeSet Type m
st -> [Type m
st]
TypeSum [Type m]
types -> [Type m]
types
TypeUnion RowType m
rt -> forall m. FieldType m -> Type m
fieldTypeType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt
TypeVariable VariableType
_ -> []
termDependencyNames :: Bool -> Bool -> Bool -> Term m -> S.Set Name
termDependencyNames :: forall m. Bool -> Bool -> Bool -> Term m -> Set Name
termDependencyNames Bool
withEls Bool
withPrims Bool
withNoms = forall a m.
TraversalOrder -> (a -> Term m -> a) -> a -> Term m -> a
foldOverTerm TraversalOrder
TraversalOrderPre forall {m}. Set Name -> Term m -> Set Name
addNames forall a. Set a
S.empty
where
addNames :: Set Name -> Term m -> Set Name
addNames Set Name
names Term m
term = case Term m
term of
TermElement Name
name -> if Bool
withEls then forall a. Ord a => a -> Set a -> Set a
S.insert Name
name Set Name
names else Set Name
names
TermFunction (FunctionPrimitive Name
name) -> if Bool
withPrims then forall a. Ord a => a -> Set a -> Set a
S.insert Name
name Set Name
names else Set Name
names
TermNominal (Named Name
name Term m
_) -> if Bool
withNoms then forall a. Ord a => a -> Set a -> Set a
S.insert Name
name Set Name
names else Set Name
names
Term m
_ -> Set Name
names
topologicalSortElements :: [Element m] -> Maybe [Name]
topologicalSortElements :: forall m. [Element m] -> Maybe [Name]
topologicalSortElements [Element m]
els = forall a. Eq a => [(a, [a])] -> Maybe [a]
topologicalSort forall a b. (a -> b) -> a -> b
$ forall {m}. Element m -> (Name, [Name])
adjlist forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Element m]
els
where
adjlist :: Element m -> (Name, [Name])
adjlist Element m
e = (forall m. Element m -> Name
elementName Element m
e, forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall m. Bool -> Bool -> Bool -> Term m -> Set Name
termDependencyNames Bool
True Bool
True Bool
True forall a b. (a -> b) -> a -> b
$ forall m. Element m -> Term m
elementData Element m
e)