Dml.ag

{-
Copyright 2009 Jake Wheat

This file contains the type checking code for dml, currently insert,
update and delete.

================================================================================

= insert

check the insert data is the correct type. Doesn't cope with columns
with default values at the moment.

-}

SEM Statement
    | Insert
        loc.tpe =
            dependsOnRTpe [getTypeAnnotation @insData.annotatedTree] $ do
              @loc.columnTypes
              Right $ Pseudo Void
        loc.statementType =
            leftToEmpty (\ct -> [StatementType [] (fromMaybe [] @returning.listType)]) @loc.columnTypes

        loc.columnTypes =
            do
            tys <- unwrapSetOfComposite $
                   getTypeAnnotation @insData.annotatedTree
            checkColumnConsistency @lhs.env
                                   @table
                                   @targetCols.strings
                                   tys

        loc.backTree = Insert @ann @table @targetCols.annotatedTree
                              @insData.annotatedTree @returning.annotatedTree
        loc.envUpdates = []

-- inject the ids into the returning part

SEM Statement
    | Insert
        returning.lib =
            fromRight @lhs.lib $ do
              atts <- envCompositeAttrs @lhs.env relationComposites @table
              updateBindings @lhs.lib @lhs.env [LibStackIDs [("", atts)]]

{-
================================================================================

= update

check the set clause assignments are ok, and inject ids into the where part

-}

SEM Statement
    | Update
        loc.tpe =
            do
            checkRelationExists @lhs.env @table
            dependsOnRTpe (map snd @assigns.pairs) $ do
              @loc.columnTypes
              liftErrors @assigns.rowSetErrors
              return $ Pseudo Void
        loc.statementType =
            leftToEmpty (\ct -> [StatementType [] (fromMaybe [] @returning.listType)]) @loc.columnTypes

        loc.columnTypes =
            checkColumnConsistency @lhs.env
                                   @table
                                   (map fst @assigns.pairs)
                                   @assigns.pairs

        loc.backTree = Update @ann
                              @table
                              @assigns.annotatedTree
                              @whr.annotatedTree
                              @returning.annotatedTree
        loc.envUpdates = []


-- local identifier bindings: pass the table attribute names and types
-- into the where expression, and the set clause expressions

SEM Statement
    | Update
        loc.lib =
             fromRight @lhs.lib $ do
             ct <- envCompositeAttrs @lhs.env
                                     relationComposites
                                     @table
             updateBindings @lhs.lib @lhs.env [LibStackIDs [("", ct)]]
        whr.lib = @loc.lib
        assigns.lib = @loc.lib
        returning.lib = @loc.lib

{-
== set clauses

small complication is slightly hacky code to deal with row set
assignments, where we assign from a multiple attribute subselect into
multiple columns - todo: check if we need so much special casing for
this: should be able to reuse the funcall typing of row set equality
(trade one hack for another, squinting so that assignment looks like
an equality check - since it type checks the same we might be ok). If
we do this, we only need to expand the row sets out to produce a
single string,type list at the end.

-}

ATTR SetClauseList [||pairs : {[(String,Type)]}
                      rowSetErrors : {[TypeError]}]

SEM SetClauseList
  | Cons lhs.pairs = @hd.pairs ++ @tl.pairs
         lhs.rowSetErrors = maybeToList @hd.rowSetError ++ @tl.rowSetErrors
  | Nil lhs.pairs = []
        lhs.rowSetErrors = []

ATTR SetClause [||pairs : {[(String,Type)]}
                  rowSetError : {Maybe TypeError}]

SEM SetClause
    | SetClause
        lhs.pairs = [(@att, getTypeAnnotation @val.annotatedTree)]
        lhs.rowSetError = Nothing
    | RowSetClause
        loc.rowSetError =
          let atts = @atts.strings
              types = getRowTypes @vals.typeList
          in if length atts /= length types
               then Just WrongNumberOfColumns
               else Nothing
        lhs.pairs = zip @atts.strings $ getRowTypes @vals.typeList

{
getRowTypes :: [Type] -> [Type]
getRowTypes [AnonymousRecordType ts] = ts
getRowTypes ts = ts
}

{-
================================================================================

= delete

pretty simple, mainly just need to inject ids into the where part

-}

SEM Statement
    | Delete
        loc.tpe =
            checkRelationExists @lhs.env @table >>
            Right (Pseudo Void)
        loc.statementType = [StatementType [] (fromMaybe [] @returning.listType)]

        loc.backTree = Delete @ann @table @whr.annotatedTree @returning.annotatedTree
        loc.envUpdates = []


SEM Statement
    | Delete
        loc.lib =
            fromRight @lhs.lib $ do
            columnTypes <- envCompositeAttrs @lhs.env relationComposites @table
            updateBindings @lhs.lib @lhs.env [LibStackIDs [("", columnTypes)]]
        whr.lib = @loc.lib
        returning.lib = @loc.lib

{-
================================================================================
-}
{

--small shortcut to help produce better errors?
checkRelationExists :: Environment -> String -> Either [TypeError] ()
checkRelationExists env tbl =
    envCompositeDef env relationComposites tbl >>
    return ()

--used by both insert and update
checkColumnConsistency :: Environment ->  String -> [String] -> [(String,Type)]
                       -> Either [TypeError] [(String,Type)]
checkColumnConsistency env tbl cols' insNameTypePairs = do
  ttcols <- lowerize <$> envCompositePublicAttrs env [] tbl
  let cols = if null cols'
               then map fst ttcols
               else map (map toLower) cols'
  errorWhen (length insNameTypePairs /= length cols) [WrongNumberOfColumns]
  let nonMatchingColumns = cols \\ map fst ttcols
  errorWhen (not $ null nonMatchingColumns) $
       map UnrecognisedIdentifier nonMatchingColumns
  let targetNameTypePairs = map (\l -> (l,fromJust $ lookup l ttcols)) cols
        --check the types of the insdata match the column targets
        --name datatype columntype
      typeTriples = map (\((a,b),c) -> (a,b,c)) $
                    zip targetNameTypePairs $
                    map snd insNameTypePairs
      errs :: [TypeError]
      errs = concat $ lefts $
             map (\(_,b,c) -> checkAssignmentValid env c b) typeTriples
  liftErrors errs
  return targetNameTypePairs
  where
    lowerize = map (\(a,b) -> (map toLower a,b))

}