{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Safe #-}

module Embedder.Atmo.DependencyGraph where

import safe Embedder.Atmo.Syntax as C
    ( FreeProgram,
      TypeSynonym(..), DataDefn(..), Defn(..),
      Exp(..), Ty(..), Poly(..),
      DataCon(..), Pat (..), FunBinding (..), PatBind (..), RecDefn (..), -- Rhs (..), GuardedRhs (..), 
      )
import ReWire.Orphans ()

import Data.List ((\\), groupBy)
import Data.Text (Text, splitOn, pack, empty)
import Data.Graph (Graph,graphFromEdges,scc, Vertex, Tree (..))
import Data.Maybe (mapMaybe)

--------------------------------------------------------------
-- Atmo Dependency Graph
--------------------------------------------------------------

-- Graph with vertices that are free variables
-- The variables we care about are:
      -- type constructor names (global type variables)
            -- defined in type synonyms and datatypes
            -- occur in type signatures everywhere
      -- data constructor names (global term variables)
            -- defined in datatypes
            -- occur in Exps in Defns
      -- definition names (global term variables)
            -- defined in Defns
            -- occur in Exps in Defns
-- Edges point from a function to its free variables
-- This means that a function depends on X if it points to X
-- This means that dependency is a 'forward' topological sort
-- And so we want our file to use a reverse topological sort

-- scc: the strongly connected components of a graph, reverse topological sort
-- scc (0 > 1 > 2 > 0, 3 > 1) ==
--      [[root = 0, [root = 1, [root = 2]]],
--       [root = 3, []]]


data Def = DDef DataDefn | RDef RecDefn | DCon DataCon | TDef TypeSynonym | Def Defn

-- Isabelle allows mutually recursive datatype definitions, but ReWire doesn't
-- ReWire does allow mutual recursion of functions; only of type ReacT
-- Atmo will have mutual recursion between things of type ReacT and perhaps lifted lambdas
data Declaration = DDecl DataDefn | RecDecl RecDefn | TDecl TypeSynonym | FDecl Defn | RDecl [Defn]

mkRDecl :: [Defn] -> Declaration
mkRDecl :: [Defn] -> Declaration
mkRDecl [Defn]
ds = [Defn] -> Declaration
RDecl (([Defn] -> Defn) -> [[Defn]] -> [Defn]
forall a b. (a -> b) -> [a] -> [b]
map [Defn] -> Defn
combineGroup [[Defn]]
groupedDefns)
      where
      groupedDefns :: [[Defn]]
groupedDefns = (Defn -> Defn -> Bool) -> [Defn] -> [[Defn]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\ Defn
d1 Defn
d2 -> Defn -> Text
defnName Defn
d1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Defn -> Text
defnName Defn
d2) [Defn]
ds
      combineDefns :: Defn -> Defn -> Defn
      combineDefns :: Defn -> Defn -> Defn
combineDefns Defn
def1 Defn
def2 = Annote -> Text -> Poly -> Maybe DefnAttr -> [FunBinding] -> Defn
Defn (Defn -> Annote
defnAnnote Defn
def1) (Defn -> Text
defnName Defn
def1) (Defn -> Poly
defnPolyTy Defn
def1) (Defn -> Maybe DefnAttr
defnAttr Defn
def1) (Defn -> [FunBinding]
defnBinds Defn
def1 [FunBinding] -> [FunBinding] -> [FunBinding]
forall a. [a] -> [a] -> [a]
++ Defn -> [FunBinding]
defnBinds Defn
def2)
      combineGroup :: [Defn] -> Defn
      combineGroup :: [Defn] -> Defn
combineGroup = \ case
            Defn
d : [Defn]
ds' -> (Defn -> Defn -> Defn) -> Defn -> [Defn] -> Defn
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Defn -> Defn -> Defn
combineDefns Defn
d [Defn]
ds'
            []      -> [Char] -> Defn
forall a. HasCallStack => [Char] -> a
error [Char]
"ERROR: mkRDecl: empty definition group"



def2Decl :: Def -> Maybe Declaration
def2Decl :: Def -> Maybe Declaration
def2Decl = \ case
      DDef DataDefn
d -> Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Declaration -> Maybe Declaration)
-> Declaration -> Maybe Declaration
forall a b. (a -> b) -> a -> b
$ DataDefn -> Declaration
DDecl DataDefn
d
      RDef RecDefn
