{- -----------------------------------------------------------------------------
Copyright 2019-2020 Kevin P. Barry

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}

-- Author: Kevin P. Barry [ta0kira@gmail.com]

{-# LANGUAGE Safe #-}

module Types.TypeCategory (
  AnyCategory(..),
  CategoryMap(..),
  CategoryResolver(..),
  FunctionName(..),
  Namespace(..),
  ParamFilter(..),
  PassedValue(..),
  ScopedFunction(..),
  SymbolScope(..),
  ValueDefine(..),
  ValueParam(..),
  ValueRefine(..),
  checkCategoryInstances,
  checkConnectedTypes,
  checkConnectionCycles,
  checkParamVariances,
  declareAllTypes, -- TODO: Remove?
  flattenAllConnections,
  formatFullContext,
  formatFullContextBrace,
  getCategory,
  getCategoryContext,
  getCategoryDefines,
  getCategoryDeps,
  getCategoryFilterMap,
  getCategoryFilters,
  getCategoryFunctions,
  getCategoryName,
  getCategoryNamespace,
  getCategoryParams,
  getCategoryRefines,
  getConcreteCategory,
  getFilterMap,
  getFunctionFilterMap,
  getInstanceCategory,
  getValueCategory,
  includeNewTypes,
  isInstanceInterface,
  isDynamicNamespace,
  isNoNamespace,
  isStaticNamespace,
  isValueConcrete,
  isValueInterface,
  mergeDefines,
  mergeFunctions,
  mergeRefines,
  noDuplicateDefines,
  noDuplicateRefines,
  parsedToFunctionType,
  partitionByScope,
  setCategoryNamespace,
  topoSortCategories,
  uncheckedSubFunction,
  validateCategoryFunction,
) where

import Control.Arrow (second)
import Control.Monad (when)
import Data.List (group,groupBy,intercalate,sort,sortBy)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Base.CompileError
import Base.Mergeable
import Types.Function
import Types.GeneralType
import Types.Positional
import Types.TypeInstance
import Types.Variance


data AnyCategory c =
  ValueInterface {
    viContext :: [c],
    viNamespace :: Namespace,
    viName :: CategoryName,
    viParams :: [ValueParam c],
    viRefines :: [ValueRefine c],
    viParamFilter :: [ParamFilter c],
    viFunctions :: [ScopedFunction c]
  } |
  InstanceInterface {
    iiContext :: [c],
    iiNamespace :: Namespace,
    iiName :: CategoryName,
    iiParams :: [ValueParam c],
    iiParamFilter :: [ParamFilter c],
    iiFunctions :: [ScopedFunction c]
  } |
  ValueConcrete {
    vcContext :: [c],
    vcNamespace :: Namespace,
    vcName :: CategoryName,
    vcParams :: [ValueParam c],
    vcRefines :: [ValueRefine c],
    vcDefines :: [ValueDefine c],
    vcParamFilter :: [ParamFilter c],
    vcFunctions :: [ScopedFunction c]
  }

formatFullContext :: Show a => [a] -> String
formatFullContext cs = intercalate " -> " (map show cs)

formatFullContextBrace :: Show a => [a] -> String
formatFullContextBrace [] = ""
formatFullContextBrace cs = " [" ++ intercalate " -> " (map show cs) ++ "]"

instance Show c => Show (AnyCategory c) where
  show = format where
    format (ValueInterface cs ns n ps rs vs fs) =
      "@value interface " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++ "\n" ++
      (intercalate "\n\n" $
         map (\r -> "  " ++ formatRefine r) rs ++
         map (\v -> "  " ++ formatValue v) vs ++
         map (\f -> formatInterfaceFunc f) fs) ++
      "\n}\n"
    format (InstanceInterface cs ns n ps vs fs) =
      "@type interface " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++
      (intercalate "\n\n" $
         map (\v -> "  " ++ formatValue v) vs ++
         map (\f -> formatInterfaceFunc f) fs) ++
      "\n}\n"
    format (ValueConcrete cs ns n ps rs ds vs fs) =
      "concrete " ++ show n ++ formatParams ps ++ namespace ns ++ " { " ++ formatContext cs ++ "\n" ++
      (intercalate "\n\n" $
         map (\r -> "  " ++ formatRefine r) rs ++
         map (\d -> "  " ++ formatDefine d) ds ++
         map (\v -> "  " ++ formatValue v) vs ++
         map (\f -> formatInterfaceFunc f) fs) ++
      "\n}\n"
    namespace ns
      | isStaticNamespace ns = " /*" ++ show ns ++ "*/"
      | otherwise = ""
    formatContext cs = "/*" ++ formatFullContext cs ++ "*/"
    formatParams ps = let (con,inv,cov) = (foldr partitionParam ([],[],[]) ps) in
      "<" ++ intercalate "," con ++ "|" ++
             intercalate "," inv ++ "|" ++
             intercalate "," cov ++ ">"
    -- NOTE: This assumes that the params are ordered by contravariant,
    -- invariant, and covariant.
    partitionParam p (con,inv,cov)
      | vpVariance p == Contravariant = ((show $ vpParam p):con,inv,cov)
      | vpVariance p == Invariant     = (con,(show $ vpParam p):inv,cov)
      | vpVariance p == Covariant     = (con,inv,(show $ vpParam p):cov)
    formatRefine r = "refines " ++ show (vrType r) ++ " " ++ formatContext (vrContext r)
    formatDefine d = "defines " ++ show (vdType d) ++ " " ++ formatContext (vdContext d)
    formatValue v = show (pfParam v) ++ " " ++ show (pfFilter v) ++
                    " " ++ formatContext (pfContext v)
    formatInterfaceFunc f = showFunctionInContext "" "  " f
    formatConcreteFunc f = showFunctionInContext (showScope (sfScope f) ++ " ") "  " f

showScope :: SymbolScope -> String
showScope CategoryScope = "@category"
showScope TypeScope     = "@type"
showScope ValueScope    = "@value"
showScope LocalScope    = "@local"

getCategoryName :: AnyCategory c -> CategoryName
getCategoryName (ValueInterface _ _ n _ _ _ _)  = n
getCategoryName (InstanceInterface _ _ n _ _ _) = n
getCategoryName (ValueConcrete _ _ n _ _ _ _ _) = n

getCategoryContext :: AnyCategory c -> [c]
getCategoryContext (ValueInterface c _ _ _ _ _ _)  = c
getCategoryContext (InstanceInterface c _ _ _ _ _) = c
getCategoryContext (ValueConcrete c _ _ _ _ _ _ _) = c

getCategoryNamespace :: AnyCategory c -> Namespace
getCategoryNamespace (ValueInterface _ ns _ _ _ _ _)  = ns
getCategoryNamespace (InstanceInterface _ ns _ _ _ _) = ns
getCategoryNamespace (ValueConcrete _ ns _ _ _ _ _ _) = ns

setCategoryNamespace :: Namespace -> AnyCategory c -> AnyCategory c
setCategoryNamespace ns (ValueInterface c _ n ps rs vs fs)   = (ValueInterface c ns n ps rs vs fs)
setCategoryNamespace ns (InstanceInterface c _ n ps vs fs)   = (InstanceInterface c ns n ps vs fs)
setCategoryNamespace ns (ValueConcrete c _ n ps rs ds vs fs) = (ValueConcrete c ns n ps rs ds vs fs)

getCategoryParams :: AnyCategory c -> [ValueParam c]
getCategoryParams (ValueInterface _ _ _ ps _ _ _)  = ps
getCategoryParams (InstanceInterface _ _ _ ps _ _) = ps
getCategoryParams (ValueConcrete _ _ _ ps _ _ _ _) = ps

getCategoryRefines :: AnyCategory c -> [ValueRefine c]
getCategoryRefines (ValueInterface _ _ _ _ rs _ _)  = rs
getCategoryRefines (InstanceInterface _ _ _ _ _ _)  = []
getCategoryRefines (ValueConcrete _ _ _ _ rs _ _ _) = rs

getCategoryDefines :: AnyCategory c -> [ValueDefine c]
getCategoryDefines (ValueInterface _ _ _ _ _ _ _)  = []
getCategoryDefines (InstanceInterface _ _ _ _ _ _)  = []
getCategoryDefines (ValueConcrete _ _ _ _ _ ds _ _) = ds

getCategoryFilters :: AnyCategory c -> [ParamFilter c]
getCategoryFilters (ValueInterface _ _ _ _ _ vs _)  = vs
getCategoryFilters (InstanceInterface _ _ _ _ vs _) = vs
getCategoryFilters (ValueConcrete _ _ _ _ _ _ vs _) = vs

getCategoryFunctions :: AnyCategory c -> [ScopedFunction c]
getCategoryFunctions (ValueInterface _ _ _ _ _ _ fs)  = fs
getCategoryFunctions (InstanceInterface _ _ _ _ _ fs) = fs
getCategoryFunctions (ValueConcrete _ _ _ _ _ _ _ fs) = fs

getCategoryDeps :: AnyCategory c -> Set.Set CategoryName
getCategoryDeps t = Set.fromList $ filter (/= getCategoryName t) $ refines ++ defines ++ filters ++ functions where
  refines = concat $ map (fromInstance . SingleType . JustTypeInstance . vrType) $ getCategoryRefines t
  defines = concat $ map (fromDefine . vdType) $ getCategoryDefines t
  filters = concat $ map (fromFilter . pfFilter) $ getCategoryFilters t
  functions = concat $ map fromFunction $ getCategoryFunctions t
  fromInstance (TypeMerge _ ps) = concat $ map fromInstance ps
  fromInstance (SingleType (JustTypeInstance (TypeInstance n ps))) = n:(concat $ map fromInstance $ pValues ps)
  fromInstance _ = []
  fromDefine (DefinesInstance n ps) = n:(concat $ map fromInstance $ pValues ps)
  fromFilter (TypeFilter _ t2@(JustTypeInstance _)) = fromInstance (SingleType t2)
  fromFilter (DefinesFilter t2) = fromDefine t2
  fromType (ValueType _ t2) = fromInstance t2
  fromFunction f = args ++ returns ++ filters where
    args = concat $ map (fromType . pvType) $ pValues $ sfArgs f
    returns = concat $ map (fromType . pvType) $ pValues $ sfReturns f
    filters = concat $ map (fromFilter . pfFilter) $ sfFilters f

isValueInterface :: AnyCategory c -> Bool
isValueInterface (ValueInterface _ _ _ _ _ _ _) = True
isValueInterface _ = False

isInstanceInterface :: AnyCategory c -> Bool
isInstanceInterface (InstanceInterface _ _ _ _ _ _) = True
isInstanceInterface _ = False

isValueConcrete :: AnyCategory c -> Bool
isValueConcrete (ValueConcrete _ _ _ _ _ _ _ _) = True
isValueConcrete _ = False

data Namespace =
  StaticNamespace {
    snName :: String
  } |
  NoNamespace |
  DynamicNamespace
  deriving (Eq,Ord)

instance Show Namespace where
  show (StaticNamespace n) = n
  show _                   = ""

isStaticNamespace (StaticNamespace _) = True
isStaticNamespace _                   = False

isNoNamespace NoNamespace = True
isNoNamespace _           = False

isDynamicNamespace DynamicNamespace = True
isDynamicNamespace _                = False

data ValueRefine c =
  ValueRefine {
    vrContext :: [c],
    vrType :: TypeInstance
  }

instance Show c => Show (ValueRefine c) where
  show (ValueRefine c t) = show t ++ formatFullContextBrace c

data ValueDefine c =
  ValueDefine {
    vdContext :: [c],
    vdType :: DefinesInstance
  }

instance Show c => Show (ValueDefine c) where
  show (ValueDefine c t) = show t ++ formatFullContextBrace c

data ValueParam c =
  ValueParam {
    vpContext :: [c],
    vpParam :: ParamName,
    vpVariance :: Variance
  }

instance Show c => Show (ValueParam c) where
  show (ValueParam c t v) = show t ++ " (" ++ show v ++ ")" ++ formatFullContextBrace c

data ParamFilter c =
  ParamFilter {
    pfContext :: [c],
    pfParam :: ParamName,
    pfFilter :: TypeFilter
  }

instance Show c => Show (ParamFilter c) where
  show (ParamFilter c n f) = show n ++ " " ++ show f ++ formatFullContextBrace c

newtype CategoryResolver c =
  CategoryResolver {
    crCategories :: CategoryMap c
  }

instance (Show c) => TypeResolver (CategoryResolver c) where
    trRefines (CategoryResolver tm) (TypeInstance n1 ps1) n2
      | n1 == n2 = do
        (_,t) <- getValueCategory tm ([],n1)
        processPairs alwaysPair (Positional $ map vpParam $ getCategoryParams t) ps1
        return ps1
      | otherwise = do
        (_,t) <- getValueCategory tm ([],n1)
        let params = map vpParam $ getCategoryParams t
        assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps1
        let pa = Map.fromList $ map (\r -> (tiName r,tiParams r)) $ map vrType $ getCategoryRefines t
        ps2 <- case n2 `Map.lookup` pa of
                    (Just x) -> return x
                    _ -> compileError $ "Category " ++ show n1 ++ " does not refine " ++ show n2
        fmap Positional $ collectAllOrErrorM $ map (subAllParams assigned) $ pValues ps2
    trDefines (CategoryResolver tm) (TypeInstance n1 ps1) n2 = do
      (_,t) <- getValueCategory tm ([],n1)
      let params = map vpParam $ getCategoryParams t
      assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps1
      let pa = Map.fromList $ map (\r -> (diName r,diParams r)) $ map vdType $ getCategoryDefines t
      ps2 <- case n2 `Map.lookup` pa of
                  (Just x) -> return x
                  _ -> compileError $ "Category " ++ show n1 ++ " does not define " ++ show n2
      fmap Positional $ collectAllOrErrorM $ map (subAllParams assigned) $ pValues ps2
    trVariance (CategoryResolver tm) n = do
      (_,t) <- getCategory tm ([],n)
      return $ Positional $ map vpVariance $ getCategoryParams t
    trTypeFilters (CategoryResolver tm) (TypeInstance n ps) = do
      (_,t) <- getValueCategory tm ([],n)
      checkFilters t ps
    trDefinesFilters (CategoryResolver tm) (DefinesInstance n ps) = do
      (_,t) <- getInstanceCategory tm ([],n)
      checkFilters t ps
    trConcrete (CategoryResolver tm) n = do
      (_,t) <- getCategory tm ([],n)
      return (isValueConcrete t)

data SymbolScope =
  LocalScope |
  CategoryScope |
  TypeScope |
  ValueScope
  deriving (Eq,Ord,Show)

partitionByScope :: (a -> SymbolScope) -> [a] -> ([a],[a],[a])
partitionByScope f = foldr bin empty where
  empty = ([],[],[])
  bin x (cs,ts,vs)
    | f x == CategoryScope = (x:cs,ts,vs)
    | f x == TypeScope     = (cs,x:ts,vs)
    | f x == ValueScope    = (cs,ts,x:vs)
    | otherwise = (cs,ts,vs)

checkFilters :: (CompileErrorM m, MergeableM m) =>
  AnyCategory c -> Positional GeneralInstance -> m (Positional [TypeFilter])
checkFilters t ps = do
  let params = map vpParam $ getCategoryParams t
  assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps
  fs <- collectAllOrErrorM $ map (subSingleFilter assigned . \f -> (pfParam f,pfFilter f))
                                  (getCategoryFilters t)
  let fa = Map.fromListWith (++) $ map (second (:[])) fs
  fmap Positional $ collectAllOrErrorM $ map (assignFilter fa) params where
    subSingleFilter pa (n,(TypeFilter v t)) = do
      (SingleType t2) <- uncheckedSubInstance (getValueForParam pa) (SingleType t)
      return (n,(TypeFilter v t2))
    subSingleFilter pa (n,(DefinesFilter (DefinesInstance n2 ps))) = do
      ps2 <- collectAllOrErrorM $ map (uncheckedSubInstance $ getValueForParam pa) (pValues ps)
      return (n,(DefinesFilter (DefinesInstance n2 (Positional ps2))))
    assignFilter fa n =
      case n `Map.lookup` fa of
            (Just x) -> return x
            _ -> return []

subAllParams :: (MergeableM m, CompileErrorM m) =>
  Map.Map ParamName GeneralInstance -> GeneralInstance -> m GeneralInstance
subAllParams pa = uncheckedSubInstance (getValueForParam pa)

type CategoryMap c = Map.Map CategoryName (AnyCategory c)

getCategory :: (Show c, CompileErrorM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getCategory tm (c,n) =
  case n `Map.lookup` tm of
       (Just t) -> return (c,t)
       _ -> compileError $ "Type " ++ show n ++ context ++ " not found"
  where
    context
      | null c = ""
      | otherwise = formatFullContextBrace c

getValueCategory :: (Show c, CompileErrorM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getValueCategory tm (c,n) = do
  (c2,t) <- getCategory tm (c,n)
  if isValueInterface t || isValueConcrete t
     then return (c2,t)
     else compileError $ "Category " ++ show n ++
                         " cannot be used as a value" ++
                         formatFullContextBrace c

getInstanceCategory :: (Show c, CompileErrorM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getInstanceCategory tm (c,n) = do
  (c2,t) <- getCategory tm (c,n)
  if isInstanceInterface t
     then return (c2,t)
     else compileError $ "Category " ++ show n ++
                         " cannot be used as a type interface" ++
                         formatFullContextBrace c

getConcreteCategory :: (Show c, CompileErrorM m) =>
  CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c)
getConcreteCategory tm (c,n) = do
  (c2,t) <- getCategory tm (c,n)
  if isValueConcrete t
     then return (c2,t)
     else compileError $ "Category " ++ show n ++
                         " cannot be used as concrete" ++
                         formatFullContextBrace c

includeNewTypes :: (Show c, MergeableM m, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes tm0 ts = do
  checkConnectionCycles tm0 ts
  checkConnectedTypes tm0 ts
  checkParamVariances tm0 ts
  ts <- topoSortCategories tm0 ts
  ts <- flattenAllConnections tm0 ts
  checkCategoryInstances tm0 ts
  declareAllTypes tm0 ts

declareAllTypes :: (Show c, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
declareAllTypes tm0 = foldr (\t tm -> tm >>= update t) (return tm0) where
  update t tm =
    case getCategoryName t `Map.lookup` tm of
        (Just t2) -> compileError $ "Type " ++ show (getCategoryName t) ++
                                    formatFullContextBrace (getCategoryContext t) ++
                                    " has already been declared" ++
                                    showExisting t2
        _ -> return $ Map.insert (getCategoryName t) t tm
  showExisting t
    | isBuiltinCategory (getCategoryName t) = " [builtin type]"
    | otherwise = formatFullContextBrace (getCategoryContext t)

getFilterMap :: [ValueParam c] -> [ParamFilter c] -> ParamFilters
getFilterMap ps fs = getFilters $ zip (Set.toList pa) (repeat []) where
  pa = Set.fromList $ map vpParam ps
  getFilters pa0 = let fs' = map (\f -> (pfParam f,pfFilter f)) fs in
                       Map.fromListWith (++) $ map (second (:[])) fs' ++ pa0

getCategoryFilterMap :: AnyCategory c -> ParamFilters
getCategoryFilterMap t = getFilterMap (getCategoryParams t) (getCategoryFilters t)

-- TODO: Use this where it's needed in this file.
getFunctionFilterMap :: ScopedFunction c -> ParamFilters
getFunctionFilterMap f = getFilterMap (pValues $ sfParams f) (sfFilters f)

checkConnectedTypes :: (Show c, MergeableM m, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkConnectedTypes tm0 ts = do
  tm <- declareAllTypes tm0 ts
  mergeAllM (map (checkSingle tm) ts)
  where
    checkSingle tm (ValueInterface c _ n _ rs _ _) = do
      let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs
      is <- collectAllOrErrorM $ map (getCategory tm) ts
      mergeAllM (map (valueRefinesInstanceError c n) is)
      mergeAllM (map (valueRefinesConcreteError c n) is)
    checkSingle tm (ValueConcrete c _ n _ rs ds _ _) = do
      let ts1 = map (\r -> (vrContext r,tiName $ vrType r)) rs
      let ts2 = map (\d -> (vdContext d,diName $ vdType d)) ds
      is1 <- collectAllOrErrorM $ map (getCategory tm) ts1
      is2 <- collectAllOrErrorM $ map (getCategory tm) ts2
      mergeAllM (map (concreteRefinesInstanceError c n) is1)
      mergeAllM (map (concreteDefinesValueError c n) is2)
      mergeAllM (map (concreteRefinesConcreteError c n) is1)
      mergeAllM (map (concreteDefinesConcreteError c n) is2)
    checkSingle _ _ = return ()
    valueRefinesInstanceError c n (c2,t)
      | isInstanceInterface t =
        compileError $ "Value interface " ++ show n ++ formatFullContextBrace c ++
                      " cannot refine type interface " ++
                      show (iiName t) ++ formatFullContextBrace c2
      | otherwise = return ()
    valueRefinesConcreteError c n (c2,t)
      | isValueConcrete t =
        compileError $ "Value interface " ++ show n ++ formatFullContextBrace c ++
                      " cannot refine concrete type " ++
                      show (getCategoryName t) ++ formatFullContextBrace c2
      | otherwise = return ()
    concreteRefinesInstanceError c n (c2,t)
      | isInstanceInterface t =
        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++
                      " cannot refine instance interface " ++
                      show (getCategoryName t) ++ formatFullContextBrace c2 ++
                      " => use defines instead"
      | otherwise = return ()
    concreteDefinesValueError c n (c2,t)
      | isValueInterface t =
        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++
                      " cannot define value interface " ++
                      show (getCategoryName t) ++ formatFullContextBrace c2 ++
                      " => use refines instead"
      | otherwise = return ()
    concreteRefinesConcreteError c n (c2,t)
      | isValueConcrete t =
        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++
                      " cannot refine concrete type " ++
                      show (getCategoryName t) ++ formatFullContextBrace c2
      | otherwise = return ()
    concreteDefinesConcreteError c n (c2,t)
      | isValueConcrete t =
        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++
                      " cannot define concrete type " ++
                      show (getCategoryName t) ++ formatFullContextBrace c2
      | otherwise = return ()

checkConnectionCycles :: (Show c, MergeableM m, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkConnectionCycles tm0 ts = mergeAllM (map (checker []) ts) where
  tm = Map.union tm0 $ Map.fromList $ zip (map getCategoryName ts) ts
  checker us (ValueInterface c _ n _ rs _ _) = do
    failIfCycle n c us
    let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs
    is <- collectAllOrErrorM $ map (getValueCategory tm) ts
    mergeAllM (map (checker (us ++ [n]) . snd) is)
  checker us (ValueConcrete c _ n _ rs _ _ _) = do
    failIfCycle n c us
    let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs
    is <- collectAllOrErrorM $ map (getValueCategory tm) ts
    mergeAllM (map (checker (us ++ [n]) . snd) is)
  checker _ _ = return ()
  failIfCycle n c us =
    when (n `Set.member` (Set.fromList us)) $
      compileError $ "Category " ++ show n ++ formatFullContextBrace c ++
                     " refers back to itself: " ++
                     intercalate " -> " (map show (us ++ [n]))

checkParamVariances :: (Show c, MergeableM m, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkParamVariances tm0 ts = do
  tm <- declareAllTypes tm0 ts
  let r = CategoryResolver tm
  mergeAllM (map (checkCategory r) ts)
  where
    checkCategory r (ValueInterface c _ n ps rs fa _) = do
      noDuplicates c n ps
      let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps
      mergeAllM (map (checkRefine r vm) rs)
      mergeAllM $ map (checkFilterVariance r vm) fa
    checkCategory r (ValueConcrete c _ n ps rs ds fa _) = do
      noDuplicates c n ps
      let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps
      mergeAllM (map (checkRefine r vm) rs)
      mergeAllM (map (checkDefine r vm) ds)
      mergeAllM $ map (checkFilterVariance r vm) fa
    checkCategory r (InstanceInterface c _ n ps fa _) = do
      noDuplicates c n ps
      let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps
      mergeAllM $ map (checkFilterVariance r vm) fa
    noDuplicates c n ps = mergeAllM (map checkCount $ group $ sort $ map vpParam ps) where
      checkCount xa@(x:_:_) =
        compileError $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++
                      " times in " ++ show n ++ formatFullContextBrace c
      checkCount _ = return ()
    checkRefine r vm (ValueRefine c t) =
      validateInstanceVariance r vm Covariant (SingleType $ JustTypeInstance t) `reviseError`
        (show t ++ formatFullContextBrace c)
    checkDefine r vm (ValueDefine c t) =
      validateDefinesVariance r vm Covariant t `reviseError`
        (show t ++ formatFullContextBrace c)
    checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterRequires t)) =
      flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do
        case n `Map.lookup` vs of
             Just Contravariant -> compileError $ "Contravariant param " ++ show n ++
                                                  " cannot have a requires filter"
             Nothing -> compileError $ "Param " ++ show n ++ " is undefined"
             _ -> return ()
        validateInstanceVariance r vs Contravariant (SingleType t)
    checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterAllows t)) =
      flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do
        case n `Map.lookup` vs of
             Just Covariant -> compileError $ "Covariant param " ++ show n ++
                                              " cannot have an allows filter"
             Nothing -> compileError $ "Param " ++ show n ++ " is undefined"
             _ -> return ()
        validateInstanceVariance r vs Covariant (SingleType t)
    checkFilterVariance r vs (ParamFilter c n f@(DefinesFilter t)) =
      flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do
        case n `Map.lookup` vs of
             Just Contravariant -> compileError $ "Contravariant param " ++ show n ++
                                                  " cannot have a defines filter"
             Nothing -> compileError $ "Param " ++ show n ++ " is undefined"
             _ -> return ()
        validateDefinesVariance r vs Contravariant t

checkCategoryInstances :: (Show c, MergeableM m, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m ()
checkCategoryInstances tm0 ts = do
  tm <- declareAllTypes tm0 ts
  let r = CategoryResolver tm
  mergeAllM $ map (checkSingle r) ts
  where
    checkSingle r t = do
      let pa = Set.fromList $ map vpParam $ getCategoryParams t
      let fm = getCategoryFilterMap t
      let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t
      mergeAllM $ map (checkFilterParam pa) (getCategoryFilters t)
      mergeAllM $ map (checkRefine r fm) (getCategoryRefines t)
      mergeAllM $ map (checkDefine r fm) (getCategoryDefines t)
      mergeAllM $ map (checkFilter r fm) (getCategoryFilters t)
      mergeAllM $ map (validateCategoryFunction r t) (getCategoryFunctions t)
    checkFilterParam pa (ParamFilter c n _) =
      when (not $ n `Set.member` pa) $
        compileError $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist"
    checkRefine r fm (ValueRefine c t) =
      validateTypeInstance r fm t `reviseError`
        (show t ++ formatFullContextBrace c)
    checkDefine r fm (ValueDefine c t) =
      validateDefinesInstance r fm t `reviseError`
        (show t ++ formatFullContextBrace c)
    checkFilter r fm (ParamFilter c n f) =
      validateTypeFilter r fm f `reviseError`
        (show n ++ " " ++ show f ++ formatFullContextBrace c)

validateCategoryFunction :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) =>
  r -> AnyCategory c -> ScopedFunction c -> m ()
validateCategoryFunction r t f = do
  let fm = getCategoryFilterMap t
  let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t
  flip reviseError ("In function:\n---\n" ++ show f ++ "\n---\n") $ do
    funcType <- parsedToFunctionType f
    case sfScope f of
         CategoryScope -> validatateFunctionType r Map.empty Map.empty funcType
         TypeScope     -> validatateFunctionType r fm vm funcType
         ValueScope    -> validatateFunctionType r fm vm funcType

topoSortCategories :: (Show c, MergeableM m, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
topoSortCategories tm0 ts = do
  tm <- declareAllTypes tm0 ts
  (ts',_) <- foldr (update tm) (return ([],Map.keysSet tm0)) ts
  return ts'
  where
    update tm t u = do
      (ts,ta) <- u
      if getCategoryName t `Set.member` ta
         then return (ts,ta)
         else do
          refines <- collectAllOrErrorM $
                    map (\r -> getCategory tm (vrContext r,tiName $ vrType r)) $ getCategoryRefines t
          defines <- collectAllOrErrorM $
                    map (\d -> getCategory tm (vdContext d,diName $ vdType d)) $ getCategoryDefines t
          (ts',ta') <- foldr (update tm) u (map snd $ refines ++ defines)
          let ts'' = ts' ++ [t]
          let ta'' = Set.insert (getCategoryName t) ta'
          return (ts'',ta'')

mergeObjects :: (MergeableM m, CompileErrorM m) =>
  (a -> a -> m ()) -> [a] -> m [a]
mergeObjects f = return . merge [] where
  merge cs [] = cs
  merge cs (x:xs) = merge (cs ++ ys) xs where
    -- TODO: Should f just perform merging? In case we want to preserve info
    -- about what was merged, e.g., return m [(p,a)].
    checker x2 = f x2 x
    ys = if isCompileError $ mergeAnyM (map checker (cs ++ xs))
            then [x] -- x is not redundant => keep.
            else []  -- x is redundant => remove.

mergeRefines :: (MergeableM m, CompileErrorM m, TypeResolver r) =>
  r -> ParamFilters -> [ValueRefine c] -> m [ValueRefine c]
mergeRefines r f = mergeObjects check where
  check (ValueRefine _ t1@(TypeInstance n1 _)) (ValueRefine _ t2@(TypeInstance n2 _))
    | n1 /= n2 = compileError $ show t1 ++ " and " ++ show t2 ++ " are incompatible"
    | otherwise = do
      checkGeneralMatch r f Covariant (SingleType $ JustTypeInstance $ t1)
                                      (SingleType $ JustTypeInstance $ t2)

mergeDefines :: (MergeableM m, CompileErrorM m, TypeResolver r) =>
  r -> ParamFilters -> [ValueDefine c] -> m [ValueDefine c]
mergeDefines r f = mergeObjects check where
  check (ValueDefine _ t1@(DefinesInstance n1 _)) (ValueDefine _ t2@(DefinesInstance n2 _))
    | n1 /= n2 = compileError $ show t1 ++ " and " ++ show t2 ++ " are incompatible"
    | otherwise = do
      checkDefinesMatch r f t1 t2
      return ()

noDuplicateRefines :: (Show c, MergeableM m, CompileErrorM m) =>
  [c] -> CategoryName -> [ValueRefine c] -> m ()
noDuplicateRefines c n rs = do
  let names = map (\r -> (tiName $ vrType r,r)) rs
  noDuplicates c n names

noDuplicateDefines :: (Show c, MergeableM m, CompileErrorM m) =>
  [c] -> CategoryName -> [ValueDefine c] -> m ()
noDuplicateDefines c n ds = do
  let names = map (\d -> (diName $ vdType d,d)) ds
  noDuplicates c n names

noDuplicates :: (Show c, Show a, MergeableM m, CompileErrorM m) =>
  [c] -> CategoryName -> [(CategoryName,a)] -> m ()
noDuplicates c n ns =
  mergeAllM $ map checkCount $ groupBy (\x y -> fst x == fst y) $
                               sortBy (\x y -> fst x `compare` fst y) ns where
    checkCount xa@(x:_:_) =
      compileError $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) ++
                      " times in " ++ show n ++ formatFullContextBrace c ++ " :\n---\n" ++
                      intercalate "\n---\n" (map (show . snd) xa)
    checkCount _ = return ()

flattenAllConnections :: (Show c, MergeableM m, CompileErrorM m) =>
  CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]
flattenAllConnections tm0 ts = do
  -- We need to process all refines before type-checking can be done.
  tm1 <- foldr preMerge (return tm0) (reverse ts)
  let r = CategoryResolver tm1
  (ts',_) <- foldr (update r) (return ([],tm0)) (reverse ts)
  return ts'
  where
    preMerge t u = do
      tm <- u
      t' <- preMergeSingle tm t
      return $ Map.insert (getCategoryName t') t' tm
    preMergeSingle tm t@(ValueInterface c ns n ps rs vs fs) = do
      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs
      return $ ValueInterface c ns n ps rs' vs fs
    preMergeSingle tm t@(ValueConcrete c ns n ps rs ds vs fs) = do
      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs
      return $ ValueConcrete c ns n ps rs' ds vs fs
    preMergeSingle _ t = return t
    update r t u = do
      (ts,tm) <- u
      t' <- updateSingle r tm t `reviseError`
              ("In category " ++ show (getCategoryName t) ++
               formatFullContextBrace (getCategoryContext t))
      return (ts ++ [t'],Map.insert (getCategoryName t') t' tm)
    updateSingle r tm t@(ValueInterface c ns n ps rs vs fs) = do
      let fm = getCategoryFilterMap t
      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs
      rs'' <- mergeRefines r fm rs'
      noDuplicateRefines c n rs''
      checkMerged r fm rs rs''
      -- Only merge from direct parents.
      fs' <- mergeFunctions r tm fm rs [] fs
      return $ ValueInterface c ns n ps rs'' vs fs'
    -- TODO: Remove duplication below and/or have separate tests.
    updateSingle r tm t@(ValueConcrete c ns n ps rs ds vs fs) = do
      let fm = getCategoryFilterMap t
      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs
      rs'' <- mergeRefines r fm rs'
      noDuplicateRefines c n rs''
      checkMerged r fm rs rs''
      ds' <- mergeDefines r fm ds
      noDuplicateDefines c n ds'
      -- Only merge from direct parents.
      fs' <- mergeFunctions r tm fm rs ds fs
      return $ ValueConcrete c ns n ps rs'' ds' vs fs'
    updateSingle _ _ t = return t
    getRefines tm ra@(ValueRefine c t@(TypeInstance n ps)) = do
      (_,v) <- getValueCategory tm (c,n)
      let refines = getCategoryRefines v
      pa <- assignParams tm c t
      fmap (ra:) $ collectAllOrErrorM $ map (subAll c pa) refines
    subAll c pa (ValueRefine c1 t1) = do
      (SingleType (JustTypeInstance t2)) <-
        uncheckedSubInstance (getValueForParam pa) (SingleType (JustTypeInstance t1))
      return $ ValueRefine (c ++ c1) t2
    assignParams tm c (TypeInstance n ps) = do
      (_,v) <- getValueCategory tm (c,n)
      let ns = map vpParam $ getCategoryParams v
      paired <- processPairs alwaysPair (Positional ns) ps
      return $ Map.fromList paired
    checkMerged r fm rs rs2 = do
      let rm = Map.fromList $ map (\t -> (tiName $ vrType t,t)) rs
      mergeAllM $ map (\t -> checkConvert r fm (tiName (vrType t) `Map.lookup` rm) t) rs2
    checkConvert r fm (Just ta1@(ValueRefine _ t1)) ta2@(ValueRefine _ t2) = do
      checkGeneralMatch r fm Covariant (SingleType $ JustTypeInstance t1)
                                       (SingleType $ JustTypeInstance t2) `reviseError`
        ("Cannot refine " ++ show ta1 ++ " from inherited " ++ show ta2)
      return ()
    checkConvert _ _ _ _ = return ()

mergeFunctions :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) =>
  r -> CategoryMap c -> ParamFilters -> [ValueRefine c] ->
  [ValueDefine c] -> [ScopedFunction c] -> m [ScopedFunction c]
mergeFunctions r tm fm rs ds fs = do
  inheritValue <- fmap concat $ collectAllOrErrorM $ map (getRefinesFuncs tm) rs
  inheritType  <- fmap concat $ collectAllOrErrorM $ map (getDefinesFuncs tm) ds
  let inheritByName  = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) $ inheritValue ++ inheritType
  let explicitByName = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) fs
  let allNames = Set.toList $ Set.union (Map.keysSet inheritByName) (Map.keysSet explicitByName)
  collectAllOrErrorM $ map (mergeByName r fm inheritByName explicitByName) allNames
getRefinesFuncs tm ra@(ValueRefine c (TypeInstance n ts)) = flip reviseError (show ra) $ do
  (_,t) <- getValueCategory tm (c,n)
  let ps = map vpParam $ getCategoryParams t
  let fs = getCategoryFunctions t
  paired <- processPairs alwaysPair (Positional ps) ts
  let assigned = Map.fromList paired
  collectAllOrErrorM (map (uncheckedSubFunction assigned) fs)
getDefinesFuncs tm da@(ValueDefine c (DefinesInstance n ts)) = flip reviseError (show da) $  do
  (_,t) <- getInstanceCategory tm (c,n)
  let ps = map vpParam $ getCategoryParams t
  let fs = getCategoryFunctions t
  paired <- processPairs alwaysPair (Positional ps) ts
  let assigned = Map.fromList paired
  collectAllOrErrorM (map (uncheckedSubFunction assigned) fs)
mergeByName r fm im em n =
  tryMerge r fm n (n `Map.lookup` im) (n `Map.lookup` em)
-- Inherited without an override.
tryMerge _ _ n (Just is) Nothing
  | length is == 1 = return $ head is
  | otherwise = compileError $ "Function " ++ show n ++ " is inherited " ++
                                show (length is) ++ " times:\n---\n" ++
                                intercalate "\n---\n" (map show is)
-- Not inherited.
tryMerge r fm n Nothing es = tryMerge r fm n (Just []) es
-- Explicit override, possibly inherited.
tryMerge r fm n (Just is) (Just es)
  | length es /= 1 = compileError $ "Function " ++ show n ++ " is declared " ++
                                    show (length es) ++ " times:\n---\n" ++
                                    intercalate "\n---\n" (map show es)
  | otherwise = do
    let ff@(ScopedFunction c n t s as rs ps fa ms) = head es
    mergeAllM $ map (checkMerge r fm ff) is
    return $ ScopedFunction c n t s as rs ps fa (ms ++ is)
    where
      checkMerge r fm f1 f2
        | sfScope f1 /= sfScope f2 =
          compileError $ "Cannot merge " ++ showScope (sfScope f2) ++ " with " ++
                          showScope (sfScope f1) ++ " in function merge:\n---\n" ++
                          show f2 ++ "\n  ->\n" ++ show f1
        | otherwise =
          flip reviseError ("In function merge:\n---\n" ++ show f2 ++
                            "\n  ->\n" ++ show f1 ++ "\n---\n") $ do
            f1' <- parsedToFunctionType f1
            f2' <- parsedToFunctionType f2
            checkFunctionConvert r fm f2' f1'

data FunctionName =
  FunctionName {
    fnName :: String
  } |
  BuiltinPresent |
  BuiltinReduce |
  BuiltinRequire |
  BuiltinStrong |
  BuiltinTypename
  deriving (Eq,Ord)

instance Show FunctionName where
  show (FunctionName n) = n
  show BuiltinPresent = "present"
  show BuiltinReduce = "reduce"
  show BuiltinRequire = "require"
  show BuiltinStrong = "strong"
  show BuiltinTypename = "typename"

data ScopedFunction c =
  ScopedFunction {
    sfContext :: [c],
    sfName :: FunctionName,
    sfType :: CategoryName,
    sfScope :: SymbolScope,
    sfArgs :: Positional (PassedValue c),
    sfReturns :: Positional (PassedValue c),
    sfParams :: Positional (ValueParam c),
    sfFilters :: [ParamFilter c],
    sfMerges :: [ScopedFunction c]
  }

instance Show c => Show (ScopedFunction c) where
  show f = showFunctionInContext (showScope (sfScope f) ++ " ") "" f

showFunctionInContext :: Show c => String -> String -> ScopedFunction c -> String
showFunctionInContext s indent (ScopedFunction cs n t _ as rs ps fa ms) =
  indent ++ s ++ "/*" ++ show t ++ "*/ " ++ show n ++
  showParams (pValues ps) ++ " " ++ formatContext cs ++ "\n" ++
  concat (map (\v -> indent ++ formatValue v ++ "\n") fa) ++
  indent ++ "(" ++ intercalate "," (map (show . pvType) $ pValues as) ++ ") -> " ++
  "(" ++ intercalate "," (map (show . pvType) $ pValues rs) ++ ")" ++ showMerges (flatten ms)
  where
    showParams [] = ""
    showParams ps = "<" ++ intercalate "," (map (show . vpParam) ps) ++ ">"
    formatContext cs = "/*" ++ formatFullContext cs ++ "*/"
    formatValue v = "  " ++ show (pfParam v) ++ " " ++ show (pfFilter v) ++
                    " " ++ formatContext (pfContext v)
    flatten [] = Set.empty
    flatten ms = Set.unions $ (Set.fromList $ map sfType ms):(map (flatten . sfMerges) ms)
    showMerges ms
      | null (Set.toList ms) = " /*not merged*/"
      | otherwise = " /*merged from: " ++ intercalate ", " (map show $ Set.toList ms) ++ "*/"

data PassedValue c =
  PassedValue {
    pvContext :: [c],
    pvType :: ValueType
  }

instance Show c => Show (PassedValue c) where
  show (PassedValue c t) = show t ++ formatFullContextBrace c

parsedToFunctionType :: (Show c, MergeableM m, CompileErrorM m) =>
  ScopedFunction c -> m FunctionType
parsedToFunctionType (ScopedFunction c n t _ as rs ps fa _) = do
  let as' = Positional $ map pvType $ pValues as
  let rs' = Positional $ map pvType $ pValues rs
  let ps' = Positional $ map vpParam $ pValues ps
  mergeAllM $ map checkFilter fa
  let fm = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) fa
  let fa' = Positional $ map (getFilters fm) $ pValues ps'
  return $ FunctionType as' rs' ps' fa'
  where
    pa = Set.fromList $ map vpParam $ pValues ps
    checkFilter f =
      when (not $ (pfParam f) `Set.member` pa) $
      compileError $ "Filtered param " ++ show (pfParam f) ++
                     " is not defined for function " ++ show n ++
                     formatFullContextBrace c
    getFilters fm n =
      case n `Map.lookup` fm of
           (Just fs) -> fs
           _ -> []

uncheckedSubFunction :: (Show c, MergeableM m, CompileErrorM m) =>
  Map.Map ParamName GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)
uncheckedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) =
  flip reviseError ("In function:\n---\n" ++ show ff ++ "\n---\n") $ do
    let fixed = Map.fromList $ map (\n -> (n,SingleType $ JustParamName n)) $ map vpParam $ pValues ps
    let pa' = Map.union pa fixed
    as' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues as
    rs' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues rs
    fa' <- collectAllOrErrorM $ map (subFilter pa') fa
    ms' <- collectAllOrErrorM $ map (uncheckedSubFunction pa) ms
    return $ (ScopedFunction c n t s as' rs' ps fa' ms')
    where
      subPassed pa (PassedValue c t) = do
        t' <- uncheckedSubValueType (getValueForParam pa) t
        return $ PassedValue c t'
      subFilter pa (ParamFilter c n f) = do
        f' <- uncheckedSubFilter (getValueForParam pa) f
        return $ ParamFilter c n f'