{- |
    Module      :  $Header$
    Description :  Generation of FlatCurry program and interface terms
    Copyright   :  (c) 2017        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module contains the generation of a 'FlatCurry' program term or
    a 'FlatCurry' interface out of an 'Annotated FlatCurry' module.
-}
module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where

import Curry.FlatCurry.Goodies
import Curry.FlatCurry.Type
import Curry.FlatCurry.Annotated.Goodies
import Curry.FlatCurry.Annotated.Type

-- transforms annotated FlatCurry code to FlatCurry code
genFlatCurry :: AProg TypeExpr -> Prog
genFlatCurry :: AProg TypeExpr -> Prog
genFlatCurry = (String
 -> [String]
 -> [TypeDecl]
 -> [AFuncDecl TypeExpr]
 -> [OpDecl]
 -> Prog)
-> AProg TypeExpr -> Prog
forall a b.
(String
 -> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> b)
-> AProg a -> b
trAProg
  (\name :: String
name imps :: [String]
imps types :: [TypeDecl]
types funcs :: [AFuncDecl TypeExpr]
funcs ops :: [OpDecl]
ops ->
    String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> Prog
Prog String
name [String]
imps [TypeDecl]
types ((AFuncDecl TypeExpr -> FuncDecl)
-> [AFuncDecl TypeExpr] -> [FuncDecl]
forall a b. (a -> b) -> [a] -> [b]
map AFuncDecl TypeExpr -> FuncDecl
genFlatFuncDecl [AFuncDecl TypeExpr]
funcs) [OpDecl]
ops)

genFlatFuncDecl :: AFuncDecl TypeExpr -> FuncDecl
genFlatFuncDecl :: AFuncDecl TypeExpr -> FuncDecl
genFlatFuncDecl = (QName
 -> Int -> Visibility -> TypeExpr -> ARule TypeExpr -> FuncDecl)
-> AFuncDecl TypeExpr -> FuncDecl
forall a b.
(QName -> Int -> Visibility -> TypeExpr -> ARule a -> b)
-> AFuncDecl a -> b
trAFunc
  (\name :: QName
name arity :: Int
arity vis :: Visibility
vis ty :: TypeExpr
ty rule :: ARule TypeExpr
rule -> QName -> Int -> Visibility -> TypeExpr -> Rule -> FuncDecl
Func QName
name Int
arity Visibility
vis TypeExpr
ty (Rule -> FuncDecl) -> Rule -> FuncDecl
forall a b. (a -> b) -> a -> b
$ ARule TypeExpr -> Rule
genFlatRule ARule TypeExpr
rule)

