never executed always true always false

    1 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DeriveFunctor, DeriveTraversable, DeriveFoldable #-}
    2 
    3 module Conjure.Language.Expression.Op.RelationProj where
    4 
    5 import Conjure.Prelude
    6 import Conjure.Language.Expression.Op.Internal.Common
    7 
    8 import qualified Data.Aeson as JSON             -- aeson
    9 import qualified Data.Aeson.KeyMap as KM
   10 
   11 import qualified Data.Vector as V               -- vector
   12 
   13 
   14 data OpRelationProj x = OpRelationProj x [Maybe x]      -- Nothing represents an _
   15     deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
   16 
   17 instance Serialize x => Serialize (OpRelationProj x)
   18 instance Hashable  x => Hashable  (OpRelationProj x)
   19 instance ToJSON    x => ToJSON    (OpRelationProj x) where toJSON = genericToJSON jsonOptions
   20 instance FromJSON  x => FromJSON  (OpRelationProj x) where parseJSON = genericParseJSON jsonOptions
   21 
   22 instance (TypeOf x, Pretty x) => TypeOf (OpRelationProj x) where
   23     typeOf p@(OpRelationProj r xs) = do
   24         tyR <- typeOf r
   25         case (tyR, xs) of
   26             (TypeRelation ts', _) -> do
   27                 let xs' = catMaybes xs
   28                 if length xs == length xs'
   29                     then do -- all Just's
   30                         let loop [] [] = return TypeBool
   31                             loop (i:is) (t:ts) = do
   32                                 tyI <- typeOf i
   33                                 if typesUnify [tyI,t]
   34                                     then loop is ts
   35                                     else raiseTypeError $ "(relation projection)" <+> pretty p
   36                             loop _ _ = raiseTypeError $ "(relation projection)" <+> pretty p
   37                         loop xs' ts'
   38                     else do
   39                         let loop [] [] = return []
   40                             loop (Nothing:is) (t:ts) = (t:) <$> loop is ts
   41                             loop (Just i :is) (t:ts) = do
   42                                 tyI <- typeOf i
   43                                 if typesUnify [tyI,t]
   44                                     then loop is ts
   45                                     else raiseTypeError $ "(relation projection)" <+> pretty p
   46                             loop _ _ = raiseTypeError $ "(relation projection)" <+> pretty p
   47                         TypeRelation <$> loop xs ts'
   48             _ -> raiseTypeError $ "(relation projection)" <+> vcat [pretty p, pretty tyR]
   49 
   50 instance SimplifyOp OpRelationProj x where
   51     simplifyOp _ = na "simplifyOp{OpRelationProj}"
   52 
   53 instance Pretty x => Pretty (OpRelationProj x) where
   54     prettyPrec _ (OpRelationProj a bs) = pretty a <> prettyList prParens "," (map pr bs)
   55         where pr Nothing = "_"
   56               pr (Just b) = pretty b
   57 
   58 instance VarSymBreakingDescription x => VarSymBreakingDescription (OpRelationProj x) where
   59     varSymBreakingDescription (OpRelationProj a b) = JSON.Object $ KM.fromList
   60         [ ("type", JSON.String "OpRelationProj")
   61         , ("children", JSON.Array $ V.fromList
   62             $ varSymBreakingDescription a
   63             : map (maybe JSON.Null varSymBreakingDescription) b
   64           )
   65         ]