module Syntax where

import Data.List

------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
------------------------------------------------------------------

-- info for all primops; the totality of the info in primops.txt(.pp)
data Info
  defaults , primops
     deriving Show

  info for one primop
data Entry
    = PrimOpSpec { cons  :: String,      -- PrimOp name
                   name  :: String,      -- name in prog text
                   ty    :: Ty,          -- type
                   cat   :: Category,    -- category
                   desc  :: String,      -- description
                   opts  :: [Option] }   -- default overrides
    | PrimVecOpSpec { cons    :: String,    -- PrimOp name
                      name    :: String,    -- name in prog text
                      prefix  :: String,    -- prefix for generated names
                      veclen  :: Int,       -- vector length
  vector 
                      ty      :: Ty,        -- type
                      cat     :: Category,  -- category
                      desc    :: String,    -- description
                      opts    :: [Option] } -- default overrides
    | PseudoOpSpec { name  :: String,      -- name in prog text
                     ty    :: Ty,          -- type
                     desc  :: String,      -- description
                     opts  :: [Option] }   -- default overrides
    | PrimTypeSpec { ty    :: Ty,      -- name in prog text
                     desc  :: String,      -- description
                     opts  :: [Option] }   -- default overrides
    | PrimVecTypeSpec { ty    :: Ty,      -- name in prog text
                        prefix  :: String,    -- prefix for generated names
                        veclen  :: Int,       -- vector length
  vector 
                        desc  :: String,      -- description
                        opts  :: [Option] }   -- default overrides
    | Section { title :: String,         -- section title
                desc  :: String }        -- description
    deriving Show

is_primop :: Entry -> Bool
is_primop (PrimOpSpec _ _ _ _ _ _) = True
is_primop _ = False

is_primtype :: Entry -> Bool
is_primtype (PrimTypeSpec {}) = True
is_primtype _ = False

-- a binding of property to value
data Option
   = OptionFalse  String          -- name = False
   | OptionTrue   String          -- name = True
   | OptionString String String   -- name = { ... unparsed stuff ... }
   | OptionInteger String Int     -- name = <int>
   | OptionVector [(String,String,Int)]  -- name = [(,...),...]
   | OptionFixity (Maybe Fixity)  -- fixity = infix{,l,r} <int> | Nothing
     deriving Show

  categorises 
data Category
   = Dyadic | Monadic | Compare | GenPrimOp
     deriving Show

-- types
data Ty
   = TyF    Ty Ty
  We only allow one constraint , keeps the grammar simpler
   | TyApp  TyCon [Ty]
   | TyVar  TyVar
  unboxed tuples ; just a  really ,
                   -- but convenient like this
   deriving (Eq,Show)

type TyVar = String

data TyCon = TyCon String
           | SCALAR
           | VECTOR
           | VECTUPLE
           | VecTyCon String String
  deriving (Eq, Ord)

instance Show TyCon where
    show (TyCon tc)      = tc
    show SCALAR          = "SCALAR"
    show VECTOR          = "VECTOR"
    show VECTUPLE        = "VECTUPLE"
    show (VecTyCon tc _) = tc

  Follow definitions of Fixity and FixityDirection in GHC

  The String exists so that it matches the SourceText field in
  BasicTypes . Fixity
data Fixity = Fixity String Int FixityDirection
  deriving (Eq, Show)

data FixityDirection = InfixN | InfixL | InfixR
  deriving (Eq, Show)

------------------------------------------------------------------
-- Sanity checking -----------------------------------------------
------------------------------------------------------------------

  Do some simple sanity checks : 
     * all the default field names are unique 
     * for each PrimOpSpec , all override field names are unique 
     * for each PrimOpSpec , all overriden field names   
           have a corresponding default value 
     * that primop types correspond in certain ways to the 
       Category : eg if Comparison , the type must be of the form 
          T - > T - > Bool . 
    Dies with " error " if there 's a problem , else returns ( ) . 

    * all the default field names are unique
    * for each PrimOpSpec, all override field names are unique
    * for each PrimOpSpec, all overriden field names   
          have a corresponding default value
    * that primop types correspond in certain ways to the 
      Category: eg if Comparison, the type must be of the form
         T -> T -> Bool.
   Dies with "error" if there's a problem, else returns ().
-}
myseqAll :: [()] -> a -> a
myseqAll (():ys) x = myseqAll ys x
myseqAll []      x = x

sanityTop :: Info -> ()
sanityTop (Info defs entries)
   = let opt_names = map get_attrib_name defs
         primops = filter is_primop entries
     in  
     if   length opt_names /= length (nub opt_names)
     then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
     else myseqAll (map (sanityPrimOp opt_names) primops) ()

sanityPrimOp :: [String] -> Entry -> ()
sanityPrimOp def_names p
   = let p_names = map get_attrib_name (opts p)
         p_names_ok
            = length p_names == length (nub p_names)
              && all (`elem` def_names) p_names
         ty_ok = sane_ty (cat p) (ty p)
     in
         if   not p_names_ok
         then error ("attribute names are non-unique or have no default in\n" ++
                     "info for primop " ++ cons p ++ "\n")
         else
         if   not ty_ok
         then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
                     " category " ++ show (cat p) ++ "\n")
         else ()

sane_ty :: Category -> Ty -> Bool
sane_ty Compare (TyF t1 (TyF t2 td)) 
   | t1 == t2 && td == TyApp (TyCon "Int#") []  = True
sane_ty Monadic (TyF t1 td) 
   | t1 == td  = True
sane_ty Dyadic (TyF t1 (TyF t2 td))
   | t1 == td && t2 == td  = True
sane_ty GenPrimOp _
   = True