d -> Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Declaration -> Maybe Declaration)
-> Declaration -> Maybe Declaration
forall a b. (a -> b) -> a -> b
$ RecDefn -> Declaration
RecDecl RecDefn
d
      DCon DataCon
_ -> Maybe Declaration
forall a. Maybe a
Nothing
      TDef TypeSynonym
d -> Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Declaration -> Maybe Declaration)
-> Declaration -> Maybe Declaration
forall a b. (a -> b) -> a -> b
$ TypeSynonym -> Declaration
TDecl TypeSynonym
d
      Def Defn
d  -> Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Declaration -> Maybe Declaration)
-> Declaration -> Maybe Declaration
forall a b. (a -> b) -> a -> b
$ Defn -> Declaration
FDecl Defn
d

fvt :: Ty -> [Text]
fvt :: Ty -> [Text]
fvt = \ case
      TyApp Annote
_a Ty
t [Ty]
ts -> Ty -> [Text]
fvt Ty
t [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Ty -> [Text]) -> [Ty] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty -> [Text]
fvt [Ty]
ts
      TyCon Annote
_a Text
n -> [Text
n]
      TyTuple Annote
_a [Ty]
ts -> (Ty -> [Text]) -> [Ty] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ty -> [Text]
fvt [Ty]
ts
      Ty
_ -> []


getNodeDefn :: Defn -> (Def,Text,[Text])
getNodeDefn :: Defn -> (Def, Text, [Text])
getNodeDefn d :: Defn
d@(Defn Annote
_ Text
n (Poly [Text]
_ Ty
t) Maybe DefnAttr
_ [FunBinding]
bs) =
      let [Text]
tvs :: [Text] = Ty -> [Text]
fvt Ty
t -- [Name TyConId]
          [Text]
dvs :: [Text] = (FunBinding -> [Text]) -> [FunBinding] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Exp -> [Text]) -> FunBinding -> [Text]
fbConcatMap Exp -> [Text]
datacons) [FunBinding]
bs -- [Name DataConId]
          [Text]
vs :: [Text] = (FunBinding -> [Text]) -> [FunBinding] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Exp -> [Text]) -> FunBinding -> [Text]
fbConcatMap Exp -> [Text]
fve) [FunBinding]
bs -- [Name Exp]
          [Text]
tvs_e :: [Text] = (FunBinding -> [Text]) -> [FunBinding] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Exp -> [Text]) -> FunBinding -> [Text]
fbConcatMap Exp -> [Text]
tycons) [FunBinding]
bs -- [Name TyConId]
      in (Defn -> Def
Def Defn
d, Text
n, [Text]
tvs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
dvs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
tvs_e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
vs)
      where
      fbConcatMap :: (Exp -> [Text]) -> FunBinding -> [Text]
      fbConcatMap :: (Exp -> [Text]) -> FunBinding -> [Text]
