module Hydra.Ext.Haskell.Utils where

import Hydra.All
import Hydra.Adapters.Coders
import Hydra.Ext.Haskell.Language
import qualified Hydra.Ext.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}

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

hsapp :: H.Expression -> H.Expression -> H.Expression
hsapp :: Expression -> Expression -> Expression
hsapp Expression
l Expression
r = Expression_Application -> Expression
H.ExpressionApplication 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 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 forall a b. (a -> b) -> a -> b
$ [NamePart] -> NamePart -> QualifiedName
H.QualifiedName [NamePart
prefix] forall a b. (a -> b) -> a -> b
$ String -> NamePart
H.NamePart String
local
  where
    (Namespace String
ns, String
local) = Name -> (Namespace, String)
toQnameEager Name
name
    prefix :: NamePart
prefix = String -> NamePart
H.NamePart forall a b. (a -> b) -> a -> b
$ String -> String
capitalize forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
L.last 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 forall a b. (a -> b) -> a -> b
$ String -> Name
rawName String
s

namespacesForModule :: Module m -> Namespaces
namespacesForModule :: forall m. Module m -> Namespaces
namespacesForModule Module m
mod = (Namespace, ModuleName) -> Map Namespace ModuleName -> Namespaces
Namespaces (Namespace, ModuleName)
focusPair Map Namespace ModuleName
mapping
  where
    ns :: Namespace
ns = forall m. Module m -> Namespace
moduleNamespace Module m
mod
    focusPair :: (Namespace, ModuleName)
focusPair = Namespace -> (Namespace, ModuleName)
toPair Namespace
ns
    mapping :: Map Namespace ModuleName
mapping = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl forall {k}.
Ord k =>
(Map k ModuleName, Set ModuleName)
-> (k, ModuleName) -> (Map k ModuleName, Set ModuleName)
addPair (forall k a. Map k a
M.empty, forall a. Set a
S.empty) (Namespace -> (Namespace, ModuleName)
toPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toList (forall m. Bool -> Bool -> Bool -> Module m -> Set Namespace
moduleDependencyNamespaces Bool
True Bool
True Bool
True Module m
mod))
    toModuleName :: Namespace -> ModuleName
toModuleName (Namespace String
n) = String -> ModuleName
H.ModuleName forall a b. (a -> b) -> a -> b
$ String -> String
capitalize forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
L.last 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 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 forall a b. (a -> b) -> a -> b
$ String
aliasStr forall a. [a] -> [a] -> [a]
++ String
"_")
      else (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
name ModuleName
alias Map k ModuleName
m, 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" forall a. [a] -> [a] -> [a]
++ Name -> String
localNameOfEager Name
name

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

recordFieldReference :: Namespaces -> Name -> FieldName -> H.Name
recordFieldReference :: Namespaces -> Name -> FieldName -> Name
recordFieldReference Namespaces
namespaces Name
sname (FieldName String
fname) = Namespaces -> Name -> Name
elementReference Namespaces
namespaces forall a b. (a -> b) -> a -> b
$ Namespace -> String -> Name
fromQname (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Name -> (Namespace, String)
toQnameEager Name
sname) String
nm
  where
    nm :: String
nm = String -> String
decapitalize (Name -> String
typeNameForRecord Name
sname) forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
fname

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

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

toTypeApplication :: [H.Type] -> H.Type
toTypeApplication :: [Type] -> Type
toTypeApplication = [Type] -> Type
app forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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) = forall a. [a] -> a
L.last (String -> String -> [String]
Strings.splitOn String
"." String
sname)

unionFieldReference :: Namespaces -> Name -> FieldName -> H.Name
unionFieldReference :: Namespaces -> Name -> FieldName -> Name
unionFieldReference Namespaces
namespaces Name
sname (FieldName String
fname) = Namespaces -> Name -> Name
elementReference Namespaces
namespaces forall a b. (a -> b) -> a -> b
$ Namespace -> String -> Name
fromQname (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Name -> (Namespace, String)
toQnameEager Name
sname) String
nm
  where
    nm :: String
nm = String -> String
capitalize (Name -> String
typeNameForRecord Name
sname) forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
fname

unpackLambdaType :: Context m -> Type m -> ([VariableType], Type m)
unpackLambdaType :: forall m. Context m -> Type m -> ([VariableType], Type m)
unpackLambdaType Context m
cx Type m
t = case forall m. Type m -> Type m
stripType Type m
t of
  TypeLambda (LambdaType VariableType
v Type m
tbody) -> (VariableType
vforall a. a -> [a] -> [a]
:[VariableType]
vars, Type m
t')
    where
      ([VariableType]
vars, Type m
t') = forall m. Context m -> Type m -> ([VariableType], Type m)
unpackLambdaType Context m
cx Type m
tbody
  Type m
_ -> ([], Type m
t)