{- |
    Module      :  $Header$
    Description :  Generation of typed FlatCurry program terms
    Copyright   :  (c) 2017        Finn Teegen
                       2018        Kai-Oliver Prott
    License     :  BSD-3-clause

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

    This module contains the generation of a type-annotated 'FlatCurry'
    program term for a given module in the intermediate language.
-}
{-# LANGUAGE CPP #-}
module Generators.GenAnnotatedFlatCurry (genAnnotatedFlatCurry) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative        ((<$>), (<*>))
#endif
import           Control.Monad              ((<=<))
import           Control.Monad.Extra        (concatMapM)
import qualified Control.Monad.State as S   ( State, evalState, get, gets
                                            , modify, put )
import           Data.Function              (on)
import           Data.List                  (nub, sortBy)
import           Data.Maybe                 (fromMaybe)
import qualified Data.Map            as Map (Map, empty, insert, lookup)
import qualified Data.Set            as Set (Set, empty, insert, member)

import           Curry.Base.Ident
import           Curry.FlatCurry.Annotated.Goodies (typeName)
import           Curry.FlatCurry.Annotated.Type
import qualified Curry.Syntax as CS

import Base.Messages       (internalError)
import Base.NestEnv        ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv
                           , nestEnv, unnestEnv )
import Base.Types

import CompilerEnv
import Env.TypeConstructor (TCEnv)

import qualified IL

-- transforms intermediate language code (IL) to type-annotated FlatCurry code
genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
                  -> AProg TypeExpr
genAnnotatedFlatCurry :: CompilerEnv -> Module Type -> Module -> AProg TypeExpr
genAnnotatedFlatCurry env :: CompilerEnv
env mdl :: Module Type
mdl il :: Module
il = AProg TypeExpr -> AProg TypeExpr
forall a. AProg a -> AProg a
patchPrelude (AProg TypeExpr -> AProg TypeExpr)
-> AProg TypeExpr -> AProg TypeExpr
forall a b. (a -> b) -> a -> b
$ CompilerEnv
-> Module Type -> FlatState (AProg TypeExpr) -> AProg TypeExpr
forall a. CompilerEnv -> Module Type -> FlatState a -> a
run CompilerEnv
env Module Type
mdl (Module -> FlatState (AProg TypeExpr)
trModule Module
il)

-- -----------------------------------------------------------------------------
-- Addition of primitive types for lists and tuples to the Prelude
-- -----------------------------------------------------------------------------

patchPrelude :: AProg a -> AProg a
patchPrelude :: AProg a -> AProg a
patchPrelude p :: AProg a
p@(AProg n :: String
n _ ts :: [TypeDecl]
ts fs :: [AFuncDecl a]
fs os :: [OpDecl]
os)
  | String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
prelude = String
-> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> AProg a
forall a.
String
-> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> AProg a
AProg String
n [] [TypeDecl]
ts' [AFuncDecl a]
fs [OpDecl]
os
  | Bool
otherwise    = AProg a
p
  where ts' :: [TypeDecl]
ts' = (TypeDecl -> TypeDecl -> Ordering) -> [TypeDecl] -> [TypeDecl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (QName -> QName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (QName -> QName -> Ordering)
-> (TypeDecl -> QName) -> TypeDecl -> TypeDecl -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TypeDecl -> QName
typeName) [TypeDecl]
pts
        pts :: [TypeDecl]
pts = [TypeDecl]
primTypes [TypeDecl] -> [TypeDecl] -> [TypeDecl]
forall a. [a] -> [a] -> [a]
++ [TypeDecl]
ts

primTypes :: [TypeDecl]
primTypes :: [TypeDecl]
primTypes =
  [ QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
arrow Visibility
Public [(0, Kind
KStar), (1, Kind
KStar)] []
  , QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
unit Visibility
Public [] [(QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
unit 0 Visibility
Public [])]
  , QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
nil Visibility
Public [(0, Kind
KStar)] [ QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
nil  0 Visibility
Public []
                                 , QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
cons 2 Visibility
Public [Int -> TypeExpr
TVar 0, QName -> [TypeExpr] -> TypeExpr
TCons QName
nil [Int -> TypeExpr
TVar 0]]
                                 ]
  ] [TypeDecl] -> [TypeDecl] -> [TypeDecl]
forall a. [a] -> [a] -> [a]
++ (Int -> TypeDecl) -> [Int] -> [TypeDecl]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TypeDecl
mkTupleType [2 .. Int
maxTupleArity]
  where arrow :: QName
arrow = String -> QName
mkPreludeQName "(->)"
        unit :: QName
unit  = String -> QName
mkPreludeQName "()"
        nil :: QName
nil   = String -> QName
mkPreludeQName "[]"
        cons :: QName
cons  = String -> QName
mkPreludeQName ":"

mkTupleType :: Int -> TypeDecl
mkTupleType :: Int -> TypeDecl
mkTupleType arity :: Int
arity = QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
tuple Visibility
Public [(Int
i, Kind
KStar) | Int
i <- [0 .. Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]]
  [QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
tuple Int
arity Visibility
Public ([TypeExpr] -> ConsDecl) -> [TypeExpr] -> ConsDecl
forall a b. (a -> b) -> a -> b
$ (Int -> TypeExpr) -> [Int] -> [TypeExpr]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TypeExpr
TVar [0 .. Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]]
  where tuple :: QName
tuple = String -> QName
mkPreludeQName (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ '(' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) ',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"

mkPreludeQName :: String -> QName
mkPreludeQName :: String -> QName
mkPreludeQName n :: String
n = (String
prelude, String
n)

prelude :: String
prelude :: String
prelude = "Prelude"

-- |Maximal arity of tuples
maxTupleArity :: Int
maxTupleArity :: Int
maxTupleArity = 15

-- -----------------------------------------------------------------------------

-- The environment 'FlatEnv' is embedded in the monadic representation
-- 'FlatState' which allows the usage of 'do' expressions.
type FlatState a = S.State FlatEnv a

-- Data type for representing an environment which contains information needed
-- for generating FlatCurry code.
data FlatEnv = FlatEnv
  { FlatEnv -> ModuleIdent
modIdent     :: ModuleIdent      -- current module
  -- for visibility calculation
  , FlatEnv -> Set Ident
tyExports    :: Set.Set Ident    -- exported types
  , FlatEnv -> Set Ident
valExports   :: Set.Set Ident    -- exported values (functions + constructors)
  , FlatEnv -> TCEnv
tcEnv        :: TCEnv            -- type constructor environment
  , FlatEnv -> [Decl Type]
typeSynonyms :: [CS.Decl Type]   -- type synonyms
  , FlatEnv -> [ModuleIdent]
imports      :: [ModuleIdent]    -- module imports
  -- state for mapping identifiers to indexes
  , FlatEnv -> Int
nextVar      :: Int              -- fresh variable index counter
  , FlatEnv -> NestEnv Int
varMap       :: NestEnv VarIndex -- map of identifier to variable index
  }

-- Runs a 'FlatState' action and returns the result
run :: CompilerEnv -> CS.Module Type -> FlatState a -> a
run :: CompilerEnv -> Module Type -> FlatState a -> a
run env :: CompilerEnv
env (CS.Module _ _ _ mid :: ModuleIdent
mid es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl Type]
ds) act :: FlatState a
act = FlatState a -> FlatEnv -> a
forall s a. State s a -> s -> a
S.evalState FlatState a
act FlatEnv
env0
  where
  es' :: [Export]
es'  = case Maybe ExportSpec
es of Just (CS.Exporting _ e :: [Export]
e) -> [Export]
e
                    _                       -> []
  env0 :: FlatEnv
env0 = FlatEnv :: ModuleIdent
-> Set Ident
-> Set Ident
-> TCEnv
-> [Decl Type]
-> [ModuleIdent]
-> Int
-> NestEnv Int
-> FlatEnv
FlatEnv
    { modIdent :: ModuleIdent
modIdent     = ModuleIdent
mid
     -- for visibility calculation
    , tyExports :: Set Ident
tyExports  = (Export -> Set Ident -> Set Ident)
-> Set Ident -> [Export] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Export -> Set Ident -> Set Ident
buildTypeExports  ModuleIdent
mid) Set Ident
forall a. Set a
Set.empty [Export]
es'
    , valExports :: Set Ident
