{- 
   Checks: Mackerel compile-time checks
   
  Part of Mackerel: a strawman device definition DSL for Barrelfish
   
  Copyright (c) 2007, 2008, ETH Zurich.
  All rights reserved.
  
  This file is distributed under the terms in the attached LICENSE file.
  If you do not find this file, copies can be found by writing to:
  ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich. Attn: Systems Group.
-}  

module Checks where

import MackerelParser
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos
import System.FilePath
import qualified TypeName as TN
import qualified TypeTable as TT
import qualified RegisterTable as RT
import qualified Space
import qualified Dev
import qualified Fields
import qualified Data.Maybe

import Text.Printf
import Data.List
import System.Environment
import System.Exit
import System.IO

data MacError = MacError SourcePos String 
              deriving Show

data CheckResult = Either String [ MacError ]

check_all :: String -> Dev.Rec -> Maybe [String]
check_all inf dev = 
    let errors = (check_devname inf dev) ++
                 (check_rous dev) ++
                 (check_dous dev) ++
                 (check_undef_consts dev) ++
                 (check_undef_regtypes dev) ++
                 (check_dup_types dev ) ++
                 (check_dup_regs dev ) ++
                 (check_dup_vals dev ) ++
                 (check_overlap dev ) ++
                 (check_undef_spaces dev )
    in
      if (length errors) > 0
      then
         let sort_errs = [ ((sourceName p), 
                            (sourceLine p), 
                            (sourceColumn p), 
                            s) | (MacError p s) <- errors ]
         in Just [ printf "%s:%d:%d: %s" n l c s | (n,l,c,s) <- sort sort_errs ]
      else Nothing
      

check_devname :: String -> Dev.Rec -> [ MacError ]
check_devname inf dev = 
  let (devname_f, ext) = splitExtension $ takeFileName inf
      devname_d = Dev.name dev
  in
   if devname_f /= devname_d
   then [ (MacError (initialPos inf)
           (printf "File %s describes dev %s not %s" inf devname_d devname_f))]
   else []

--
-- Check for Registers of Unusual Size
--

check_rous :: Dev.Rec -> [ MacError ]
check_rous d = 
    [ make_rous_error t 
    | t@(TT.RegFormat {}) <- (Dev.types d), check_rous_type t ]
    ++
    [ make_rous_error t 
    | RT.Rec { RT.tpe = t@(TT.ConstType {}) } <- (Dev.registers d), check_rous_type t ]

check_rous_type t = notElem (TT.tt_size t) [ 8, 16, 32, 64 ]
make_rous_error t = 
    (MacError (TT.pos t)
     (if TT.tt_size t == -1 
      then 
        (printf "Register type '%s' (%s) has no width() specifier"
         (TT.type_name t) (TT.tt_desc t))
      else
        (printf "Type '%s' (%s) is a Register Of Unusual Size (%d bits)"
         (TT.type_name t) (TT.tt_desc t) (TT.tt_size t))))
      
--
-- Check for Data types of Unusual Size
--

check_dous :: Dev.Rec -> [ MacError ]
check_dous d = 
    [ make_dous_error t | t@(TT.DataFormat {}) <- (Dev.types d), check_dous_type t ]

-- XXX Make this a bit more lenient. 
check_dous_type t = notElem (TT.tt_size t) [ 8, 16, 32, 64, 96, 128, 160, 224, 
                                             256, 384, 512 ] 
make_dous_error t = 
    (MacError (TT.pos t)
     (printf "Data type '%s' (%s) is a Datatype Of Unusual Size (%d bits)"
                 (TT.type_name t)
                 (TT.tt_desc t)
                 (TT.tt_size t)))
 
-- 
-- Check for undefined constant types: every use of a constant type in
-- a register definition must have a corresponding constant type
-- definition.
--
check_undef_consts :: Dev.Rec -> [ MacError ]
check_undef_consts d = 
    let clist = [ (TT.tt_name c) | c@(TT.ConstType {}) <- Dev.all_types d ]
    in 
    concat [ check_undef_consts_reg r clist | r <- (Dev.registers d) ]
           
check_undef_consts_reg :: RT.Rec -> [ TN.Name ] -> [MacError]
check_undef_consts_reg r clist = 
    [ make r f | f <- (RT.fl r), check r clist f ]
    where
      check r clist f = 
          case Fields.tpe f of
            Nothing -> False
            Just t -> notElem t clist
      make r f = 
          (MacError (Fields.pos f)
           (printf "Field '%s' (%s) of register '%s' (%s) is of undefined type '%s'"
            (Fields.name f) (Fields.desc f) (RT.name r) (RT.desc r) (TN.toString $ Data.Maybe.fromJust $ Fields.tpe f)))