genFlatRule :: ARule TypeExpr -> Rule
genFlatRule :: ARule TypeExpr -> Rule
genFlatRule = (TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> Rule)
-> (TypeExpr -> String -> Rule) -> ARule TypeExpr -> Rule
forall a b.
(a -> [(Int, a)] -> AExpr a -> b)
-> (a -> String -> b) -> ARule a -> b
trARule
  (\_ args :: [(Int, TypeExpr)]
args e :: AExpr TypeExpr
e -> [Int] -> Expr -> Rule
Rule (((Int, TypeExpr) -> Int) -> [(Int, TypeExpr)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst [(Int, TypeExpr)]
args) (Expr -> Rule) -> Expr -> Rule
forall a b. (a -> b) -> a -> b
$ AExpr TypeExpr -> Expr
genFlatExpr AExpr TypeExpr
e)
  ((String -> Rule) -> TypeExpr -> String -> Rule
forall a b. a -> b -> a
const String -> Rule
External)

genFlatExpr :: AExpr TypeExpr -> Expr
genFlatExpr :: AExpr TypeExpr -> Expr
genFlatExpr = (TypeExpr -> Int -> Expr)
-> (TypeExpr -> Literal -> Expr)
-> (TypeExpr -> CombType -> (QName, TypeExpr) -> [Expr] -> Expr)
-> (TypeExpr -> [((Int, TypeExpr), Expr)] -> Expr -> Expr)
-> (TypeExpr -> [(Int, TypeExpr)] -> Expr -> Expr)
-> (TypeExpr -> Expr -> Expr -> Expr)
-> (TypeExpr -> CaseType -> Expr -> [BranchExpr] -> Expr)
-> (APattern TypeExpr -> Expr -> BranchExpr)
-> (TypeExpr -> Expr -> TypeExpr -> Expr)
-> AExpr TypeExpr
-> Expr
forall a b c.
(a -> Int -> b)
-> (a -> Literal -> b)
-> (a -> CombType -> (QName, a) -> [b] -> b)
-> (a -> [((Int, a), b)] -> b -> b)
-> (a -> [(Int, a)] -> b -> b)
-> (a -> b -> b -> b)
-> (a -> CaseType -> b -> [c] -> b)
-> (APattern a -> b -> c)
-> (a -> b -> TypeExpr -> b)
-> AExpr a
-> b
trAExpr
  ((Int -> Expr) -> TypeExpr -> Int -> Expr
forall a b. a -> b -> a
const Int -> Expr
Var)
  ((Literal -> Expr) -> TypeExpr -> Literal -> Expr
forall a b. a -> b -> a
const Literal -> Expr
Lit)
  (\_ ct :: CombType
ct (name :: QName
name, _) args :: [Expr]
args -> CombType -> QName -> [Expr] -> Expr
Comb CombType
ct QName
name [Expr]
args)
  (([((Int, TypeExpr), Expr)] -> Expr -> Expr)
-> TypeExpr -> [((Int, TypeExpr), Expr)] -> Expr -> Expr
forall a b. a -> b -> a
const (([((Int, TypeExpr), Expr)] -> Expr -> Expr)
 -> TypeExpr -> [((Int, TypeExpr), Expr)] -> Expr -> Expr)
-> ([((Int, TypeExpr), Expr)] -> Expr -> Expr)
-> TypeExpr
-> [((Int, TypeExpr), Expr)]
-> Expr
-> Expr
forall a b. (a -> b) -> a -> b
$ [(Int, Expr)] -> Expr -> Expr
Let ([(Int, Expr)] -> Expr -> Expr)
-> ([((Int, TypeExpr), Expr)] -> [(Int, Expr)])
-> [((Int, TypeExpr), Expr)]
-> Expr
-> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Int, TypeExpr), Expr) -> (Int, Expr))
-> [((Int, TypeExpr), Expr)] -> [(Int, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: (Int, TypeExpr)
v, e' :: Expr
e') -> ((Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst (Int, TypeExpr)
v, Expr
e')))
  (([(Int, TypeExpr)] -> Expr -> Expr)
-> TypeExpr -> [(Int, TypeExpr)] -> Expr -> Expr
forall a b. a -> b -> a
const (([(Int, TypeExpr)] -> Expr -> Expr)
 -> TypeExpr -> [(Int, TypeExpr)] -> Expr -> Expr)
-> ([(Int, TypeExpr)] -> Expr -> Expr)
-> TypeExpr
-> [(Int, TypeExpr)]
-> Expr
-> Expr
forall a b. (a -> b) -> a -> b
$ [Int] -> Expr -> Expr
Free ([Int] -> Expr -> Expr)
-> ([(Int, TypeExpr)] -> [Int])
-> [(Int, TypeExpr)]
-> Expr
-> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, TypeExpr) -> Int) -> [(Int, TypeExpr)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst)
  ((Expr -> Expr -> Expr) -> TypeExpr -> Expr -> Expr -> Expr
forall a b. a -> b -> a
const Expr -> Expr -> Expr
Or)
  ((CaseType -> Expr -> [BranchExpr] -> Expr)
-> TypeExpr -> CaseType -> Expr -> [BranchExpr] -> Expr
forall a b. a -> b -> a
const CaseType -> Expr -> [BranchExpr] -> Expr
Case)
  (Pattern -> Expr -> BranchExpr
Branch (Pattern -> Expr -> BranchExpr)
-> (APattern TypeExpr -> Pattern)
-> APattern TypeExpr
-> Expr
-> BranchExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. APattern TypeExpr -> Pattern
genFlatPattern)
  ((Expr -> TypeExpr -> Expr) -> TypeExpr -> Expr -> TypeExpr -> Expr
forall a b. a -> b -> a
const Expr -> TypeExpr -> Expr
Typed)

genFlatPattern :: APattern TypeExpr -> Pattern
genFlatPattern :: APattern TypeExpr -> Pattern
genFlatPattern = (TypeExpr -> (QName, TypeExpr) -> [(Int, TypeExpr)] -> Pattern)
-> (TypeExpr -> Literal -> Pattern) -> APattern TypeExpr -> Pattern
forall a b.
(a -> (QName, a) -> [(Int, a)] -> b)
-> (a -> Literal -> b) -> APattern a -> b
trAPattern
  (\_ (name :: QName
name, _) args :: [(Int, TypeExpr)]
args -> QName -> [Int] -> Pattern
Pattern QName
name ([Int] -> Pattern) -> [Int] -> Pattern
forall a b. (a -> b) -> a -> b
$ ((Int, TypeExpr) -> Int) -> [(Int, TypeExpr)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst [(Int, TypeExpr)]
args)
  ((Literal -> Pattern) -> TypeExpr -> Literal -> Pattern
forall a b. a -> b -> a
const Literal -> Pattern
LPattern)

-- transforms a FlatCurry module to a FlatCurry interface
genFlatInterface :: Prog -> Prog
genFlatInterface :: Prog -> Prog
genFlatInterface =
  Update Prog [FuncDecl]
updProgFuncs Update Prog [FuncDecl] -> Update Prog [FuncDecl]
forall a b. (a -> b) -> a -> b
$ (FuncDecl -> FuncDecl) -> [FuncDecl] -> [FuncDecl]
forall a b. (a -> b) -> [a] -> [b]
map ((FuncDecl -> FuncDecl) -> [FuncDecl] -> [FuncDecl])
-> (FuncDecl -> FuncDecl) -> [FuncDecl] -> [FuncDecl]
forall a b. (a -> b) -> a -> b
$ Update FuncDecl Rule
updFuncRule Update FuncDecl Rule -> Update FuncDecl Rule
forall a b. (a -> b) -> a -> b
$ Rule -> Rule -> Rule
forall a b. a -> b -> a
const (Rule -> Rule -> Rule) -> Rule -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$ [Int] -> Expr -> Rule
Rule [] (Expr -> Rule) -> Expr -> Rule
forall a b. (a -> b) -> a -> b
$ Int -> Expr
Var 0