-- Generates in's and out's for given data types
module InOut where

import Data.Transform.TwoLevel ((><),(/\))
import Language.Haskell.Parser
import Language.Haskell.Syntax
import Language.Haskell.Pretty (prettyPrint)

import Language.Pointwise.Syntax hiding (swap)
import Language.Pointwise.Pretty (pw2hs)

-- In
makeIn :: [HsConDecl] -> Term
makeIn = makeIn2 . makeIn1
        where
                makeIn1 :: [HsConDecl] -> [(String, Int)] -- (Name, arity)
		makeIn1 lcons = map removeRecs lcons
                -- 'Strict' or not, doesn't really matter
		removeRecs :: HsConDecl -> (String, Int)
		removeRecs (HsConDecl loc (HsIdent name) l)  = (name, length l)
                removeRecs (HsConDecl loc (HsSymbol name) l) = (name, length l)
                removeRecs (HsRecDecl loc name l) = error "makeIn: record constructors not supported"

                makeIn2 :: [(String, Int)] -> Term
		makeIn2 [x] = handle x
                makeIn2 (h:t) = (Const "either" :@: handle h) :@: makeIn2 t

                handle :: (String, Int) -> Term
		handle (s,0) = Const "const" :@: Const s
                handle (s,1) = Const s
                handle (s,n) = (foldr1 (:@:) (replicate (pred n) (Const "uncurry"))) :@: Const s
                
-- Out
makeOut :: [HsConDecl] -> Term
makeOut = Match (Var "x") . (uncurry zip) . (makeLhs /\ makeRhs) . makeOut1
        where
                makeOut1 :: [HsConDecl] -> [(String, Int)] -- (Name, arity)
		makeOut1 lcons = map removeRecs lcons
                -- 'Strict' or not, doesn't really matter
		removeRecs :: HsConDecl -> (String, Int)
		removeRecs (HsConDecl loc (HsIdent name) l)  = (name, length l)
                removeRecs (HsConDecl loc (HsSymbol name) l) = (name, length l)
                removeRecs (HsRecDecl loc name l) = error "makeOut: record constructors not supported"

                makeLhs :: [(String, Int)] -> [Term]
		makeLhs = map (\(s,a) -> getVars s a)
                        where
                                getVars s 0 = Var s
                                getVars s 1 = Var s :@: (Var $ head vars)
                                -- getVars s n = Var s :@: (foldr1 (:@:) $ map Var (take n vars)) -- :@: is not right
				getVars s n = Var s :@: (Const (foldr1 (\a b -> a++" "++b) (take n vars))) -- awful solution

                makeRhs :: [(String, Int)] -> [Term]
		makeRhs l = map (\((s,a),(i,n)) -> handle (i,n) a) l2 
                        where l2 = zip l [(i, length l) | i <- [1..]]

                handle :: (Int,Int) -> Int -> Term
		handle (i,1) a = getVars a
                handle (i,n) a = (getPlace i n) $ getVars a
                getVars 0 = Unit
                getVars 1 = Var $ head vars
                getVars n = foldr1 (:&:) $ map Var (take n vars)
                
                getPlace :: Int -> Int -> (Term -> Term)
		getPlace i n 
                        | i == 1 = Inl
                        | i > 1 && i < n = ini . Inl
                        | i == n = ini
                        | otherwise = error "getPlace: not enough constructors"
                        where
                                ini :: Term -> Term
				ini t = foldr ($) t (replicate (pred i) (Inr))
                
                vars :: [String]
		vars = map (\(a,b) -> a : show b) $ zip (repeat 'x') [1..]

{-
-- Tests, stuff to remove
pppw :: Term -> String
pppw = prettyPrint . pw2hs 

testIns = do
        let 
                tests =
                        [
                                "data A = Empty", 
                                "data B = Empty1 | Empty2 ()",
                                "data C = Cons1 Int Bool | Cons2 (Int,Bool)",
                                "data D = Lister [Maybe Int]",
                                "data E = Leaf | Node E",
                                "data F = Nil | Cons Int X",
                                "data G = Fun (Int -> Bool)",
                                "data H = Rose [H] | A | B | C Int Int Int Int",
                                "data I = Use H"
                        ]
        mapM putStrLn $ map (pppw . makeIn . parse) tests
        
testOuts = do
        let 
                tests =
                        [
                                "data A = Empty", 
                                "data B = Empty1 | Empty2 ()",
                                "data C = Cons1 Int Bool | Cons2 (Int,Bool)",
                                "data D = Lister [Maybe Int]",
                                "data E = Leaf | Node E",
                                "data F = Nil | Cons Int X",
                                "data G = Fun (Int -> Bool)",
                                "data H = Rose [H] | A | B | C Int Int Int Int",
                                "data I = Use H"
                        ]
        mapM putStrLn $ map (pppw . makeOut . parse) tests
  
parse s =
        case (parseModule s) of
           ParseOk (HsModule _ _ _ _ [HsDataDecl _ _ _ _ x _]) -> x
-}