import Data.List
import Control.Monad


type Check a = Either String a

type Type = String
type Var  = String
type FSym = String
type FSym_Info = ([Type], Type)
type Vars = Var -> Check Type
type Sig = FSym -> Check FSym_Info
data Term = 
  Var Var 
  | Fun FSym [Term]
  deriving (Eq, Show)

failure :: String -> Check a
failure = Left

assert :: Bool -> String -> Check ()
assert p err = if p then return () else failure err

type_check :: Sig -> Vars -> Term -> Check Type
type_check sig vars (Var x) = vars x
type_check sig vars t@(Fun f ts) = do
  (tys_in, ty_out) <- sig f
  tys_ts <- mapM (type_check sig vars) ts
  assert (tys_ts == tys_in) ("argument types different"
    ++ " from types of function symbol " ++ f ++ " when "
    ++ " checking term " ++ show t)
  return ty_out


infer_type :: Sig -> Type -> Term -> Check [(Var,Type)]
infer_type sig ty (Var x) = return [(x, ty)]
infer_type sig ty (Fun f ts) = do
  (tys_in, ty_out) <- sig f
  assert (ty == ty_out) "message"
  assert (length tys_in == length ts) "message"
  vars_l <- mapM 
    (\ (ty_i, ti) -> infer_type sig ty_i ti)
    (zip tys_in ts)
  let vars = nub (concat vars_l)
  assert (distinct (map fst vars)) "message"
  return vars


distinct :: Eq a => [a] -> Bool
distinct xs = length (nub xs) == length xs

  
type_check_eqn :: Sig -> (Term, Term) -> Check ()
type_check_eqn sigma (Var x, r) = failure "message"
type_check_eqn sigma (l @ (Fun f _), r) = do
  (_, ty_out) <- sigma f
  vars <- infer_type sigma ty_out l
  ty_r <- type_check sigma 
    (\ x -> maybeToEither "var not found" (lookup x vars)) 
    r
  assert (ty_out == ty_r) "message"

maybeToEither :: e -> Maybe a -> Either e a
maybeToEither err Nothing = Left err
maybeToEither _ (Just x) = Right x




data Data_Definition = Data Type [(FSym, FSym_Info)]
data Function_Definition = Function 
  FSym 
  FSym_Info 
  [(Term,Term)]
type Functional_Prog = 
  ([Data_Definition],[Function_Definition])

type Sig_List = [(FSym, FSym_Info)]
type Defs = Sig_List
type Cons = Sig_List
type Equations = [(Term,Term)]

data Prog_Info = Prog_Info 
  [Type] 
  Cons 
  Defs 
  Equations 
  deriving Show

process_data_definition :: 
  Prog_Info -> Data_Definition -> Check Prog_Info
process_data_definition 
  pi@(Prog_Info tys cons defs eqs) 
  (Data ty new_cs) 
  = do
  -- check that type is fresh
      assert (not (elem ty tys)) (ty ++ " is not a fresh type name")
  -- compute new types
      let new_tys = ty : tys
      let old_names = map fst (cons ++ defs)
  -- check distinctness of new constructor names
      assert (distinct (map fst new_cs)) "message"
  -- check fresh constructor names
      mapM 
        ( \ c -> assert (not (elem c old_names)) 
           (c ++ " is not a fresh name"))
        (map fst new_cs)
     -- oder so
      assert (all  
        ( \ c -> not (elem c old_names))
        (map fst new_cs)) "message"
  -- check types of constructors
      assert (all 
        ( \ (c, (tys_in, ty_out)) -> 
           ty_out == ty && 
           all ( \ ty_arg -> elem ty_arg new_tys ) tys_in
        )
        new_cs
       ) "message"
  -- check existence of non-recursive constructor  
      assert (any 
        ( \ (c, (tys_in, _)) -> 
           all ( \ ty_arg -> elem ty_arg tys ) tys_in
        )
        new_cs
       ) "no non-rec. constructor"
  -- return new prog info
      return (Prog_Info new_tys (new_cs ++ cons) defs eqs)




process_data_definitions :: 
  Prog_Info -> [Data_Definition] -> Check Prog_Info
process_data_definitions = foldM process_data_definition