module Hydra.Langs.Haskell.Utils where

import Hydra.Kernel
import Hydra.Langs.Haskell.Language
import qualified Hydra.Langs.Haskell.Ast as H
import qualified Hydra.Lib.Strings as Strings

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S


data Namespaces = Namespaces {
  Namespaces -> (Namespace, ModuleName)
namespacesFocus :: (Namespace, H.ModuleName),
  Namespaces -> Map Namespace ModuleName
namespacesMapping :: M.Map Namespace H.ModuleName} deriving Int -> Namespaces -> ShowS
[Namespaces] -> ShowS
Namespaces -> String
(Int -> Namespaces -> ShowS)
-> (Namespaces -> String)
-> ([Namespaces] -> ShowS)
-> Show Namespaces
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Namespaces -> ShowS
showsPrec :: Int -> Namespaces -> ShowS
$cshow :: Namespaces -> String
show :: Namespaces -> String
$cshowList :: [Namespaces] -> ShowS
showList :: [Namespaces] -> ShowS
Show

applicationPattern :: Name -> [Pattern] -> Pattern
applicationPattern Name
name [Pattern]
args = Pattern_Application -> Pattern
H.PatternApplication (Pattern_Application -> Pattern) -> Pattern_Application -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> [Pattern] -> Pattern_Application
H.Pattern_Application Name
name [Pattern]
args

elementReference :: Namespaces -> Name -> H.Name
elementReference :: Namespaces -> Name -> Name
elementReference (Namespaces (Namespace
gname, H.ModuleName String
gmod) Map Namespace ModuleName
namespaces) Name
name = case (QualifiedName -> Maybe Namespace
qualifiedNameNamespace QualifiedName
qname) of
    Maybe Namespace
Nothing -> String -> Name
simpleName String
local
    Just Namespace
ns -> case Namespace -> Map Namespace ModuleName -> Maybe ModuleName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Namespace
ns Map Namespace ModuleName
namespaces of
      Maybe ModuleName
Nothing -> String -> Name
simpleName String
local
      Just (H.ModuleName String
a) -> if Namespace
ns Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Namespace
gname
         then String -> Name
simpleName String
escLocal
         else String -> Name
rawName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
escLocal
  where
    qname :: QualifiedName
qname = Name -> QualifiedName
qualifyNameEager Name
name
    local :: String
local = QualifiedName -> String
qualifiedNameLocal QualifiedName
qname
    escLocal :: String
escLocal = ShowS
sanitizeHaskellName String
local
    simple :: Name
simple = String -> Name
simpleName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ QualifiedName -> String
qualifiedNameLocal QualifiedName
qname

hsapp :: H.Expression -> H.Expression -> H.Expression
hsapp :: Expression -> Expression -> Expression
hsapp Expression
l Expression
r = Expression_Application -> Expression
H.ExpressionApplication (Expression_Application -> Expression)
-> Expression_Application -> Expression
forall a b. (a -> b) -> a -> b
$ Expression -> Expression -> Expression_Application
H.Expression_Application Expression
l Expression
r

hslambda :: String -> H.Expression -> H.Expression
hslambda :: String -> Expression -> Expression
hslambda String
v Expression
rhs = Expression_Lambda -> Expression
H.ExpressionLambda ([Pattern] -> Expression -> Expression_Lambda
H.Expression_Lambda [Name -> Pattern
H.PatternName (Name -> Pattern) -> Name -> Pattern
forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
v] Expression
rhs)

hslit :: H.Literal -> H.Expression
hslit :: Literal -> Expression
hslit = Literal -> Expression
H.ExpressionLiteral

hsPrimitiveReference :: Name -> H.Name
hsPrimitiveReference :: Name -> Name
hsPrimitiveReference Name
name = QualifiedName -> Name
H.NameNormal (QualifiedName -> Name) -> QualifiedName -> Name
forall a b. (a -> b) -> a -> b
$ [NamePart] -> NamePart -> QualifiedName
H.QualifiedName [NamePart
prefix] (NamePart -> QualifiedName) -> NamePart -> QualifiedName
forall a b. (a -> b) -> a -> b
$ String -> NamePart
H.NamePart String
local
  where
    QualifiedName (Just (Namespace String
ns)) String
local = Name -> QualifiedName
qualifyNameEager Name
name
    prefix :: NamePart
prefix = String -> NamePart
H.NamePart (String -> NamePart) -> String -> NamePart
forall a b. (a -> b) -> a -> b
$ ShowS
capitalize ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
L.last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
Strings.splitOn String
"/" String
ns

hsvar :: String -> H.Expression
hsvar :: String -> Expression
hsvar String
s = Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
s

