Misc.ag

{-
Copyright 2009 Jake Wheat

Contains bit and pieces of type checking which don't fit anywhere else

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

= type names

Types with type modifiers (called PrecTypeName here, to be changed),
are not supported at the moment.

-}

ATTR TypeName [||namedType : Type]

SEM TypeName
     | SimpleTypeName ArrayTypeName SetOfTypeName PrecTypeName
         lhs.namedType = tpeToT @loc.tpe
         lhs.annotatedTree = updateAnnotation
                               ((map TypeErrorA $ getErrors @loc.tpe) ++)
                               @loc.backTree


SEM TypeName
     | SimpleTypeName
        loc.tpe = catLookupType @lhs.cat $ canonicalizeTypeName @tn
        loc.backTree = SimpleTypeName @ann @tn
     | ArrayTypeName
        loc.tpe = dependsOnRTpe [@typ.namedType] $ Right $ ArrayType @typ.namedType
        loc.backTree = ArrayTypeName @ann @typ.annotatedTree
     | SetOfTypeName
        loc.tpe = dependsOnRTpe [@typ.namedType] $ Right $ SetOfType @typ.namedType
        loc.backTree = SetOfTypeName @ann @typ.annotatedTree
     | PrecTypeName
        loc.tpe = catLookupType @lhs.cat $ canonicalizeTypeName @tn
        loc.backTree = PrecTypeName @ann @tn @prec


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

= generic node types

-}

--expression list and list list - just collect up the types

ATTR ExpressionList [||typeList : {[Type]}]

SEM ExpressionList
    | Cons lhs.typeList = getTypeAnnotation @hd.annotatedTree : @tl.typeList
    | Nil lhs.typeList = []


ATTR ExpressionListList  [||typeListList : {[[Type]]}]

SEM ExpressionListList
    | Cons lhs.typeListList = @hd.typeList : @tl.typeListList
    | Nil lhs.typeListList = []


-- stringlist: collect the strings
ATTR StringList [||strings : {[String]}]

SEM StringList
  | Cons lhs.strings = @hd : @tl.strings
  | Nil lhs.strings = []

-- maybe bool expression: if present, then check its type is bool

SEM MaybeBoolExpression
    | Just
        lhs.annotatedTree =
          if getTypeAnnotation @just.annotatedTree `notElem` [typeBool, TypeCheckFailed]
            then Just $ updateAnnotation ((TypeErrorA ExpressionMustBeBool) :)
                          @just.annotatedTree
            else Just $ @just.annotatedTree


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

= couple of small utils

I think this should be alright, an identifier referenced in an
expression can only have zero or one dot in it.
-}

splitIdentifier :: String -> (String,String)
splitIdentifier s = let (a,b) = span (/= '.') s
                    in if b == ""
                         then ("", a)
                         else (a,tail b)

{-
helper to make adding annotations a bit easier
-}

annTypesAndErrors :: Data a => a -> Type -> [TypeError]
                  -> Maybe [AnnotationElement] -> a
annTypesAndErrors item nt errs add =
    updateAnnotation modifier item
    where
      modifier = (([TypeAnnotation nt] ++ fromMaybe [] add ++
       map TypeErrorA errs) ++)

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

proper dodgy:
1st pass is to add inferred types to the tree. This is done only for
expressions in a funcall argument list atm. Then we pull out the
placeholders after they've had this information added. Only the
placeholders in funcall argument lists will have their type inferred
in this way, to be expanded. Insert also does this currently, but in Dml.ag

This should probably be done during the typechecking phase instead,
but probably needs a proper type inferencing algorithm to be used, is
done like this for development expediency.

-}
getPlaceholders :: Data a => a -> [Expression]
getPlaceholders st =
    filter isPlaceholder $ everything (++) (mkQ [] ga) (setInferredTypes st)
    where
      ga :: Expression -> [Expression]
      ga s = [s]
      isPlaceholder e = case e of
                          PositionalArg _ _ -> True
                          Placeholder _ -> True
                          _ -> False

getPlaceholderTypes :: Data a => a -> [Type]
getPlaceholderTypes ex =
    map (getInferredType . getAnnotation) $ getPlaceholders ex
    where
      getInferredType (InferredType t:_) = t
      getInferredType (_:as) = getInferredType as
      getInferredType [] = TypeCheckFailed


setInferredTypes :: Data a => a -> a
setInferredTypes =
      doExprs {-. doSts-}
     where
       doExprs =
         transformBi (\x ->
           case x of
             FunCall an op exprs
                 -> FunCall an op (addInferredTypes an exprs)
             x1 -> x1)
       {-doSts =
         transformBi (\x ->
           case x of
             Insert ann table targetCols insData returning
                 -> Insert ann table targetCols insData returning
             x1 -> x1)-}
       addInferredTypes an exprs =
           let args1 = fmap (\(_,a,_,_) -> a) $ fp an
               args = fromMaybe [] args1
               fargs = args ++ repeat TypeCheckFailed
           in flip map (zip exprs fargs)
                  (\(ex, ty) -> updateAnnotation (++ [InferredType ty]) ex)
           where
             fp (FunctionPrototypeA f:_) = Just f
             fp (_:ls) = fp ls
             fp [] = Nothing

}