fbConcatMap Exp -> [Text]
f (FunBinding Annote
_ [Pat]
ps Exp
rhs) = (Pat -> [Text]) -> [Pat] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat -> [Text]
dataconsPat [Pat]
ps [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
f Exp
rhs -- rhsConcatMap f rhs


tycons :: Exp -> [Text] -- Name TyConId
tycons :: Exp -> [Text]
tycons = \ case
      C.App Annote
_a Maybe Poly
mp Maybe Ty
_mt Exp
e [Exp]
es -> Exp -> [Text]
tycons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
tycons [Exp]
es [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      Lam Annote
_a Maybe Poly
mp Maybe Ty
_mt [Text]
_vs Exp
e -> Exp -> [Text]
tycons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      Var Annote
_a Maybe Poly
mp Maybe Ty
_mt Text
_n -> Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      Con Annote
_a Maybe Poly
mp Maybe Ty
_mt Text
_n -> Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      C.Case Annote
_a Maybe Poly
mp Maybe Ty
_mt Exp
e [PatBind]
pbs -> Exp -> [Text]
tycons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (PatBind -> [Text]) -> [PatBind] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatBind -> [Text]
pbTycons [PatBind]
pbs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      RWUser Annote
_a Maybe Poly
mp Maybe Ty
_mt RWUserOp
_b -> Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      LitInt {} -> []
      LitStr {} -> []
      C.LitVec Annote
_a Maybe Poly
mp Maybe Ty
_mt [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
tycons [Exp]
es [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      LitList Annote
_a Maybe Poly
mp Maybe Ty
_mt [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
tycons [Exp]
es [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      Tuple Annote
_a Maybe Poly
mp Maybe Ty
_mt [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
tycons [Exp]
es [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      If Annote
_ Maybe Poly
mp Maybe Ty
_mt Exp
t Exp
c Exp
a -> Exp -> [Text]
tycons Exp
t [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
tycons Exp
c [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
tycons Exp
a [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      Let Annote
_ Maybe Poly
mp Maybe Ty
_mt [PatBind]
pbs Exp
e -> (PatBind -> [Text]) -> [PatBind] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatBind -> [Text]
pbTycons [PatBind]
pbs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
tycons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      RecVal Annote
_ Maybe Poly
mp Maybe Ty
_ [(Text, Exp)]
fs   -> ((Text, Exp) -> [Text]) -> [(Text, Exp)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp -> [Text]
tycons (Exp -> [Text]) -> ((Text, Exp) -> Exp) -> (Text, Exp) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Exp) -> Exp
forall a b. (a, b) -> b
snd) [(Text, Exp)]
fs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      RecUpd Annote
_ Maybe Poly
mp Maybe Ty
_ Exp
e [(Text, Exp)]
fs -> Exp -> [Text]
tycons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ((Text, Exp) -> [Text]) -> [(Text, Exp)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp -> [Text]
tycons (Exp -> [Text]) -> ((Text, Exp) -> Exp) -> (Text, Exp) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Exp) -> Exp
forall a b. (a, b) -> b
snd) [(Text, Exp)]
fs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      RecSel Annote
_ Maybe Poly
mp Maybe Ty
_ Text
_ Exp
e  -> Exp -> [Text]
tycons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Poly -> [Text]
mp_fvt Maybe Poly
mp
      where
            mp_fvt :: Maybe Poly -> [Text]
            mp_fvt :: Maybe Poly -> [Text]
mp_fvt = \ case
                  Just (Poly [Text]
_ Ty
t) -> Ty -> [Text]
fvt Ty
t
                  Maybe Poly
_ -> []

pbTycons :: PatBind -> [Text]
pbTycons :: PatBind -> [Text]
pbTycons (PatBind Pat
_ Exp
e) = Exp -> [Text]
tycons Exp
e

fve :: Exp -> [Text] -- Name Exp
fve :: Exp -> [Text]
fve = \ case
      C.App Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
e [Exp]
es -> Exp -> [Text]
fve Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
fve [Exp]
es
      Lam Annote
_ Maybe Poly
_ Maybe Ty
_ [Text]
vs Exp
e -> Exp -> [Text]
fve Exp
e [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
vs
      Var Annote
_ Maybe Poly
_ Maybe Ty
_ Text
n -> [Text
n]
      Con Annote
_ Maybe Poly
_ Maybe Ty
_ Text
_n -> []
      C.Case Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
e [PatBind]
pbs -> Exp -> [Text]
fve Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (PatBind -> [Text]) -> [PatBind] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatBind -> [Text]
fvePb [PatBind]
pbs
      RWUser Annote
_ Maybe Poly
_ Maybe Ty
_ RWUserOp
_b -> []
      LitInt {} -> []
      LitStr {} -> []
      C.LitVec Annote
_ Maybe Poly
_ Maybe Ty
_ [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
fve [Exp]
es
      LitList Annote
_ Maybe Poly
_ Maybe Ty
_ [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
fve [Exp]
es
      Tuple Annote
_ Maybe Poly
_ Maybe Ty
_ [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
fve [Exp]
es
      If Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
t Exp
c Exp
a -> Exp -> [Text]
fve Exp
t [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
fve Exp
c [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
fve Exp
a
      Let Annote
_ Maybe Poly
_ Maybe Ty
_ [PatBind]
pbs Exp
e -> (PatBind -> [Text]) -> [PatBind] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatBind -> [Text]
fvePb [PatBind]
pbs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
fve Exp
e
      RecVal Annote
_ Maybe Poly
_ Maybe Ty
_ [(Text, Exp)]
fs    -> ((Text, Exp) -> [Text]) -> [(Text, Exp)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp -> [Text]
fve (Exp -> [Text]) -> ((Text, Exp) -> Exp) -> (Text, Exp) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Exp) -> Exp
forall a b. (a, b) -> b
snd) [(Text, Exp)]
fs
      RecUpd Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
e [(Text, Exp)]
fs  -> Exp -> [Text]
fve Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ((Text, Exp) -> [Text]) -> [(Text, Exp)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp -> [Text]
fve (Exp -> [Text]) -> ((Text, Exp) -> Exp) -> (Text, Exp) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Exp) -> Exp
forall a b. (a, b) -> b
snd) [(Text, Exp)]
fs
      RecSel Annote
_ Maybe Poly
_ Maybe Ty
_ Text
_ Exp
e   -> Exp -> [Text]
fve Exp
e

fvePb :: PatBind -> [Text]
fvePb :: PatBind -> [Text]
fvePb (PatBind Pat
p Exp
e) = Pat -> [Text]
fvePat Pat
p [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
fve Exp
e

fvePat :: Pat -> [Text] -- Name Exp
fvePat :: Pat -> [Text]
fvePat = \ case
           PatCon      Annote
_ Maybe Poly
_ Maybe Ty
_ Text
_n [Pat]
ps -> (Pat -> [Text]) -> [Pat] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat -> [Text]
fvePat [Pat]
ps
           PatVar      Annote
_ Maybe Poly
_ Maybe Ty
_ Text
n -> [Text
n]
           PatWildCard {} -> []
           PatTuple    Annote
_ Maybe Poly
_ Maybe Ty
_ [Pat]
ps -> (Pat -> [Text]) -> [Pat] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat -> [Text]
fvePat [Pat]
ps
           PatAs       Annote
_ Maybe Poly
_ Maybe Ty
_ Text
n Pat
p -> Text
n Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Pat -> [Text]
fvePat Pat
p
           PatRec Annote
_ Maybe Poly
_ Maybe Ty
_ [(Text, Pat)]
fs -> ((Text, Pat) -> [Text]) -> [(Text, Pat)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Pat -> [Text]
fvePat (Pat -> [Text]) -> ((Text, Pat) -> Pat) -> (Text, Pat) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Pat) -> Pat
forall a b. (a, b) -> b
snd) [(Text, Pat)]
fs

datacons :: Exp -> [Text] -- Name DataConId
datacons :: Exp -> [Text]
datacons = \ case
      C.App Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
e [Exp]
es -> Exp -> [Text]
datacons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
datacons [Exp]
es
      Lam Annote
_ Maybe Poly
_ Maybe Ty
_ [Text]
_vs Exp
e -> Exp -> [Text]
datacons Exp
e
      Var Annote
_ Maybe Poly
_ Maybe Ty
_ Text
_n -> []
      Con Annote
_ Maybe Poly
_ Maybe Ty
_ Text
n -> [Text
n]
      C.Case Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
e [PatBind]
pbs -> Exp -> [Text]
datacons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (PatBind -> [Text]) -> [PatBind] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatBind -> [Text]
dataconsPb [PatBind]
pbs
      RWUser Annote
_ Maybe Poly
_ Maybe Ty
_ RWUserOp
_b -> []
      LitInt {} -> []
      LitStr {} -> []
      C.LitVec Annote
_ Maybe Poly
_ Maybe Ty
_ [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
datacons [Exp]
es
      LitList Annote
_ Maybe Poly
_ Maybe Ty
_ [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
datacons [Exp]
es
      Tuple Annote
_ Maybe Poly
_ Maybe Ty
_ [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
datacons [Exp]
es
      If Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
t Exp
c Exp
a -> Exp -> [Text]
datacons Exp
t [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
datacons Exp
c [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
datacons Exp
a
      Let Annote
_ Maybe Poly
_ Maybe Ty
_ [PatBind]
pbs Exp
e -> (PatBind -> [Text]) -> [PatBind] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatBind -> [Text]
dataconsPb [PatBind]
pbs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
datacons Exp
e
      RecVal Annote
_ Maybe Poly
_ Maybe Ty
_ [(Text, Exp)]
fs    -> ((Text, Exp) -> [Text]) -> [(Text, Exp)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp -> [Text]
datacons (Exp -> [Text]) -> ((Text, Exp) -> Exp) -> (Text, Exp) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Exp) -> Exp
forall a b. (a, b) -> b
snd) [(Text, Exp)]
fs
      RecUpd Annote
_ Maybe Poly
_ Maybe Ty
_ Exp
e [(Text, Exp)]
fs  -> Exp -> [Text]
datacons Exp
e [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ((Text, Exp) -> [Text]) -> [(Text, Exp)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp -> [Text]
datacons (Exp -> [Text]) -> ((Text, Exp) -> Exp) -> (Text, Exp) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Exp) -> Exp
forall a b. (a, b) -> b
snd) [(Text, Exp)]
fs
      RecSel Annote
_ Maybe Poly
_ Maybe Ty
_ Text
_ Exp
e   -> Exp -> [Text]
datacons Exp
e


dataconsPb :: PatBind -> [Text]
dataconsPb :: PatBind -> [Text]
dataconsPb (PatBind Pat
p Exp
e) = Pat -> [Text]
dataconsPat Pat
p [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Exp -> [Text]
datacons Exp
e

dataconsPat :: Pat -> [Text] -- Name DataConId
dataconsPat :: Pat -> [Text]
dataconsPat = \ case
           PatCon      Annote
_ Maybe Poly
_ Maybe Ty
_ Text
n [Pat]
ps -> Text
n Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Pat -> [Text]) -> [Pat] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat -> [Text]
dataconsPat [Pat]
ps
           PatVar      Annote
_ Maybe Poly
_ Maybe Ty
_ Text
_n -> []
           PatWildCard {} -> []
           PatTuple    Annote
_ Maybe Poly
_ Maybe Ty
_ [Pat]
ps -> (Pat -> [Text]) -> [Pat] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat -> [Text]
dataconsPat [Pat]
ps
           PatAs       Annote
_ Maybe Poly
_ Maybe Ty
_ Text
_ Pat
p -> Pat -> [Text]
dataconsPat Pat
p
           PatRec      Annote
_ Maybe Poly
_ Maybe Ty
_ [(Text, Pat)]
fs -> ((Text, Pat) -> [Text]) -> [(Text, Pat)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Pat -> [Text]
dataconsPat (Pat -> [Text]) -> ((Text, Pat) -> Pat) -> (Text, Pat) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Pat) -> Pat
forall a b. (a, b) -> b
snd) [(Text, Pat)]
fs

getNodeTSyns :: TypeSynonym -> (Def,Text,[Text])
getNodeTSyns :: TypeSynonym -> (Def, Text, [Text])
getNodeTSyns d :: TypeSynonym
d@(C.TypeSynonym Annote
_ Text
n (Poly [Text]
_ Ty
t)) = (TypeSynonym -> Def
TDef TypeSynonym
d, Text
n, Ty -> [Text]
fvt Ty
t :: [Text]) -- Name TyConId

getNodeData :: DataDefn -> [(Def,Text,[Text])]
getNodeData :: DataDefn -> [(Def, Text, [Text])]
getNodeData d :: DataDefn
d@(DataDefn Annote
_ Text
n [Text]
_ [DataCon]
cons) =
      (DataDefn -> Def
DDef DataDefn
d, Text
ddef_name, [Text]
ddef_fvs) (Def, Text, [Text])
-> [(Def, Text, [Text])] -> [(Def, Text, [Text])]
forall a. a -> [a] -> [a]
: (DataCon -> (Def, Text, [Text]))
-> [DataCon] -> [(Def, Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> (Def, Text, [Text])
getNodeDataCon [DataCon]
cons
      where
            ddef_name :: Text
ddef_name = Text
n
            ddef_fvs :: [Text]
ddef_fvs = (DataCon -> [Text]) -> [DataCon] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [Text]
dcon_fvs [DataCon]
cons
            dcon_fvs :: DataCon -> [Text]
            dcon_fvs :: DataCon -> [Text]
dcon_fvs (DataCon Annote
_ Text
_ (Poly [Text]
_ Ty
t)) = Ty -> [Text]
fvt Ty
t :: [Text]
            getNodeDataCon :: DataCon -> (Def,Text,[Text])
            getNodeDataCon :: DataCon -> (Def, Text, [Text])
getNodeDataCon c :: DataCon
c@(DataCon Annote
_ Text
name Poly
_) =
                  (DataCon -> Def
DCon DataCon
c, Text
name, Text
ddef_name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: DataCon -> [Text]
dcon_fvs DataCon
c)

getNodeRec :: RecDefn -> (Def,Text,[Text])
getNodeRec :: RecDefn -> (Def, Text, [Text])
getNodeRec d :: RecDefn
d@(RecDefn Annote
_ Text
n [Text]
_ Poly
poly [(Text, Ty)]
fs) =
      (RecDefn -> Def
RDef RecDefn
d, Text
n, [Text]
deps)
      where
            deps :: [Text]
deps = Ty -> [Text]
fvt (case Poly
poly of Poly [Text]
_ Ty
t -> Ty
t) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ((Text, Ty) -> [Text]) -> [(Text, Ty)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Ty -> [Text]
fvt (Ty -> [Text]) -> ((Text, Ty) -> Ty) -> (Text, Ty) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Ty) -> Ty
forall a b. (a, b) -> b
snd) [(Text, Ty)]
fs

-- | Function to convert a qualified name to an unqualified name
unqualify :: Text -> Text
unqualify :: Text -> Text
unqualify Text
qualifiedName =
  case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn ([Char] -> Text
pack [Char]
".") Text
qualifiedName of
    [] -> Text
empty  -- handle unexpected empty case gracefully
    [Text]
parts -> [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
parts  -- take the last part after splitting by '.'

-- | Function to transform a node to use unqualified names in the second and third components
unqualifyNode :: (Def, Text, [Text]) -> (Def, Text, [Text])
unqualifyNode :: (Def, Text, [Text]) -> (Def, Text, [Text])
unqualifyNode (Def
def, Text
qualifiedName, [Text]
qualifiedList) =
  let unqualifiedName :: Text
unqualifiedName = Text -> Text
unqualify Text
qualifiedName
      unqualifiedList :: [Text]
unqualifiedList = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
unqualify [Text]
qualifiedList
  in (Def
def, Text
unqualifiedName, [Text]
unqualifiedList)


sortFreeProgram :: FreeProgram -> ([Declaration], Graph, [Tree Vertex])
sortFreeProgram :: FreeProgram -> ([Declaration], Graph, [Tree Vertex])
sortFreeProgram ([DataDefn]
datadefs,[RecDefn]
recdefs,[TypeSynonym]
tysns,[Defn]
defs) =
      let   [(Def, Text, [Text])]
nodes :: [(Def,Text,[Text])] = (DataDefn -> [(Def, Text, [Text])])
-> [DataDefn] -> [(Def, Text, [Text])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataDefn -> [(Def, Text, [Text])]
getNodeData [DataDefn]
datadefs [(Def, Text, [Text])]
-> [(Def, Text, [Text])] -> [(Def, Text, [Text])]
forall a. [a] -> [a] -> [a]
++ (RecDefn -> (Def, Text, [Text]))
-> [RecDefn] -> [(Def, Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map RecDefn -> (Def, Text, [Text])
getNodeRec [RecDefn]
recdefs [(Def, Text, [Text])]
-> [(Def, Text, [Text])] -> [(Def, Text, [Text])]
forall a. [a] -> [a] -> [a]
++  (TypeSynonym -> (Def, Text, [Text]))
-> [TypeSynonym] -> [(Def, Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map TypeSynonym -> (Def, Text, [Text])
getNodeTSyns [TypeSynonym]
tysns [(Def, Text, [Text])]
-> [(Def, Text, [Text])] -> [(Def, Text, [Text])]
forall a. [a] -> [a] -> [a]
++ (Defn -> (Def, Text, [Text])) -> [Defn] -> [(Def, Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map Defn -> (Def, Text, [Text])
getNodeDefn [Defn]
defs
            nodes' :: [(Def, Text, [Text])]
nodes' = ((Def, Text, [Text]) -> (Def, Text, [Text]))
-> [(Def, Text, [Text])] -> [(Def, Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (Def, Text, [Text]) -> (Def, Text, [Text])
unqualifyNode [(Def, Text, [Text])]
nodes
            (Graph
graph,Vertex -> (Def, Text, [Text])
getV,Text -> Maybe Vertex
_) = [(Def, Text, [Text])]
-> (Graph, Vertex -> (Def, Text, [Text]), Text -> Maybe Vertex)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges [(Def, Text, [Text])]
nodes'
            tree :: [Tree Vertex]
tree = Graph -> [Tree Vertex]
scc Graph
graph
      in
            ((Vertex -> Def) -> [Tree Vertex] -> [Declaration]
tree2decls ((\ (Def
d,Text
_,[Text]
_) -> Def
d) ((Def, Text, [Text]) -> Def)
-> (Vertex -> (Def, Text, [Text])) -> Vertex -> Def
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> (Def, Text, [Text])
getV) [Tree Vertex]
tree, Graph
graph, [Tree Vertex]
tree)
            where
            toDecl :: Tree Def -> Maybe Declaration
            toDecl :: Tree Def -> Maybe Declaration
toDecl = \ case
                  Node Def
d []                    -> Def -> Maybe Declaration
def2Decl Def
d
                  Node (Def Defn
d) ([Tree Def] -> [Defn]
toDecls -> [Defn]
ds) -> Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Declaration -> Maybe Declaration)
-> Declaration -> Maybe Declaration
forall a b. (a -> b) -> a -> b
$ [Defn] -> Declaration
mkRDecl (Defn
d Defn -> [Defn] -> [Defn]
forall a. a -> [a] -> [a]
: [Defn]
ds)
                  Tree Def
_ -> [Char] -> Maybe Declaration
forall a. HasCallStack => [Char] -> a
error [Char]
"ERROR: toDecl found non-fun mutual recursion"
            toDecls :: [Tree Def] -> [Defn]
            toDecls :: [Tree Def] -> [Defn]
toDecls = \ case
                 [] -> []
                 (Tree Def -> Maybe Declaration
toDecl -> Just (FDecl Defn
d)) : ([Tree Def] -> [Defn]
toDecls -> [Defn]
ds) -> Defn
d Defn -> [Defn] -> [Defn]
forall a. a -> [a] -> [a]
: [Defn]
ds
                 (Tree Def -> Maybe Declaration
toDecl -> Just (RDecl [Defn]
ds)) : ([Tree Def] -> [Defn]
toDecls -> [Defn]
ds')    -> [Defn]
ds [Defn] -> [Defn] -> [Defn]
forall a. [a] -> [a] -> [a]
++ [Defn]
ds'
                 [Tree Def]
_ -> [Char] -> [Defn]
forall a. HasCallStack => [Char] -> a
error [Char]
"ERROR: toDecls found non-fun mutual recursion"
            tree2decls :: (Vertex -> Def) -> [Tree Vertex] -> [Declaration]
            tree2decls :: (Vertex -> Def) -> [Tree Vertex] -> [Declaration]
tree2decls Vertex -> Def
f = (Tree Vertex -> Maybe Declaration)
-> [Tree Vertex] -> [Declaration]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Tree Def -> Maybe Declaration
toDecl (Tree Def -> Maybe Declaration)
-> (Tree Vertex -> Tree Def) -> Tree Vertex -> Maybe Declaration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex -> Def) -> Tree Vertex -> Tree Def
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vertex -> Def
f)