{-
Tock: a compiler for parallel languages
Copyright (C) 2007, 2008, 2009  University of Kent

This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation, either version 2 of the License, or (at your
option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

-- | Generates the OrdAST module.  Template Haskell was a bit too heavyweight
-- for this.  Uses Data.Generics to pick out all the constructors for the
-- given types, skip Meta tags and write out the OrdAST module
-- (to stdout).
module GenOrdAST where

import Control.Monad.State
import Control.Monad.Writer
import Data.Generics
import Data.List

import Metadata
import PregenUtils
import Utils

genHeader :: [String]
genHeader = [
  -- Turn on lots of warnings and make them errors to help ensure our generated code is right:

  "{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}"
 ,"-- | Contains Ord instances for AST elements."
 ,"-- NOTE: This file is auto-generated by the GenOrdAST program, and should not be edited directly."
 ,"module OrdAST where"
 ,""
 ,"import qualified AST"
 ,"import Utils"
 ,""
 ]

-- | Here's the idea for easily building a compare function.  Go through in ascending order.
-- Match A vs A in detail.  For A vs _ give LT, and for _ vs A give GT.  Then repeat for B, C, etc
-- But for the last item, do not give the LT and GT matches!
ordFor' :: forall a. (Data a, Typeable a) => String -> a -> [String]
ordFor' typeName x = process $ map processConstr $ dataTypeConstrs $ dataTypeOf x
  where
    process :: [(String, String, String, [String])] -> [String]
    process [] = []
    process items =
      ["instance Ord (" ++ typeName ++ ") where"]
      ++ concat [ [ "  compare (" ++ name ++ headL ++ ") (" ++ name ++ headR ++ ") = " ++
                    --Shortcut:
                    if null comparisons then "EQ" else
                      "combineCompare [" ++ joinWith "," comparisons ++ "]"
                  ] ++ if isLast then [] else
                  [ "  compare (" ++ name ++ " {}) _ = LT"
                  , "  compare _ (" ++ name ++ " {}) = GT"]
                 | (isLast, (name, headL, headR, comparisons)) <- zip (repeat False) (init items) ++ [(True,last items)] ]
    nextVar :: State Int String
    nextVar = do n <- get
                 put (n + 1)
                 return $ "x" ++ show n
  
    doNormal :: forall a. a -> WriterT (String, String, [String]) (State Int) a
    doNormal x = do v <- lift nextVar
                    tell (" " ++ v ++ " ", " " ++ v ++ "' ", ["compare " ++ v ++ " " ++ v ++ "'"])
                    return x
    
    doMeta :: Meta -> WriterT (String, String, [String]) (State Int) Meta
    doMeta m = tell (" _ ", " _ ", []) >> return m
  
    processConstr :: Constr -> (String, String, String, [String])
    processConstr c = let (x,y,z) = flip evalState 0 $ execWriterT $ gmapM (doNormal `extM` doMeta) $ (fromConstr c :: a) in
                      ("AST." ++ showConstr c, x, y, z)
  
items :: [String]
items = concat [ordFor w | DataBox w <- astTypes]
 where
   ordFor x = ordFor' (show $ typeOf x) x

main :: IO ()
main = putStr $ unlines $ genHeader ++ items