sane_ty _ _
   = False

get_attrib_name :: Option -> String
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm)  = nm
get_attrib_name (OptionString nm _) = nm
get_attrib_name (OptionInteger nm _) = nm
get_attrib_name (OptionVector _) = "vector"
get_attrib_name (OptionFixity _) = "fixity"

lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
lookup_attrib nm (a:as) 
    = if get_attrib_name a == nm then Just a else lookup_attrib nm as

is_vector :: Entry -> Bool
is_vector i = case lookup_attrib "vector" (opts i) of
                Nothing -> False
                _       -> True

----------------------------------------------------------------
 Abstract syntax -----------------------------------------------
----------------------------------------------------------------
 info for all primops; the totality of the info in primops.txt(.pp)
 PrimOp name
 name in prog text
 type
 category
 description
 default overrides
 PrimOp name
 name in prog text
 prefix for generated names
 vector length
 type
 category
 description
 default overrides
 name in prog text
 type
 description
 default overrides
 name in prog text
 description
 default overrides
 name in prog text
 prefix for generated names
 vector length
 description
 default overrides
 section title
 description
 a binding of property to value
 name = False
 name = True
 name = { ... unparsed stuff ... }
 name = <int>
 name = [(,...),...]
 fixity = infix{,l,r} <int> | Nothing
 types
 but convenient like this
----------------------------------------------------------------
 Sanity checking -----------------------------------------------
----------------------------------------------------------------
module Syntax where

import Data.List


data Info
  defaults , primops
     deriving Show

  info for one primop
data Entry
  vector 
  vector 
    deriving Show

is_primop :: Entry -> Bool
is_primop (PrimOpSpec _ _ _ _ _ _) = True
is_primop _ = False

is_primtype :: Entry -> Bool
is_primtype (PrimTypeSpec {}) = True
is_primtype _ = False

data Option
     deriving Show

  categorises 
data Category
   = Dyadic | Monadic | Compare | GenPrimOp
     deriving Show

data Ty
   = TyF    Ty Ty
  We only allow one constraint , keeps the grammar simpler
   | TyApp  TyCon [Ty]
   | TyVar  TyVar
  unboxed tuples ; just a  really ,
   deriving (Eq,Show)

type TyVar = String

data TyCon = TyCon String
           | SCALAR
           | VECTOR
           | VECTUPLE
           | VecTyCon String String
  deriving (Eq, Ord)

instance Show TyCon where
    show (TyCon tc)      = tc
    show SCALAR          = "SCALAR"
    show VECTOR          = "VECTOR"
    show VECTUPLE        = "VECTUPLE"
    show (VecTyCon tc _) = tc

  Follow definitions of Fixity and FixityDirection in GHC

  The String exists so that it matches the SourceText field in
  BasicTypes . Fixity
data Fixity = Fixity String Int FixityDirection
  deriving (Eq, Show)

data FixityDirection = InfixN | InfixL | InfixR
  deriving (Eq, Show)


  Do some simple sanity checks : 
     * all the default field names are unique 
     * for each PrimOpSpec , all override field names are unique 
     * for each PrimOpSpec , all overriden field names   
           have a corresponding default value 
     * that primop types correspond in certain ways to the 
       Category : eg if Comparison , the type must be of the form 
          T - > T - > Bool . 
    Dies with " error " if there 's a problem , else returns ( ) . 

    * all the default field names are unique
    * for each PrimOpSpec, all override field names are unique
    * for each PrimOpSpec, all overriden field names   
          have a corresponding default value
    * that primop types correspond in certain ways to the 
      Category: eg if Comparison, the type must be of the form
         T -> T -> Bool.
   Dies with "error" if there's a problem, else returns ().
-}
myseqAll :: [()] -> a -> a
myseqAll (():ys) x = myseqAll ys x
myseqAll []      x = x

sanityTop :: Info -> ()
sanityTop (Info defs entries)
   = let opt_names = map get_attrib_name defs
         primops = filter is_primop entries
     in  
     if   length opt_names /= length (nub opt_names)
     then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
     else myseqAll (map (sanityPrimOp opt_names) primops) ()

sanityPrimOp :: [String] -> Entry -> ()
sanityPrimOp def_names p
   = let p_names = map get_attrib_name (opts p)
         p_names_ok
            = length p_names == length (nub p_names)
              && all (`elem` def_names) p_names
         ty_ok = sane_ty (cat p) (ty p)
     in
         if   not p_names_ok
         then error ("attribute names are non-unique or have no default in\n" ++
                     "info for primop " ++ cons p ++ "\n")
         else
         if   not ty_ok
         then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
                     " category " ++ show (cat p) ++ "\n")
         else ()

sane_ty :: Category -> Ty -> Bool
sane_ty Compare (TyF t1 (TyF t2 td)) 
   | t1 == t2 && td == TyApp (TyCon "Int#") []  = True
sane_ty Monadic (TyF t1 td) 
   | t1 == td  = True
sane_ty Dyadic (TyF t1 (TyF t2 td))
   | t1 == td && t2 == td  = True
sane_ty GenPrimOp _
   = True
sane_ty _ _
   = False

get_attrib_name :: Option -> String
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm)  = nm
get_attrib_name (OptionString nm _) = nm
get_attrib_name (OptionInteger nm _) = nm
get_attrib_name (OptionVector _) = "vector"
get_attrib_name (OptionFixity _) = "fixity"

lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
lookup_attrib nm (a:as) 
    = if get_attrib_name a == nm then Just a else lookup_attrib nm as

is_vector :: Entry -> Bool
is_vector i = case lookup_attrib "vector" (opts i) of
                Nothing -> False
                _       -> True