-- 
-- Check for undefined register types (every register must have a type)
--
check_undef_regtypes :: Dev.Rec -> [ MacError ]
check_undef_regtypes d = 
    [ make r | r <- (Dev.registers d), not (check r (Dev.types d)) ]
    where
      check r ttbl = TN.is_builtin_type (RT.typename r)
                     || elem (RT.typename r) [ (TT.tt_name t) | t <- (Dev.types d)]
      make r = (MacError (RT.pos r)
                (printf "Register '%s' (%s) is of undefined type '%s'"
                            (RT.name r) (RT.desc r) (RT.origtype r) ))



check_dups :: [String] -> ( String -> MacError ) -> [ MacError ]
check_dups names errfn = [ errfn n | n <- names \\ nub names ]

--
-- Duplicate types
-- 
check_dup_types :: Dev.Rec -> [ MacError ]
check_dup_types d = 
    let names = map TT.tt_name (Dev.types d)
        dups = [ n | n <- names \\ nub names ]
    in [ make_dup_type_error d n | n <- dups ]
                   
make_dup_type_error :: Dev.Rec -> TN.Name -> MacError
make_dup_type_error d n =
    let cl = [ (TT.pos c, TT.tt_desc c) | c <- (Dev.types d), (TT.tt_name c) == n ]
        l = sort cl
        (p, _) = head l
    in
      (MacError p
       (printf "Type name '%s' is multiply defined, as:%s" (TN.toString n)
               (concat [ (printf "\n  '%s' (%s)" td (show tp))::String | (tp, td) <- l ])))

-- 
-- Duplicate register names
--
check_dup_regs :: Dev.Rec -> [ MacError ]
check_dup_regs d = 
    check_dups (map RT.name rtbl) (make_dup_reg_error rtbl)
    where rtbl = Dev.registers d

make_dup_reg_error :: [RT.Rec] -> String -> MacError
make_dup_reg_error rtbl n =
    let l = [ (RT.pos c, RT.desc c) | c <- rtbl, (RT.name c) == n ]
        (p, _) = head l
    in
      (MacError p
       (printf "Register '%s' is multiply defined, as:%s" n
               (concat [ (printf "\n  '%s' (%s)" td (show tp))::String | (tp, td) <- l ])))

-- 
-- Duplicate constant values
--
check_dup_vals :: Dev.Rec -> [ MacError ]
check_dup_vals d = 
    let cvals = concat([ [ v | v <- TT.tt_vals c ] | c@(TT.ConstType {}) <- (Dev.types d) ])
    in check_dups (map TT.cname cvals) (make_dup_val_error cvals)
       
make_dup_val_error cvl n =
    let l = [ (TT.cpos c, TT.cdesc c) | c <- cvl, (TT.cname c) == n ]
        (p, _) = head l
    in
      (MacError p
       (printf "Constant value '%s' is multiply defined, as:%s" n
        (concat [ (printf "\n  '%s' (%s)" td (show tp))::String | (tp, td) <- l ])))

-- 
-- Undefined address spaces
--
check_undef_spaces :: Dev.Rec -> [MacError ]
check_undef_spaces d =
    let l = [ (RT.spc_id r, RT.pos r) 
              | r <- (Dev.registers d), (RT.spc r) == Space.UndefinedSpace ]
    in
      [ MacError p (printf "Undefined address space '%s'" n) 
        | (n,p) <- l ]

--
-- Registers overlapping
--
check_overlap :: Dev.Rec -> [ MacError ]
check_overlap d = 
    let l = [ r | r <- Dev.registers d, not (RT.also r) ]
    in
      check_overlap1 l

check_overlap1 [] = []
check_overlap1 [s] = []
check_overlap1 (h:t) = 
    (check_overlap1 t)
    ++ 
    [ make_overlap_error h te | te <- t, RT.overlap h te ]

make_overlap_error :: RT.Rec -> RT.Rec -> MacError
make_overlap_error r1 r2 = 
    MacError (RT.pos r1) (printf "Register '%s' overlaps with register '%s' at '%s'" (RT.name r1) (RT.name r2) (show (RT.pos r2)) )