namespacesForModule :: Module -> Flow (Graph) Namespaces
namespacesForModule :: Module -> Flow Graph Namespaces
namespacesForModule Module
mod = do
    Set Namespace
nss <- Bool
-> Bool -> Bool -> Bool -> Module -> Flow Graph (Set Namespace)
moduleDependencyNamespaces Bool
True Bool
True Bool
True Bool
True Module
mod
    Namespaces -> Flow Graph Namespaces
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Namespaces -> Flow Graph Namespaces)
-> Namespaces -> Flow Graph Namespaces
forall a b. (a -> b) -> a -> b
$ (Namespace, ModuleName) -> Map Namespace ModuleName -> Namespaces
Namespaces (Namespace, ModuleName)
focusPair (Map Namespace ModuleName -> Namespaces)
-> Map Namespace ModuleName -> Namespaces
forall a b. (a -> b) -> a -> b
$ (Map Namespace ModuleName, Set ModuleName)
-> Map Namespace ModuleName
forall a b. (a, b) -> a
fst ((Map Namespace ModuleName, Set ModuleName)
 -> Map Namespace ModuleName)
-> (Map Namespace ModuleName, Set ModuleName)
-> Map Namespace ModuleName
forall a b. (a -> b) -> a -> b
$ ((Map Namespace ModuleName, Set ModuleName)
 -> (Namespace, ModuleName)
 -> (Map Namespace ModuleName, Set ModuleName))