valExports = (Export -> Set Ident -> Set Ident)
-> Set Ident -> [Export] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Export -> Set Ident -> Set Ident
buildValueExports ModuleIdent
mid) Set Ident
forall a. Set a
Set.empty [Export]
es'
    -- This includes *all* imports, even unused ones
    , imports :: [ModuleIdent]
imports      = [ModuleIdent] -> [ModuleIdent]
forall a. Eq a => [a] -> [a]
nub [ ModuleIdent
m | CS.ImportDecl _ m :: ModuleIdent
m _ _ _ <- [ImportDecl]
is ]
    -- Environment to retrieve the type of identifiers
    , tcEnv :: TCEnv
tcEnv        = CompilerEnv -> TCEnv
tyConsEnv CompilerEnv
env
    -- Type synonyms in the module
    , typeSynonyms :: [Decl Type]
typeSynonyms = [ Decl Type
d | d :: Decl Type
d@CS.TypeDecl{} <- [Decl Type]
ds ]
    , nextVar :: Int
nextVar      = 0
    , varMap :: NestEnv Int
varMap       = NestEnv Int
forall a. NestEnv a
emptyEnv
    }

-- Builds a table containing all exported identifiers from a module.
buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident
buildTypeExports :: ModuleIdent -> Export -> Set Ident -> Set Ident
buildTypeExports mid :: ModuleIdent
mid (CS.ExportTypeWith _ tc :: QualIdent
tc _)
  | ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
tc = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert (QualIdent -> Ident
unqualify QualIdent
tc)
buildTypeExports _   _  = Set Ident -> Set Ident
forall a. a -> a
id

-- Builds a table containing all exported identifiers from a module.
buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident
buildValueExports :: ModuleIdent -> Export -> Set Ident -> Set Ident
buildValueExports mid :: ModuleIdent
mid (CS.Export         _     q :: QualIdent
q)
  | ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
q  = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert (QualIdent -> Ident
unqualify QualIdent
q)
buildValueExports mid :: ModuleIdent
mid (CS.ExportTypeWith _ tc :: QualIdent
tc cs :: [Ident]
cs)
  | ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
tc = (Set Ident -> [Ident] -> Set Ident)
-> [Ident] -> Set Ident -> Set Ident
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> Set Ident -> Set Ident)
-> Set Ident -> [Ident] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert) [Ident]
cs
buildValueExports _   _  = Set Ident -> Set Ident
forall a. a -> a
id

getModuleIdent :: FlatState ModuleIdent
getModuleIdent :: FlatState ModuleIdent
getModuleIdent = (FlatEnv -> ModuleIdent) -> FlatState ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> ModuleIdent
modIdent

-- Retrieve imports
getImports :: [ModuleIdent] -> FlatState [String]
getImports :: [ModuleIdent] -> FlatState [String]
getImports imps :: [ModuleIdent]
imps = ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([ModuleIdent] -> [String]) -> [ModuleIdent] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleIdent -> String) -> [ModuleIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleIdent -> String
moduleName ([ModuleIdent] -> [String])
-> ([ModuleIdent] -> [ModuleIdent]) -> [ModuleIdent] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ModuleIdent]
imps [ModuleIdent] -> [ModuleIdent] -> [ModuleIdent]
forall a. [a] -> [a] -> [a]
++)) ([ModuleIdent] -> [String])
-> StateT FlatEnv Identity [ModuleIdent] -> FlatState [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlatEnv -> [ModuleIdent]) -> StateT FlatEnv Identity [ModuleIdent]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> [ModuleIdent]
imports

-- -----------------------------------------------------------------------------
-- Stateful part, used for translation of rules and expressions
-- -----------------------------------------------------------------------------

-- resets var index and environment
withFreshEnv :: FlatState a -> FlatState a
withFreshEnv :: FlatState a -> FlatState a
withFreshEnv act :: FlatState a
act = (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify (\ s :: FlatEnv
s -> FlatEnv
s { nextVar :: Int
nextVar = 0, varMap :: NestEnv Int
varMap = NestEnv Int
forall a. NestEnv a
emptyEnv }) StateT FlatEnv Identity () -> FlatState a -> FlatState a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FlatState a
act

-- Execute an action in a nested variable mapping
inNestedEnv :: FlatState a -> FlatState a
inNestedEnv :: FlatState a -> FlatState a
inNestedEnv act :: FlatState a
act = do
  (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ())
-> (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \ s :: FlatEnv
s -> FlatEnv
s { varMap :: NestEnv Int
varMap = NestEnv Int -> NestEnv Int
forall a. NestEnv a -> NestEnv a
nestEnv   (NestEnv Int -> NestEnv Int) -> NestEnv Int -> NestEnv Int
forall a b. (a -> b) -> a -> b
$ FlatEnv -> NestEnv Int
varMap FlatEnv
s }
  a
res <- FlatState a
act
  (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ())
-> (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \ s :: FlatEnv
s -> FlatEnv
s { varMap :: NestEnv Int
varMap = NestEnv Int -> NestEnv Int
forall a. NestEnv a -> NestEnv a
unnestEnv (NestEnv Int -> NestEnv Int) -> NestEnv Int -> NestEnv Int
forall a b. (a -> b) -> a -> b
$ FlatEnv -> NestEnv Int
varMap FlatEnv
s }
  a -> FlatState a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- Generates a new variable index for an identifier
newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)
newVar :: Type -> Ident -> FlatState (Int, TypeExpr)
newVar ty :: Type
ty i :: Ident
i = do
  Int
idx <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Int -> Int)
-> StateT FlatEnv Identity Int -> StateT FlatEnv Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlatEnv -> Int) -> StateT FlatEnv Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> Int
nextVar
  (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ())
-> (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \ s :: FlatEnv
s -> FlatEnv
s { nextVar :: Int
nextVar = Int
idx, varMap :: NestEnv Int
varMap = Ident -> Int -> NestEnv Int -> NestEnv Int
forall a. Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv Ident
i Int
idx (FlatEnv -> NestEnv Int
varMap FlatEnv
s) }
  TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
  (Int, TypeExpr) -> FlatState (Int, TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
idx, TypeExpr
ty')

-- Retrieve the variable index assigned to an identifier
getVarIndex :: Ident -> FlatState VarIndex
getVarIndex :: Ident -> StateT FlatEnv Identity Int
getVarIndex i :: Ident
i = (FlatEnv -> NestEnv Int) -> StateT FlatEnv Identity (NestEnv Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> NestEnv Int
varMap StateT FlatEnv Identity (NestEnv Int)
-> (NestEnv Int -> StateT FlatEnv Identity Int)
-> StateT FlatEnv Identity Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ varEnv :: NestEnv Int
varEnv -> case Ident -> NestEnv Int -> [Int]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
i NestEnv Int
varEnv of
  [v :: Int
v] -> Int -> StateT FlatEnv Identity Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
v
  _   -> String -> StateT FlatEnv Identity Int
forall a. String -> a
internalError (String -> StateT FlatEnv Identity Int)
-> String -> StateT FlatEnv Identity Int
forall a b. (a -> b) -> a -> b
$ "GenTypeAnnotatedFlatCurry.getVarIndex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
escName Ident
i

-- -----------------------------------------------------------------------------
-- Translation of a module
-- -----------------------------------------------------------------------------

trModule :: IL.Module -> FlatState (AProg TypeExpr)
trModule :: Module -> FlatState (AProg TypeExpr)
trModule (IL.Module mid :: ModuleIdent
mid is :: [ModuleIdent]
is ds :: [Decl]
ds) = do
  [String]
is' <- [ModuleIdent] -> FlatState [String]
getImports [ModuleIdent]
is
  [TypeDecl]
tds <- (Decl -> StateT FlatEnv Identity [TypeDecl])
-> [Decl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl -> StateT FlatEnv Identity [TypeDecl]
trTypeDecl [Decl]
ds
  [AFuncDecl TypeExpr]
fds <- (Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> [Decl] -> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ([AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([AFuncDecl TypeExpr]
 -> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> ([AFuncDecl TypeExpr] -> [AFuncDecl TypeExpr])
-> [AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AFuncDecl TypeExpr -> AFuncDecl TypeExpr)
-> [AFuncDecl TypeExpr] -> [AFuncDecl TypeExpr]
forall a b. (a -> b) -> [a] -> [b]
map AFuncDecl TypeExpr -> AFuncDecl TypeExpr
forall a. Normalize a => a -> a
runNormalization ([AFuncDecl TypeExpr]
 -> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> (Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> Decl
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr]
trAFuncDecl) [Decl]
ds
  AProg TypeExpr -> FlatState (AProg TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AProg TypeExpr -> FlatState (AProg TypeExpr))
-> AProg TypeExpr -> FlatState (AProg TypeExpr)
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> [TypeDecl]
-> [AFuncDecl TypeExpr]
-> [OpDecl]
-> AProg TypeExpr
forall a.
String
-> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> AProg a
AProg (ModuleIdent -> String
moduleName ModuleIdent
mid) [String]
is' [TypeDecl]
tds [AFuncDecl TypeExpr]
fds []

-- Translate a data declaration
-- For empty data declarations, an additional constructor is generated. This
-- is due to the fact that external data declarations are translated into data
-- declarations with zero constructors and without the additional constructor
-- empty data declarations could not be distinguished from external ones.
trTypeDecl :: IL.Decl -> FlatState [TypeDecl]
trTypeDecl :: Decl -> StateT FlatEnv Identity [TypeDecl]
trTypeDecl (IL.DataDecl      qid :: QualIdent
qid ks :: [Kind]
ks []) = do
  QName
q'  <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
  Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
  QName
c   <- QualIdent -> FlatState QName
trQualIdent (QualIdent -> FlatState QName) -> QualIdent -> FlatState QName
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify (String -> Ident
mkIdent (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ "_Constr#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
idName (QualIdent -> Ident
unqualify QualIdent
qid))
  let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
      tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
  [TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [TVarWithKind]
tvs [QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
c 1 Visibility
Private [QName -> [TypeExpr] -> TypeExpr
TCons QName
q' ([TypeExpr] -> TypeExpr) -> [TypeExpr] -> TypeExpr
forall a b. (a -> b) -> a -> b
$ Int -> TypeExpr
TVar (Int -> TypeExpr)
-> (TVarWithKind -> Int) -> TVarWithKind -> TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVarWithKind -> Int
forall a b. (a, b) -> a
fst (TVarWithKind -> TypeExpr) -> [TVarWithKind] -> [TypeExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TVarWithKind]
tvs]]]
trTypeDecl (IL.DataDecl      qid :: QualIdent
qid ks :: [Kind]
ks cs :: [ConstrDecl]
cs) = do
  QName
q'  <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
  Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
  [ConsDecl]
cs' <- (ConstrDecl -> StateT FlatEnv Identity ConsDecl)
-> [ConstrDecl] -> StateT FlatEnv Identity [ConsDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstrDecl -> StateT FlatEnv Identity ConsDecl
trConstrDecl [ConstrDecl]
cs
  let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
      tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
  [TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [TVarWithKind]
tvs [ConsDecl]
cs']
trTypeDecl (IL.NewtypeDecl   qid :: QualIdent
qid ks :: [Kind]
ks nc :: NewConstrDecl
nc) = do
  QName
q'  <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
  Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
  NewConsDecl
nc' <- NewConstrDecl -> FlatState NewConsDecl
trNewConstrDecl NewConstrDecl
nc
  let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
      tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
  [TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> NewConsDecl -> TypeDecl
TypeNew QName
q' Visibility
vis [TVarWithKind]
tvs NewConsDecl
nc']
trTypeDecl (IL.ExternalDataDecl qid :: QualIdent
qid ks :: [Kind]
ks) = do
  QName
q'  <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
  Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
  let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
      tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
  [TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [TVarWithKind]
tvs []]
trTypeDecl _                           = [TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Translate a constructor declaration
trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl
trConstrDecl :: ConstrDecl -> StateT FlatEnv Identity ConsDecl
trConstrDecl (IL.ConstrDecl qid :: QualIdent
qid tys :: [Type]
tys) = (QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl)
-> Int -> QName -> Visibility -> [TypeExpr] -> ConsDecl
forall a b c. (a -> b -> c) -> b -> a -> c
flip QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys)
  (QName -> Visibility -> [TypeExpr] -> ConsDecl)
-> FlatState QName
-> StateT FlatEnv Identity (Visibility -> [TypeExpr] -> ConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
qid
  StateT FlatEnv Identity (Visibility -> [TypeExpr] -> ConsDecl)
-> FlatState Visibility
-> StateT FlatEnv Identity ([TypeExpr] -> ConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualIdent -> FlatState Visibility
getVisibility QualIdent
qid
  StateT FlatEnv Identity ([TypeExpr] -> ConsDecl)
-> StateT FlatEnv Identity [TypeExpr]
-> StateT FlatEnv Identity ConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> FlatState TypeExpr)
-> [Type] -> StateT FlatEnv Identity [TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> FlatState TypeExpr
trType [Type]
tys

-- Translate a constructor declaration for newtypes
trNewConstrDecl :: IL.NewConstrDecl -> FlatState NewConsDecl
trNewConstrDecl :: NewConstrDecl -> FlatState NewConsDecl
trNewConstrDecl (IL.NewConstrDecl qid :: QualIdent
qid ty :: Type
ty) = QName -> Visibility -> TypeExpr -> NewConsDecl
NewCons
  (QName -> Visibility -> TypeExpr -> NewConsDecl)
-> FlatState QName
-> StateT FlatEnv Identity (Visibility -> TypeExpr -> NewConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
qid
  StateT FlatEnv Identity (Visibility -> TypeExpr -> NewConsDecl)
-> FlatState Visibility
-> StateT FlatEnv Identity (TypeExpr -> NewConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualIdent -> FlatState Visibility
getVisibility QualIdent
qid
  StateT FlatEnv Identity (TypeExpr -> NewConsDecl)
-> FlatState TypeExpr -> FlatState NewConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> FlatState TypeExpr
trType Type
ty

-- Translate a type expression
trType :: IL.Type -> FlatState TypeExpr
trType :: Type -> FlatState TypeExpr
trType (IL.TypeConstructor t :: QualIdent
t tys :: [Type]
tys) = QName -> [TypeExpr] -> TypeExpr
TCons (QName -> [TypeExpr] -> TypeExpr)
-> FlatState QName
-> StateT FlatEnv Identity ([TypeExpr] -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
t StateT FlatEnv Identity ([TypeExpr] -> TypeExpr)
-> StateT FlatEnv Identity [TypeExpr] -> FlatState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> FlatState TypeExpr)
-> [Type] -> StateT FlatEnv Identity [TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> FlatState TypeExpr
trType [Type]
tys
trType (IL.TypeVariable      idx :: Int
idx) = TypeExpr -> FlatState TypeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeExpr -> FlatState TypeExpr) -> TypeExpr -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ Int -> TypeExpr
TVar (Int -> TypeExpr) -> Int -> TypeExpr
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs Int
idx
trType (IL.TypeArrow     ty1 :: Type
ty1 ty2 :: Type
ty2) = TypeExpr -> TypeExpr -> TypeExpr
FuncType (TypeExpr -> TypeExpr -> TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (TypeExpr -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty1 StateT FlatEnv Identity (TypeExpr -> TypeExpr)
-> FlatState TypeExpr -> FlatState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> FlatState TypeExpr
trType Type
ty2
trType (IL.TypeForall    idxs :: [TypeVariableWithKind]
idxs ty :: Type
ty) = [TVarWithKind] -> TypeExpr -> TypeExpr
ForallType ((TypeVariableWithKind -> TVarWithKind)
-> [TypeVariableWithKind] -> [TVarWithKind]
forall a b. (a -> b) -> [a] -> [b]
map TypeVariableWithKind -> TVarWithKind
trTVarWithKind [TypeVariableWithKind]
idxs) (TypeExpr -> TypeExpr) -> FlatState TypeExpr -> FlatState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty

-- Translates a type variable with kind.
trTVarWithKind :: (Int, IL.Kind) -> (Int, Kind)
trTVarWithKind :: TypeVariableWithKind -> TVarWithKind
trTVarWithKind (i :: Int
i, k :: Kind
k) = (Int -> Int
forall a. Num a => a -> a
abs Int
i, Kind -> Kind
trKind Kind
k)

-- Translate a kind
trKind :: IL.Kind -> Kind
trKind :: Kind -> Kind
trKind IL.KindStar          = Kind
KStar
trKind (IL.KindVariable  _) = Kind
KStar
trKind (IL.KindArrow k1 :: Kind
k1 k2 :: Kind
k2) = Kind -> Kind -> Kind
KArrow (Kind -> Kind
trKind Kind
k1) (Kind -> Kind
trKind Kind
k2)

-- -----------------------------------------------------------------------------
-- Function declarations
-- -----------------------------------------------------------------------------

-- Translate a function declaration
trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]
trAFuncDecl :: Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr]
trAFuncDecl (IL.FunctionDecl f :: QualIdent
f vs :: [(Type, Ident)]
vs ty :: Type
ty e :: Expression
e) = do
  QName
f'  <- QualIdent -> FlatState QName
trQualIdent QualIdent
f
  Visibility
vis <- QualIdent -> FlatState Visibility
getVisibility QualIdent
f
  TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
  ARule TypeExpr
r'  <- Type -> [(Type, Ident)] -> Expression -> FlatState (ARule TypeExpr)
trARule Type
ty [(Type, Ident)]
vs Expression
e
  [AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName
-> Int
-> Visibility
-> TypeExpr
-> ARule TypeExpr
-> AFuncDecl TypeExpr
forall a.
QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f' ([(Type, Ident)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Ident)]
vs) Visibility
vis TypeExpr
ty' ARule TypeExpr
r']
trAFuncDecl (IL.ExternalDecl    f :: QualIdent
f a :: Int
a ty :: Type
ty) = do
  QName
f'   <- QualIdent -> FlatState QName
trQualIdent QualIdent
f
  Visibility
vis  <- QualIdent -> FlatState Visibility
getVisibility QualIdent
f
  TypeExpr
ty'  <- Type -> FlatState TypeExpr
trType Type
ty
  ARule TypeExpr
r'   <- Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal Type
ty QualIdent
f --TODO: get arity from type?
  [AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName
-> Int
-> Visibility
-> TypeExpr
-> ARule TypeExpr
-> AFuncDecl TypeExpr
forall a.
QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f' Int
a Visibility
vis TypeExpr
ty' ARule TypeExpr
r']
trAFuncDecl _                           = [AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Translate a function rule.
-- Resets variable index so that for every rule variables start with index 1
trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression
        -> FlatState (ARule TypeExpr)
trARule :: Type -> [(Type, Ident)] -> Expression -> FlatState (ARule TypeExpr)
trARule ty :: Type
ty vs :: [(Type, Ident)]
vs e :: Expression
e = FlatState (ARule TypeExpr) -> FlatState (ARule TypeExpr)
forall a. FlatState a -> FlatState a
withFreshEnv (FlatState (ARule TypeExpr) -> FlatState (ARule TypeExpr))
-> FlatState (ARule TypeExpr) -> FlatState (ARule TypeExpr)
forall a b. (a -> b) -> a -> b
$ TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr
forall a. a -> [(Int, a)] -> AExpr a -> ARule a
ARule (TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
-> FlatState TypeExpr
-> StateT
     FlatEnv
     Identity
     ([(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty
                                    StateT
  FlatEnv
  Identity
  ([(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
-> StateT FlatEnv Identity [(Int, TypeExpr)]
-> StateT FlatEnv Identity (AExpr TypeExpr -> ARule TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type, Ident) -> FlatState (Int, TypeExpr))
-> [(Type, Ident)] -> StateT FlatEnv Identity [(Int, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (Int, TypeExpr))
-> (Type, Ident) -> FlatState (Int, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (Int, TypeExpr)
newVar) [(Type, Ident)]
vs
                                    StateT FlatEnv Identity (AExpr TypeExpr -> ARule TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> FlatState (ARule TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e

trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal :: Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal ty :: Type
ty f :: QualIdent
f = (TypeExpr -> String -> ARule TypeExpr)
-> String -> TypeExpr -> ARule TypeExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> String -> ARule TypeExpr
forall a. a -> String -> ARule a
AExternal (QualIdent -> String
qualName QualIdent
f) (TypeExpr -> ARule TypeExpr)
-> FlatState TypeExpr -> FlatState (ARule TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty

-- Translate an expression
trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)
trAExpr :: Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr (IL.Literal       ty :: Type
ty l :: Literal
l) = TypeExpr -> Literal -> AExpr TypeExpr
forall a. a -> Literal -> AExpr a
ALit (TypeExpr -> Literal -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (Literal -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Literal -> AExpr TypeExpr)
-> StateT FlatEnv Identity Literal
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Literal -> StateT FlatEnv Identity Literal
trLiteral Literal
l
trAExpr (IL.Variable      ty :: Type
ty v :: Ident
v) = TypeExpr -> Int -> AExpr TypeExpr
forall a. a -> Int -> AExpr a
AVar (TypeExpr -> Int -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (Int -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Int -> AExpr TypeExpr)
-> StateT FlatEnv Identity Int
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT FlatEnv Identity Int
getVarIndex Ident
v
trAExpr (IL.Function    ty :: Type
ty f :: QualIdent
f a :: Int
a) = Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Fun Type
ty QualIdent
f Int
a []
trAExpr (IL.Constructor ty :: Type
ty c :: QualIdent
c a :: Int
a) = Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Con Type
ty QualIdent
c Int
a []
trAExpr (IL.Apply        e1 :: Expression
e1 e2 :: Expression
e2) = Expression
-> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trApply Expression
e1 Expression
e2
trAExpr c :: Expression
c@(IL.Case      t :: Eval
t e :: Expression
e bs :: [Alt]
bs) = (TypeExpr
 -> CaseType
 -> AExpr TypeExpr
 -> [ABranchExpr TypeExpr]
 -> AExpr TypeExpr)
-> CaseType
-> TypeExpr
-> AExpr TypeExpr
-> [ABranchExpr TypeExpr]
-> AExpr TypeExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr
-> CaseType
-> AExpr TypeExpr
-> [ABranchExpr TypeExpr]
-> AExpr TypeExpr
forall a. a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a
ACase (Eval -> CaseType
cvEval Eval
t) (TypeExpr
 -> AExpr TypeExpr -> [ABranchExpr TypeExpr] -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
     FlatEnv
     Identity
     (AExpr TypeExpr -> [ABranchExpr TypeExpr] -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
c) StateT
  FlatEnv
  Identity
  (AExpr TypeExpr -> [ABranchExpr TypeExpr] -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT
     FlatEnv Identity ([ABranchExpr TypeExpr] -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
                                  StateT FlatEnv Identity ([ABranchExpr TypeExpr] -> AExpr TypeExpr)
-> StateT FlatEnv Identity [ABranchExpr TypeExpr]
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr))
-> [Alt] -> StateT FlatEnv Identity [ABranchExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT FlatEnv Identity (ABranchExpr TypeExpr)
-> StateT FlatEnv Identity (ABranchExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (ABranchExpr TypeExpr)
 -> StateT FlatEnv Identity (ABranchExpr TypeExpr))
-> (Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr))
-> Alt
-> StateT FlatEnv Identity (ABranchExpr TypeExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr)
trAlt) [Alt]
bs
trAExpr (IL.Or           e1 :: Expression
e1 e2 :: Expression
e2) = TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> AExpr a -> AExpr a -> AExpr a
AOr (TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
     FlatEnv
     Identity
     (AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e1) StateT
  FlatEnv
  Identity
  (AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e1 StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e2
trAExpr (IL.Exist       v :: Ident
v ty :: Type
ty e :: Expression
e) = StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (AExpr TypeExpr)
 -> StateT FlatEnv Identity (AExpr TypeExpr))
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ do
  (Int, TypeExpr)
v' <- Type -> Ident -> FlatState (Int, TypeExpr)
newVar Type
ty Ident
v
  AExpr TypeExpr
e' <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
  TypeExpr
ty' <- Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e)
  AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr))
-> AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ case AExpr TypeExpr
e' of AFree ty'' :: TypeExpr
ty'' vs :: [(Int, TypeExpr)]
vs e'' :: AExpr TypeExpr
e'' -> TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> [(Int, a)] -> AExpr a -> AExpr a
AFree TypeExpr
ty'' ((Int, TypeExpr)
v' (Int, TypeExpr) -> [(Int, TypeExpr)] -> [(Int, TypeExpr)]
forall a. a -> [a] -> [a]
: [(Int, TypeExpr)]
vs) AExpr TypeExpr
e''
                      _                 -> TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> [(Int, a)] -> AExpr a -> AExpr a
AFree TypeExpr
ty'  ((Int, TypeExpr)
v' (Int, TypeExpr) -> [(Int, TypeExpr)] -> [(Int, TypeExpr)]
forall a. a -> [a] -> [a]
: []) AExpr TypeExpr
e'
trAExpr (IL.Let (IL.Binding v :: Ident
v b :: Expression
b) e :: Expression
e) = StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (AExpr TypeExpr)
 -> StateT FlatEnv Identity (AExpr TypeExpr))
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ do
  (Int, TypeExpr)
v' <- Type -> Ident -> FlatState (Int, TypeExpr)
newVar (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
b) Ident
v
  AExpr TypeExpr
b' <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
b
  AExpr TypeExpr
e' <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
  TypeExpr
ty' <- Type -> FlatState TypeExpr
trType (Type -> FlatState TypeExpr) -> Type -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e
  AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr))
-> AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ case AExpr TypeExpr
e' of ALet ty'' :: TypeExpr
ty'' bs :: [((Int, TypeExpr), AExpr TypeExpr)]
bs e'' :: AExpr TypeExpr
e'' -> TypeExpr
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet TypeExpr
ty'' (((Int, TypeExpr)
v', AExpr TypeExpr
b')((Int, TypeExpr), AExpr TypeExpr)
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> [((Int, TypeExpr), AExpr TypeExpr)]
forall a. a -> [a] -> [a]
:[((Int, TypeExpr), AExpr TypeExpr)]
bs) AExpr TypeExpr
e''
                      _                -> TypeExpr
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet TypeExpr
ty'  (((Int, TypeExpr)
v', AExpr TypeExpr
b')((Int, TypeExpr), AExpr TypeExpr)
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> [((Int, TypeExpr), AExpr TypeExpr)]
forall a. a -> [a] -> [a]
:[]) AExpr TypeExpr
e'
trAExpr (IL.Letrec   bs :: [Binding]
bs e :: Expression
e) = StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (AExpr TypeExpr)
 -> StateT FlatEnv Identity (AExpr TypeExpr))
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ do
  let (vs :: [(Type, Ident)]
vs, es :: [Expression]
es) = [((Type, Ident), Expression)] -> ([(Type, Ident)], [Expression])
forall a b. [(a, b)] -> ([a], [b])
unzip [ ((Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
b, Ident
v), Expression
b) | IL.Binding v :: Ident
v b :: Expression
b <- [Binding]
bs]
  TypeExpr
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet (TypeExpr
 -> [((Int, TypeExpr), AExpr TypeExpr)]
 -> AExpr TypeExpr
 -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
     FlatEnv
     Identity
     ([((Int, TypeExpr), AExpr TypeExpr)]
      -> AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e)
       StateT
  FlatEnv
  Identity
  ([((Int, TypeExpr), AExpr TypeExpr)]
   -> AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity [((Int, TypeExpr), AExpr TypeExpr)]
-> StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(Int, TypeExpr)]
-> [AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(Int, TypeExpr)]
 -> [AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)])
-> StateT FlatEnv Identity [(Int, TypeExpr)]
-> StateT
     FlatEnv
     Identity
     ([AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type, Ident) -> FlatState (Int, TypeExpr))
-> [(Type, Ident)] -> StateT FlatEnv Identity [(Int, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (Int, TypeExpr))
-> (Type, Ident) -> FlatState (Int, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (Int, TypeExpr)
newVar) [(Type, Ident)]
vs StateT
  FlatEnv
  Identity
  ([AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)])
-> StateT FlatEnv Identity [AExpr TypeExpr]
-> StateT FlatEnv Identity [((Int, TypeExpr), AExpr TypeExpr)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expression -> StateT FlatEnv Identity (AExpr TypeExpr))
-> [Expression] -> StateT FlatEnv Identity [AExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr [Expression]
es)
       StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
trAExpr (IL.Typed e :: Expression
e ty :: Type
ty) = TypeExpr -> AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr
forall a. a -> AExpr a -> TypeExpr -> AExpr a
ATyped (TypeExpr -> AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
     FlatEnv Identity (AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlatState TypeExpr
ty' StateT
  FlatEnv Identity (AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e StateT FlatEnv Identity (TypeExpr -> AExpr TypeExpr)
-> FlatState TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FlatState TypeExpr
ty'
  where ty' :: FlatState TypeExpr
ty' = Type -> FlatState TypeExpr
trType (Type -> FlatState TypeExpr) -> Type -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ Type
ty

-- Translate a literal
trLiteral :: IL.Literal -> FlatState Literal
trLiteral :: Literal -> StateT FlatEnv Identity Literal
trLiteral (IL.Char  c :: Char
c) = Literal -> StateT FlatEnv Identity Literal
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StateT FlatEnv Identity Literal)
-> Literal -> StateT FlatEnv Identity Literal
forall a b. (a -> b) -> a -> b
$ Char -> Literal
Charc  Char
c
trLiteral (IL.Int   i :: Integer
i) = Literal -> StateT FlatEnv Identity Literal
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StateT FlatEnv Identity Literal)
-> Literal -> StateT FlatEnv Identity Literal
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Intc   Integer
i
trLiteral (IL.Float f :: Double
f) = Literal -> StateT FlatEnv Identity Literal
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StateT FlatEnv Identity Literal)
-> Literal -> StateT FlatEnv Identity Literal
forall a b. (a -> b) -> a -> b
$ Double -> Literal
Floatc Double
f

-- Translate a higher-order application
trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr)
trApply :: Expression
-> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trApply e1 :: Expression
e1 e2 :: Expression
e2 = Expression
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genFlatApplic Expression
e1 [Expression
e2]
  where
  genFlatApplic :: Expression
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genFlatApplic e :: Expression
e es :: [Expression]
es = case Expression
e of
    IL.Apply        ea :: Expression
ea eb :: Expression
eb -> Expression
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genFlatApplic Expression
ea (Expression
ebExpression -> [Expression] -> [Expression]
forall a. a -> [a] -> [a]
:[Expression]
es)
    IL.Function    ty :: Type
ty f :: QualIdent
f a :: Int
a -> Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Fun Type
ty QualIdent
f Int
a [Expression]
es
    IL.Constructor ty :: Type
ty c :: QualIdent
c a :: Int
a -> Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Con Type
ty QualIdent
c Int
a [Expression]
es
    _ -> do
      AExpr TypeExpr
expr <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
      AExpr TypeExpr
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genApply AExpr TypeExpr
expr [Expression]
es

-- Translate an alternative
trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)
trAlt :: Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr)
trAlt (IL.Alt p :: ConstrTerm
p e :: Expression
e) = APattern TypeExpr -> AExpr TypeExpr -> ABranchExpr TypeExpr
forall a. APattern a -> AExpr a -> ABranchExpr a
ABranch (APattern TypeExpr -> AExpr TypeExpr -> ABranchExpr TypeExpr)
-> StateT FlatEnv Identity (APattern TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr -> ABranchExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstrTerm -> StateT FlatEnv Identity (APattern TypeExpr)
trPat ConstrTerm
p StateT FlatEnv Identity (AExpr TypeExpr -> ABranchExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (ABranchExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e

-- Translate a pattern
trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)
trPat :: ConstrTerm -> StateT FlatEnv Identity (APattern TypeExpr)
trPat (IL.LiteralPattern        ty :: Type
ty l :: Literal
l) = TypeExpr -> Literal -> APattern TypeExpr
forall a. a -> Literal -> APattern a
ALPattern (TypeExpr -> Literal -> APattern TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (Literal -> APattern TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Literal -> APattern TypeExpr)
-> StateT FlatEnv Identity Literal
-> StateT FlatEnv Identity (APattern TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Literal -> StateT FlatEnv Identity Literal
trLiteral Literal
l
trPat (IL.ConstructorPattern ty :: Type
ty c :: QualIdent
c vs :: [(Type, Ident)]
vs) = do
  TypeExpr
qty <- Type -> FlatState TypeExpr
trType (Type -> FlatState TypeExpr) -> Type -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
IL.TypeArrow Type
ty ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ ((Type, Ident) -> Type) -> [(Type, Ident)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Ident) -> Type
forall a b. (a, b) -> a
fst [(Type, Ident)]
vs
  TypeExpr
-> (QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr
forall a. a -> (QName, a) -> [(Int, a)] -> APattern a
APattern  (TypeExpr
 -> (QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr)
-> FlatState TypeExpr
-> StateT
     FlatEnv
     Identity
     ((QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT
  FlatEnv
  Identity
  ((QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr)
-> StateT FlatEnv Identity (QName, TypeExpr)
-> StateT FlatEnv Identity ([(Int, TypeExpr)] -> APattern TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((\q :: QName
q -> (QName
q, TypeExpr
qty)) (QName -> (QName, TypeExpr))
-> FlatState QName -> StateT FlatEnv Identity (QName, TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
c) StateT FlatEnv Identity ([(Int, TypeExpr)] -> APattern TypeExpr)
-> StateT FlatEnv Identity [(Int, TypeExpr)]
-> StateT FlatEnv Identity (APattern TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type, Ident) -> FlatState (Int, TypeExpr))
-> [(Type, Ident)] -> StateT FlatEnv Identity [(Int, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (Int, TypeExpr))
-> (Type, Ident) -> FlatState (Int, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (Int, TypeExpr)
newVar) [(Type, Ident)]
vs
trPat (IL.VariablePattern        _ _) = String -> StateT FlatEnv Identity (APattern TypeExpr)
forall a. String -> a
internalError "GenTypeAnnotatedFlatCurry.trPat"

-- Convert a case type
cvEval :: IL.Eval -> CaseType
cvEval :: Eval -> CaseType
cvEval IL.Rigid = CaseType
Rigid
cvEval IL.Flex  = CaseType
Flex

data Call = Fun | Con

-- Generate a function or constructor call
genCall :: Call -> IL.Type -> QualIdent -> Int -> [IL.Expression]
        -> FlatState (AExpr TypeExpr)
genCall :: Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall call :: Call
call ty :: Type
ty f :: QualIdent
f arity :: Int
arity es :: [Expression]
es = do
  QName
f'    <- QualIdent -> FlatState QName
trQualIdent QualIdent
f
  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
supplied Int
arity of
    LT -> Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb Type
ty QName
f' [Expression]
es (Call -> Int -> CombType
part Call
call (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
supplied))
    EQ -> Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb Type
ty QName
f' [Expression]
es (Call -> CombType
full Call
call)
    GT -> do
      let (es1 :: [Expression]
es1, es2 :: [Expression]
es2) = Int -> [Expression] -> ([Expression], [Expression])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
arity [Expression]
es
      AExpr TypeExpr
funccall <- Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb Type
ty QName
f' [Expression]
es1 (Call -> CombType
full Call
call)
      AExpr TypeExpr
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genApply AExpr TypeExpr
funccall [Expression]
es2
  where
  supplied :: Int
supplied = [Expression] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression]
es
  full :: Call -> CombType
full Fun = CombType
FuncCall
  full Con = CombType
ConsCall
  part :: Call -> Int -> CombType
part Fun = Int -> CombType
FuncPartCall
  part Con = Int -> CombType
ConsPartCall

genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)
genAComb :: Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb ty :: Type
ty qid :: QName
qid es :: [Expression]
es ct :: CombType
ct = do
  TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
  let ty'' :: TypeExpr
ty'' = TypeExpr -> Int -> TypeExpr
forall t. (Eq t, Num t) => TypeExpr -> t -> TypeExpr
defunc TypeExpr
ty' ([Expression] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression]
es)
  TypeExpr
-> CombType
-> (QName, TypeExpr)
-> [AExpr TypeExpr]
-> AExpr TypeExpr
forall a. a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
AComb TypeExpr
ty'' CombType
ct (QName
qid, TypeExpr
ty') ([AExpr TypeExpr] -> AExpr TypeExpr)
-> StateT FlatEnv Identity [AExpr TypeExpr]
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression -> StateT FlatEnv Identity (AExpr TypeExpr))
-> [Expression] -> StateT FlatEnv Identity [AExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr [Expression]
es
  where
  defunc :: TypeExpr -> t -> TypeExpr
defunc t :: TypeExpr
t               0 = TypeExpr
t
  defunc (FuncType _ t2 :: TypeExpr
t2) n :: t
n = TypeExpr -> t -> TypeExpr
defunc TypeExpr
t2 (t
n t -> t -> t
forall a. Num a => a -> a -> a
- 1)
  defunc _               _ = String -> TypeExpr
forall a. String -> a
internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc"

genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)
genApply :: AExpr TypeExpr
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genApply e :: AExpr TypeExpr
e es :: [Expression]
es = do
  QName
ap  <- QualIdent -> FlatState QName
trQualIdent (QualIdent -> FlatState QName) -> QualIdent -> FlatState QName
forall a b. (a -> b) -> a -> b
$ QualIdent
qApplyId
  [AExpr TypeExpr]
es' <- (Expression -> StateT FlatEnv Identity (AExpr TypeExpr))
-> [Expression] -> StateT FlatEnv Identity [AExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr [Expression]
es
  AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr))
-> AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ (AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
-> AExpr TypeExpr -> [AExpr TypeExpr] -> AExpr TypeExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\e1 :: AExpr TypeExpr
e1 e2 :: AExpr TypeExpr
e2 -> let FuncType ty1 :: TypeExpr
ty1 ty2 :: TypeExpr
ty2 = AExpr TypeExpr -> TypeExpr
forall a. Typeable a => a -> TypeExpr
typeOf AExpr TypeExpr
e1 in TypeExpr
-> CombType
-> (QName, TypeExpr)
-> [AExpr TypeExpr]
-> AExpr TypeExpr
forall a. a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
AComb TypeExpr
ty2 CombType
FuncCall (QName
ap, TypeExpr -> TypeExpr -> TypeExpr
FuncType (TypeExpr -> TypeExpr -> TypeExpr
FuncType TypeExpr
ty1 TypeExpr
ty2) (TypeExpr -> TypeExpr -> TypeExpr
FuncType TypeExpr
ty1 TypeExpr
ty2)) [AExpr TypeExpr
e1, AExpr TypeExpr
e2]) AExpr TypeExpr
e [AExpr TypeExpr]
es'

-- -----------------------------------------------------------------------------
-- Normalization
-- -----------------------------------------------------------------------------

runNormalization :: Normalize a => a -> a
runNormalization :: a -> a
runNormalization x :: a
x = State (Int, Map Int Int) a -> (Int, Map Int Int) -> a
forall s a. State s a -> s -> a
S.evalState (a -> State (Int, Map Int Int) a
forall a. Normalize a => a -> NormState a
normalize a
x) (0, Map Int Int
forall k a. Map k a
Map.empty)

type NormState a = S.State (Int, Map.Map Int Int) a

class Normalize a where
  normalize :: a -> NormState a

instance Normalize a => Normalize [a] where
  normalize :: [a] -> NormState [a]
normalize = (a -> StateT (Int, Map Int Int) Identity a) -> [a] -> NormState [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize

instance Normalize Int where
  normalize :: Int -> NormState Int
normalize i :: Int
i = do
    (n :: Int
n, m :: Map Int Int
m) <- StateT (Int, Map Int Int) Identity (Int, Map Int Int)
forall s (m :: * -> *). MonadState s m => m s
S.get
    case Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
i Map Int Int
m of
      Nothing -> do
        (Int, Map Int Int) -> StateT (Int, Map Int Int) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
i Int
n Map Int Int
m)
        Int -> NormState Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
      Just n' :: Int
n' -> Int -> NormState Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'

instance Normalize TypeExpr where
  normalize :: TypeExpr -> NormState TypeExpr
normalize (TVar           i :: Int
i) = Int -> TypeExpr
TVar (Int -> TypeExpr) -> NormState Int -> NormState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> NormState Int
forall a. Normalize a => a -> NormState a
normalize Int
i
  normalize (TCons      q :: QName
q tys :: [TypeExpr]
tys) = QName -> [TypeExpr] -> TypeExpr
TCons QName
q ([TypeExpr] -> TypeExpr)
-> StateT (Int, Map Int Int) Identity [TypeExpr]
-> NormState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeExpr] -> StateT (Int, Map Int Int) Identity [TypeExpr]
forall a. Normalize a => a -> NormState a
normalize [TypeExpr]
tys
  normalize (FuncType ty1 :: TypeExpr
ty1 ty2 :: TypeExpr
ty2) = TypeExpr -> TypeExpr -> TypeExpr
FuncType (TypeExpr -> TypeExpr -> TypeExpr)
-> NormState TypeExpr
-> StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty1 StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
-> NormState TypeExpr -> NormState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty2
  normalize (ForallType is :: [TVarWithKind]
is ty :: TypeExpr
ty) = [TVarWithKind] -> TypeExpr -> TypeExpr
ForallType ([TVarWithKind] -> TypeExpr -> TypeExpr)
-> StateT (Int, Map Int Int) Identity [TVarWithKind]
-> StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVarWithKind -> StateT (Int, Map Int Int) Identity TVarWithKind)
-> [TVarWithKind]
-> StateT (Int, Map Int Int) Identity [TVarWithKind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TVarWithKind -> StateT (Int, Map Int Int) Identity TVarWithKind
forall a a.
Normalize a =>
(a, a) -> StateT (Int, Map Int Int) Identity (a, a)
normalizeTypeVar [TVarWithKind]
is
                                            StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
-> NormState TypeExpr -> NormState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty
    where normalizeTypeVar :: (a, a) -> StateT (Int, Map Int Int) Identity (a, a)
normalizeTypeVar (tv :: a
tv, k :: a
k) = (,) (a -> a -> (a, a))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
tv StateT (Int, Map Int Int) Identity (a -> (a, a))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> StateT (Int, Map Int Int) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
k

instance Normalize a => Normalize (AFuncDecl a) where
  normalize :: AFuncDecl a -> NormState (AFuncDecl a)
normalize (AFunc f :: QName
f a :: Int
a v :: Visibility
v ty :: TypeExpr
ty r :: ARule a
r) = QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
forall a.
QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f Int
a Visibility
v (TypeExpr -> ARule a -> AFuncDecl a)
-> NormState TypeExpr
-> StateT (Int, Map Int Int) Identity (ARule a -> AFuncDecl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty StateT (Int, Map Int Int) Identity (ARule a -> AFuncDecl a)
-> StateT (Int, Map Int Int) Identity (ARule a)
-> NormState (AFuncDecl a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ARule a -> StateT (Int, Map Int Int) Identity (ARule a)
forall a. Normalize a => a -> NormState a
normalize ARule a
r

instance Normalize a => Normalize (ARule a) where
  normalize :: ARule a -> NormState (ARule a)
normalize (ARule     ty :: a
ty vs :: [(Int, a)]
vs e :: AExpr a
e) = a -> [(Int, a)] -> AExpr a -> ARule a
forall a. a -> [(Int, a)] -> AExpr a -> ARule a
ARule (a -> [(Int, a)] -> AExpr a -> ARule a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> ARule a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
                                        StateT
  (Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> ARule a)
-> StateT (Int, Map Int Int) Identity [(Int, a)]
-> StateT (Int, Map Int Int) Identity (AExpr a -> ARule a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int, a) -> StateT (Int, Map Int Int) Identity (Int, a))
-> [(Int, a)] -> StateT (Int, Map Int Int) Identity [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, a) -> StateT (Int, Map Int Int) Identity (Int, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple [(Int, a)]
vs
                                        StateT (Int, Map Int Int) Identity (AExpr a -> ARule a)
-> StateT (Int, Map Int Int) Identity (AExpr a)
-> NormState (ARule a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> StateT (Int, Map Int Int) Identity (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
  normalize (AExternal ty :: a
ty    s :: String
s) = (a -> String -> ARule a) -> String -> a -> ARule a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> String -> ARule a
forall a. a -> String -> ARule a
AExternal String
s (a -> ARule a)
-> StateT (Int, Map Int Int) Identity a -> NormState (ARule a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty

normalizeTuple :: Normalize b => (a, b) -> NormState (a, b)
normalizeTuple :: (a, b) -> NormState (a, b)
normalizeTuple (a :: a
a, b :: b
b) = (,) (a -> b -> (a, b))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a StateT (Int, Map Int Int) Identity (b -> (a, b))
-> StateT (Int, Map Int Int) Identity b -> NormState (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> StateT (Int, Map Int Int) Identity b
forall a. Normalize a => a -> NormState a
normalize b
b  

instance Normalize a => Normalize (AExpr a) where
  normalize :: AExpr a -> NormState (AExpr a)
normalize (AVar  ty :: a
ty       v :: Int
v) = (a -> Int -> AExpr a) -> Int -> a -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Int -> AExpr a
forall a. a -> Int -> AExpr a
AVar  Int
v  (a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a -> NormState (AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
  normalize (ALit  ty :: a
ty       l :: Literal
l) = (a -> Literal -> AExpr a) -> Literal -> a -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Literal -> AExpr a
forall a. a -> Literal -> AExpr a
ALit  Literal
l  (a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a -> NormState (AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
  normalize (AComb ty :: a
ty ct :: CombType
ct f :: (QName, a)
f es :: [AExpr a]
es) = (a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a)
-> CombType -> a -> (QName, a) -> [AExpr a] -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
forall a. a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
AComb CombType
ct (a -> (QName, a) -> [AExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int) Identity ((QName, a) -> [AExpr a] -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
                                               StateT
  (Int, Map Int Int) Identity ((QName, a) -> [AExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity (QName, a)
-> StateT (Int, Map Int Int) Identity ([AExpr a] -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QName, a) -> StateT (Int, Map Int Int) Identity (QName, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple (QName, a)
f
                                               StateT (Int, Map Int Int) Identity ([AExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity [AExpr a]
-> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [AExpr a] -> StateT (Int, Map Int Int) Identity [AExpr a]
forall a. Normalize a => a -> NormState a
normalize [AExpr a]
es
  normalize (ALet  ty :: a
ty    ds :: [((Int, a), AExpr a)]
ds e :: AExpr a
e) = a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet (a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int)
     Identity
     ([((Int, a), AExpr a)] -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
                                      StateT
  (Int, Map Int Int)
  Identity
  ([((Int, a), AExpr a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity [((Int, a), AExpr a)]
-> StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (((Int, a), AExpr a)
 -> StateT (Int, Map Int Int) Identity ((Int, a), AExpr a))
-> [((Int, a), AExpr a)]
-> StateT (Int, Map Int Int) Identity [((Int, a), AExpr a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int, a), AExpr a)
-> StateT (Int, Map Int Int) Identity ((Int, a), AExpr a)
forall b a a.
(Normalize b, Normalize a) =>
((a, b), a) -> StateT (Int, Map Int Int) Identity ((a, b), a)
normalizeBinding [((Int, a), AExpr a)]
ds
                                      StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
-> NormState (AExpr a) -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
    where normalizeBinding :: ((a, b), a) -> StateT (Int, Map Int Int) Identity ((a, b), a)
normalizeBinding (v :: (a, b)
v, b :: a
b) = (,) ((a, b) -> a -> ((a, b), a))
-> StateT (Int, Map Int Int) Identity (a, b)
-> StateT (Int, Map Int Int) Identity (a -> ((a, b), a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, b) -> StateT (Int, Map Int Int) Identity (a, b)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple (a, b)
v StateT (Int, Map Int Int) Identity (a -> ((a, b), a))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity ((a, b), a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
b
  normalize (AOr   ty :: a
ty     a :: AExpr a
a b :: AExpr a
b) = a -> AExpr a -> AExpr a -> AExpr a
forall a. a -> AExpr a -> AExpr a -> AExpr a
AOr (a -> AExpr a -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int) Identity (AExpr a -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a -> AExpr a)
-> NormState (AExpr a)
-> StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
a
                                     StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
-> NormState (AExpr a) -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
b
  normalize (ACase ty :: a
ty ct :: CaseType
ct e :: AExpr a
e bs :: [ABranchExpr a]
bs) = (a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a)
-> CaseType -> a -> AExpr a -> [ABranchExpr a] -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a
forall a. a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a
ACase CaseType
ct (a -> AExpr a -> [ABranchExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int) Identity (AExpr a -> [ABranchExpr a] -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT
  (Int, Map Int Int) Identity (AExpr a -> [ABranchExpr a] -> AExpr a)
-> NormState (AExpr a)
-> StateT (Int, Map Int Int) Identity ([ABranchExpr a] -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
                                               StateT (Int, Map Int Int) Identity ([ABranchExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity [ABranchExpr a]
-> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ABranchExpr a]
-> StateT (Int, Map Int Int) Identity [ABranchExpr a]
forall a. Normalize a => a -> NormState a
normalize [ABranchExpr a]
bs
  normalize (AFree  ty :: a
ty   vs :: [(Int, a)]
vs e :: AExpr a
e) = a -> [(Int, a)] -> AExpr a -> AExpr a
forall a. a -> [(Int, a)] -> AExpr a -> AExpr a
AFree (a -> [(Int, a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
                                       StateT
  (Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity [(Int, a)]
-> StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int, a) -> StateT (Int, Map Int Int) Identity (Int, a))
-> [(Int, a)] -> StateT (Int, Map Int Int) Identity [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, a) -> StateT (Int, Map Int Int) Identity (Int, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple [(Int, a)]
vs
                                       StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
-> NormState (AExpr a) -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
  normalize (ATyped ty :: a
ty  e :: AExpr a
e ty' :: TypeExpr
ty') = a -> AExpr a -> TypeExpr -> AExpr a
forall a. a -> AExpr a -> TypeExpr -> AExpr a
ATyped (a -> AExpr a -> TypeExpr -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int) Identity (AExpr a -> TypeExpr -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT (Int, Map Int Int) Identity (AExpr a -> TypeExpr -> AExpr a)
-> NormState (AExpr a)
-> StateT (Int, Map Int Int) Identity (TypeExpr -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
                                        StateT (Int, Map Int Int) Identity (TypeExpr -> AExpr a)
-> NormState TypeExpr -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty'

instance Normalize a => Normalize (ABranchExpr a) where
  normalize :: ABranchExpr a -> NormState (ABranchExpr a)
normalize (ABranch p :: APattern a
p e :: AExpr a
e) = APattern a -> AExpr a -> ABranchExpr a
forall a. APattern a -> AExpr a -> ABranchExpr a
ABranch (APattern a -> AExpr a -> ABranchExpr a)
-> StateT (Int, Map Int Int) Identity (APattern a)
-> StateT (Int, Map Int Int) Identity (AExpr a -> ABranchExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APattern a -> StateT (Int, Map Int Int) Identity (APattern a)
forall a. Normalize a => a -> NormState a
normalize APattern a
p StateT (Int, Map Int Int) Identity (AExpr a -> ABranchExpr a)
-> StateT (Int, Map Int Int) Identity (AExpr a)
-> NormState (ABranchExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> StateT (Int, Map Int Int) Identity (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e

instance Normalize a => Normalize (APattern a) where
  normalize :: APattern a -> NormState (APattern a)
normalize (APattern  ty :: a
ty c :: (QName, a)
c vs :: [(Int, a)]
vs) = a -> (QName, a) -> [(Int, a)] -> APattern a
forall a. a -> (QName, a) -> [(Int, a)] -> APattern a
APattern (a -> (QName, a) -> [(Int, a)] -> APattern a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
     (Int, Map Int Int)
     Identity
     ((QName, a) -> [(Int, a)] -> APattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
                                           StateT
  (Int, Map Int Int)
  Identity
  ((QName, a) -> [(Int, a)] -> APattern a)
-> StateT (Int, Map Int Int) Identity (QName, a)
-> StateT (Int, Map Int Int) Identity ([(Int, a)] -> APattern a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QName, a) -> StateT (Int, Map Int Int) Identity (QName, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple (QName, a)
c
                                           StateT (Int, Map Int Int) Identity ([(Int, a)] -> APattern a)
-> StateT (Int, Map Int Int) Identity [(Int, a)]
-> NormState (APattern a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int, a) -> StateT (Int, Map Int Int) Identity (Int, a))
-> [(Int, a)] -> StateT (Int, Map Int Int) Identity [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, a) -> StateT (Int, Map Int Int) Identity (Int, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple [(Int, a)]
vs
  normalize (ALPattern ty :: a
ty    l :: Literal
l) = (a -> Literal -> APattern a) -> Literal -> a -> APattern a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Literal -> APattern a
forall a. a -> Literal -> APattern a
ALPattern Literal
l (a -> APattern a)
-> StateT (Int, Map Int Int) Identity a -> NormState (APattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty

-- -----------------------------------------------------------------------------
-- Helper functions
-- -----------------------------------------------------------------------------

trQualIdent :: QualIdent -> FlatState QName
trQualIdent :: QualIdent -> FlatState QName
trQualIdent qid :: QualIdent
qid = do
  ModuleIdent
mid <- FlatState ModuleIdent
getModuleIdent
  QName -> FlatState QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> FlatState QName) -> QName -> FlatState QName
forall a b. (a -> b) -> a -> b
$ (ModuleIdent -> String
moduleName (ModuleIdent -> String) -> ModuleIdent -> String
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Maybe ModuleIdent -> ModuleIdent
forall a. a -> Maybe a -> a
fromMaybe ModuleIdent
mid Maybe ModuleIdent
mid', Ident -> String
idName Ident
i)
  where
  mid' :: Maybe ModuleIdent
mid' | Ident
i Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident
listId, Ident
consId, Ident
nilId, Ident
unitId] Bool -> Bool -> Bool
|| Ident -> Bool
isTupleId Ident
i
       = ModuleIdent -> Maybe ModuleIdent
forall a. a -> Maybe a
Just ModuleIdent
preludeMIdent
       | Bool
otherwise
       = QualIdent -> Maybe ModuleIdent
qidModule QualIdent
qid
  i :: Ident
i = QualIdent -> Ident
qidIdent QualIdent
qid

getTypeVisibility :: QualIdent -> FlatState Visibility
getTypeVisibility :: QualIdent -> FlatState Visibility
getTypeVisibility i :: QualIdent
i = (FlatEnv -> Visibility) -> FlatState Visibility
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((FlatEnv -> Visibility) -> FlatState Visibility)
-> (FlatEnv -> Visibility) -> FlatState Visibility
forall a b. (a -> b) -> a -> b
$ \s :: FlatEnv
s ->
  if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (QualIdent -> Ident
unqualify QualIdent
i) (FlatEnv -> Set Ident
tyExports FlatEnv
s) then Visibility
Public else Visibility
Private

getVisibility :: QualIdent -> FlatState Visibility
getVisibility :: QualIdent -> FlatState Visibility
getVisibility i :: QualIdent
i = (FlatEnv -> Visibility) -> FlatState Visibility
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((FlatEnv -> Visibility) -> FlatState Visibility)
-> (FlatEnv -> Visibility) -> FlatState Visibility
forall a b. (a -> b) -> a -> b
$ \s :: FlatEnv
s ->
  if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (QualIdent -> Ident
unqualify QualIdent
i) (FlatEnv -> Set Ident
valExports FlatEnv
s) then Visibility
Public else Visibility
Private