-> (Map Namespace ModuleName, Set ModuleName)
-> [(Namespace, ModuleName)]
-> (Map Namespace ModuleName, Set ModuleName)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (Map Namespace ModuleName, Set ModuleName)
-> (Namespace, ModuleName)
-> (Map Namespace ModuleName, Set ModuleName)
forall {k}.
Ord k =>
(Map k ModuleName, Set ModuleName)
-> (k, ModuleName) -> (Map k ModuleName, Set ModuleName)
addPair (Map Namespace ModuleName
forall k a. Map k a
M.empty, Set ModuleName
forall a. Set a
S.empty) (Namespace -> (Namespace, ModuleName)
toPair (Namespace -> (Namespace, ModuleName))
-> [Namespace] -> [(Namespace, ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Namespace -> [Namespace]
forall a. Set a -> [a]
S.toList Set Namespace
nss)
  where
    ns :: Namespace
ns = Module -> Namespace
moduleNamespace Module
mod
    focusPair :: (Namespace, ModuleName)
focusPair = Namespace -> (Namespace, ModuleName)
toPair Namespace
ns
    toModuleName :: Namespace -> ModuleName
toModuleName (Namespace String
n) = String -> ModuleName
H.ModuleName (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ ShowS
capitalize ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
L.last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
Strings.splitOn String
"/" String
n
    toPair :: Namespace -> (Namespace, ModuleName)
toPair Namespace
name = (Namespace
name, Namespace -> ModuleName
toModuleName Namespace
name)
    addPair :: (Map k ModuleName, Set ModuleName)
-> (k, ModuleName) -> (Map k ModuleName, Set ModuleName)
addPair (Map k ModuleName
m, Set ModuleName
s) (k
name, alias :: ModuleName
alias@(H.ModuleName String
aliasStr)) = if ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member ModuleName
alias Set ModuleName
s
      then (Map k ModuleName, Set ModuleName)
-> (k, ModuleName) -> (Map k ModuleName, Set ModuleName)
addPair (Map k ModuleName
m, Set ModuleName
s) (k
name, String -> ModuleName
H.ModuleName (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ String
aliasStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_")
      else (k -> ModuleName -> Map k ModuleName -> Map k ModuleName
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
name ModuleName
alias Map k ModuleName
m, ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => a -> Set a -> Set a
S.insert ModuleName
alias Set ModuleName
s)

newtypeAccessorName :: Name -> String
newtypeAccessorName :: Name -> String
newtypeAccessorName Name
name = String
"un" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
localNameOfEager Name
name

rawName :: String -> H.Name
rawName :: String -> Name
rawName String
n = QualifiedName -> Name
H.NameNormal (QualifiedName -> Name) -> QualifiedName -> Name
forall a b. (a -> b) -> a -> b
$ [NamePart] -> NamePart -> QualifiedName
H.QualifiedName [] (NamePart -> QualifiedName) -> NamePart -> QualifiedName
forall a b. (a -> b) -> a -> b
$ String -> NamePart
H.NamePart String
n

recordFieldReference :: Namespaces -> Name -> Name -> H.Name
recordFieldReference :: Namespaces -> Name -> Name -> Name
recordFieldReference Namespaces
namespaces Name
sname (Name String
fname) = Namespaces -> Name -> Name
elementReference Namespaces
namespaces (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$
    QualifiedName -> Name
unqualifyName (QualifiedName -> Name) -> QualifiedName -> Name
forall a b. (a -> b) -> a -> b
$ Maybe Namespace -> String -> QualifiedName
QualifiedName (QualifiedName -> Maybe Namespace
qualifiedNameNamespace (QualifiedName -> Maybe Namespace)
-> QualifiedName -> Maybe Namespace
forall a b. (a -> b) -> a -> b
$ Name -> QualifiedName
qualifyNameEager Name
sname) String
nm
  where
    nm :: String
nm = ShowS
decapitalize (Name -> String
typeNameForRecord Name
sname) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
fname

sanitizeHaskellName :: String -> String
sanitizeHaskellName :: ShowS
sanitizeHaskellName = Set String -> ShowS
sanitizeWithUnderscores Set String
reservedWords

simpleName :: String -> H.Name
simpleName :: String -> Name
simpleName = String -> Name
rawName (String -> Name) -> ShowS -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sanitizeHaskellName

simpleValueBinding :: H.Name -> H.Expression -> Maybe H.LocalBindings -> H.ValueBinding
simpleValueBinding :: Name -> Expression -> Maybe LocalBindings -> ValueBinding
simpleValueBinding Name
hname Expression
rhs Maybe LocalBindings
bindings = ValueBinding_Simple -> ValueBinding
H.ValueBindingSimple (ValueBinding_Simple -> ValueBinding)
-> ValueBinding_Simple -> ValueBinding
forall a b. (a -> b) -> a -> b
$ Pattern
-> RightHandSide -> Maybe LocalBindings -> ValueBinding_Simple
H.ValueBinding_Simple Pattern
pat (Expression -> RightHandSide
H.RightHandSide Expression
rhs) Maybe LocalBindings
bindings
  where
    pat :: Pattern
pat = Pattern_Application -> Pattern
H.PatternApplication (Pattern_Application -> Pattern) -> Pattern_Application -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> [Pattern] -> Pattern_Application
H.Pattern_Application Name
hname []

toTypeApplication :: [H.Type] -> H.Type
toTypeApplication :: [Type] -> Type
toTypeApplication = [Type] -> Type
app ([Type] -> Type) -> ([Type] -> [Type]) -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> [Type]
forall a. [a] -> [a]
L.reverse
  where
    app :: [Type] -> Type
app [Type]
l = case [Type]
l of
      [Type
e] -> Type
e
      (Type
h:[Type]
r) -> Type_Application -> Type
H.TypeApplication (Type_Application -> Type) -> Type_Application -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type_Application
H.Type_Application ([Type] -> Type
app [Type]
r) Type
h

typeNameForRecord :: Name -> String
typeNameForRecord :: Name -> String
typeNameForRecord (Name String
sname) = [String] -> String
forall a. HasCallStack => [a] -> a
L.last (String -> String -> [String]
Strings.splitOn String
"." String
sname)

unionFieldReference :: Namespaces -> Name -> Name -> H.Name
unionFieldReference :: Namespaces -> Name -> Name -> Name
unionFieldReference Namespaces
namespaces Name
sname (Name String
fname) = Namespaces -> Name -> Name
elementReference Namespaces
namespaces (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$
    QualifiedName -> Name
unqualifyName (QualifiedName -> Name) -> QualifiedName -> Name
forall a b. (a -> b) -> a -> b
$ Maybe Namespace -> String -> QualifiedName
QualifiedName Maybe Namespace
ns String
nm
  where
    ns :: Maybe Namespace
ns = QualifiedName -> Maybe Namespace
qualifiedNameNamespace (QualifiedName -> Maybe Namespace)
-> QualifiedName -> Maybe Namespace
forall a b. (a -> b) -> a -> b
$ Name -> QualifiedName
qualifyNameEager Name
sname
    nm :: String
nm = ShowS
capitalize (Name -> String
typeNameForRecord Name
sname) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
fname

unpackLambdaType :: Graph -> Type -> ([Name], Type)
unpackLambdaType :: Graph -> Type -> ([Name], Type)
unpackLambdaType Graph
cx Type
t = case Type -> Type
stripType Type
t of
  TypeLambda (LambdaType Name
v Type
tbody) -> (Name
vName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
vars, Type
t')
    where
      ([Name]
vars, Type
t') = Graph -> Type -> ([Name], Type)
unpackLambdaType Graph
cx Type
tbody
  Type
_ -> ([], Type
t)